Browse Source

* Patch from Mattias Gaertner:
jswriter:
less duplicate brackets
pasresolver:
break, continue, option to fix case of overrides
pas2js:
procedure args default values,
try..except,
try..except..on..else,
raise, raise E,
class vars,
call class methods,
break,
continue,
rename name conflicts with JS identifiers: apply, call, null, ...

git-svn-id: trunk@35402 -

michael 8 years ago
parent
commit
767645014c

+ 98 - 53
packages/fcl-js/src/jswriter.pp

@@ -104,7 +104,8 @@ Type
     FOptions: TWriteOptions;
     FWriter: TTextWriter;
     FFreeWriter : Boolean;
-    FSkipBrackets : Boolean;
+    FSkipCurlyBrackets : Boolean;
+    FSkipRoundBrackets : Boolean;
     function GetUseUTF8: Boolean;
     procedure SetOptions(AValue: TWriteOptions);
   Protected
@@ -125,7 +126,7 @@ Type
     Procedure WriteLiteral(El: TJSLiteral);virtual;
     Procedure WriteArrayLiteral(El: TJSArrayLiteral);virtual;
     Procedure WriteObjectLiteral(El: TJSObjectLiteral);virtual;
-    Procedure WriteMemberExpression(el: TJSMemberExpression);virtual;
+    Procedure WriteMemberExpression(El: TJSMemberExpression);virtual;
     Procedure WriteCallExpression(El: TJSCallExpression);virtual;
     Procedure WriteSwitchStatement(El: TJSSwitchStatement);virtual;
     Procedure WriteUnary(El: TJSUnary);virtual;
@@ -497,7 +498,7 @@ begin
     end;
   if Assigned(FD.Body) then
     begin
-    FSkipBrackets:=True;
+    FSkipCurlyBrackets:=True;
     //writeln('TJSWriter.WriteFuncDef '+FD.Body.ClassName);
     WriteJS(FD.Body);
     If (Assigned(FD.Body.A))
@@ -551,7 +552,7 @@ end;
 
 procedure TJSWriter.WriteLiteral(El: TJSLiteral);
 begin
-  WriteValue(el.Value);
+  WriteValue(El.Value);
 end;
 
 procedure TJSWriter.WritePrimaryExpression(El: TJSPrimaryExpression);
@@ -595,6 +596,7 @@ begin
     Write(Copy(BC,1,1));
   For I:=0 to C do
     begin
+    FSkipRoundBrackets:=true;
     WriteJS(El.Elements[i].Expr);
     if I<C then
       if WC then
@@ -622,7 +624,7 @@ Var
   S : TJSString;
 
 begin
-  C:=EL.Elements.Count-1;
+  C:=El.Elements.Count-1;
   QE:=(woQuoteElementNames in Options);
   if C=-1 then
     begin
@@ -639,16 +641,18 @@ begin
     end;
   For I:=0 to C do
    begin
-   S:=EL.Elements[i].Name;
+   S:=El.Elements[i].Name;
    if QE then
      S:='"'+S+'"';
    Write(S+': ');
    Indent;
-   WriteJS(EL.Elements[i].Expr);
+   FSkipRoundBrackets:=true;
+   WriteJS(El.Elements[i].Expr);
    if I<C then
      if WC then Write(', ') else Writeln(',');
    Undent;
    end;
+  FSkipRoundBrackets:=false;
   if not WC then
     begin
     Writeln('');
@@ -657,27 +661,29 @@ begin
   Write('}');
 end;
 
-procedure TJSWriter.WriteMemberExpression(el: TJSMemberExpression);
+procedure TJSWriter.WriteMemberExpression(El: TJSMemberExpression);
 
 begin
-  if el is TJSNewMemberExpression then
+  if El is TJSNewMemberExpression then
     Write('new ');
-  WriteJS(el.MExpr);
-  if el is TJSDotMemberExpression then
+  WriteJS(El.MExpr);
+  if El is TJSDotMemberExpression then
     begin
     write('.');
-    Write(TJSDotMemberExpression(el).Name);
+    Write(TJSDotMemberExpression(El).Name);
     end
-  else if el is TJSBracketMemberExpression then
+  else if El is TJSBracketMemberExpression then
     begin
     write('[');
-    WriteJS(TJSBracketMemberExpression(el).Name);
+    FSkipRoundBrackets:=true;
+    WriteJS(TJSBracketMemberExpression(El).Name);
+    FSkipRoundBrackets:=false;
     write(']');
     end
-  else if (el is TJSNewMemberExpression) then
+  else if (El is TJSNewMemberExpression) then
     begin
-    if (Assigned(TJSNewMemberExpression(el).Args)) then
-      WriteArrayLiteral(TJSNewMemberExpression(el).Args)
+    if (Assigned(TJSNewMemberExpression(El).Args)) then
+      WriteArrayLiteral(TJSNewMemberExpression(El).Args)
     else
       Write('()');
     end;
@@ -699,6 +705,7 @@ Var
   S : String;
 
 begin
+  FSkipRoundBrackets:=false;
   S:=El.PreFixOperator;
   if (S<>'') then
     Write(S);
@@ -719,13 +726,13 @@ Var
   LastEl: TJSElement;
 
 begin
-  //write('TJSWriter.WriteStatementList '+BoolToStr(FSkipBrackets,true));
+  //write('TJSWriter.WriteStatementList '+BoolToStr(FSkipCurlyBrackets,true));
   //if El.A<>nil then write(' El.A='+El.A.ClassName) else write(' El.A=nil');
   //if El.B<>nil then write(' El.B='+El.B.ClassName) else write(' El.B=nil');
   //writeln(' ');
 
   C:=(woCompact in Options);
-  B:= Not FSkipBrackets;
+  B:= Not FSkipCurlyBrackets;
   if B then
     begin
     Write('{');
@@ -745,7 +752,7 @@ begin
         else
           Writeln(';');
         end;
-      FSkipBrackets:=True;
+      FSkipCurlyBrackets:=True;
       WriteJS(El.B);
       LastEl:=El.B;
       end;
@@ -762,24 +769,26 @@ end;
 procedure TJSWriter.WriteWithStatement(El: TJSWithStatement);
 begin
    Write('with (');
-   WriteJS(EL.A);
+   FSkipRoundBrackets:=true;
+   WriteJS(El.A);
+   FSkipRoundBrackets:=false;
    if (woCompact in Options) then
      Write(') ')
    else
      WriteLn(')');
    Indent;
-   WriteJS(EL.B);
+   WriteJS(El.B);
    Undent;
 end;
 
 procedure TJSWriter.WriteVarDeclarationList(El: TJSVariableDeclarationList);
 
 begin
-  WriteJS(EL.A);
-  If Assigned(EL.B) then
+  WriteJS(El.A);
+  If Assigned(El.B) then
     begin
     Write(', ');
