pastojs: filer: try-except

git-svn-id: trunk@43952 -

packages/pastojs/src/pas2jsfiler.pp

@@ -843,6 +843,7 @@ type
     procedure WriteImplSimple(Obj: TJSONObject; El: TPasImplSimple; aContext: TPCUWriterContext); virtual;
     procedure WriteImplTry(Obj: TJSONObject; El: TPasImplTry; aContext: TPCUWriterContext); virtual;
     procedure WriteImplTryHandler(Obj: TJSONObject; El: TPasImplTryHandler; aContext: TPCUWriterContext); virtual;
+    procedure WriteImplExceptOn(Obj: TJSONObject; El: TPasImplExceptOn; aContext: TPCUWriterContext); virtual;
     procedure WriteImplRaise(Obj: TJSONObject; El: TPasImplRaise; aContext: TPCUWriterContext); virtual;
   public
     constructor Create; override;
@@ -937,6 +938,7 @@ type
     procedure Set_PropertyScope_AncestorProp(RefEl: TPasElement; Data: TObject);
     procedure Set_ProcedureScope_ImplProc(RefEl: TPasElement; Data: TObject);
     procedure Set_ProcedureScope_Overridden(RefEl: TPasElement; Data: TObject);
+    procedure Set_ExceptOn_TypeEl(RefEl: TPasElement; Data: TObject);
     procedure Set_ResolvedReference_Declaration(RefEl: TPasElement; Data: TObject);
     procedure Set_ResolvedReference_CtxConstructor(RefEl: TPasElement; Data: TObject);
     procedure Set_ResolvedReference_CtxAttrProc(RefEl: TPasElement; Data: TObject);
@@ -1104,6 +1106,7 @@ type
     procedure ReadImplSimple(Obj: TJSONObject; El: TPasImplSimple; aContext: TPCUReaderContext); virtual;
     procedure ReadImplTry(Obj: TJSONObject; El: TPasImplTry; aContext: TPCUReaderContext); virtual;
     procedure ReadImplTryHandler(Obj: TJSONObject; El: TPasImplTryHandler; aContext: TPCUReaderContext); virtual;
+    procedure ReadImplExceptOn(Obj: TJSONObject; El: TPasImplExceptOn; aContext: TPCUReaderContext); virtual;
     procedure ReadImplRaise(Obj: TJSONObject; El: TPasImplRaise; aContext: TPCUReaderContext); virtual;
   public
     constructor Create; override;
@@ -2834,7 +2837,7 @@ var
 begin
   if El=nil then exit;
   if (Parent<>El.Parent) then
-    RaiseMsg(20180208221751,El,GetObjName(Parent)+'<>'+GetObjName(El.Parent));
+    RaiseMsg(20180208221751,El,PropName+': '+GetObjName(Parent)+'<>'+GetObjName(El.Parent));
   SubObj:=TJSONObject.Create;
   Obj.Add(PropName,SubObj);
   WriteElement(SubObj,El,aContext);
@@ -3585,6 +3588,11 @@ begin
     Obj.Add('Type','ExceptElse');
     WriteImplTryHandler(Obj,TPasImplTryExceptElse(El),aContext);
     end
+  else if C=TPasImplExceptOn then
+    begin
+    Obj.Add('Type','ExceptOn');
+    WriteImplExceptOn(Obj,TPasImplExceptOn(El),aContext);
+    end
   else if C=TPasImplRaise then
     begin
     Obj.Add('Type','Raise');
@@ -4559,6 +4567,16 @@ begin
   WriteElementList(Obj,El,'El',El.Elements,aContext);
 end;
 
+procedure TPCUWriter.WriteImplExceptOn(Obj: TJSONObject; El: TPasImplExceptOn;
+  aContext: TPCUWriterContext);
+begin
+  WritePasElement(Obj,El,aContext);
+  WriteElementProperty(Obj,El,'Var',El.VarEl,aContext);
+  if El.VarEl=nil then
+    WriteElType(Obj,El,'VarType',El.TypeEl,aContext);
+  WriteElementProperty(Obj,El,'Body',El.Body,aContext);
+end;
+
 procedure TPCUWriter.WriteImplRaise(Obj: TJSONObject; El: TPasImplRaise;
   aContext: TPCUWriterContext);
 begin
@@ -5079,6 +5097,20 @@ begin
     RaiseMsg(20180213215959,Scope.Element,GetObjName(RefEl));
 end;
 
