fcl-passrc: fixed checking statement after except-on

compiler/packages/fcl-passrc/src/pasresolver.pp

@@ -3935,10 +3935,16 @@ end;
 { EPasResolve }
 
 procedure EPasResolve.SetPasElement(AValue: TPasElement);
+var
+  Old: TPasElement;
 begin
   if FPasElement=AValue then Exit;
-  if PasElement<>nil then
+  Old:=FPasElement;
+  if Old<>nil then
+    begin
+    Old:=nil;
     PasElement.Release{$IFDEF CheckPasTreeRefCount}('EPasResolve.SetPasElement'){$ENDIF};
+    end;
   FPasElement:=AValue;
   if PasElement<>nil then
     PasElement.AddRef{$IFDEF CheckPasTreeRefCount}('EPasResolve.SetPasElement'){$ENDIF};
@@ -7523,11 +7529,13 @@ procedure TPasResolver.FinishExceptOnExpr;
 var
   El: TPasImplExceptOn;
   ResolvedType: TPasResolverResult;
+  TypeEl: TPasType;
 begin
   CheckTopScope(TPasExceptOnScope);
   El:=TPasImplExceptOn(FTopScope.Element);
-  ComputeElement(El.TypeEl,ResolvedType,[rcType]);
+  TypeEl:=El.TypeEl;
-  CheckIsClass(El.TypeEl,ResolvedType);
+  ComputeElement(TypeEl,ResolvedType,[rcType]);
+  CheckIsClass(TypeEl,ResolvedType);
 end;
 
 procedure TPasResolver.FinishExceptOnStatement;

compiler/packages/fcl-passrc/src/pparser.pp

@@ -5937,10 +5937,23 @@ var
 
   function CloseBlock: boolean; // true if parent reached
   var C: TPasImplBlockClass;
+    NeedUnget: Boolean;
   begin
     C:=TPasImplBlockClass(CurBlock.ClassType);
     if C=TPasImplExceptOn then
-      Engine.FinishScope(stExceptOnStatement,CurBlock)
+      begin
+      Engine.FinishScope(stExceptOnStatement,CurBlock);
+      NeedUnget:=CurToken=tkSemicolon;
+      if NeedUnget then
+        NextToken;
+      if (CurToken in [tkend,tkelse])
+          or ((CurToken=tkIdentifier) and (lowercase(CurTokenString)='on')) then
+        // ok
+      else
+        ParseExcExpectedAorB('end','on');
+      if NeedUnget then
+        UngetToken;
+      end
     else if C=TPasImplWithDo then
       Engine.FinishScope(stWithExpr,CurBlock);
     CurBlock:=CurBlock.Parent as TPasImplBlock;
@@ -5999,6 +6012,7 @@ var
   TypeEl: TPasType;
   ImplRaise: TPasImplRaise;
   VarEl: TPasVariable;
+  ImplExceptOn: TPasImplExceptOn;
 
 begin
   NewImplElement:=nil;
@@ -6422,6 +6436,8 @@ begin
         //        ParseExc;
         CheckStatementCanStart;
 
+        //writeln('TPasParser.ParseStatement ',CurToken,' ',CurTokenString);
+
         // On is usable as an identifier
         if lowerCase(CurTokenText)='on' then
           begin
@@ -6432,31 +6448,33 @@ begin
             begin
               SrcPos:=CurTokenPos;
               ExpectIdentifier;
-              El:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock,SrcPos));
+              ImplExceptOn:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock,SrcPos));
+              El:=ImplExceptOn;
               SrcPos:=CurSourcePos;
               Name:=CurTokenString;
               NextToken;
+              //writeln('TPasParser.ParseStatement ',CurToken,' ',CurTokenString);
               //writeln('ON t=',Name,' Token=',CurTokenText);
               if CurToken=tkColon then
                 begin
                 // the first expression was the variable name
                 NextToken;
-                TypeEl:=ParseSimpleType(El,SrcPos,'');
+                TypeEl:=ParseSimpleType(ImplExceptOn,SrcPos,'');
-                TPasImplExceptOn(El).TypeEl:=TypeEl;
+                ImplExceptOn.TypeEl:=TypeEl;
-                VarEl:=TPasVariable(CreateElement(TPasVariable,Name,El,SrcPos));
+                VarEl:=TPasVariable(CreateElement(TPasVariable,Name,ImplExceptOn,SrcPos));
-                TPasImplExceptOn(El).VarEl:=VarEl;
+                ImplExceptOn.VarEl:=VarEl;
                 VarEl.VarType:=TypeEl;
                 TypeEl.AddRef{$IFDEF CheckPasTreeRefCount}('TPasVariable.VarType'){$ENDIF};
-                if TypeEl.Parent=El then
+                if TypeEl.Parent=ImplExceptOn then
                   TypeEl.Parent:=VarEl;
                 end
               else
                 begin
                 UngetToken;
-                TPasImplExceptOn(El).TypeEl:=ParseSimpleType(El,SrcPos,'');
+                ImplExceptOn.TypeEl:=ParseSimpleType(ImplExceptOn,SrcPos,'');
                 end;
-              Engine.FinishScope(stExceptOnExpr,El);
+              Engine.FinishScope(stExceptOnExpr,ImplExceptOn);
-              CreateBlock(TPasImplExceptOn(El));
+              CreateBlock(ImplExceptOn);
               El:=nil;
               ExpectToken(tkDo);
             end else

compiler/packages/fcl-passrc/tests/tcresolver.pas

@@ -342,6 +342,7 @@ type
     Procedure TestTryStatement;
     Procedure TestTryExceptOnNonTypeFail;
     Procedure TestTryExceptOnNonClassFail;
+    Procedure TestTryStatementMissingOnFail;
     Procedure TestRaiseNonVarFail;
     Procedure TestRaiseNonClassFail;
     Procedure TestRaiseDescendant;
@@ -1738,6 +1739,8 @@ begin
         end;
       ok:=true;
       end;
+    on E: Exception do
+      Fail('Expected EPasResolve but got '+E.ClassName);
   end;
   AssertEquals('Missing resolver error {'+Msg+'} ('+IntToStr(MsgNumber)+')',true,ok);
 end;
@@ -1758,6 +1761,8 @@ begin
         MsgNumber,Parser.LastMsgNumber);
       ok:=true;
       end;
+    on E: Exception do
+      Fail('Expected EParserError but got '+E.ClassName);
   end;
   AssertEquals('Missing parser error '+Msg+' ('+IntToStr(MsgNumber)+')',true,ok);
 end;
@@ -5405,6 +5410,23 @@ begin
   CheckResolverException('class expected, but Longint found',nXExpectedButYFound);
 end;
 
+procedure TTestResolver.TestTryStatementMissingOnFail;
+begin
+  StartProgram(true,[supTObject]);
+  Add([
+  'procedure Run;',
+  'begin',
+  '  try',
+  '  except',
+  '    on TObject do ;',
+  '    Run;',
+  '  end;',
+  'end;',
+  'begin',
+  '']);
+  CheckParserException('Expected "end" or "on"',nParserExpectToken2Error);
+end;
+
 procedure TTestResolver.TestRaiseNonVarFail;
 begin
   StartProgram(false);