-    WriteJS(EL.B);
+    WriteJS(El.B);
     end;
 end;
 
@@ -787,12 +796,15 @@ procedure TJSWriter.WriteBinary(El: TJSBinary);
 
 Var
   S : AnsiString;
-  AllowCompact : Boolean;
+  AllowCompact, WithBrackets: Boolean;
 begin
-  Write('(');
-  WriteJS(EL.A);
+  WithBrackets:=not FSkipRoundBrackets;
+  if WithBrackets then
+    Write('(');
+  FSkipRoundBrackets:=false;
+  WriteJS(El.A);
   AllowCompact:=False;
-  if (el is TJSBinaryExpression) then
+  if (El is TJSBinaryExpression) then
     begin
     S:=TJSBinaryExpression(El).OperatorString;
     AllowCompact:=TJSBinaryExpression(El).AllowCompact;
@@ -800,19 +812,20 @@ begin
   If Not (AllowCompact and (woCompact in Options)) then
     S:=' '+S+' ';
   Write(S);
-  WriteJS(EL.B);
-  Write(')');
+  WriteJS(El.B);
+  if WithBrackets then
+    Write(')');
 end;
 
 procedure TJSWriter.WriteConditionalExpression(El: TJSConditionalExpression);
 
 begin
   write('(');
-  WriteJS(EL.A);
+  WriteJS(El.A);
   write(' ? ');
-  WriteJS(EL.B);
+  WriteJS(El.B);
   write(' : ');
-  WriteJS(EL.C);
+  WriteJS(El.C);
   write(')');
 end;
 
@@ -821,22 +834,26 @@ procedure TJSWriter.WriteAssignStatement(El: TJSAssignStatement);
 Var
   S : AnsiString;
 begin
-  WriteJS(EL.LHS);
+  WriteJS(El.LHS);
   S:=El.OperatorString;
   If Not (woCompact in Options) then
     S:=' '+S+' ';
   Write(s);
-  WriteJS(EL.Expr);
+  FSkipRoundBrackets:=true;
+  WriteJS(El.Expr);
+  FSkipRoundBrackets:=false;
 end;
 
 procedure TJSWriter.WriteVarDeclaration(El: TJSVarDeclaration);
 
 begin
-  Write(EL.Name);
-  if Assigned(EL.Init) then
+  Write(El.Name);
+  if Assigned(El.Init) then
     begin
     Write(' = ');
-    WriteJS(EL.Init);
+    FSkipRoundBrackets:=true;
+    WriteJS(El.Init);
+    FSkipRoundBrackets:=false;
     end;
 end;
 
@@ -844,17 +861,25 @@ procedure TJSWriter.WriteIfStatement(El: TJSIfStatement);
 
 begin
   Write('if (');
+  FSkipRoundBrackets:=true;
   WriteJS(El.Cond);
+  FSkipRoundBrackets:=false;
   Write(')');
   If Not (woCompact in Options) then
     Write(' ');
   if (El.BTrue<>nil) and (not (El.BTrue is TJSEmptyStatement)) then
+    begin
     WriteJS(El.BTrue);
+    end;
   if Assigned(El.BFalse) then
     begin
     if (El.BTrue=nil) or (El.BTrue is TJSEmptyStatement) then
-      Write('{}');
-    Write(' else ');
+      Writeln('{}')
+    else if not (El.BTrue is TJSStatementList) then
+      Writeln('')
+    else
+      Write(' ');
+    Write('else ');
     WriteJS(El.BFalse)
     end;
 end;
@@ -881,7 +906,11 @@ begin
     WriteJS(El.Init);
   Write('; ');
   if Assigned(El.Cond) then
+    begin
+    FSkipRoundBrackets:=true;
     WriteJS(El.Cond);
+    FSkipRoundBrackets:=false;
+    end;
   Write('; ');
   if Assigned(El.Incr) then
     WriteJS(El.Incr);
@@ -899,19 +928,27 @@ begin
     Write('do ');
     if Assigned(El.Body) then
       begin
-      FSkipBrackets:=false;
+      FSkipCurlyBrackets:=false;
       WriteJS(El.Body);
       end;
     Write(' while (');
     If Assigned(El.Cond) then
+      begin
+      FSkipRoundBrackets:=true;
       WriteJS(EL.Cond);
+      FSkipRoundBrackets:=false;
+      end;
     Write(')');
     end
   else
     begin
     Write('while (');
     If Assigned(El.Cond) then
+      begin
+      FSkipRoundBrackets:=true;
       WriteJS(EL.Cond);
+      FSkipRoundBrackets:=false;
+      end;
     Write(') ');
     if Assigned(El.Body) then
       WriteJS(El.Body);
@@ -937,7 +974,11 @@ begin
   C:=(woCompact in Options);
   Write('switch (');
   If Assigned(El.Cond) then
+    begin
+    FSkipRoundBrackets:=true;
     WriteJS(El.Cond);
+    FSkipRoundBrackets:=false;
+    end;
   if C then
     Write(') {')
   else
@@ -950,7 +991,9 @@ begin
     else
       begin
       Write('case ');
+      FSkipRoundBrackets:=true;
       WriteJS(EC.Expr);
+      FSkipRoundBrackets:=false;
       end;
     If C then
       Write(': ')
@@ -958,7 +1001,7 @@ begin
       Writeln(':');
     if Assigned(EC.Body) then
       begin
-      FSkipBrackets:=true;
+      FSkipCurlyBrackets:=true;
       Indent;
       WriteJS(EC.Body);
       Undent;
@@ -1020,22 +1063,24 @@ begin
   else
     begin
     Write('return ');
+    FSkipRoundBrackets:=true;
     WriteJS(El.Expr);
+    FSkipRoundBrackets:=false;
     end;
 end;
 
 procedure TJSWriter.WriteLabeledStatement(El: TJSLabeledStatement);
 begin
-  if Assigned(EL.TheLabel) then
+  if Assigned(El.TheLabel) then
     begin
-    Write(EL.TheLabel.Name);
+    Write(El.TheLabel.Name);
     if woCompact in Options then
       Write(': ')
     else
       Writeln(':');
     end;
   // Target ??
-  WriteJS(EL.A);
+  WriteJS(El.A);
 end;
 
 procedure TJSWriter.WriteTryStatement(El: TJSTryStatement);
@@ -1047,7 +1092,7 @@ begin
   C:=woCompact in Options;
   Write('try {');
   if Not C then writeln('');
-  FSkipBrackets:=True;
+  FSkipCurlyBrackets:=True;
   Indent;
   WriteJS(El.Block);
   Undent;
@@ -1060,7 +1105,7 @@ begin
       Write(' {')
     else
       Writeln(' {');