+procedure TPCUReader.Set_ExceptOn_TypeEl(RefEl: TPasElement; Data: TObject);
+var
+  El: TPasImplExceptOn absolute Data;
+begin
+  if RefEl is TPasType then
+    begin
+    El.TypeEl:=TPasType(RefEl);
+    if RefEl.Parent<>El then
+      RefEl.AddRef{$IFDEF CheckPasTreeRefCount}('TPasVariable.VarType'){$ENDIF};
+    end
+  else
+    RaiseMsg(20200115214455,El,GetObjName(RefEl));
+end;
+
 procedure TPCUReader.Set_ResolvedReference_Declaration(RefEl: TPasElement;
   Data: TObject);
 var
@@ -7267,6 +7299,11 @@ begin
       Result:=CreateElement(TPasImplTryExceptElse,Name,Parent);
       ReadImplTryHandler(Obj,TPasImplTryExceptElse(Result),aContext);
       end;
+    'ExceptOn':
+      begin
+      Result:=CreateElement(TPasImplExceptOn,Name,Parent);
+      ReadImplExceptOn(Obj,TPasImplExceptOn(Result),aContext);
+      end;
     'Raise':
       begin
       Result:=CreateElement(TPasImplRaise,Name,Parent);
@@ -8819,20 +8856,13 @@ end;
 
 procedure TPCUReader.ReadImplTry(Obj: TJSONObject; El: TPasImplTry;
   aContext: TPCUReaderContext);
-var
-  FinallyEl: TPasImplTryHandler;
-  ElseEl: TPasImplTryExceptElse;
 begin
   ReadPasElement(Obj,El,aContext);
   ReadElementList(Obj,El,'Try',El.Elements,
     {$IFDEF CheckPasTreeRefCount}'TPasImplTry.Elements'{$ELSE}true{$ENDIF}
     ,aContext);
-  FinallyEl:=TPasImplTryHandler(ReadElementProperty(Obj,El,'Finally',TPasImplTryHandler,aContext));
-  if  FinallyEl<>nil then
-    El.FinallyExcept:=FinallyEl;
-  ElseEl:=TPasImplTryExceptElse(ReadElementProperty(Obj,El,'Else',TPasImplTryExceptElse,aContext));
-  if  FinallyEl<>nil then
-    El.ElseBranch:=ElseEl;
+  El.FinallyExcept:=TPasImplTryHandler(ReadElementProperty(Obj,El,'Finally',TPasImplTryHandler,aContext));
+  El.ElseBranch:=TPasImplTryExceptElse(ReadElementProperty(Obj,El,'Else',TPasImplTryExceptElse,aContext));
 end;
 
 procedure TPCUReader.ReadImplTryHandler(Obj: TJSONObject;
@@ -8844,6 +8874,25 @@ begin
     ,aContext);
 end;
 
+procedure TPCUReader.ReadImplExceptOn(Obj: TJSONObject; El: TPasImplExceptOn;
+  aContext: TPCUReaderContext);
+var
+  Body: TPasImplElement;
+begin
+  ReadPasElement(Obj,El,aContext);
+  El.VarEl:=TPasVariable(ReadElementProperty(Obj,El,'Var',TPasVariable,aContext));
+  if El.VarEl<>nil then
+    begin
+    El.TypeEl:=El.VarEl.VarType;
+    El.TypeEl.AddRef{$IFDEF CheckPasTreeRefCount}('TPasVariable.VarType'){$ENDIF};
+    end
+  else
+    ReadElType(Obj,'VarType',El,@Set_ExceptOn_TypeEl,aContext);
+  Body:=TPasImplElement(ReadElementProperty(Obj,El,'Body',TPasImplElement,aContext));
+  if Body<>nil then
+    El.AddElement(Body);
+end;
+
 procedure TPCUReader.ReadImplRaise(Obj: TJSONObject; El: TPasImplRaise;
   aContext: TPCUReaderContext);
 begin

packages/pastojs/tests/tcfiler.pas