-    FSkipBrackets:=True;
+    FSkipCurlyBrackets:=True;
     Indent;
     WriteJS(El.BCatch);
     Undent;
@@ -1073,7 +1118,7 @@ begin
     else
       Writeln(' finally {');
     Indent;
-    FSkipBrackets:=True;
+    FSkipCurlyBrackets:=True;
     WriteJS(El.BFinally);
     Undent;
     Write('}');
@@ -1083,7 +1128,7 @@ end;
 procedure TJSWriter.WriteFunctionBody(El: TJSFunctionBody);
 
 begin
-  //writeln('TJSWriter.WriteFunctionBody '+El.A.ClassName+' FSkipBrackets='+BoolToStr(FSkipBrackets,'true','false'));
+  //writeln('TJSWriter.WriteFunctionBody '+El.A.ClassName+' FSkipBrackets='+BoolToStr(FSkipCurlyBrackets,'true','false'));
   if Assigned(El.A) and (not (El.A is TJSEmptyBlockStatement)) then
     WriteJS(El.A);
 end;
@@ -1092,8 +1137,8 @@ procedure TJSWriter.WriteFunctionDeclarationStatement(
   El: TJSFunctionDeclarationStatement);
 
 begin
-  if Assigned(EL.AFunction) then
-    WriteFuncDef(EL.AFunction);
+  if Assigned(El.AFunction) then
+    WriteFuncDef(El.AFunction);
 end;
 
 procedure TJSWriter.WriteSourceElements(El: TJSSourceElements);
@@ -1200,7 +1245,7 @@ begin
   else
     Error(SErrUnknownJSClass,[El.ClassName]);
 //  Write('/* '+El.ClassName+' */');
-  FSkipBrackets:=False;
+  FSkipCurlyBrackets:=False;
 end;
 
 { TFileWriter }

+ 2 - 1
packages/fcl-passrc/examples/parsepp.pp

@@ -26,6 +26,7 @@ function TSimpleEngine.CreateElement(AClass: TPTreeElement; const AName: String;
   AParent: TPasElement; AVisibility: TPasMemberVisibility;
   const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
 begin
+  Writeln(AName,' : ',AClass.ClassName,' at ',ASourceFilename,':',ASourceLinenumber);
   Result := AClass.Create(AName, AParent);
   Result.Visibility := AVisibility;
   Result.SourceFilename := ASourceFilename;
@@ -85,4 +86,4 @@ begin
  
     FreeAndNil(M);
   finally FreeAndNil(E) end;
-end.
+end.

+ 129 - 1
packages/fcl-passrc/src/pasresolver.pp

@@ -95,6 +95,7 @@
   - procedure type
   - method type
   - function without params: mark if call or address, rrfImplicitCallWithoutParams
+  - procedure break, procedure continue
 
  ToDo:
   - overloads
@@ -206,6 +207,7 @@ const
   nCantAssignValuesToAnAddress = 3042;
   nIllegalExpression = 3043;
   nCantAccessPrivateMember = 3044;
+  nMustBeInsideALoop = 3045;
 
 // resourcestring patterns of messages
 resourcestring
@@ -253,6 +255,7 @@ resourcestring
   sCantAssignValuesToAnAddress = 'Can''t assign values to an address';
   sIllegalExpression = 'Illegal expression';
   sCantAccessPrivateMember = 'Can''t access %s member %s';
+  sMustBeInsideALoop = '%s must be inside a loop';
 
 type
   TResolverBaseType = (
@@ -396,6 +399,8 @@ type
     bfInclude,
     bfExclude,
     bfOrd,
+    bfBreak,
+    bfContinue,
     bfExit,
     bfInc,
     bfDec,
@@ -412,6 +417,8 @@ const
     'Include',
     'Exclude',
     'Ord',
+    'Break',
+    'Continue',
     'Exit',
     'Inc',
     'Dec',
@@ -826,6 +833,11 @@ type
   end;
   PPRFindData = ^TPRFindData;
 
+  TPasResolverOption = (
+    proFixCaseOfOverrides  // fix Name of overriding procs to the overriden proc
+    );
+  TPasResolverOptions = set of TPasResolverOption;
+
   { TPasResolver }
 
   TPasResolver = Class(TPasTreeContainer)
@@ -853,6 +865,7 @@ type
     FRootElement: TPasElement;
     FTopScope: TPasScope;
     FPendingForwards: TFPList; // list of TPasElement needed to check for forward procs
+    FOptions: TPasResolverOptions;
     function GetBaseType(bt: TResolverBaseType): TPasUnresolvedSymbolRef; inline;
     function GetScopes(Index: integer): TPasScope; inline;
   protected
@@ -938,6 +951,7 @@ type
     procedure FinishProcedure;
     procedure FinishProcedureHeader(El: TPasProcedureType);
     procedure FinishMethodDeclHeader(Proc: TPasProcedure);
+    procedure ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope: TPasProcedureScope);
     procedure FinishMethodImplHeader(ImplProc: TPasProcedure);
     procedure CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure);
     procedure FinishExceptOnExpr;
@@ -981,6 +995,10 @@ type
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
     procedure OnGetCallResult_Ord(Proc: TResElDataBuiltInProc;
       {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
+    function OnGetCallCompatibility_Break(Proc: TResElDataBuiltInProc;
+      Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
+    function OnGetCallCompatibility_Continue(Proc: TResElDataBuiltInProc;
+      Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
     function OnGetCallCompatibility_Exit(Proc: TResElDataBuiltInProc;
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
     function OnGetCallCompatibility_IncDec(Proc: TResElDataBuiltInProc;
@@ -1097,12 +1115,14 @@ type
       ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer;
     function ResolvedElHasValue(const ResolvedEl: TPasResolverResult): boolean;
     function ResolvedElCanBeVarParam(const ResolvedEl: TPasResolverResult): boolean;
+    function ResolvedElIsClassInstance(const ResolvedEl: TPasResolverResult): boolean;
     // uility functions
     function GetPasPropertyType(El: TPasProperty): TPasType;
     function GetPasPropertyAncestor(El: TPasProperty): TPasProperty;
     function GetPasPropertyGetter(El: TPasProperty): TPasElement;
     function GetPasPropertySetter(El: TPasProperty): TPasElement;
     function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
+    function GetLoop(El: TPasElement): TPasImplElement;
     function ResolveAliasType(aType: TPasType): TPasType;
     function ExprIsAddrTarget(El: TPasExpr): boolean;
     function GetLastExprIdentifier(El: TPasExpr): TPasExpr;
@@ -1125,6 +1145,7 @@ type
     property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern;
     property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs;
     property LastMsgElement: TPasElement read FLastMsgElement write FLastMsgElement;
+    property Options: TPasResolverOptions read FOptions write FOptions;
   end;
 
 function GetObjName(o: TObject): string;
@@ -2750,7 +2771,6 @@ begin
       FinishMethodDeclHeader(Proc);
       exit;
       end;
-
     FindData:=Default(TFindOverloadProcData);
     FindData.Proc:=Proc;
     FindData.Args:=Proc.ProcType.Args;
@@ -2789,6 +2809,8 @@ begin
       // remove DeclProc from scope
       FoundInScope:=FindData.ElScope as TPasIdentifierScope;
       FoundInScope.RemoveLocalIdentifier(DeclProc);
+      // replace arguments with declaration arguments
+      ReplaceProcScopeImplArgsWithDeclArgs(ProcScope);
       end
     else
       begin
@@ -2850,6 +2872,8 @@ begin
           sNoMethodInAncestorToOverride,[GetProcDesc(Proc.ProcType)],Proc.ProcType);
       // override a virtual method
       CheckProcSignatureMatch(OverloadProc,Proc);
+      if proFixCaseOfOverrides in Options then
+        Proc.Name:=OverloadProc.Name;
       end
     else if not Proc.IsReintroduced then
       begin
@@ -2860,6 +2884,37 @@ begin
     end;
 end;
 
+procedure TPasResolver.ReplaceProcScopeImplArgsWithDeclArgs(
+  ImplProcScope: TPasProcedureScope);
+var
+  DeclProc, ImplProc: TPasProcedure;
+  DeclArgs, ImplArgs: TFPList;
+  i: Integer;
+  DeclArg, ImplArg: TPasArgument;
+  Identifier: TPasIdentifier;
+begin
+  ImplProc:=ImplProcScope.Element as TPasProcedure;
+  ImplArgs:=ImplProc.ProcType.Args;
+  DeclProc:=ImplProcScope.DeclarationProc;
+  DeclArgs:=DeclProc.ProcType.Args;
+  for i:=0 to DeclArgs.Count-1 do
+    begin
+    DeclArg:=TPasArgument(DeclArgs[i]);
+    if i<ImplArgs.Count then
+      begin
+      ImplArg:=TPasArgument(ImplArgs[i]);
+      Identifier:=ImplProcScope.FindLocalIdentifier(DeclArg.Name);
+      //writeln('TPasResolver.ReplaceProcScopeImplArgsWithDeclArgs i=',i,' replacing ',GetObjName(ImplArg),' with ',GetObjName(DeclArg));
+      if Identifier.Element<>ImplArg then
+        RaiseInternalError(20170203161659,GetObjName(DeclArg)+' '+GetObjName(ImplArg));
+      Identifier.Element:=DeclArg;
+      Identifier.Identifier:=DeclArg.Name;
+      end
+    else
+      RaiseNotYetImplemented(20170203161826,ImplProc);
+    end;
+end;
+
 procedure TPasResolver.FinishMethodImplHeader(ImplProc: TPasProcedure);
 var
   ProcName: String;
@@ -2914,6 +2969,9 @@ begin
   DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
   DeclProcScope.ImplProc:=ImplProc;
 
+  // replace arguments in scope with declaration arguments
+  ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope);
+
   if not DeclProc.IsStatic then
     begin
     // add 'Self'
@@ -5660,6 +5718,44 @@ begin
   SetResolverIdentifier(ResolvedEl,btSmallInt,Proc.Proc,FBaseTypes[btSmallInt],[rrfReadable]);
 end;
 
+function TPasResolver.OnGetCallCompatibility_Break(Proc: TResElDataBuiltInProc;
+  Expr: TPasExpr; RaiseOnError: boolean): integer;
+var
+  Params: TParamsExpr;
+begin
+  if GetLoop(Expr)=nil then
+    RaiseMsg(nMustBeInsideALoop,sMustBeInsideALoop,['Break'],Expr);
+  if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then
+    exit(cExact);
+  Params:=TParamsExpr(Expr);
+  {$IFDEF VerbosePasResolver}
+  writeln('TPasResolver.OnGetCallCompatibility_Break Params=',length(Params.Params));
+  {$ENDIF}
+  if RaiseOnError then
+    RaiseMsg(nWrongNumberOfParametersForCallTo,
+      sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]);
+  Result:=cIncompatible;
+end;
+
+function TPasResolver.OnGetCallCompatibility_Continue(
+  Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
+var
+  Params: TParamsExpr;
+begin
+  if GetLoop(Expr)=nil then
+    RaiseMsg(nMustBeInsideALoop,sMustBeInsideALoop,['Continue'],Expr);
+  if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then
+    exit(cExact);
+  Params:=TParamsExpr(Expr);
+  {$IFDEF VerbosePasResolver}
+  writeln('TPasResolver.OnGetCallCompatibility_Continue Params=',length(Params.Params));
+  {$ENDIF}
+  if RaiseOnError then
+    RaiseMsg(nWrongNumberOfParametersForCallTo,
+      sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]);
+  Result:=cIncompatible;
+end;
+
 function TPasResolver.OnGetCallCompatibility_Exit(Proc: TResElDataBuiltInProc;
   Expr: TPasExpr; RaiseOnError: boolean): integer;
 var
@@ -6390,6 +6486,12 @@ begin
   if bfOrd in BaseProcs then
     AddBuiltInProc('Ord','function Ord(const Enum or Char): integer',
         @OnGetCallCompatibility_Ord,@OnGetCallResult_Ord,bfOrd);
+  if bfBreak in BaseProcs then
+    AddBuiltInProc('Break','procedure Break',
+        @OnGetCallCompatibility_Break,nil,bfBreak);
+  if bfContinue in BaseProcs then
+    AddBuiltInProc('Continue','procedure Continue',
+        @OnGetCallCompatibility_Continue,nil,bfContinue);
   if bfExit in BaseProcs then
     AddBuiltInProc('Exit','procedure Exit(result)',
         @OnGetCallCompatibility_Exit,nil,bfExit);
@@ -7266,6 +7368,19 @@ begin
     end;
 end;
 
+function TPasResolver.ResolvedElIsClassInstance(
+  const ResolvedEl: TPasResolverResult): boolean;
+begin
+  Result:=false;
+  if ResolvedEl.BaseType<>btContext then exit;
+  if ResolvedEl.TypeEl=nil then exit;
+  if ResolvedEl.TypeEl.ClassType<>TPasClassType then exit;
+  if (ResolvedEl.IdentEl is TPasVariable)
+      or (ResolvedEl.IdentEl.ClassType=TPasArgument)
+      or (ResolvedEl.IdentEl.ClassType=TPasResultElement) then
+    exit(true);
+end;
+
 function TPasResolver.GetPasPropertyType(El: TPasProperty): TPasType;
 begin
   Result:=nil;
@@ -8044,6 +8159,19 @@ begin
     end;
 end;
 
+function TPasResolver.GetLoop(El: TPasElement): TPasImplElement;
+begin
+  while El<>nil do
+    begin
+    if (El.ClassType=TPasImplRepeatUntil)
+        or (El.ClassType=TPasImplWhileDo)
+        or (El.ClassType=TPasImplForLoop) then
+      exit(TPasImplElement(El));
+    El:=El.Parent;
+    end;
+  Result:=nil;
+end;
+
 function TPasResolver.ResolveAliasType(aType: TPasType): TPasType;
 begin
   Result:=aType;

+ 27 - 21
packages/fcl-passrc/src/pparser.pp

@@ -2352,7 +2352,7 @@ var
   TypeName: String;
   PT : TProcType;
   NamePos: TPasSourcePos;
-  ok: Boolean;
+  OldForceCaret,ok: Boolean;
 
 begin
   CurBlock := declNone;
@@ -2455,9 +2455,9 @@ begin
               end;
             declType:
               begin
-              Scanner.ForceCaret:=True;
+              OldForceCaret:=Scanner.SetForceCaret(True);
               TypeEl := ParseTypeDecl(Declarations);
-              Scanner.ForceCaret:=True; // It may have been switched off
+              // Scanner.SetForceCaret(OldForceCaret); // It may have been switched off
               if Assigned(TypeEl) then        // !!!
                 begin
                   Declarations.Declarations.Add(TypeEl);
@@ -2696,8 +2696,10 @@ end;
 
 // Starts after the variable name
 function TPasParser.ParseConstDecl(Parent: TPasElement): TPasConst;
+
 var
-  ok: Boolean;
+  OldForceCaret,ok: Boolean;
+
 begin
   SaveComments;
   Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent));
@@ -2706,11 +2708,11 @@ begin
     NextToken;
     if CurToken = tkColon then
       begin
-      Scanner.ForceCaret:=True;
+      OldForceCaret:=Scanner.SetForceCaret(True);
       try
         Result.VarType := ParseType(Result,Scanner.CurSourcePos);
       finally
-        Scanner.ForceCaret:=False;
+        Scanner.SetForceCaret(OldForceCaret);
       end;
 {      if Result.VarType is TPasRangeType then
         Ungettoken; // Range type stops on token after last range token}
@@ -2876,15 +2878,17 @@ function TPasParser.ParseTypeDecl(Parent: TPasElement): TPasType;
 var
   TypeName: String;
   NamePos: TPasSourcePos;
+  OldForceCaret : Boolean;
+  
 begin
   TypeName := CurTokenString;
   NamePos:=Scanner.CurSourcePos;
   ExpectToken(tkEqual);
-  Scanner.ForceCaret:=True;
+  OldForceCaret:=Scanner.SetForceCaret(True);
   try
     Result:=ParseType(Parent,NamePos,TypeName,True);
   finally
-    Scanner.ForceCaret:=False;
+    Scanner.SetForceCaret(OldForceCaret);
   end;
 end;
 
@@ -2991,7 +2995,7 @@ var
   H : TPasMemberHints;
   VarMods: TVariableModifiers;
   D,Mods,Loc,aLibName,aExpName : string;
-  ok: Boolean;
+  OldForceCaret,ok: Boolean;
 
 begin
   OldListCount:=VarList.Count;
@@ -3009,11 +3013,11 @@ begin
       if CurToken=tkComma then
         ExpectIdentifier;
     Until (CurToken=tkColon);
-    Scanner.ForceCaret:=False;
+    OldForceCaret:=Scanner.SetForceCaret(True);
     try
       VarType := ParseComplexType(VarEl);
     finally
-      Scanner.ForceCaret:=False;
+      Scanner.SetForceCaret(OldForceCaret);
     end;
     // read type
     for i := OldListCount to VarList.Count - 1 do
@@ -3936,9 +3940,10 @@ begin
       begin
         NextToken;
         Left:=DoParseExpression(CurBlock);
-        UNgettoken;
+        UngetToken;
         El:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock));
         TPasImplIfElse(El).ConditionExpr:=Left;