@@ -147,6 +147,7 @@ type
     procedure CheckRestoredImplSimple(const Path: string; Orig, Rest: TPasImplSimple; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredImplTry(const Path: string; Orig, Rest: TPasImplTry; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredImplTryHandler(const Path: string; Orig, Rest: TPasImplTryHandler; Flags: TPCCheckFlags); virtual;
+    procedure CheckRestoredImplExceptOn(const Path: string; Orig, Rest: TPasImplExceptOn; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredImplRaise(const Path: string; Orig, Rest: TPasImplRaise; Flags: TPCCheckFlags); virtual;
   public
     property Analyzer: TPas2JSAnalyzer read FAnalyzer;
@@ -201,13 +202,12 @@ type
     procedure TestPC_GenericFunction_IfElse;
     procedure TestPC_GenericFunction_WhileDo;
     procedure TestPC_GenericFunction_WithDo;
-    // TPasImplCaseOf
-    // TPasImplForLoop
-    // TPasImplAssign
-    // TPasImplSimple
-    // TPasImplTry    TPasImplTryHandler  TPasImplTryFinally  TPasImplTryExcept TPasImplTryExceptElse TPasImplExceptOn
-    // TPasImplRaise
-
+    procedure TestPC_GenericFunction_CaseOf;
+    procedure TestPC_GenericFunction_ForLoop;
+    procedure TestPC_GenericFunction_Simple;
+    procedure TestPC_GenericFunction_TryFinally;
+    procedure TestPC_GenericFunction_TryExcept;
+    procedure TestPC_GenericFunction_LocalProc;
 
     procedure TestPC_UseUnit;
     procedure TestPC_UseUnit_Class;
@@ -1054,7 +1054,10 @@ begin
       C:=Orig.ClassType;
       if (C=TResolvedReference)
           or (C=TPasWithScope)
-          or (C=TPas2JSWithExprScope) then
+          or (C=TPas2JSWithExprScope)
+          or (C=TPasForLoopScope)
+          or (C=TPasExceptOnScope)
+          or C.InheritsFrom(TResEvalValue) then
         exit
       else
         Fail(Path+': Generic Orig='+GetObjName(Orig)+' Rest=nil');
@@ -1292,6 +1295,8 @@ begin
       or (C=TPasImplTryExcept)
       or (C=TPasImplTryExceptElse) then
     CheckRestoredImplTryHandler(Path,TPasImplTryHandler(Orig),TPasImplTryHandler(Rest),Flags)
+  else if (C=TPasImplExceptOn) then
+    CheckRestoredImplExceptOn(Path,TPasImplExceptOn(Orig),TPasImplExceptOn(Rest),Flags)
   else if (C=TPasImplRaise) then
     CheckRestoredImplRaise(Path,TPasImplRaise(Orig),TPasImplRaise(Rest),Flags)
   else if (C=TPasModule)
@@ -1906,6 +1911,14 @@ begin
   CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
 end;
 
+procedure TCustomTestPrecompile.CheckRestoredImplExceptOn(const Path: string;
+  Orig, Rest: TPasImplExceptOn; Flags: TPCCheckFlags);
+begin
+  CheckRestoredElement(Path+'.VarEl',Orig.VarEl,Rest.VarEl,Flags);
+  CheckRestoredElOrRef(Path+'.TypeEl',Orig,Orig.TypeEl,Rest,Rest.TypeEl,Flags);
+  CheckRestoredElement(Path+'.Body',Orig.Body,Rest.Body,Flags);
+end;
+
 procedure TCustomTestPrecompile.CheckRestoredImplRaise(const Path: string;
   Orig, Rest: TPasImplRaise; Flags: TPCCheckFlags);
 begin
@@ -2798,6 +2811,173 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_GenericFunction_CaseOf;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'generic function Run<T>(a: T): T;',
+  'implementation',
+  'generic function Run<T>(a: T): T;',
+  'var i,j,k,l,m,n,o: word;',
+  'begin',
+  '  case i of',
+  '  1: ;',
+  '  end;',
+  '  case j of',
+  '  1: ;',
+  '  2..3: ;',
+  '  4,5: ;',
+  '  end;',
+  '  case k of',
+  '  1: ;',
+  '  else',
+  '  end;',
+  '  case l of',
+  '  1: ;',
+  '  else m:=m;',
+  '  end;',
+  '  case n of',
+  '  1: o:=o;',
+  '  end;',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_GenericFunction_ForLoop;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'generic function Run<T>(a: T): T;',
+  'implementation',
+  'generic function Run<T>(a: T): T;',
+  'var i,j,k,l: word;',
+  '  c: char;',
+  'begin',
+  '  for i:=1 to 3 do ;',
+  '  for j:=1+4 to 3*7 do ;',
+  '  for k:=-1 to 2 do l:=l;',
+  '  for c in char do ;',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_GenericFunction_Simple;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'generic function Run<T>(a: T): T;',
+  'implementation',
+  'procedure Fly(w: word = 0); begin end;',
+  'generic function Run<T>(a: T): T;',
+  'begin',
+  '  Fly;',
+  '  Fly();',
+  '  Fly(3);',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_GenericFunction_TryFinally;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'generic function Run<T>(a: T): T;',
+  'implementation',
+  'generic function Run<T>(a: T): T;',
+  'var i: word;',
+  'begin',
+  '  try',
+  '  finally;',
+  '  end;',
+  '  try',
+  '    i:=i;',
+  '  finally;',
+  '  end;',
+  '  try',
+  '  finally;',
+  '    i:=i;',
+  '  end;',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_GenericFunction_TryExcept;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  TObject = class end;',
+  '  Exception = class Msg: string; end;',
+  '  EInvalidCast = class(Exception) end;',
+  'generic function Run<T>(a: T): T;',
+  'implementation',
+  'generic function Run<T>(a: T): T;',
+  'var vI: longint;',
+  'begin',
+  '  try',
+  '    vi:=1;',
+  '  except',
+  '    vi:=2',
+  '  end;',
+  '  try',
+  '  except',
+  '    raise;',
+  '  end;',
+  '  try',
+  '    VI:=4;',
+  '  except',
+  '    on einvalidcast do',
+  '      raise;',
+  '    on E: exception do',
+  '      if e.msg='''' then',
+  '        raise e;',
+  '    else',
+  '      vi:=5',
+  '  end;',
+  '  try',
+  '    VI:=6;',
+  '  except',
+  '    on einvalidcast do ;',
+  '  end;',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_GenericFunction_LocalProc;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'generic function Run<T>(a: T): T;',
+  'implementation',
+  'generic function Run<T>(a: T): T;',
+  'var vI: longint;',
+  '  procedure SubA; forward;',
+  '  procedure SubB;',
+  '  begin',
+  '    SubA;',
+  '  end;',
+  '  procedure SubA;',
+  '  begin',
+  '    SubB;',
+  '  end;',
+  'begin',
+  '  SubB;',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_UseUnit;
 begin
   AddModuleWithIntfImplSrc('unit2.pp',

packages/pastojs/tests/tcmodules.pas

@@ -8028,38 +8028,40 @@ end;
 procedure TTestModule.TestTryExcept;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  TObject = class end;');
-  Add('  Exception = class Msg: string; end;');
-  Add('  EInvalidCast = class(Exception) end;');
-  Add('var vI: longint;');
-  Add('begin');
-  Add('  try');
-  Add('    vi:=1;');
-  Add('  except');
-  Add('    vi:=2');
-  Add('  end;');
-  Add('  try');
-  Add('    vi:=3;');
-  Add('  except');
-  Add('    raise;');
-  Add('  end;');
-  Add('  try');
-  Add('    VI:=4;');
-  Add('  except');
-  Add('    on einvalidcast do');
-  Add('      raise;');
-  Add('    on E: exception do');
-  Add('      if e.msg='''' then');
-  Add('        raise e;');
-  Add('    else');
-  Add('      vi:=5');
-  Add('  end;');
-  Add('  try');
-  Add('    VI:=6;');
-  Add('  except');
-  Add('    on einvalidcast do ;');
-  Add('  end;');
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  Exception = class Msg: string; end;',
+  '  EInvalidCast = class(Exception) end;',
+  'var vI: longint;',
+  'begin',
+  '  try',
+  '    vi:=1;',
+  '  except',
+  '    vi:=2',
+  '  end;',
+  '  try',
+  '    vi:=3;',
+  '  except',
+  '    raise;',
+  '  end;',
+  '  try',
+  '    VI:=4;',
+  '  except',
+  '    on einvalidcast do',
+  '      raise;',
+  '    on E: exception do',
+  '      if e.msg='''' then',
+  '        raise e;',
+  '    else',
+  '      vi:=5',
+  '  end;',
+  '  try',
+  '    VI:=6;',
+  '  except',
+  '    on einvalidcast do ;',
+  '  end;',
+  '']);
   ConvertProgram;
   CheckSource('TestTryExcept',
     LinesToStr([ // statements