+        Left.Parent:=El;
         //WriteLn(i,'IF Condition="',Condition,'" Token=',CurTokenText);
         CreateBlock(TPasImplIfElse(El));
         ExpectToken(tkthen);
@@ -3999,8 +4004,8 @@ begin
       begin
         // while Condition do
         NextToken;
-        left:=DoParseExpression(Parent);
-        ungettoken;
+        left:=DoParseExpression(CurBlock);
+        UngetToken;
         //WriteLn(i,'WHILE Condition="',Condition,'" Token=',CurTokenText);
         El:=TPasImplWhileDo(CreateElement(TPasImplWhileDo,'',CurBlock));
         TPasImplWhileDo(El).ConditionExpr:=left;
@@ -4009,7 +4014,7 @@ begin
       end;
     tkgoto:
       begin
-        nexttoken;
+        NextToken;
         curblock.AddCommand('goto '+curtokenstring);
         expecttoken(tkSemiColon);
       end;
@@ -4076,17 +4081,18 @@ begin
         // with Expr, Expr do
         SrcPos:=Scanner.CurSourcePos;
         NextToken;
-        Left:=DoParseExpression(Parent);
+        Left:=DoParseExpression(CurBlock);
         //writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText);
         El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
         TPasImplWithDo(El).AddExpression(Left);
+        Left.Parent:=El;
         CreateBlock(TPasImplWithDo(El));
         repeat
           if CurToken=tkdo then break;
           if CurToken<>tkComma then
             ParseExcTokenError(TokenInfos[tkdo]);
           NextToken;
-          Left:=DoParseExpression(Parent);
+          Left:=DoParseExpression(CurBlock);
           //writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
           TPasImplWithDo(CurBlock).AddExpression(Left);
         until false;
@@ -4094,7 +4100,7 @@ begin
     tkcase:
       begin
         NextToken;
-        Left:=DoParseExpression(Parent);
+        Left:=DoParseExpression(CurBlock);
         UngetToken;
         //writeln(i,'CASE OF Expr="',Expr,'" Token=',CurTokenText);
         ExpectToken(tkof);
@@ -4295,7 +4301,7 @@ begin
         if CurBlock is TPasImplRepeatUntil then
         begin
           NextToken;
-          Left:=DoParseExpression(Parent);
+          Left:=DoParseExpression(CurBlock);
           UngetToken;
           TPasImplRepeatUntil(CurBlock).ConditionExpr:=Left;
           //WriteLn(i,'UNTIL Condition="',Condition,'" Token=',CurTokenString);
@@ -4304,7 +4310,7 @@ begin
           ParseExcSyntaxError;
       end;
     else
-      left:=DoParseExpression(Parent);
+      left:=DoParseExpression(CurBlock);
       case CurToken of
         tkAssign,
         tkAssignPlus,
@@ -4315,7 +4321,7 @@ begin
           // assign statement
           Ak:=TokenToAssignKind(CurToken);
           NextToken;
-          right:=DoParseExpression(Parent); // this may solve TPasImplWhileDo.AddElement BUG
+          right:=DoParseExpression(CurBlock); // this may solve TPasImplWhileDo.AddElement BUG
           El:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock));
           left.Parent:=El;
           right.Parent:=El;

+ 12 - 3
packages/fcl-passrc/src/pscanner.pp

@@ -474,6 +474,7 @@ type
     Procedure RemoveDefine(S : String);
     Procedure SetCompilerMode(S : String);
     function CurSourcePos: TPasSourcePos;
+    Function SetForceCaret(AValue : Boolean) : Boolean;
 
     property FileResolver: TBaseFileResolver read FFileResolver;
     property CurSourceFile: TLineReader read FCurSourceFile;
@@ -500,7 +501,7 @@ type
     property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern;
     property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs;
     Property CurrentModeSwitches : TModeSwitches Read FCurrentModeSwitches Write FCurrentModeSwitches;
-    Property ForceCaret : Boolean Read FForceCaret Write FForceCaret;
+    Property ForceCaret : Boolean Read FForceCaret;
   end;
 
 const
@@ -2183,8 +2184,8 @@ begin
       end;
     '^':
       begin
-      if ForceCaret or
-         (PreviousToken in [tkIdentifier,tkNil,tkOperator,tkBraceClose,tkSquaredBraceClose,tkCARET]) then
+      if ForceCaret or PPisSkipping or
+         (PreviousToken in [tkeof,tkComment,tkIdentifier,tkNil,tkOperator,tkBraceClose,tkSquaredBraceClose,tkCARET]) then
         begin
         Inc(TokenStr);
         Result := tkCaret;
@@ -2379,4 +2380,12 @@ begin
   Result.Column:=CurColumn;
 end;
 
+Function TPascalScanner.SetForceCaret (AValue : Boolean): Boolean;
+
+begin
+  Result:=FForceCaret;
+  FForceCaret:=AValue;
+end;
+
+
 end.

+ 126 - 20
packages/fcl-passrc/tests/tcresolver.pas

@@ -228,6 +228,8 @@ type
     Procedure TestAssignProcResultFail;
     Procedure TestFunctionResultInCondition;
     Procedure TestExit;
+    Procedure TestBreak;
+    Procedure TestContinue;
 
     // record
     Procedure TestRecord;
@@ -241,6 +243,7 @@ type
     Procedure TestClassForward;
     Procedure TestClassForwardNotResolved;
     Procedure TestClass_Method;
+    Procedure TestClass_MethodWithParams;
     Procedure TestClass_MethodUnresolved;
     Procedure TestClass_MethodAbstract;
     Procedure TestClass_MethodAbstractWithoutVirtualFail;
@@ -251,6 +254,7 @@ type
     Procedure TestClass_MethodInvalidOverload;
     Procedure TestClass_MethodOverride;
     Procedure TestClass_MethodOverride2;
+    Procedure TestClass_MethodOverrideFixCase;
     Procedure TestClass_MethodScope;
     Procedure TestClass_IdentifierSelf;
     Procedure TestClassCallInherited;
@@ -2731,10 +2735,11 @@ procedure TTestResolver.TestUnitIntfProc;
 begin
   StartUnit(false);
   Add('interface');
-  Add('procedure {#A_forward}FuncA(i: longint);');
+  Add('procedure {#A_forward}FuncA({#Bar}Bar: longint);');
   Add('implementation');
-  Add('procedure {#A}FuncA(i: longint);');
+  Add('procedure {#A}FuncA(bar: longint);');
   Add('begin');
+  Add('  if {@Bar}bar=3 then ;');
   Add('end;');
   Add('initialization');
   Add('  {@A_forward}FuncA(3);');
@@ -2867,6 +2872,36 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestBreak;
+begin
+  StartProgram(false);
+  Add('var i: longint;');
+  Add('begin');
+  Add('  repeat');
+  Add('    break;');
+  Add('  until false;');
+  Add('  while true do');
+  Add('    break;');
+  Add('  for i:=0 to 1 do');
+  Add('    break;');
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestContinue;
+begin
+  StartProgram(false);
+  Add('var i: longint;');
+  Add('begin');
+  Add('  repeat');
+  Add('    continue;');
+  Add('  until false;');
+  Add('  while true do');
+  Add('    continue;');
+  Add('  for i:=0 to 1 do');
+  Add('    continue;');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestRecord;
 begin
   StartProgram(false);
@@ -3053,6 +3088,24 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClass_MethodWithParams;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  {#A}TObject = class');
+  Add('    procedure {#ProcA_Decl}ProcA({#Bar}Bar: longint);');
+  Add('  end;');
+  Add('procedure tobject.proca(bar: longint);');
+  Add('begin');
+  Add('  if {@Bar}bar=3 then ;');
+  Add('end;');
+  Add('var');
+  Add('  {#V}{=A}Obj: TObject;');
+  Add('begin');
+  Add('  {@V}Obj.{@ProcA_Decl}ProcA(4);');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestClass_MethodUnresolved;
 begin
   StartProgram(false);
@@ -3217,6 +3270,59 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClass_MethodOverrideFixCase;
+
+  procedure CheckOverrideName(aLabel: string);
+  var
+    Elements: TFPList;
+    i: Integer;
+    El: TPasElement;
+    Scope: TPasProcedureScope;
+  begin
+    Elements:=FindElementsAtSrcLabel(aLabel);
+    try
+      for i:=0 to Elements.Count-1 do
+        begin
+        El:=TPasElement(Elements[i]);
+        if not (El is TPasProcedure) then continue;
+        Scope:=El.CustomData as TPasProcedureScope;
+        if Scope.OverriddenProc=nil then
+          Fail('Scope.OverriddenProc=nil');
+        AssertEquals('Proc Name and Proc.Scope.OverriddenProc.Name',El.Name,Scope.OverriddenProc.Name);
+        end;
+    finally
+      Elements.Free;
+    end;
+  end;
+
+begin
+  ResolverEngine.Options:=ResolverEngine.Options+[proFixCaseOfOverrides];
+  StartProgram(false);
+  Add('type');
+  Add('  TObject = class');
+  Add('    procedure {#TOBJ_ProcA}ProcA; virtual; abstract;');
+  Add('  end;');
+  Add('  {#A}TClassA = class');
+  Add('    procedure {#A_ProcA}proca; override;');
+  Add('  end;');
+  Add('  {#B}TClassB = class');
+  Add('    procedure {#B_ProcA}prOca; override;');
+  Add('  end;');
+  Add('procedure tclassa.proca;');
+  Add('begin');
+  Add('end;');
+  Add('procedure tclassb.proca;');
+  Add('begin');
+  Add('end;');
+  Add('var');
+  Add('  {#V}{=B}v: TClassB;');
+  Add('begin');
+  Add('  {@V}v.{@B_ProcA}ProcA;');
+  ParseProgram;
+  CheckOverrideName('A_ProcA');
+  CheckOverrideName('B_ProcA');
+end;
+
 procedure TTestResolver.TestClass_MethodScope;
 begin
   StartProgram(false);
@@ -3261,30 +3367,30 @@ begin
   StartProgram(false);
   Add('type');
   Add('  TObject = class');
-  Add('    procedure {#TOBJ_ProcA}ProcA(i: longint); virtual;');
-  Add('    procedure {#TOBJ_ProcB}ProcB(j: longint); virtual;');
+  Add('    procedure {#TOBJ_ProcA}ProcA(vI: longint); virtual;');
+  Add('    procedure {#TOBJ_ProcB}ProcB(vJ: longint); virtual;');
   Add('  end;');
   Add('  {#A}TClassA = class');
-  Add('    procedure {#A_ProcA}ProcA(i: longint); override;');
-  Add('    procedure {#A_ProcB}ProcB(j: longint); override;');
+  Add('    procedure {#A_ProcA}ProcA({#i1}vI: longint); override;');
+  Add('    procedure {#A_ProcB}ProcB(vJ: longint); override;');
   Add('    procedure {#A_ProcC}ProcC; virtual;');
   Add('  end;');
-  Add('procedure TObject.ProcA(i: longint);');
+  Add('procedure TObject.ProcA(vi: longint);');
   Add('begin');
   Add('  inherited; // ignore, do not raise error');
   Add('end;');
-  Add('procedure TObject.ProcB(j: longint);');
+  Add('procedure TObject.ProcB(vj: longint);');
   Add('begin');
   Add('end;');
-  Add('procedure TClassA.ProcA({#i1}i: longint);');
+  Add('procedure TClassA.ProcA(vi: longint);');
   Add('begin');
-  Add('  {@A_ProcA}ProcA({@i1}i);');
+  Add('  {@A_ProcA}ProcA({@i1}vI);');
   Add('  {@TOBJ_ProcA}inherited;');
-  Add('  inherited {@TOBJ_ProcA}ProcA({@i1}i);');
-  Add('  {@A_ProcB}ProcB({@i1}i);');
-  Add('  inherited {@TOBJ_ProcB}ProcB({@i1}i);');
+  Add('  inherited {@TOBJ_ProcA}ProcA({@i1}vI);');
+  Add('  {@A_ProcB}ProcB({@i1}vI);');
+  Add('  inherited {@TOBJ_ProcB}ProcB({@i1}vI);');
   Add('end;');
-  Add('procedure TClassA.ProcB(j: longint);');
+  Add('procedure TClassA.ProcB(vJ: longint);');
   Add('begin');
   Add('end;');
   Add('procedure TClassA.ProcC;');
@@ -3338,20 +3444,20 @@ begin
   StartProgram(false);
   Add('type');
   Add('  TObject = class');
-  Add('    constructor {#TOBJ_CreateA}Create(i: longint); virtual;');
+  Add('    constructor {#TOBJ_CreateA}Create(vI: longint); virtual;');
   Add('  end;');
   Add('  {#A}TClassA = class');
-  Add('    constructor {#A_CreateA}Create(i: longint); override;');
+  Add('    constructor {#A_CreateA}Create({#i1}vI: longint); override;');
   Add('  end;');
-  Add('constructor TObject.Create(i: longint);');
+  Add('constructor TObject.Create(vI: longint);');
   Add('begin');
   Add('  inherited; // ignore and do not raise error');
   Add('end;');
-  Add('constructor TClassA.Create({#i1}i: longint);');
+  Add('constructor TClassA.Create(vI: longint);');
   Add('begin');
-  Add('  {@A_CreateA}Create({@i1}i);');
+  Add('  {@A_CreateA}Create({@i1}vI);');
   Add('  {@TOBJ_CreateA}inherited;');
-  Add('  inherited {@TOBJ_CreateA}Create({@i1}i);');
+  Add('  inherited {@TOBJ_CreateA}Create({@i1}vI);');
   Add('end;');
   Add('begin');
   ParseProgram;

File diff suppressed because it is too large
+ 366 - 145
packages/pastojs/src/fppas2js.pp


+ 69 - 37
packages/pastojs/tests/tcconverter.pp

@@ -607,18 +607,29 @@ Var
   L : TJSStatementList;
 
 begin
-  // Try a:=B except b:=c end;
+  // Try a:=b except b:=c end;
+  (*
+    Becomes:
+    try {
+     a=b;
+    } catch {
+      b = c;
+    }
+  *)
   T:=TPasImplTry.Create('',Nil);
   T.AddElement(CreateAssignStatement('a','b'));
   F:=T.AddExcept;
   F.AddElement(CreateAssignStatement('b','c'));
+  // Convert
   El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement));
+  AssertEquals('No exception object name','',String(El.Ident));
+  // check "a=b;"
   L:=AssertListStatement('try..except block is statement list',El.Block);
   AssertAssignStatement('Correct assignment in try..except block',L.A,'a','b');
   AssertNull('No second statement',L.B);
+  // check "b=c;'
   L:=AssertListStatement('try..except block is statement list',El.BCatch);
   AssertAssignStatement('Correct assignment in except..end block',L.A,'b','c');
-  AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
   AssertNull('No second statement',L.B);
 end;
 
@@ -631,19 +642,21 @@ Var
   El : TJSTryCatchStatement;
   L : TJSStatementList;
   I : TJSIfStatement;
-  IC : TJSRelationalExpressionInstanceOf;
-  V : TJSVarDeclaration;
+  IC : TJSCallExpression;
+  D: TJSDotMemberExpression;
+  ExObj: TJSElement;
+  VS: TJSVariableStatement;
+  V: TJSVarDeclaration;
 
 begin
-  // Try a:=B except on E : exception do  b:=c end;
   // Try a:=B except on E : exception do  b:=c end;
   (*
     Becomes:
     try {
      a=b;
-    } catch (ExceptObject) {
-      if (ExceptObject instanceof exception) {
-        var e = ExceptObject;
+    } catch (exceptobject) {
+      if (exception.isPrototypeOf(exceptobject)) {
+        var e = exceptobject;
         b = c;
       }
     }
@@ -655,20 +668,28 @@ begin
   O.Body:=CreateAssignStatement('b','c');
   // Convert
   El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement));
+  // check "catch(exceptobject)"
   AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
-  L:=AssertListStatement('try..except block is statement list',El.BCatch);
-  AssertNull('No second statement',L.B);
-  I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A));
-  Ic:=TJSRelationalExpressionInstanceOf(AssertElement('If condition is InstanceOf expression',TJSRelationalExpressionInstanceOf,I.Cond));
-  Assertidentifier('InstanceOf left is exception object',Ic.A,lowercase(DefaultJSExceptionObject));
-  // Lowercased exception - May need checking
-  Assertidentifier('InstanceOf right is original exception type',Ic.B,'exception');
-  L:=AssertListStatement('On block is always a list',i.btrue);
-  V:=TJSVarDeclaration(AssertElement('First statement in list is a var declaration',TJSVarDeclaration,L.A));
+  // check "if"
+  I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,El.BCatch));
+  // check if condition "exception.isPrototypeOf(exceptobject)"
+  IC:=TJSCallExpression(AssertElement('If condition is call expression',TJSCallExpression,I.Cond));
+  D:=TJSDotMemberExpression(AssertElement('exception.isPrototypeOf is dot member expression',TJSDotMemberExpression,IC.Expr));
+  Assertidentifier('left side of exception.isPrototypeOf',D.MExpr,'exception');
+  AssertEquals('right side of exception.isPrototypeOf','isPrototypeOf',String(D.Name));
+  AssertNotNull('args of exception.isPrototypeOf(exceptobject)',IC.Args);
+  AssertEquals('args of exception.isPrototypeOf(exceptobject)',1,IC.Args.Elements.Count);
+  ExObj:=IC.Args.Elements.Elements[0].Expr;
+  Assertidentifier('arg of exception.isPrototypeOf(exceptobject)',ExObj,lowercase(DefaultJSExceptionObject));
+  // check statement "var e = exceptobject;"
+  L:=AssertListStatement('On block is always a list',I.BTrue);
+  writeln('TTestStatementConverter.TestTryExceptStatementOnE ',L.A.ClassName);
+  VS:=TJSVariableStatement(AssertElement('First statement in list is a var statement',TJSVariableStatement,L.A));
+  V:=TJSVarDeclaration(AssertElement('var declaration e=ExceptObject',TJSVarDeclaration,VS.A));
   AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name);
-  Assertidentifier('Variable init is exception object',v.init,lowercase(DefaultJSExceptionObject));
-  L:=AssertListStatement('Second statement is again list',L.B);
-  AssertAssignStatement('Original assignment in second statement',L.A,'b','c');
+  Assertidentifier('Variable init is exception object',V.Init,lowercase(DefaultJSExceptionObject));
+  // check "b = c;"
+  AssertAssignStatement('Original assignment in second statement',L.B,'b','c');
 end;
 
 Procedure TTestStatementConverter.TestReRaise;
@@ -679,20 +700,23 @@ Var
   El : TJSTryCatchStatement;
   L : TJSStatementList;
   I : TJSIfStatement;
-  IC : TJSRelationalExpressionInstanceOf;
+  IC : TJSCallExpression;
   R : TJSThrowStatement;
   V : TJSVarDeclaration;
+  D: TJSDotMemberExpression;
+  ExObj: TJSElement;
+  VS: TJSVariableStatement;
 
 begin
-  // Try a:=B except on E : exception do  b:=c end;
+  // Try a:=B except on E : exception do raise; end;
   (*
     Becomes:
     try {
      a=b;
-    } catch (jsexception) {
-      if jsexception instanceof exception {
-        var e = jsexception;
-        throw jsexception;
+    } catch (exceptobject) {
+      if (exception.isPrototypeOf(exceptobject)) {
+        var e = exceptobject;
+        throw exceptobject;
       }
     }
   *)
@@ -703,19 +727,27 @@ begin
   O.Body:=TPasImplRaise.Create('',Nil);
   // Convert
   El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement));
+  // check "catch(exceptobject)"
   AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
-  L:=AssertListStatement('try..except block is statement list',El.BCatch);
-  AssertNull('No second statement',L.B);
-  I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A));
-  Ic:=TJSRelationalExpressionInstanceOf(AssertElement('If condition is InstanceOf expression',TJSRelationalExpressionInstanceOf,I.Cond));
-  Assertidentifier('InstanceOf left is exception object',Ic.A,lowercase(DefaultJSExceptionObject));
-  // Lowercased exception - May need checking
-  L:=AssertListStatement('On block is always a list',i.btrue);
-  V:=TJSVarDeclaration(AssertElement('First statement in list is a var declaration',TJSVarDeclaration,L.A));
+  // check "if"
+  I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,El.BCatch));
+  // check if condition "exception.isPrototypeOf(exceptobject)"
+  IC:=TJSCallExpression(AssertElement('If condition is call expression',TJSCallExpression,I.Cond));
+  D:=TJSDotMemberExpression(AssertElement('exception.isPrototypeOf is dot member expression',TJSDotMemberExpression,IC.Expr));
+  Assertidentifier('left side of exception.isPrototypeOf',D.MExpr,'exception');
+  AssertEquals('right side of exception.isPrototypeOf','isPrototypeOf',String(D.Name));
+  AssertNotNull('args of exception.isPrototypeOf(ExceptObject)',IC.Args);
+  AssertEquals('args of exception.isPrototypeOf(ExceptObject)',1,IC.Args.Elements.Count);
+  ExObj:=IC.Args.Elements.Elements[0].Expr;
+  Assertidentifier('arg of exception.isPrototypeOf(ExceptObject)',ExObj,lowercase(DefaultJSExceptionObject));
+  // check statement "var e = exceptobject;"
+  L:=AssertListStatement('On block is always a list',I.BTrue);
+  writeln('TTestStatementConverter.TestTryExceptStatementOnE ',L.A.ClassName);
+  VS:=TJSVariableStatement(AssertElement('First statement in list is a var statement',TJSVariableStatement,L.A));
+  V:=TJSVarDeclaration(AssertElement('var declaration e=ExceptObject',TJSVarDeclaration,VS.A));
   AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name);
-  Assertidentifier('Variable init is exception object',v.init,lowercase(DefaultJSExceptionObject));
-  L:=AssertListStatement('Second statement is again list',L.B);
-  R:=TJSThrowStatement(AssertElement('On block is throw statement',TJSThrowStatement,L.A));
+  Assertidentifier('Variable init is exception object',V.Init,lowercase(DefaultJSExceptionObject));
+  R:=TJSThrowStatement(AssertElement('On block is throw statement',TJSThrowStatement,L.B));
   Assertidentifier('R expression is original exception ',R.A,lowercase(DefaultJSExceptionObject));
 end;
 

File diff suppressed because it is too large
+ 320 - 238
packages/pastojs/tests/tcmodules.pas


Some files were not shown because too many files changed in this diff