浏览代码

# revisions: 40446,40447,40450,40451,40452,40455,40456,40457,40458,40459,40460,40461,40469,40470,40471,40473,40474,40475,40476,40477,40478,40479,40483,40484,40486,40487,40488,40489,40491,40493,40494,40495,40505,40506,40507,40508,40509,40514,40516,40517,40518,40522,40523,40530,40531,40533,40534,40549,40550,40551,40553,40554,40555,40558,40559,40562,40580,40582,40584,40591,40593,40594,40596,40597,40620,40638,40639,40650,40659,40671,40672,40674,40675,40685,40691,40708,40712,40714,40715,40722,40768,40795,40796,40797,40799

git-svn-id: branches/fixes_3_2@41993 -
marco 6 年之前
父节点
当前提交
586398ad41
共有 44 个文件被更改,包括 6923 次插入2091 次删除
  1. 7 0
      .gitattributes
  2. 238 52
      packages/fcl-db/tests/testjsondataset.pp
  3. 2 2
      packages/fcl-js/src/jsbase.pp
  4. 2 0
      packages/fcl-js/src/jswriter.pp
  5. 89 66
      packages/fcl-passrc/src/pasresolveeval.pas
  6. 374 145
      packages/fcl-passrc/src/pasresolver.pp
  7. 317 167
      packages/fcl-passrc/src/pastree.pp
  8. 94 66
      packages/fcl-passrc/src/pasuseanalyzer.pas
  9. 311 147
      packages/fcl-passrc/src/pparser.pp
  10. 33 7
      packages/fcl-passrc/src/pscanner.pp
  11. 3 1
      packages/fcl-passrc/tests/tcclasstype.pas
  12. 1031 39
      packages/fcl-passrc/tests/tcresolver.pas
  13. 1 1
      packages/fcl-passrc/tests/tcscanner.pas
  14. 236 38
      packages/fcl-passrc/tests/tctypeparser.pas
  15. 37 0
      packages/fcl-passrc/tests/tcuseanalyzer.pas
  16. 13 1
      packages/pastojs/fpmake.pp
  17. 373 107
      packages/pastojs/src/fppas2js.pp
  18. 5 0
      packages/pastojs/src/pas2js_defines.inc
  19. 325 570
      packages/pastojs/src/pas2jscompiler.pp
  20. 97 0
      packages/pastojs/src/pas2jscompilercfg.pp
  21. 262 0
      packages/pastojs/src/pas2jscompilerpp.pp
  22. 206 340
      packages/pastojs/src/pas2jsfilecache.pp
  23. 28 20
      packages/pastojs/src/pas2jsfiler.pp
  24. 0 88
      packages/pastojs/src/pas2jsfileutils.pp
  25. 453 0
      packages/pastojs/src/pas2jsfs.pp
  26. 166 0
      packages/pastojs/src/pas2jsfscompiler.pp
  27. 8 4
      packages/pastojs/src/pas2jslibcompiler.pp
  28. 64 8
      packages/pastojs/src/pas2jslogger.pp
  29. 103 79
      packages/pastojs/src/pas2jspcucompiler.pp
  30. 430 0
      packages/pastojs/src/pas2jsutils.pp
  31. 1 0
      packages/pastojs/tests/tcconverter.pp
  32. 146 4
      packages/pastojs/tests/tcfiler.pas
  33. 643 73
      packages/pastojs/tests/tcmodules.pas
  34. 9 9
      packages/pastojs/tests/tcoptimizations.pas
  35. 6 6
      packages/pastojs/tests/tcprecompile.pas
  36. 6 5
      packages/pastojs/tests/tcunitsearch.pas
  37. 7 8
      packages/pastojs/tests/testpas2js.lpi
  38. 67 19
      utils/pas2js/dist/rtl.js
  39. 65 8
      utils/pas2js/docs/translation.html
  40. 6 4
      utils/pas2js/nodepas2js.pp
  41. 25 3
      utils/pas2js/pas2js.lpi
  42. 7 4
      utils/pas2js/pas2js.pp
  43. 97 0
      utils/pas2js/pas2jswebcompiler.pp
  44. 530 0
      utils/pas2js/webfilecache.pp

+ 7 - 0
.gitattributes

@@ -6947,16 +6947,21 @@ packages/pastojs/src/fppas2js.pp svneol=native#text/plain
 packages/pastojs/src/fppjssrcmap.pp svneol=native#text/plain
 packages/pastojs/src/pas2js_defines.inc svneol=native#text/plain
 packages/pastojs/src/pas2jscompiler.pp svneol=native#text/plain
+packages/pastojs/src/pas2jscompilercfg.pp svneol=native#text/plain
+packages/pastojs/src/pas2jscompilerpp.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsfilecache.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsfiler.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsfileutils.pp svneol=native#text/plain
 packages/pastojs/src/pas2jsfileutilsnodejs.inc svneol=native#text/plain
 packages/pastojs/src/pas2jsfileutilsunix.inc svneol=native#text/plain
 packages/pastojs/src/pas2jsfileutilswin.inc svneol=native#text/plain
+packages/pastojs/src/pas2jsfs.pp svneol=native#text/plain
+packages/pastojs/src/pas2jsfscompiler.pp svneol=native#text/plain
 packages/pastojs/src/pas2jslibcompiler.pp svneol=native#text/plain
 packages/pastojs/src/pas2jslogger.pp svneol=native#text/plain
 packages/pastojs/src/pas2jspcucompiler.pp svneol=native#text/plain
 packages/pastojs/src/pas2jspparser.pp svneol=native#text/plain
+packages/pastojs/src/pas2jsutils.pp svneol=native#text/plain
 packages/pastojs/tests/tcconverter.pp svneol=native#text/plain
 packages/pastojs/tests/tcfiler.pas svneol=native#text/plain
 packages/pastojs/tests/tcmodules.pas svneol=native#text/plain
@@ -17346,6 +17351,7 @@ utils/pas2js/pas2js.lpi svneol=native#text/plain
 utils/pas2js/pas2js.pp svneol=native#text/plain
 utils/pas2js/pas2jslib.lpi svneol=native#text/plain
 utils/pas2js/pas2jslib.pp svneol=native#text/plain
+utils/pas2js/pas2jswebcompiler.pp svneol=native#text/plain
 utils/pas2js/samples/arraydemo.pp svneol=native#text/plain
 utils/pas2js/samples/fordemo.pp svneol=native#text/plain
 utils/pas2js/samples/fordowndemo.pp svneol=native#text/plain
@@ -17353,6 +17359,7 @@ utils/pas2js/samples/hello.pas svneol=native#text/plain
 utils/pas2js/samples/ifdemo.pp svneol=native#text/plain
 utils/pas2js/samples/repeatdemo.pp svneol=native#text/plain
 utils/pas2js/samples/whiledemo.pp svneol=native#text/plain
+utils/pas2js/webfilecache.pp svneol=native#text/plain
 utils/pas2js/webidl2pas.lpi svneol=native#text/plain
 utils/pas2js/webidl2pas.pp svneol=native#text/plain
 utils/pas2ut/Makefile svneol=native#text/plain

+ 238 - 52
packages/fcl-db/tests/testjsondataset.pp

@@ -1,80 +1,106 @@
-program testjsondataset;
+program devds;
 
 {$DEFINE TESTCALCFIELDS}
+{$DEFINE TESTLOOKUPFIELDS}
 
-uses sysutils, db, jsonparser, fpjson,fpjsondataset, extjsdataset;
+uses variants, varutils, sysutils, db, fpjson , fpjsondataset, ExtJSDataset, types;
 
 Type
 
   { TApp }
 
   TApp = Class(TObject)
-    Procedure DumpRecord(DS : TDataset);
-    Procedure DumpRecords(DS : TDataset);
-    Procedure Run;
   private
+    DS : TExtJSJSONObjectDataSet;
+    DC : TExtJSJSONObjectDataSet;
+    Procedure DumpRecord(aDS : TDataset);
+    Procedure DumpRecords(aDS : TDataset);
+    procedure CreateDataset;
     procedure DoCalcFields(DataSet: TDataSet);
+    procedure TestAppend;
+    procedure TestBookMark;
+    procedure TestDataLinkActiveRecord;
+    procedure TestDataLinkEdit;
+    procedure TestEdit;
+    procedure TestInsert;
+    procedure TestLocate;
+    procedure TestLookup;
+    procedure TestNavigation;
+  Public
+    Procedure Run;
   end;
 
-Procedure TApp.DumpRecord(DS : TDataset);
-
-//Var
-//  F : TField;
+Procedure TApp.DumpRecord(aDS : TDataset);
 
 begin
-//  For F in  DS.Fields do
-//    Write(F.Name,' : ',F.IsNull,' ');
-//  WriteLn;
   Writeln(
   {$IFDEF TESTCALCFIELDS}
-          'Full name: ',DS.FieldByName('fullname').AsString,
+          'Full name: ',aDS.FieldByName('fullname').AsString,
+  {$ENDIF}
+          'First name: ',aDS.FieldByName('firstname').AsString,
+          ', Last name:', aDS.FieldByName('lastname').AsString,
+          ', Children:', aDS.FieldByName('children').AsInteger,
+          ', Birthday:', aDS.FieldByName('birthday').AsString,
+          ', Weight:', aDS.FieldByName('weight').AsFloat,
+          ', Business:', aDS.FieldByName('business').AsBoolean,
+          ', Country:', aDS.FieldByName('Country').AsString
+  {$IFDEF TESTLOOKUPFIELDS}
+          ,', CountryName:', aDS.FieldByName('CountryName').AsString
   {$ENDIF}
-          'First name: ',DS.FieldByName('firstname').AsString,
-          ', Last name: ', DS.FieldByName('lastname').AsString,
-          ', Children: ', DS.FieldByName('children').AsInteger,
-          ', Birthday: ', DS.FieldByName('birthday').AsString
   );
 end;
 
-Procedure TApp.DumpRecords(DS : TDataset);
+Procedure TApp.DumpRecords(aDS : TDataset);
 
 begin
-  While not DS.EOF do
+  While not aDS.EOF do
     begin
-    Write(DS.RecNo,': ');
-    DumpRecord(DS);
-    DS.Next;
+    DumpRecord(aDS);
+    aDS.Next;
     end;
 end;
 
 
-Procedure TApp.Run;
+Procedure TApp.CreateDataset;
 
-Var
-  DS : TExtJSJSONObjectDataSet;
-  B : TBookmark;
-  t: TDataLink;
-  DSS : TDatasource;
 {$IFDEF TESTCALCFIELDS}
+Var
   F : TField;
 {$ENDIF}
 
 begin
-
+  Writeln('Creating dataset');
   DS:=TExtJSJSONObjectDataSet.Create(Nil);
-  DS.MetaData:=GetJSON(' { "fields" : [ {"name": "firstname", "maxLen" : 100}, {"name": "lastname","maxLen" : 100}, '+
-                       ' { "name" : "children", "type": "int" }, '+
-                       ' { "name" : "birthday", "type": "date", "dateFormat": "yyyy\"-\"mm\"-\"dd" } ]}') as TJSONObject;
-  DS.Rows:=GetJSON('[{"firstname" : "Michael", "lastname" : "Van Canneyt", "children" : 2, "birthday": "1970-07-07" },'+
-                                  '  {"firstname" : "Mattias", "lastname" : "Gaertner", "children" : 0, "birthday" : "1970-07-08" }, '+
-                                  '  {"firstname" : "Bruno", "lastname" : "Fierens", "children" : 3, "birthday" : "1970-07-09" },'+
-                                  '  {"firstname" : "Detlef", "lastname" : "Overbeek", "children" : 2, "birthday" : "1950-07-08" }'+
-                                  ' ]') as TJSONarray;
+  DS.MetaData:=GetJSON('{ "fields" : [ '+
+                                          ' { "name": "firstname"}, '+
+                                          ' { "name": "lastname"}, '+
+                                          ' { "name" : "children", "type": "int" }, '+
+                                          ' { "name" : "birthday", "type": "date", "dateFormat": "yyyy\"-\"mm\"-\"dd" }, '+
+                                          ' { "name" : "country",  "type": "string", "maxLen" : 2 }, '+
+                                          ' { "name" : "business", "type": "boolean" }, '+
+                                          ' { "name" : "weight",   "type": "float" } '+
+                                       ']}') as TJSONObject;
+  DS.Rows:=GetJSON('[{"firstname" : "Michael", "lastname" : "Van Canneyt", "children" : 2, "birthday": "1970-07-07", "business" : false, "weight": 75.5, "country": "BE" },'+
+                                  '  {"firstname" : "Mattias", "lastname" : "Gaertner", "children" : 0, "birthday" : "1970-07-08", "business" : false, "weight": 76.2, "country": "DE"   }, '+
+                                  '  {"firstname" : "Bruno", "lastname" : "Fierens", "children" : 3, "birthday" : "1970-07-09", "business" : true, "weight": 77.3, "country": "BE"  },'+
+                                  '  {"firstname" : "Detlef", "lastname" : "Overbeek", "children" : 2, "birthday" : "1950-07-08", "business" : true, "weight": 78.8, "country": "NL"  }'+
+                                  ' ]') as TJSONArray;
+  DC:=TExtJSJSONObjectDataSet.Create(Nil);
+  DC.MetaData:=GetJSON('{ "fields" : [ '+
+                                       ' { "name": "code"}, '+
+                                       ' { "name": "name"} '+
+                                       ']} ') as TJSONObject;
+  DC.Rows:=GetJSON('[{"code" : "BE", "name" : "Belgium" }, '+
+                                 '  {"code" : "DE", "name" : "Germany" }, '+
+                                 '  {"code" : "NL", "name" : "Netherlands" }, '+
+                                 '  {"code" : "FR", "name" : "France" }, '+
+                                 '  {"code" : "UK", "name" : "United Kingdom" } '+
+                                 ' ]') as TJSONArray;
 {$IFDEF TESTCALCFIELDS}
   F:=TStringField.Create(DS);
   F.FieldKind:=fkCalculated;
   F.Size:=200;
-  F.FieldName:='fullname';
+  F.FieldName:='FullName';
   F.Dataset:=DS;
   F:=TStringField.Create(DS);
   F.FieldKind:=fkData;
@@ -90,15 +116,40 @@ begin
   F.FieldKind:=fkData;
   F.FieldName:='children';
   F.Dataset:=DS;
-  F:=TJSONDateField.Create(DS);
-  TJSONDateField(F).DateFormat:='yyyy"-"mm"-"dd';
+  F:=TDateField.Create(DS);
   F.FieldKind:=fkData;
   F.FieldName:='birthday';
-
   F.Dataset:=DS;
+  F:=TBooleanField.Create(DS);
+  F.FieldKind:=fkData;
+  F.FieldName:='business';
+  F.Dataset:=DS;
+  F:=TFloatField.Create(DS);
+  F.FieldKind:=fkData;
+  F.FieldName:='weight';
+  F.Dataset:=DS;
+  F:=TStringField.Create(DS);
+  F.FieldKind:=fkData;
+  F.Size:=2;
+  F.FieldName:='country';
+  F.Dataset:=DS;
+  {$IFDEF TESTLOOKUPFIELDS}
+  F:=TStringField.Create(DS);
+  F.FieldKind:=fkLookup;
+  F.LookupDataSet:=DC;
+  F.KeyFields:='country';
+  F.LookupKeyFields:='code';
+  F.LookupResultField:='name';
+  F.FieldName:='CountryName';
+  F.Dataset:=DS;
+  {$ENDIF}
   DS.OnCalcFields:=@DoCalcFields;
 {$ENDIF}
-  DS.Open;
+end;
+
+Procedure TApp.TestNavigation;
+
+begin
   Writeln('All records');
   DumpRecords(DS);
   Writeln('First record (expect Michael.)');
@@ -113,16 +164,17 @@ begin
     DumpRecord(DS);
     DS.Prior;
     end;
+end;
+
+Procedure TApp.TestAppend;
+
+begin
   DS.Append;
   Writeln('Dumping record after APPEND (expect empty)');
-  Writeln('Modified before dump (expect False): ',DS.Modified);
+  Writeln('Modified before  (expect False): ',DS.Modified);
   DumpRecord(DS);
   DS.FieldByName('firstname').AsString:='Florian';
-  Write('Old value of field first name (expect null): ');
-  if DS.FieldByName('firstname').OldValue=Null then
-    Writeln('Null')
-  else
-    Writeln(DS.FieldByName('firstname').OldValue);
+  Writeln('Old value of field first name (expect null): ', DS.FieldByName('firstname').OldValue);
   DS.FieldByName('lastname').AsString:='Klaempfl';
   DS.FieldByName('children').AsInteger:=1;
   DS.FieldByName('birthday').AsDateTime:=EncodeDate(1980,5,4);
@@ -135,6 +187,11 @@ begin
   Writeln('Jump to first (expect Michael)');
   DS.First;
   DumpRecord(DS);
+end;
+
+Procedure TApp.TestEdit;
+
+begin
   DS.Edit;
   Writeln('Dumping record after EDIT');
   Writeln('Modified before  (expect False): ',DS.Modified);
@@ -167,6 +224,14 @@ begin
   Writeln('Jump to first and dumping all records (expect Dolores first)');
   DS.First;
   DumpRecords(DS);
+end;
+
+Procedure TApp.TestBookMark;
+
+var
+  B : TBookmark;
+
+begin
   Writeln('Jump to first  (expect Dolores)');
   DS.First;
   DumpRecord(DS);
@@ -181,9 +246,13 @@ begin
   DS.Delete;
   DumpRecord(DS);
   Writeln('Setting Bookmark (expect Detlef)');
-  Writeln('BM value: ',PNativeInt(B)^);
   DS.BookMark:=B;
   DumpRecord(DS);
+end;
+
+Procedure TApp.TestInsert;
+
+begin
   Writeln('Jump to second (expect Bruno)');
   DS.First;
   DS.Next;
@@ -205,12 +274,22 @@ begin
   Writeln('Jump to first and dumping all records (expect Mattias first, then Felicity)');
   DS.First;
   DumpRecords(DS);
+end;
+
+Procedure TApp.TestDataLinkEdit;
+
+var
+  t: TDataLink;
+  DSS : TDatasource;
+
+begin
   Writeln('Jump to first before edit');
   DS.First;
-  DSS:=TDatasource.Create(Nil);
-  DSS.DataSet:=DS;
+  DSS:=Nil;
   t:=TDataLink.Create;
   try
+    DSS:=TDatasource.Create(Nil);
+    DSS.DataSet:=DS;
     Writeln('Buffercount');
     t.BufferCount := 10;
     t.DataSource := DSS;
@@ -230,9 +309,22 @@ begin
     t.ActiveRecord := 0;
   Finally
     t.Free;
+    dss.free;
   end;
+end;
+
+Procedure TApp.TestDataLinkActiveRecord;
+
+var
+  t: TDataLink;
+  DSS : TDatasource;
+
+begin
+  DSS:=Nil;
   t:=TDataLink.Create;
   try
+    DSS.DataSet:=DS;
+    DSS.DataSet:=DS;
     t.DataSource := DSS;
     DS.Last;
     Writeln('Last record :',DS.RecNo);
@@ -247,13 +339,107 @@ begin
     t.ActiveRecord := 0;
   Finally
     t.Free;
+    dss.Free;
   end;
+end;
+
+Procedure TApp.TestLocate;
+
+Var
+  V : Variant;
 
+begin
+  DS.First;
+  Writeln('Locating 3 children (expect true, Bruno): ',DS.Locate('Children',3,[]));
+  DumpRecord(DS);
+  DS.First;
+  v:=VarArrayCreate([0,0],varVariant);
+  V[0]:=3;
+  Writeln('Locating 3 children using array (expect true, Bruno): ',DS.Locate('Children',V,[]));
+  DumpRecord(DS);
+  DS.First;
+  Writeln('Locating 4 children (expect false): ',DS.Locate('Children',4,[]));
+  DS.First;
+  Writeln('Locating first name Detlef (expect true): ',DS.Locate('Firstname','Detlef',[]));
+  DumpRecord(DS);
+  DS.First;
+  Writeln('Locating first name detlef (expect false): ',DS.Locate('Firstname','detlef',[]));
+  DS.First;
+  Writeln('Locating first name detlef (loCaseInsensitive, expect true): ',DS.Locate('Firstname','detlef',[loCaseInsensitive]));
+  DumpRecord(DS);
+  DS.First;
+  Writeln('Locating first name Det (expect false): ',DS.Locate('Firstname','Det',[]));
+  DS.First;
+  Writeln('Locating first name Det (loPartialKey,expect true): ',DS.Locate('Firstname','Det',[loPartialKey]));
+  DumpRecord(DS);
+  DS.First;
+  Writeln('Locating first name det (loPartialKey, expect false): ',DS.Locate('Firstname','det',[loPartialKey]));
+  DS.First;
+  Writeln('Locating first name det (loCaseInsensitive,loPartialKey, expect true): ',DS.Locate('Firstname','det',[loCaseInsensitive,loPartialKey]));
+  DumpRecord(DS);
+  v:=VarArrayCreate([0,1],varVariant);
+  V[0]:=3;
+  V[1]:='Detlef';
+  DS.First;
+  Writeln('Locating first name Detlef & children 3  ( expect false): ',DS.Locate('Children;Firstname',v,[]));
+  V[0]:=2;
+  V[1]:='Detlef';
+  DS.First;
+  Writeln('Locating first name Detlef & children 2 ( expect true): ',DS.Locate('Children;Firstname',v,[]));
+  DS.First;
+  Writeln('Locating birthday  (expect true, Bruno): ',DS.Locate('BirthDay',EncodeDate(1970,07,09),[]));
+  DS.First;
+  Writeln('Locating business  (expect true, Bruno): ',DS.Locate('business',true,[]));
+  DumpRecord(DS);
+  DS.First;
+  Writeln('Deleting first');
+  DS.Delete;
+  Writeln('Locating weight  (expect true, bruno): ',DS.Locate('weight',77.3,[]));
+  DumpRecord(DS);
+
+end;
+
+procedure TApp.TestLookup;
+begin
+  DS.First;
+  Writeln('Locating weight  (expect true, detlef overbeek): ',DS.Lookup('weight',78.8,'fullname'));
+  Writeln('Still on Michael:');
+  DumpRecord(DS);
+  DS.First;
+  Writeln('Locating birthday  (expect true, Bruno): ',DS.Lookup('BirthDay',EncodeDate(1970,07,09),'firstname'));
+  Writeln('Still on Michael:');
+  DumpRecord(DS);
+end;
+
+Procedure TApp.Run;
+
+
+begin
+  try
+    CreateDataset;
+    Writeln('Opening dataset');
+
+    DC.Open;
+    DS.Open;
+//    TestLocate;
+    TestLookup;
+    exit;
+    TestNavigation;
+    TestAppend;
+    TestEdit;
+    TestBookmark;
+    TestInsert;
+    TestDataLinkEdit;
+    TestDataLinkActiveRecord;
+  except
+    On E : Exception do
+      Writeln('!! Caught Exception ',E.ClassName,' : ',E.Message);
+  end;
 end;
 
 procedure TApp.DoCalcFields(DataSet: TDataSet);
 begin
-  Writeln('In calcfields callback');
+//  Writeln('In callback');
   Dataset.FieldByName('FullName').AsString:= Dataset.FieldByName('firstName').AsString+' '+Dataset.FieldByName('lastname').AsString;
 end;
 

+ 2 - 2
packages/fcl-js/src/jsbase.pp

@@ -26,8 +26,8 @@ uses
   Classes, SysUtils;
 
 const
-  MinSafeIntDouble = -$10000000000000; // -4503599627370496
-  MaxSafeIntDouble =   $fffffffffffff; //  4503599627370495
+  MinSafeIntDouble = -$fffffffffffff-1; // -4503599627370496
+  MaxSafeIntDouble =  $fffffffffffff; //  4503599627370495
 Type
   TJSType = (jstUNDEFINED,jstNull,jstBoolean,jstNumber,jstString,jstObject,jstReference,jstCompletion);
 

+ 2 - 0
packages/fcl-js/src/jswriter.pp

@@ -470,6 +470,7 @@ Var
   S : String;
 
 begin
+  //system.writeln('TJSWriter.Write unicodestring=',U);
   WriteIndent;
   if UseUTF8 then
     begin
@@ -488,6 +489,7 @@ end;
 
 procedure TJSWriter.Write(const S: TJSWriterString);
 begin
+  //system.writeln('TJSWriter.Write TJSWriterString=',S);
   {$ifdef FPC_HAS_CPSTRING}
   if Not (woUseUTF8 in Options) then
     Write(UnicodeString(S))

+ 89 - 66
packages/fcl-passrc/src/pasresolveeval.pas

@@ -134,10 +134,10 @@ const
   nFoundCallCandidateX = 3057;
   nTextAfterFinalIgnored = 3058;
   nNoMemberIsProvidedToAccessProperty = 3059;
-  // free 3060
-  // free 3061
-  // free 3062
-  // free 3063
+  nTheUseOfXisNotAllowedInARecord = 3060;
+  nParameterlessConstructorsNotAllowedInRecords = 3061;
+  nMultipleXinTypeYNameZCAandB = 3062;
+  nXCannotHaveParameters = 3063;
   nRangeCheckError = 3064;
   nHighRangeLimitLTLowRangeLimit = 3065;
   nRangeCheckEvaluatingConstantsVMinMax = 3066;
@@ -154,14 +154,14 @@ const
   nMethodHidesMethodOfBaseType = 3077;
   nContextExpectedXButFoundY = 3078;
   nContextXInvalidY = 3079;
-  // free 3080;
+  nIdentifierXIsNotAnInstanceField = 3080;
   nXIsNotSupported = 3081;
   nOperatorIsNotOverloadedAOpB = 3082;
   nIllegalQualifierAfter = 3084;
   nIllegalQualifierInFrontOf = 3085;
   nIllegalQualifierWithin = 3086;
   nMethodClassXInOtherUnitY = 3087;
-  // free 3088
+  nClassMethodsMustBeStaticInRecords = 3088;
   nCannotMixMethodResolutionAndDelegationAtX = 3089;
   nImplementsDoesNotSupportArrayProperty = 3101;
   nImplementsDoesNotSupportIndex = 3102;
@@ -251,6 +251,10 @@ resourcestring
   sFoundCallCandidateX = 'Found call candidate %s';
   sTextAfterFinalIgnored = 'Text after final ''end.''. ignored by compiler';
   sNoMemberIsProvidedToAccessProperty = 'No member is provided to access property';
+  sTheUseOfXisNotAllowedInARecord = 'The use of "%s" is not allowed in a record';
+  sParameterlessConstructorsNotAllowedInRecords = 'Parameterless constructors are not allowed in records or record/type helpers';
+  sMultipleXinTypeYNameZCAandB = 'Multiple %s in %s %s: %s and %s';
+  sXCannotHaveParameters = '%s cannot have parameters';
   sSymbolXIsNotPortable = 'Symbol "%s" is not portable';
   sSymbolXIsExperimental = 'Symbol "%s" is experimental';
   sSymbolXIsNotImplemented = 'Symbol "%s" is not implemented';
@@ -273,6 +277,7 @@ resourcestring
   sMethodHidesMethodOfBaseType = 'Method "%s" hides method of base type "%s" at %s';
   sContextExpectedXButFoundY = '%s: expected "%s", but found "%s"';
   sContextXInvalidY = '%s: invalid %s';
+  sIdentifierXIsNotAnInstanceField = 'Identifier "%s" is not an instance field';
   sConstructingClassXWithAbstractMethodY = 'Constructing a class "%s" with abstract method "%s"';
   sXIsNotSupported = '%s is not supported';
   sOperatorIsNotOverloadedAOpB = 'Operator is not overloaded: "%s" %s "%s"';
@@ -281,6 +286,7 @@ resourcestring
   sIllegalQualifierWithin = 'illegal qualifier "%s" within "%s"';
   sMethodClassXInOtherUnitY = 'method class "%s" in other unit "%s"';
   sNoMatchingImplForIntfMethodXFound = 'No matching implementation for interface method "%s" found';
+  sClassMethodsMustBeStaticInRecords = 'Class methods must be static in records';
   sCannotMixMethodResolutionAndDelegationAtX = 'Cannot mix method resolution and delegation at %s';
   sImplementsDoesNotSupportArrayProperty = '"implements" does dot support array property';
   sImplementsDoesNotSupportIndex = '"implements" does not support "index"';
@@ -340,8 +346,8 @@ const
   MinSafeIntSingle = -16777216;
   MaxSafeIntSingle =  16777216;
   MaskUIntSingle = $3fffff;
-  MinSafeIntDouble = -$10000000000000; // -4503599627370496
-  MaxSafeIntDouble =   $fffffffffffff; //  4503599627370495
+  MinSafeIntDouble = -$fffffffffffff-1; // -4503599627370496
+  MaxSafeIntDouble =  $fffffffffffff; //  4503599627370495
   MaskUIntDouble = $fffffffffffff;
 
 type
@@ -697,6 +703,8 @@ type
     procedure PredValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
     procedure SuccValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
     function EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
+    function EvalStringAddExpr(Expr, LeftExpr, RightExpr: TPasExpr;
+      LeftValue, RightValue: TResEvalValue): TResEvalValue; virtual;
     function EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
       Flags: TResEvalFlags): TResEvalEnum; virtual;
     {$ifdef FPC_HAS_CPSTRING}
@@ -1249,7 +1257,7 @@ begin
           reitLongWord: TResEvalInt(Result).Int:=not longword(TResEvalInt(Result).Int);
           reitLongInt: TResEvalInt(Result).Int:=not longint(TResEvalInt(Result).Int);
           reitUIntDouble: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $fffffffffffff;
-          reitIntDouble: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $1fffffffffffff;
+          reitIntDouble: {$ifdef fpc}TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $1fffffffffffff{$endif};
           else TResEvalInt(Result).Int:=not TResEvalInt(Result).Int;
         end;
         end;
@@ -1534,9 +1542,6 @@ var
   UInt: TMaxPrecUInt;
   Flo: TMaxPrecFloat;
   aCurrency: TMaxPrecCurrency;
-  {$ifdef FPC_HAS_CPSTRING}
-  LeftCP, RightCP: TSystemCodePage;
-  {$endif}
   LeftSet, RightSet: TResEvalSet;
   i: Integer;
 begin
@@ -1634,58 +1639,10 @@ begin
       end;
       end;
     {$ifdef FPC_HAS_CPSTRING}
-    revkString:
-      case RightValue.Kind of
-      revkString:
-        begin
-        LeftCP:=GetCodePage(TResEvalString(LeftValue).S);
-        RightCP:=GetCodePage(TResEvalString(RightValue).S);
-        if (LeftCP=RightCP) then
-          begin
-          Result:=TResEvalString.Create;
-          TResEvalString(Result).S:=TResEvalString(LeftValue).S+TResEvalString(RightValue).S;
-          end
-        else
-          begin
-          Result:=TResEvalUTF16.Create;
-          TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left)
-                                  +GetUnicodeStr(TResEvalString(RightValue).S,Expr.right);
-          end;
-        end;
-      revkUnicodeString:
-        begin
-        Result:=TResEvalUTF16.Create;
-        TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left)
-                                +TResEvalUTF16(RightValue).S;
-        end;
-      else
-        {$IFDEF VerbosePasResolver}
-        writeln('TResExprEvaluator.EvalBinaryAddExpr string+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
-        {$ENDIF}
-        RaiseNotYetImplemented(20170601141834,Expr);
-      end;
+    revkString,
     {$endif}
     revkUnicodeString:
-      case RightValue.Kind of
-      {$ifdef FPC_HAS_CPSTRING}
-      revkString:
-        begin
-        Result:=TResEvalUTF16.Create;
-        TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S
-                                +GetUnicodeStr(TResEvalString(RightValue).S,Expr.right);
-        end;
-      {$endif}
-      revkUnicodeString:
-        begin
-        Result:=TResEvalUTF16.Create;
-        TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S+TResEvalUTF16(RightValue).S;
-        end;
-      else
-        {$IFDEF VerbosePasResolver}
-        writeln('TResExprEvaluator.EvalBinaryAddExpr utf16+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
-        {$ENDIF}
-        RaiseNotYetImplemented(20170601141811,Expr);
-      end;
+      Result:=EvalStringAddExpr(Expr,Expr.left,Expr.right,LeftValue,RightValue);
     revkSetOfInt:
       case RightValue.Kind of
       revkSetOfInt:
@@ -4081,9 +4038,9 @@ begin
           begin
           c:=S[p];
           case c of
-          '0'..'9': u:=u*16+ord(c)-ord('0');
-          'a'..'f': u:=u*16+ord(c)-ord('a')+10;
-          'A'..'F': u:=u*16+ord(c)-ord('A')+10;
+          '0'..'9': u:=u*16+longword(ord(c)-ord('0'));
+          'a'..'f': u:=u*16+longword(ord(c)-ord('a'))+10;
+          'A'..'F': u:=u*16+longword(ord(c)-ord('A'))+10;
           else break;
           end;
           if u>$10FFFF then
@@ -4111,7 +4068,7 @@ begin
           begin
           c:=S[p];
           case c of
-          '0'..'9': u:=u*10+ord(c)-ord('0');
+          '0'..'9': u:=u*10+longword(ord(c)-ord('0'));
           else break;
           end;
           if u>$ffff then
@@ -4792,6 +4749,72 @@ begin
     {$endif}
 end;
 
+function TResExprEvaluator.EvalStringAddExpr(Expr, LeftExpr,
+  RightExpr: TPasExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
+{$ifdef FPC_HAS_CPSTRING}
+var
+  LeftCP, RightCP: TSystemCodePage;
+{$endif}
+begin
+  case LeftValue.Kind of
+  {$ifdef FPC_HAS_CPSTRING}
+  revkString:
+    case RightValue.Kind of
+    revkString:
+      begin
+      LeftCP:=GetCodePage(TResEvalString(LeftValue).S);
+      RightCP:=GetCodePage(TResEvalString(RightValue).S);
+      if (LeftCP=RightCP) then
+        begin
+        Result:=TResEvalString.Create;
+        TResEvalString(Result).S:=TResEvalString(LeftValue).S+TResEvalString(RightValue).S;
+        end
+      else
+        begin
+        Result:=TResEvalUTF16.Create;
+        TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,LeftExpr)
+                                +GetUnicodeStr(TResEvalString(RightValue).S,RightExpr);
+        end;
+      end;
+    revkUnicodeString:
+      begin
+      Result:=TResEvalUTF16.Create;
+      TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,LeftExpr)
+                              +TResEvalUTF16(RightValue).S;
+      end;
+    else
+      {$IFDEF VerbosePasResolver}
+      writeln('TResExprEvaluator.EvalBinaryAddExpr string+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
+      {$ENDIF}
+      RaiseNotYetImplemented(20170601141834,Expr);
+    end;
+  {$endif}
+  revkUnicodeString:
+    case RightValue.Kind of
+    {$ifdef FPC_HAS_CPSTRING}
+    revkString:
+      begin
+      Result:=TResEvalUTF16.Create;
+      TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S
+                              +GetUnicodeStr(TResEvalString(RightValue).S,RightExpr);
+      end;
+    {$endif}
+    revkUnicodeString:
+      begin
+      Result:=TResEvalUTF16.Create;
+      TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S+TResEvalUTF16(RightValue).S;
+      end;
+    else
+      {$IFDEF VerbosePasResolver}
+      writeln('TResExprEvaluator.EvalBinaryAddExpr utf16+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
+      {$ENDIF}
+      RaiseNotYetImplemented(20170601141811,Expr);
+    end;
+  else
+    RaiseNotYetImplemented(20181219233139,Expr);
+  end;
+end;
+
 function TResExprEvaluator.EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
   Flags: TResEvalFlags): TResEvalEnum;
 var

文件差异内容过多而无法显示
+ 374 - 145
packages/fcl-passrc/src/pasresolver.pp


+ 317 - 167
packages/fcl-passrc/src/pastree.pp

@@ -82,6 +82,8 @@ resourcestring
   SPasTreeClassDestructor = 'class destructor';
   SPasTreeConstructor = 'constructor';
   SPasTreeDestructor = 'destructor';
+  SPasTreeAnonymousProcedure = 'anonymous procedure';
+  SPasTreeAnonymousFunction = 'anonymous function';
   SPasTreeProcedureImpl = 'procedure/function implementation';
   SPasTreeConstructorImpl = 'constructor implementation';
   SPasTreeDestructorImpl = 'destructor implementation';
@@ -192,7 +194,7 @@ type
 
   TPasExprKind = (pekIdent, pekNumber, pekString, pekSet, pekNil, pekBoolConst,
      pekRange, pekUnary, pekBinary, pekFuncParams, pekArrayParams, pekListOfExp,
-     pekInherited, pekSelf, pekSpecialize);
+     pekInherited, pekSelf, pekSpecialize, pekProcedure);
 
   TExprOpCode = (eopNone,
                  eopAdd,eopSubtract,eopMultiply,eopDivide, eopDiv,eopMod, eopPower,// arithmetic
@@ -690,14 +692,31 @@ type
     Members: TPasRecordType;
   end;
 
-  { TPasRecordType }
+  { TPasMembersType - base type for TPasRecordType and TPasClassType }
 
-  TPasRecordType = class(TPasType)
+  TPasMembersType = class(TPasType)
   private
     procedure ClearChildReferences(El: TPasElement; arg: pointer);
-    procedure GetMembers(S: TStrings);
   protected
     procedure SetParent(const AValue: TPasElement); override;
+  public
+    PackMode: TPackMode;
+    Members: TFPList;
+    GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
+    Constructor Create(const AName: string; AParent: TPasElement); override;
+    Destructor Destroy; override;
+    Function IsPacked: Boolean;
+    Function IsBitPacked : Boolean;
+    Procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
+      const Arg: Pointer); override;
+    Procedure SetGenericTemplates(AList: TFPList); virtual;
+  end;
+
+  { TPasRecordType }
+
+  TPasRecordType = class(TPasMembersType)
+  private
+    procedure GetMembers(S: TStrings);
   public
     constructor Create(const AName: string; AParent: TPasElement); override;
     destructor Destroy; override;
@@ -706,15 +725,9 @@ type
     procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
       const Arg: Pointer); override;
   public
-    PackMode: TPackMode;
-    Members: TFPList;     // list of TPasVariable elements
     VariantEl: TPasElement; // nil or TPasVariable or TPasType
     Variants: TFPList;	// list of TPasVariant elements, may be nil!
-    GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
-    Function IsPacked: Boolean;
-    Function IsBitPacked : Boolean;
     Function IsAdvancedRecord : Boolean;
-    Procedure SetGenericTemplates(AList : TFPList);
   end;
 
   TPasGenericTemplateType = Class(TPasType)
@@ -735,9 +748,7 @@ type
 
   { TPasClassType }
 
-  TPasClassType = class(TPasType)
-  private
-    procedure ClearChildReferences(El: TPasElement; arg: pointer);
+  TPasClassType = class(TPasMembersType)
   protected
     procedure SetParent(const AValue: TPasElement); override;
   public
@@ -747,7 +758,6 @@ type
     procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
       const Arg: Pointer); override;
   public
-    PackMode: TPackMode;
     ObjKind: TPasObjKind;
     AncestorType: TPasType;   // TPasClassType or TPasUnresolvedTypeRef or TPasAliasType or TPasTypeAliasType
                               // Note: AncestorType can be nil even though it has a default ancestor
@@ -756,25 +766,20 @@ type
     IsExternal : Boolean;
     IsShortDefinition: Boolean;//class(anchestor); without end
     GUIDExpr : TPasExpr;
-    Members: TFPList;     // list of TPasElement
     Modifiers: TStringList;
     Interfaces : TFPList; // list of TPasType
-    GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
     ExternalNameSpace : String;
     ExternalName : String;
     InterfaceType: TPasClassInterfaceType;
-    Procedure SetGenericTemplates(AList : TFPList);
+    Procedure SetGenericTemplates(AList : TFPList); override;
     Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
     Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
-    Function IsPacked : Boolean;
     Function InterfaceGUID : string;
     Function IsSealed : Boolean;
     Function IsAbstract : Boolean;
     Function HasModifier(const aModifier: String): Boolean;
   end;
 
-
-
   TArgumentAccess = (argDefault, argConst, argVar, argOut, argConstRef);
 
   { TPasArgument }
@@ -972,7 +977,8 @@ type
                ptOperator, ptClassOperator,
                ptConstructor, ptDestructor,
                ptClassProcedure, ptClassFunction,
-               ptClassConstructor, ptClassDestructor);
+               ptClassConstructor, ptClassDestructor,
+               ptAnonymousProcedure, ptAnonymousFunction);
 
   { TPasProcedureBase }
 
@@ -1007,6 +1013,8 @@ type
                         
   TProcedureBody = class;
 
+  { TPasProcedure - named procedure, not anonymous }
+
   TPasProcedure = class(TPasProcedureBase)
   Private
     FModifiers : TProcedureModifiers;
@@ -1023,13 +1031,13 @@ type
     procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
       const Arg: Pointer); override;
   public
-    ProcType : TPasProcedureType;
-    Body : TProcedureBody;
     PublicName, // e.g. public PublicName;
     LibrarySymbolName,
     LibraryExpr : TPasExpr; // e.g. external LibraryExpr name LibrarySymbolName;
     DispIDExpr :  TPasExpr;
     AliasName : String;
+    ProcType : TPasProcedureType;
+    Body : TProcedureBody;
     Procedure AddModifier(AModifier : TProcedureModifier);
     Function IsVirtual : Boolean;
     Function IsDynamic : Boolean;
@@ -1042,6 +1050,7 @@ type
     Function IsReintroduced : Boolean;
     Function IsStatic : Boolean;
     Function IsForward: Boolean;
+    Function GetProcTypeEnum: TProcType; virtual;
     Property Modifiers : TProcedureModifiers Read FModifiers Write FModifiers;
     Property CallingConvention : TCallingConvention Read GetCallingConvention Write SetCallingConvention;
     Property MessageName : String Read FMessageName Write FMessageName;
@@ -1051,14 +1060,16 @@ type
 
   TArrayOfPasProcedure = array of TPasProcedure;
 
+  { TPasFunction - named function, not anonymous function}
+
   TPasFunction = class(TPasProcedure)
   private
     function GetFT: TPasFunctionType; inline;
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
-    function GetDeclaration (full : boolean) : string; override;
     Property FuncType : TPasFunctionType Read GetFT;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasOperator }
@@ -1085,17 +1096,18 @@ type
     Function OldName(WithPath : Boolean) : String;
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
     function GetDeclaration (full : boolean) : string; override;
     Property OperatorType : TOperatorType Read FOperatorType Write FOperatorType;
     // True if the declaration was using a token instead of an identifier
     Property TokenBased : Boolean Read FTokenBased Write FTokenBased;
   end;
 
-Type
   { TPasClassOperator }
 
   TPasClassOperator = class(TPasOperator)
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
 
@@ -1105,6 +1117,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassConstructor }
@@ -1113,6 +1126,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasDestructor }
@@ -1121,6 +1135,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassDestructor }
@@ -1129,6 +1144,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassProcedure }
@@ -1137,6 +1153,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassFunction }
@@ -1145,8 +1162,43 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
+  end;
+
+  { TPasAnonymousProcedure - parent is TProcedureExpr }
+
+  TPasAnonymousProcedure = class(TPasProcedure)
+  public
+    function ElementTypeName: string; override;
+    function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
+  end;
+
+  { TPasAnonymousFunction - parent is TProcedureExpr and ProcType is TPasFunctionType}
+
+  TPasAnonymousFunction = class(TPasAnonymousProcedure)
+  private
+    function GetFT: TPasFunctionType; inline;
+  public
+    function ElementTypeName: string; override;
+    function TypeName: string; override;
+    Property FuncType : TPasFunctionType Read GetFT;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
+  { TProcedureExpr }
+
+  TProcedureExpr = class(TPasExpr)
+  public
+    Proc: TPasAnonymousProcedure;
+    constructor Create(AParent: TPasElement); overload;
+    destructor Destroy; override;
+    function GetDeclaration(full: Boolean): string; override;
+    procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
+      const Arg: Pointer); override;
+  end;
+
+
   TPasImplBlock = class;
 
   { TProcedureBody - the var+type+const+begin, without the header, child of TPasProcedure }
@@ -1580,7 +1632,8 @@ const
       'ListOfExp',
       'Inherited',
       'Self',
-      'Specialize');
+      'Specialize',
+      'Procedure');
 
   OpcodeStrings : Array[TExprOpCode] of string = (
         '','+','-','*','/','div','mod','**',
@@ -1646,6 +1699,26 @@ begin
   El:=nil;
 end;
 
+Function IndentStrings(S : TStrings; indent : Integer) : string;
+Var
+  I,CurrLen,CurrPos : Integer;
+begin
+  Result:='';
+  CurrLen:=0;
+  CurrPos:=0;
+  For I:=0 to S.Count-1 do
+    begin
+    CurrLen:=Length(S[i]);
+    If (CurrLen+CurrPos)>72 then
+      begin
+      Result:=Result+LineEnding+StringOfChar(' ',Indent);
+      CurrPos:=Indent;
+      end;
+    Result:=Result+S[i];
+    CurrPos:=CurrPos+CurrLen;
+    end;
+end;
+
 {$IFDEF HasPTDumpStack}
 procedure PTDumpStack;
 begin
@@ -1846,6 +1919,11 @@ begin
   Result:='class operator';
 end;
 
+function TPasClassOperator.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptClassOperator;
+end;
+
 { TPasImplAsmStatement }
 
 constructor TPasImplAsmStatement.Create(const AName: string;
@@ -1868,6 +1946,78 @@ begin
   Result:='class '+ inherited TypeName;
 end;
 
+function TPasClassConstructor.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptClassConstructor;
+end;
+
+{ TPasAnonymousProcedure }
+
+function TPasAnonymousProcedure.ElementTypeName: string;
+begin
+  Result:=SPasTreeAnonymousProcedure;
+end;
+
+function TPasAnonymousProcedure.TypeName: string;
+begin
+  Result:='anonymous procedure';
+end;
+
+function TPasAnonymousProcedure.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptAnonymousProcedure;
+end;
+
+{ TPasAnonymousFunction }
+
+function TPasAnonymousFunction.GetFT: TPasFunctionType;
+begin
+  Result:=ProcType as TPasFunctionType;
+end;
+
+function TPasAnonymousFunction.ElementTypeName: string;
+begin
+  Result := SPasTreeAnonymousFunction;
+end;
+
+function TPasAnonymousFunction.TypeName: string;
+begin
+  Result:='anonymous function';
+end;
+
+function TPasAnonymousFunction.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptAnonymousFunction;
+end;
+
+{ TProcedureExpr }
+
+constructor TProcedureExpr.Create(AParent: TPasElement);
+begin
+  inherited Create(AParent,pekProcedure,eopNone);
+end;
+
+destructor TProcedureExpr.Destroy;
+begin
+  ReleaseAndNil(TPasElement(Proc){$IFDEF CheckPasTreeRefCount},'TProcedureExpr.Proc'{$ENDIF});
+  inherited Destroy;
+end;
+
+function TProcedureExpr.GetDeclaration(full: Boolean): string;
+begin
+  if Proc<>nil then
+    Result:=Proc.GetDeclaration(full)
+  else
+    Result:='procedure-expr';
+end;
+
+procedure TProcedureExpr.ForEachCall(const aMethodCall: TOnForEachPasElement;
+  const Arg: Pointer);
+begin
+  inherited ForEachCall(aMethodCall, Arg);
+  ForEachChildCall(aMethodCall,Arg,Proc,false);
+end;
+
 { TPasImplRaise }
 
 destructor TPasImplRaise.Destroy;
@@ -2160,7 +2310,7 @@ begin
   Result:=ProcType as TPasFunctionType;
 end;
 
-function TPasFunction.ElementTypeName: string; begin Result := SPasTreeFunction end;
+function TPasFunction.ElementTypeName: string; begin Result := SPasTreeFunction; end;
 function TPasClassProcedure.ElementTypeName: string; begin Result := SPasTreeClassProcedure; end;
 function TPasClassConstructor.ElementTypeName: string; begin Result := SPasTreeClassConstructor; end;
 function TPasClassDestructor.ElementTypeName: string; begin Result := SPasTreeClassDestructor; end;
@@ -2170,6 +2320,11 @@ begin
   Result:='destructor';
 end;
 
+function TPasClassDestructor.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptClassDestructor;
+end;
+
 function TPasClassFunction.ElementTypeName: string; begin Result := SPasTreeClassFunction; end;
 
 class function TPasOperator.OperatorTypeToToken(T: TOperatorType): String;
@@ -2799,22 +2954,12 @@ end;
 constructor TPasRecordType.Create(const AName: string; AParent: TPasElement);
 begin
   inherited Create(AName, AParent);
-  Members := TFPList.Create;
-  GenericTemplateTypes:=TFPList.Create;
 end;
 
 destructor TPasRecordType.Destroy;
 var
   i: Integer;
 begin
-  for i := 0 to GenericTemplateTypes.Count - 1 do
-    TPasElement(GenericTemplateTypes[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasRecordType.GenericTemplateTypes'){$ENDIF};
-  FreeAndNil(GenericTemplateTypes);
-
-  for i := 0 to Members.Count - 1 do
-    TPasVariable(Members[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasRecordType.Members'){$ENDIF};
-  FreeAndNil(Members);
-
   ReleaseAndNil(TPasElement(VariantEl){$IFDEF CheckPasTreeRefCount},'TPasRecordType.VariantEl'{$ENDIF});
 
   if Assigned(Variants) then
@@ -2829,19 +2974,12 @@ end;
 
 { TPasClassType }
 
-procedure TPasClassType.ClearChildReferences(El: TPasElement; arg: pointer);
-begin
-  El.ClearTypeReferences(Self);
-  if arg=nil then ;
-end;
-
 procedure TPasClassType.SetParent(const AValue: TPasElement);
 begin
   if (AValue=nil) and (Parent<>nil) then
     begin
     // parent is cleared
-    // -> clear all child references to this class (releasing loops)
-    ForEachCall(@ClearChildReferences,nil);
+    // -> clear all references to this class (releasing loops)
     if AncestorType=Self then
       ReleaseAndNil(TPasElement(AncestorType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF});
     if HelperForType=Self then
@@ -2853,27 +2991,15 @@ end;
 constructor TPasClassType.Create(const AName: string; AParent: TPasElement);
 begin
   inherited Create(AName, AParent);
-  PackMode:=pmNone;                     // 12/04/04 - Dave - Added
   IsShortDefinition := False;
-  Members := TFPList.Create;
   Modifiers := TStringList.Create;
   Interfaces:= TFPList.Create;
-  GenericTemplateTypes:=TFPList.Create;
 end;
 
 destructor TPasClassType.Destroy;
 var
   i: Integer;
-  El: TPasElement;
 begin
-  for i := 0 to Members.Count - 1 do
-    begin
-    El:=TPasElement(Members[i]);
-    El.Parent:=nil;
-    El.Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Members'){$ENDIF};
-    end;
-  FreeAndNil(Members);
-
   for i := 0 to Interfaces.Count - 1 do
     TPasElement(Interfaces[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Interfaces'){$ENDIF};
   FreeAndNil(Interfaces);
@@ -2881,9 +3007,6 @@ begin
   ReleaseAndNil(TPasElement(HelperForType){$IFDEF CheckPasTreeRefCount},'TPasClassType.HelperForType'{$ENDIF});
   ReleaseAndNil(TPasElement(GUIDExpr){$IFDEF CheckPasTreeRefCount},'TPasClassType.GUIDExpr'{$ENDIF});
   FreeAndNil(Modifiers);
-  for i := 0 to GenericTemplateTypes.Count - 1 do
-    TPasElement(GenericTemplateTypes[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.GenericTemplateTypes'){$ENDIF};
-  FreeAndNil(GenericTemplateTypes);
   inherited Destroy;
 end;
 
@@ -2913,26 +3036,12 @@ begin
     ForEachChildCall(aMethodCall,Arg,TPasElement(Interfaces[i]),true);
   ForEachChildCall(aMethodCall,Arg,HelperForType,true);
   ForEachChildCall(aMethodCall,Arg,GUIDExpr,false);
-  for i:=0 to Members.Count-1 do
-    ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
-  for i:=0 to GenericTemplateTypes.Count-1 do
-    ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false);
 end;
 
 procedure TPasClassType.SetGenericTemplates(AList: TFPList);
-
-Var
-  I : Integer;
-
 begin
   ObjKind:=okGeneric;
-  For I:=0 to AList.Count-1 do
-    begin
-    TPasElement(AList[i]).Parent:=Self;
-    GenericTemplateTypes.Add(AList[i]);
-    end;
-  AList.Clear;
-  ObjKind:=okGeneric;
+  inherited SetGenericTemplates(AList);
 end;
 
 function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement;
@@ -3006,12 +3115,6 @@ begin
   Result:=false;
 end;
 
-function TPasClassType.IsPacked: Boolean;
-begin
-  Result:=PackMode<>pmNone;
-end;
-
-
 { TPasArgument }
 
 destructor TPasArgument.Destroy;
@@ -3232,12 +3335,12 @@ end;
 
 destructor TPasProcedure.Destroy;
 begin
-  ReleaseAndNil(TPasElement(ProcType){$IFDEF CheckPasTreeRefCount},'TPasProcedure.ProcType'{$ENDIF});
-  ReleaseAndNil(TPasElement(Body){$IFDEF CheckPasTreeRefCount},'TPasProcedure.Body'{$ENDIF});
   ReleaseAndNil(TPasElement(PublicName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.PublicName'{$ENDIF});
   ReleaseAndNil(TPasElement(LibraryExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibraryExpr'{$ENDIF});
   ReleaseAndNil(TPasElement(LibrarySymbolName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibrarySymbolName'{$ENDIF});
   ReleaseAndNil(TPasElement(DispIDExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.DispIDExpr'{$ENDIF});
+  ReleaseAndNil(TPasElement(ProcType){$IFDEF CheckPasTreeRefCount},'TPasProcedure.ProcType'{$ENDIF});
+  ReleaseAndNil(TPasElement(Body){$IFDEF CheckPasTreeRefCount},'TPasProcedure.Body'{$ENDIF});
   inherited Destroy;
 end;
 
@@ -3767,29 +3870,6 @@ begin
   ForEachChildCall(aMethodCall,Arg,ElType,true);
 end;
 
-Function IndentStrings(S : TStrings; indent : Integer) : string;
-
-Var
-  I,CurrLen,CurrPos : Integer;
-
-
-begin
-  Result:='';
-  CurrLen:=0;
-  CurrPos:=0;
-  For I:=0 to S.Count-1 do
-    begin
-    CurrLen:=Length(S[i]);
-    If (CurrLen+CurrPos)>72 then
-      begin
-      Result:=Result+LineEnding+StringOfChar(' ',Indent);
-      CurrPos:=Indent;
-      end;
-    Result:=Result+S[i];
-    CurrPos:=CurrPos+CurrLen;
-    end;
-end;
-
 function TPasEnumType.GetDeclaration (full : boolean) : string;
 
 Var
@@ -3861,12 +3941,95 @@ begin
   ForEachChildCall(aMethodCall,Arg,EnumType,true);
 end;
 
-procedure TPasRecordType.ClearChildReferences(El: TPasElement; arg: pointer);
+{ TPasMembersType }
+
+procedure TPasMembersType.ClearChildReferences(El: TPasElement; arg: pointer);
 begin
   El.ClearTypeReferences(Self);
   if arg=nil then ;
 end;
 
+procedure TPasMembersType.SetParent(const AValue: TPasElement);
+begin
+  if (AValue=nil) and (Parent<>nil) then
+    begin
+    // parent is cleared
+    // -> clear all child references to this class/record (releasing loops)
+    ForEachCall(@ClearChildReferences,nil);
+    end;
+  inherited SetParent(AValue);
+end;
+
+constructor TPasMembersType.Create(const AName: string; AParent: TPasElement);
+begin
+  inherited Create(AName, AParent);
+  PackMode:=pmNone;
+  Members := TFPList.Create;
+  GenericTemplateTypes:=TFPList.Create;
+end;
+
+destructor TPasMembersType.Destroy;
+var
+  i: Integer;
+  El: TPasElement;
+begin
+  for i := 0 to Members.Count - 1 do
+    begin
+    El:=TPasElement(Members[i]);
+    El.Parent:=nil;
+    El.Release{$IFDEF CheckPasTreeRefCount}('TPasMembersType.Members'){$ENDIF};
+    end;
+  FreeAndNil(Members);
+
+  for i := 0 to GenericTemplateTypes.Count - 1 do
+    begin
+    El:=TPasElement(GenericTemplateTypes[i]);
+    El.Parent:=nil;
+    El.Release{$IFDEF CheckPasTreeRefCount}('TPasMembersType.GenericTemplateTypes'){$ENDIF};
+    end;
+  FreeAndNil(GenericTemplateTypes);
+
+  inherited Destroy;
+end;
+
+function TPasMembersType.IsPacked: Boolean;
+begin
+  Result:=(PackMode <> pmNone);
+end;
+
+function TPasMembersType.IsBitPacked: Boolean;
+begin
+  Result:=(PackMode=pmBitPacked)
+end;
+
+procedure TPasMembersType.ForEachCall(const aMethodCall: TOnForEachPasElement;
+  const Arg: Pointer);
+var
+  i: Integer;
+begin
+  inherited ForEachCall(aMethodCall, Arg);
+  for i:=0 to GenericTemplateTypes.Count-1 do
+    ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),true);
+  for i:=0 to Members.Count-1 do
+    ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
+end;
+
+procedure TPasMembersType.SetGenericTemplates(AList: TFPList);
+var
+  I: Integer;
+  El: TPasElement;
+begin
+  For I:=0 to AList.Count-1 do
+    begin
+    El:=TPasElement(AList[i]);
+    El.Parent:=Self;
+    GenericTemplateTypes.Add(El);
+    end;
+  AList.Clear;
+end;
+
+{ TPasRecordType }
+
 procedure TPasRecordType.GetMembers(S: TStrings);
 
 Var
@@ -3923,17 +4086,6 @@ begin
   end;
 end;
 
-procedure TPasRecordType.SetParent(const AValue: TPasElement);
-begin
-  if (AValue=nil) and (Parent<>nil) then
-    begin
-    // parent is cleared
-    // -> clear all child references to this class (releasing loops)
-    ForEachCall(@ClearChildReferences,nil);
-    end;
-  inherited SetParent(AValue);
-end;
-
 function TPasRecordType.GetDeclaration (full : boolean) : string;
 
 Var
@@ -3967,54 +4119,30 @@ var
   i: Integer;
 begin
   inherited ForEachCall(aMethodCall, Arg);
-  for i:=0 to GenericTemplateTypes.Count-1 do
-    ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),true);
-  for i:=0 to Members.Count-1 do
-    ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
   ForEachChildCall(aMethodCall,Arg,VariantEl,true);
   if Variants<>nil then
     for i:=0 to Variants.Count-1 do
       ForEachChildCall(aMethodCall,Arg,TPasElement(Variants[i]),false);
 end;
 
-function TPasRecordType.IsPacked: Boolean;
-begin
-  Result:=(PackMode <> pmNone);
-end;
-
-function TPasRecordType.IsBitPacked: Boolean;
-begin
-  Result:=(PackMode=pmBitPacked)
-end;
-
 function TPasRecordType.IsAdvancedRecord: Boolean;
 
 Var
   I : Integer;
+  Member: TPasElement;
 
 begin
   Result:=False;
   I:=0;
   While (Not Result) and (I<Members.Count) do
     begin
-    Result:=TPasElement(Members[i]).InheritsFrom(TPasProcedureBase) or
-            TPasElement(Members[i]).InheritsFrom(TPasProperty);
+    Member:=TPasElement(Members[i]);
+    if (Member.Visibility<>visPublic) then exit(true);
+    if (Member.ClassType<>TPasVariable) then exit(true);
     Inc(I);
     end;
 end;
 
-procedure TPasRecordType.SetGenericTemplates(AList: TFPList);
-var
-  I: Integer;
-begin
-  For I:=0 to AList.Count-1 do
-    begin
-    TPasElement(AList[i]).Parent:=Self;
-    GenericTemplateTypes.Add(AList[i]);
-    end;
-  AList.Clear;
-end;
-
 procedure TPasProcedureType.GetArguments(List : TStrings);
 
 Var
@@ -4281,8 +4409,8 @@ procedure TPasProcedure.ForEachCall(const aMethodCall: TOnForEachPasElement;
   const Arg: Pointer);
 begin
   inherited ForEachCall(aMethodCall, Arg);
-  ForEachChildCall(aMethodCall,Arg,PublicName,false);
   ForEachChildCall(aMethodCall,Arg,ProcType,false);
+  ForEachChildCall(aMethodCall,Arg,PublicName,false);
   ForEachChildCall(aMethodCall,Arg,LibraryExpr,false);
   ForEachChildCall(aMethodCall,Arg,LibrarySymbolName,false);
   ForEachChildCall(aMethodCall,Arg,Body,false);
@@ -4350,36 +4478,28 @@ begin
   Result:=pmForward in FModifiers;
 end;
 
-function TPasProcedure.GetDeclaration(full: Boolean): string;
-
-Var
-  S : TStringList;
+function TPasProcedure.GetProcTypeEnum: TProcType;
 begin
-  S:=TStringList.Create;
-  try
-    If Full then
-      S.Add(TypeName+' '+Name);
-    ProcType.GetArguments(S);
-    GetModifiers(S);
-    Result:=IndentStrings(S,Length(S[0]));
-  finally
-    S.Free;
-  end;
+  Result:=ptProcedure;
 end;
 
-function TPasFunction.GetDeclaration (full : boolean) : string;
-
+function TPasProcedure.GetDeclaration(full: Boolean): string;
 Var
   S : TStringList;
-  T : string;
-
+  T: String;
 begin
   S:=TStringList.Create;
   try
     If Full then
-      S.Add(TypeName+' '+Name);
+      begin
+      T:=TypeName;
+      if Name<>'' then
+        T:=T+' '+Name;
+      S.Add(T);
+      end;
     ProcType.GetArguments(S);
-    If Assigned((Proctype as TPasFunctionType).ResultEl) then
+    If (ProcType is TPasFunctionType)
+        and Assigned(TPasFunctionType(Proctype).ResultEl) then
       With TPasFunctionType(ProcType).ResultEl.ResultType do
         begin
         T:=' : ';
@@ -4401,6 +4521,11 @@ begin
   Result:='function';
 end;
 
+function TPasFunction.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptFunction;
+end;
+
 function TPasOperator.GetOperatorDeclaration(Full : Boolean) : string;
 
 begin
@@ -4453,26 +4578,51 @@ begin
   Result:='operator';
 end;
 
+function TPasOperator.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptOperator;
+end;
+
 function TPasClassProcedure.TypeName: string;
 begin
   Result:='class procedure';
 end;
 
+function TPasClassProcedure.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptClassProcedure;
+end;
+
 function TPasClassFunction.TypeName: string;
 begin
   Result:='class function';
 end;
 
+function TPasClassFunction.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptClassFunction;
+end;
+
 function TPasConstructor.TypeName: string;
 begin
   Result:='constructor';
 end;
 
+function TPasConstructor.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptConstructor;
+end;
+
 function TPasDestructor.TypeName: string;
 begin
   Result:='destructor';
 end;
 
+function TPasDestructor.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptDestructor;
+end;
+
 function TPasArgument.GetDeclaration (full : boolean) : string;
 begin
   If Assigned(ArgType) then

+ 94 - 66
packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -262,8 +262,7 @@ type
     procedure UseProcedure(Proc: TPasProcedure); virtual;
     procedure UseProcedureType(ProcType: TPasProcedureType; Mark: boolean); virtual;
     procedure UseType(El: TPasType; Mode: TPAUseMode); virtual;
-    procedure UseRecordType(El: TPasRecordType; Mode: TPAUseMode); virtual;
-    procedure UseClassType(El: TPasClassType; Mode: TPAUseMode); virtual;
+    procedure UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode); virtual;
     procedure UseVariable(El: TPasVariable; Access: TResolvedRefAccess;
       UseFull: boolean); virtual;
     procedure UseResourcestring(El: TPasResString); virtual;
@@ -390,9 +389,7 @@ begin
   aModule:=El.GetModule;
   if aModule=El then exit;
   if aModule=nil then
-    Result:='NilModule.'+Result
-  else
-    Result:=aModule.Name+'.'+Result;
+    Result:='NilModule.'+Result;
 end;
 
 function dbgs(a: TPAIdentifierAccess): string;
@@ -1180,7 +1177,7 @@ begin
   UseInitFinal(aModule.FinalizationSection);
   ModScope:=aModule.CustomData as TPasModuleScope;
   if ModScope.RangeErrorClass<>nil then
-    UseClassType(ModScope.RangeErrorClass,paumElement);
+    UseClassOrRecType(ModScope.RangeErrorClass,paumElement);
   if ModScope.RangeErrorConstructor<>nil then
     UseProcedure(ModScope.RangeErrorConstructor);
 
@@ -1481,6 +1478,25 @@ begin
         begin
         BuiltInProc:=TResElDataBuiltInProc(Decl.CustomData);
         case BuiltInProc.BuiltIn of
+        bfExit:
+          begin
+          if El.Parent is TParamsExpr then
+            begin
+            Params:=(El.Parent as TParamsExpr).Params;
+            if length(Params)=1 then
+              begin
+              SubEl:=El.Parent;
+              while (SubEl<>nil) and not (SubEl is TPasProcedure) do
+                SubEl:=SubEl.Parent;
+              if (SubEl is TPasProcedure)
+                  and (TPasProcedure(SubEl).ProcType is TPasFunctionType) then
+                begin
+                SubEl:=TPasFunctionType(TPasProcedure(SubEl).ProcType).ResultEl;
+                UseElement(SubEl,rraAssign,false);
+                end;
+              end;
+            end;
+          end;
         bfTypeInfo:
           begin
           Params:=(El.Parent as TParamsExpr).Params;
@@ -1492,9 +1508,10 @@ begin
           {$ENDIF}
           if ParamResolved.IdentEl=nil then
             RaiseNotSupported(20180628155107,Params[0]);
-          if ParamResolved.IdentEl is TPasFunction then
+          if (ParamResolved.IdentEl is TPasProcedure)
+              and (TPasProcedure(ParamResolved.IdentEl).ProcType is TPasFunctionType) then
             begin
-            SubEl:=TPasFunction(ParamResolved.IdentEl).FuncType.ResultEl.ResultType;
+            SubEl:=TPasFunctionType(TPasProcedure(ParamResolved.IdentEl).ProcType).ResultEl.ResultType;
             MarkImplScopeRef(El,SubEl,psraTypeInfo);
             UseTypeInfo(SubEl);
             end
@@ -1554,6 +1571,8 @@ begin
     end
   else if C=TInheritedExpr then
     UseInheritedExpr(TInheritedExpr(El))
+  else if C=TProcedureExpr then
+    UseProcedure(TProcedureExpr(El).Proc)
   else
     RaiseNotSupported(20170307085444,El);
 end;
@@ -1795,10 +1814,8 @@ begin
     {$IFDEF VerbosePasAnalyzer}
     writeln('TPasAnalyzer.UseType searching exports in ',GetElModName(El),' ...');
     {$ENDIF}
-    if C=TPasRecordType then
-      UseRecordType(TPasRecordType(El),Mode)
-    else if C=TPasClassType then
-      UseClassType(TPasClassType(El),Mode);
+    if (C=TPasRecordType) or (C=TPasClassType) then
+      UseClassOrRecType(TPasMembersType(El),Mode);
     end
   else
     begin
@@ -1828,10 +1845,8 @@ begin
         UseExpr(TPasArrayType(El).Ranges[i]);
       UseElType(El,TPasArrayType(El).ElType,Mode);
       end
-    else if C=TPasRecordType then
-      UseRecordType(TPasRecordType(El),Mode)
-    else if C=TPasClassType then
-      UseClassType(TPasClassType(El),Mode)
+    else if (C=TPasRecordType) or (C=TPasClassType) then
+      UseClassOrRecType(TPasMembersType(El),Mode)
     else if C=TPasEnumType then
       begin
       if not MarkElementAsUsed(El) then exit;
@@ -1863,22 +1878,7 @@ begin
     end;
 end;
 
-procedure TPasAnalyzer.UseRecordType(El: TPasRecordType; Mode: TPAUseMode);
-// called by UseType
-var
-  i: Integer;
-begin
-  if Mode=paumAllExports then exit;
-  MarkElementAsUsed(El);
-  if not ElementVisited(El,Mode) then
-    begin
-    if (Mode=paumAllPasUsable) or Resolver.IsTGUID(El) then
-      for i:=0 to El.Members.Count-1 do
-        UseVariable(TObject(El.Members[i]) as TPasVariable,rraNone,true);
-    end;
-end;
-
-procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode);
+procedure TPasAnalyzer.UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode);
 // called by UseType
 
   procedure UseDelegations;
@@ -1916,7 +1916,7 @@ procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode);
         Map:=TPasClassIntfMap(o);
         repeat
           if Map.Intf<>nil then
-            UseClassType(TPasClassType(Map.Intf),paumElement);
+            UseClassOrRecType(TPasClassType(Map.Intf),paumElement);
           if Map.Procs<>nil then
             for j:=0 to Map.Procs.Count-1 do
               UseProcedure(TPasProcedure(Map.Procs[j]));
@@ -1940,6 +1940,7 @@ var
   o: TObject;
   Map: TPasClassIntfMap;
   ImplProc, IntfProc: TPasProcedure;
+  aClass: TPasClassType;
 begin
   FirstTime:=true;
   case Mode of
@@ -1962,35 +1963,54 @@ begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.UseClassType ',GetElModName(El),' ',Mode,' First=',FirstTime);
   {$ENDIF}
-  if El.IsForward then
+  aClass:=nil;
+  ClassScope:=nil;
+  IsCOMInterfaceRoot:=false;
+
+  if El is TPasClassType then
     begin
-    Ref:=El.CustomData as TResolvedReference;
-    UseClassType(Ref.Declaration as TPasClassType,Mode);
-    exit;
-    end;
+    aClass:=TPasClassType(El);
+    if aClass.IsForward then
+      begin
+      Ref:=aClass.CustomData as TResolvedReference;
+      UseClassOrRecType(Ref.Declaration as TPasClassType,Mode);
+      exit;
+      end;
 
-  ClassScope:=El.CustomData as TPasClassScope;
-  if ClassScope=nil then
-    exit; // ClassScope can be nil if msIgnoreInterfaces
+    ClassScope:=aClass.CustomData as TPasClassScope;
+    if ClassScope=nil then
+      exit; // ClassScope can be nil if msIgnoreInterfaces
 
-  IsCOMInterfaceRoot:=false;
-  if FirstTime then
-    begin
-    UseElType(El,ClassScope.DirectAncestor,paumElement);
-    UseElType(El,El.HelperForType,paumElement);
-    UseExpr(El.GUIDExpr);
-    // El.Interfaces: using a class does not use automatically the interfaces
-    if El.ObjKind=okInterface then
+    if FirstTime then
       begin
-      UseDelegations;
-      if (El.InterfaceType=citCom) and (El.AncestorType=nil) then
-        IsCOMInterfaceRoot:=true;
+      UseElType(El,ClassScope.DirectAncestor,paumElement);
+      UseElType(El,aClass.HelperForType,paumElement);
+      UseExpr(aClass.GUIDExpr);
+      // aClass.Interfaces: using a class does not use automatically the interfaces
+      if aClass.ObjKind=okInterface then
+        begin
+        UseDelegations;
+        if (aClass.InterfaceType=citCom) and (aClass.AncestorType=nil) then
+          IsCOMInterfaceRoot:=true;
+        end;
+      if (aClass.ObjKind=okClass) and (ScopeModule<>nil)
+          and (ClassScope.Interfaces<>nil) then
+        // when checking a single unit, mark all method+properties implementing the interfaces
+        MarkAllInterfaceImplementations(ClassScope);
       end;
-    if (El.ObjKind=okClass) and (ScopeModule<>nil)
-        and (ClassScope.Interfaces<>nil) then
-      // when checking a single unit, mark all method+properties implementing the interfaces
-      MarkAllInterfaceImplementations(ClassScope);
-    end;
+    end
+  else if El is TPasRecordType then
+    begin
+    if (Mode<>paumAllPasUsable) and Resolver.IsTGUID(TPasRecordType(El)) then
+      for i:=0 to El.Members.Count-1 do
+        begin
+        Member:=TPasElement(El.Members[i]);
+        if Member is TPasVariable then
+          UseVariable(TPasVariable(Member),rraNone,true);
+        end;
+    end
+  else
+    RaiseNotSupported(20181229103139,El);
 
   // members
   AllPublished:=(Mode<>paumAllExports);
@@ -2054,11 +2074,11 @@ begin
       UseTypeInfo(Member);
       end
     else
-      ; // else: class is in unit interface, mark all non private members
+      ; // else: class/record is in unit interface, mark all non private members
     UseElement(Member,rraNone,true);
     end;
 
-  if FirstTime then
+  if FirstTime and (ClassScope<>nil) then
     begin
     // method resolution
     List:=ClassScope.Interfaces;
@@ -2070,7 +2090,7 @@ begin
           begin
           // interface delegation
           // Note: This class is used. When the intftype is used, this delegation is used.
-          AddOverride(TPasType(El.Interfaces[i]),TPasProperty(o));
+          AddOverride(TPasType(aClass.Interfaces[i]),TPasProperty(o));
           end
         else if o is TPasClassIntfMap then
           begin
@@ -2091,7 +2111,7 @@ begin
             end;
           end
         else
-          RaiseNotSupported(20180328224632,El,GetObjName(o));
+          RaiseNotSupported(20180328224632,aClass,GetObjName(o));
         end;
     end;
 end;
@@ -2335,6 +2355,7 @@ var
   UsedModule, aModule: TPasModule;
   UsesClause: TPasUsesClause;
   Use: TPasUsesUnit;
+  PosEl: TPasElement;
 begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.EmitSectionHints ',GetElModName(Section));
@@ -2350,8 +2371,12 @@ begin
       UsedModule:=TPasModule(Use.Module);
       if CompareText(UsedModule.Name,'system')=0 then continue;
       if not PAElementExists(UsedModule) then
+        begin
+        PosEl:=Use.Expr;
+        if PosEl=nil then PosEl:=Use;
         EmitMessage(20170311191725,mtHint,nPAUnitNotUsed,sPAUnitNotUsed,
-          [UsedModule.Name,aModule.Name],Use.Expr);
+          [UsedModule.Name,aModule.Name],PosEl);
+        end;
       end;
     end;
 
@@ -2488,6 +2513,7 @@ var
   ProcScope: TPasProcedureScope;
   PosEl: TPasElement;
   DeclProc, ImplProc: TPasProcedure;
+  FuncType: TPasFunctionType;
 begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.EmitProcedureHints ',GetElModName(El));
@@ -2553,12 +2579,14 @@ begin
         end;
       end;
     // check result
-    if (El is TPasFunction) then
+    if (El.ProcType is TPasFunctionType) then
       begin
-      PosEl:=TPasFunction(El).FuncType.ResultEl;
-      if (ProcScope.ImplProc<>nil) and (TPasFunction(ProcScope.ImplProc).FuncType.ResultEl<>nil) then
+      FuncType:=TPasFunctionType(TPasProcedure(El).ProcType);
+      PosEl:=FuncType.ResultEl;
+      if (ProcScope.ImplProc<>nil)
+          and (TPasFunction(ProcScope.ImplProc).FuncType.ResultEl<>nil) then
         PosEl:=TPasFunction(ProcScope.ImplProc).FuncType.ResultEl;
-      Usage:=FindElement(TPasFunction(El).FuncType.ResultEl);
+      Usage:=FindElement(FuncType.ResultEl);
       if (Usage=nil) or (Usage.Access in [paiaNone,paiaRead]) then
         // result was never used
         EmitMessage(20170313214038,mtHint,nPAFunctionResultDoesNotSeemToBeSet,

文件差异内容过多而无法显示
+ 311 - 147
packages/fcl-passrc/src/pparser.pp


+ 33 - 7
packages/fcl-passrc/src/pscanner.pp

@@ -486,6 +486,7 @@ type
     FIncludePaths: TStringList;
     FStrictFileCase : Boolean;
   Protected
+    function FindIncludeFileName(const aFilename: string): String; virtual; abstract;
     procedure SetBaseDirectory(AValue: string); virtual;
     procedure SetStrictFileCase(AValue: Boolean); virtual;
     Property IncludePaths: TStringList Read FIncludePaths;
@@ -509,7 +510,7 @@ type
     FUseStreams: Boolean;
     {$endif}
   Protected
-    Function FindIncludeFileName(const AName: string): String; virtual;
+    Function FindIncludeFileName(const AName: string): String; override;
     Function CreateFileReader(Const AFileName : String) : TLineReader; virtual;
   Public
     function FindSourceFile(const AName: string): TLineReader; override;
@@ -530,6 +531,8 @@ type
     function FindStream(const AName: string; ScanIncludes: Boolean): TStream;
     function FindStreamReader(const AName: string; ScanIncludes: Boolean): TLineReader;
     procedure SetOwnsStreams(AValue: Boolean);
+  Protected
+    function FindIncludeFileName(const aFilename: string): String; override;
   Public
     constructor Create; override;
     destructor Destroy; override;
@@ -746,6 +749,7 @@ type
     procedure SetReadOnlyModeSwitches(const AValue: TModeSwitches);
     procedure SetReadOnlyValueSwitches(const AValue: TValueSwitches);
   protected
+    function ReadIdentifier(const AParam: string): string;
     function FetchLine: boolean;
     procedure AddFile(aFilename: string); virtual;
     function GetMacroName(const Param: String): String;
@@ -2539,6 +2543,12 @@ begin
   FOwnsStreams:=AValue;
 end;
 
+function TStreamResolver.FindIncludeFileName(const aFilename: string): String;
+begin
+  raise EFileNotFoundError.Create('TStreamResolver.FindIncludeFileName not supported '+aFilename);
+  Result:='';
+end;
+
 constructor TStreamResolver.Create;
 begin
   Inherited;
@@ -3448,13 +3458,16 @@ begin
 end;
 
 procedure TPascalScanner.HandleIFDEF(const AParam: String);
+var
+  aName: String;
 begin
   PushSkipMode;
   if PPIsSkipping then
     PPSkipMode := ppSkipAll
   else
     begin
-    if IsDefined(AParam) then
+    aName:=ReadIdentifier(AParam);
+    if IsDefined(aName) then
       PPSkipMode := ppSkipElseBranch
     else
       begin
@@ -3463,20 +3476,23 @@ begin
       end;
     If LogEvent(sleConditionals) then
       if PPSkipMode=ppSkipElseBranch then
-        DoLog(mtInfo,nLogIFDefAccepted,sLogIFDefAccepted,[AParam])
+        DoLog(mtInfo,nLogIFDefAccepted,sLogIFDefAccepted,[aName])
       else
-        DoLog(mtInfo,nLogIFDefRejected,sLogIFDefRejected,[AParam]);
+        DoLog(mtInfo,nLogIFDefRejected,sLogIFDefRejected,[aName]);
     end;
 end;
 
 procedure TPascalScanner.HandleIFNDEF(const AParam: String);
+var
+  aName: String;
 begin
   PushSkipMode;
   if PPIsSkipping then
     PPSkipMode := ppSkipAll
   else
     begin
-    if IsDefined(AParam) then
+    aName:=ReadIdentifier(AParam);
+    if IsDefined(aName) then
       begin
       PPSkipMode := ppSkipIfBranch;
       PPIsSkipping := true;
@@ -3485,9 +3501,9 @@ begin
       PPSkipMode := ppSkipElseBranch;
     If LogEvent(sleConditionals) then
       if PPSkipMode=ppSkipElseBranch then
-        DoLog(mtInfo,nLogIFNDefAccepted,sLogIFNDefAccepted,[AParam])
+        DoLog(mtInfo,nLogIFNDefAccepted,sLogIFNDefAccepted,[aName])
       else
-        DoLog(mtInfo,nLogIFNDefRejected,sLogIFNDefRejected,[AParam]);
+        DoLog(mtInfo,nLogIFNDefRejected,sLogIFNDefRejected,[aName]);
     end;
 end;
 
@@ -4673,6 +4689,16 @@ begin
   FReadOnlyValueSwitches:=AValue;
 end;
 
+function TPascalScanner.ReadIdentifier(const AParam: string): string;
+var
+  p, l: Integer;
+begin
+  p:=1;
+  l:=length(AParam);
+  while (p<=l) and (AParam[p] in IdentChars) do inc(p);
+  Result:=LeftStr(AParam,p-1);
+end;
+
 function TPascalScanner.FetchLine: boolean;
 begin
   if CurSourceFile.IsEOF then

+ 3 - 1
packages/fcl-passrc/tests/tcclasstype.pas

@@ -253,6 +253,8 @@ procedure TTestClassType.StartClass(AncestorName: String; InterfaceList: String)
 Var
   S : String;
 begin
+  if FStarted then
+    Fail('TTestClassType.StartClass already started');
   FStarted:=True;
   S:='TMyClass = Class';
   if (AncestorName<>'') then
@@ -426,7 +428,7 @@ end;
 procedure TTestClassType.SetUp;
 begin
   inherited SetUp;
-  FDecl:=TstringList.Create;
+  FDecl:=TStringList.Create;
   FClass:=Nil;
   FParent:='';
   FStarted:=False;

文件差异内容过多而无法显示
+ 1031 - 39
packages/fcl-passrc/tests/tcresolver.pas


+ 1 - 1
packages/fcl-passrc/tests/tcscanner.pas

@@ -1404,7 +1404,7 @@ procedure TTestScanner.TestDefine2;
 
 begin
   FSCanner.Defines.Add('ALWAYS');
-  TestTokens([tkComment,tkWhitespace,tkOf,tkWhitespace,tkcomment],'{$IFDEF ALWAYS} of {$ENDIF}');
+  TestTokens([tkComment,tkWhitespace,tkOf,tkWhitespace,tkcomment],'{$IFDEF ALWAYS comment} of {$ENDIF}');
 end;
 
 procedure TTestScanner.TestDefine21;

+ 236 - 38
packages/fcl-passrc/tests/tctypeparser.pas

@@ -171,19 +171,33 @@ type
 
   { TTestRecordTypeParser }
 
-  TTestRecordTypeParser= Class(TBaseTestTypeParser)
+  TTestRecordTypeParser = Class(TBaseTestTypeParser)
   private
+    FDecl : TStrings;
+    FAdvanced,
+    FEnded,
+    FStarted: boolean;
+    FRecord: TPasRecordType;
+    FMember1: TPasElement;
     function GetC(AIndex: Integer): TPasConst;
     Function GetField(AIndex : Integer; R : TPasRecordType) : TPasVariable;
     Function GetField(AIndex : Integer; R : TPasVariant) : TPasVariable;
     function GetF(AIndex: Integer): TPasVariable;
-    function GetR: TPasRecordType;
+    function GetM(AIndex : Integer): TPasElement;
     Function GetVariant(AIndex : Integer; R : TPasRecordType) : TPasVariant;
     function GetV(AIndex: Integer): TPasVariant;
   Protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+    Procedure StartRecord(Advanced: boolean = false);
+    Procedure EndRecord(AEnd : String = 'end');
+    Procedure AddMember(S : String);
+    Procedure ParseRecord;
+    Procedure ParseRecordFail(Msg: string; MsgNumber: integer);
+    Procedure DoParseRecord;
     Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
     procedure AssertVariantSelector(AName, AType: string);
-    procedure AssertConst1(Hints: TPasMemberHints);
+    procedure AssertConst1(Hints: TPasMemberHints; Index: integer = 1);
     procedure AssertField1(Hints: TPasMemberHints);
     procedure AssertField2(Hints: TPasMemberHints);
     procedure AssertMethod2(Hints: TPasMemberHints; isClass : Boolean = False);
@@ -216,12 +230,15 @@ type
     procedure DoTestVariantNestedVariantFirstDeprecated(Const AHint : string);
     procedure DoTestVariantNestedVariantSecondDeprecated(const AHint: string);
     procedure DoTestVariantNestedVariantBothDeprecated(const AHint: string);
-    Property TheRecord : TPasRecordType Read GetR;
+    Property TheRecord : TPasRecordType Read FRecord;
+    Property Advanced: boolean read FAdvanced;
     Property Const1 : TPasConst Index 0 Read GetC;
     Property Field1 : TPasVariable Index 0 Read GetF;
     Property Field2 : TPasVariable Index 1 Read GetF;
     Property Variant1 : TPasVariant Index 0 Read GetV;
     Property Variant2 : TPasVariant Index 1 Read GetV;
+    Property Members[AIndex : Integer] : TPasElement Read GetM;
+    Property Member1 : TPasElement Read FMember1;
   Published
     Procedure TestEmpty;
     Procedure TestEmptyComment;
@@ -240,7 +257,6 @@ type
     Procedure TestOnePlatformField;
     Procedure TestOnePlatformFieldDeprecated;
     Procedure TestOnePlatformFieldPlatform;
-    Procedure TestOneConstOneField;
     Procedure TestOneGenericField;
     Procedure TestTwoFields;
     procedure TestTwoFieldProtected;
@@ -333,6 +349,17 @@ type
     Procedure TestVariantNestedVariantBothDeprecatedDeprecated;
     Procedure TestVariantNestedVariantBothDeprecatedPlatform;
     Procedure TestOperatorField;
+    Procedure TestPropertyFail;
+    Procedure TestAdvRec_TwoConst;
+    Procedure TestAdvRec_Property;
+    Procedure TestAdvRec_PropertyImplementsFail;
+    Procedure TestAdvRec_PropertyNoTypeFail;
+    Procedure TestAdvRec_ForwardFail;
+    Procedure TestAdvRec_PublishedFail;
+    Procedure TestAdvRec_ProcVirtualFail;
+    Procedure TestAdvRec_ProcOverrideFail;
+    Procedure TestAdvRec_ProcMessageFail;
+    Procedure TestAdvRec_DestructorFail;
   end;
 
   { TTestProcedureTypeParser }
@@ -1148,7 +1175,7 @@ end;
 
 function TTestRecordTypeParser.GetC(AIndex: Integer): TPasConst;
 begin
-  Result:=TObject(GetR.Members[AIndex]) as TPasConst;
+  Result:=TObject(TheRecord.Members[AIndex]) as TPasConst;
 end;
 
 function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasRecordType
@@ -1174,12 +1201,18 @@ end;
 
 function TTestRecordTypeParser.GetF(AIndex: Integer): TPasVariable;
 begin
-  Result:=GetField(AIndex,GetR);
+  Result:=GetField(AIndex,TheRecord);
 end;
 
-function TTestRecordTypeParser.GetR: TPasRecordType;
+function TTestRecordTypeParser.GetM(AIndex : Integer): TPasElement;
 begin
-  Result:=TheType as TPasRecordType;
+  AssertNotNull('Have Record',TheRecord);
+  if (AIndex>=TheRecord.Members.Count) then
+    Fail('No member '+IntToStr(AIndex));
+  AssertNotNull('Have member'+IntToStr(AIndex),TheRecord.Members[AIndex]);
+  If Not (TObject(TheRecord.Members[AIndex]) is TPasElement) then
+    Fail('Member '+IntTostr(AIndex)+' is not a TPasElement');
+  Result:=TPasElement(TheRecord.Members[AIndex])
 end;
 
 function TTestRecordTypeParser.GetVariant(AIndex: Integer; R: TPasRecordType
@@ -1194,7 +1227,95 @@ end;
 
 function TTestRecordTypeParser.GetV(AIndex: Integer): TPasVariant;
 begin
-  Result:=GetVariant(AIndex,GetR);
+  Result:=GetVariant(AIndex,TheRecord);
+end;
+
+procedure TTestRecordTypeParser.SetUp;
+begin
+  inherited SetUp;
+  FDecl:=TStringList.Create;
+  FStarted:=false;
+  FEnded:=false;
+end;
+
+procedure TTestRecordTypeParser.TearDown;
+begin
+  FreeAndNil(FDecl);
+  inherited TearDown;
+end;
+
+procedure TTestRecordTypeParser.StartRecord(Advanced: boolean);
+var
+  S: String;
+begin
+  if FStarted then
+    Fail('TTestRecordTypeParser.StartRecord already started');
+  FStarted:=True;
+  S:='TMyRecord = record';
+  if Advanced then
+    S:='{$modeswitch advancedrecords}'+sLineBreak+S;
+  FDecl.Add(S);
+end;
+
+procedure TTestRecordTypeParser.EndRecord(AEnd: String);
+begin
+  if FEnded then exit;
+  if not FStarted then
+    StartRecord;
+  FEnded:=True;
+  if (AEnd<>'') then
+    FDecl.Add('  '+AEnd);
+end;
+
+procedure TTestRecordTypeParser.AddMember(S: String);
+begin
+  if Not FStarted then
+    StartRecord;
+  FDecl.Add('    '+S);
+end;
+
+procedure TTestRecordTypeParser.ParseRecord;
+begin
+  DoParseRecord;
+end;
+
+procedure TTestRecordTypeParser.ParseRecordFail(Msg: string; MsgNumber: integer
+  );
+var
+  ok: Boolean;
+begin
+  ok:=false;
+  try
+    ParseRecord;
+  except
+    on E: EParserError do
+      begin
+      AssertEquals('Expected {'+Msg+'} '+IntToStr(MsgNumber)+', but got msg {'+Parser.LastMsg+'} '+IntToStr(Parser.LastMsgNumber),MsgNumber,Parser.LastMsgNumber);
+      AssertEquals('Expected {'+Msg+'}, but got msg {'+Parser.LastMsg+'}',Msg,Parser.LastMsg);
+      ok:=true;
+      end;
+  end;
+  AssertEquals('Missing parser error {'+Msg+'} ('+IntToStr(MsgNumber)+')',true,ok);
+end;
+
+procedure TTestRecordTypeParser.DoParseRecord;
+begin
+  EndRecord;
+  Add('Type');
+  if AddComment then
+    begin
+    Add('// A comment');
+    Engine.NeedComments:=True;
+    end;
+  Add('  '+TrimRight(FDecl.Text)+';');
+  ParseDeclarations;
+  AssertEquals('One record type definition',1,Declarations.Types.Count);
+  AssertEquals('First declaration is type definition.',TPasRecordType,TObject(Declarations.Types[0]).ClassType);
+  FRecord:=TObject(Declarations.Types[0]) as TPasRecordType;
+  TheType:=FRecord; // needed by AssertComment
+  Definition:=TheType; // needed by CheckHint
+  if TheRecord.Members.Count>0 then
+    FMember1:=TObject(TheRecord.Members[0]) as TPasElement;
 end;
 
 procedure TTestRecordTypeParser.TestFields(const Fields: array of string;
@@ -1205,17 +1326,14 @@ Var
   I : integer;
 
 begin
-  S:='';
+  StartRecord;
   For I:=Low(Fields) to High(Fields) do
-    begin
-    if (S<>'') then
-      S:=S+sLineBreak;
-    S:=S+'    '+Fields[i];
-    end;
-  if (S<>'') then
-    S:=S+sLineBreak;
-  S:='record'+sLineBreak+s+'  end';
-  ParseType(S,TPasRecordType,AHint);
+    AddMember(Fields[i]);
+  S:='end';
+  if AHint<>'' then
+    S:=S+' '+AHint;
+  EndRecord(S);
+  ParseRecord;
   if HaveVariant then
     begin
     AssertNotNull('Have variants',TheRecord.Variants);
@@ -1228,6 +1346,8 @@ begin
     end;
   if AddComment then
     AssertComment;
+  if (AHint<>'') then
+    CheckHint(TPasMemberHint(GetEnumValue(TypeInfo(TPasMemberHint),'h'+AHint)));
 end;
 
 procedure TTestRecordTypeParser.AssertVariantSelector(AName,AType : string);
@@ -1250,15 +1370,15 @@ begin
     end;
 end;
 
-procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints);
+procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints;
+  Index: integer);
 begin
   if Hints=[] then ;
-  AssertEquals('Member 1 type',TPasConst,TObject(TheRecord.Members[0]).ClassType);
-  AssertEquals('Const 1 name','x',Const1.Name);
-  AssertNotNull('Have 1 const expr',Const1.Expr);
+  AssertEquals('Member '+IntToStr(Index+1)+' type',TPasConst,TObject(TheRecord.Members[Index]).ClassType);
+  AssertEquals('Const '+IntToStr(Index+1)+' name','x',Const1.Name);
+  AssertNotNull('Have '+IntToStr(Index+1)+' const expr',Const1.Expr);
 end;
 
-
 procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
 begin
   TestFields([],AHint);
@@ -1271,7 +1391,6 @@ begin
   AssertVariant1(Hints,['0']);
 end;
 
-
 procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints;
   VariantLabels: array of string);
 
@@ -1787,15 +1906,6 @@ begin
   AssertOneIntegerField([hplatform]);
 end;
 
-procedure TTestRecordTypeParser.TestOneConstOneField;
-begin
-  Scanner.Options:=[po_Delphi];
-  TestFields(['public','Const x =123;','y : integer'],'',False);
-  AssertConst1([]);
-  AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility);
-  AssertField2([]);
-end;
-
 procedure TTestRecordTypeParser.TestOneGenericField;
 begin
   TestFields(['Generic : Integer;'],'',False);
@@ -2043,6 +2153,7 @@ Var
   P : TPasFunction;
 
 begin
+  Scanner.CurrentModeSwitches:=Scanner.CurrentModeSwitches+[msAdvancedRecords];
   TestFields(['x : integer;','class operator assign(a : ta; b : Cardinal) : boolean;','function dosomething3 : Integer;'],'',False);
   AssertEquals('Member count',3,TheRecord.Members.Count);
   AssertField1([]);
@@ -2057,6 +2168,7 @@ end;
 
 procedure TTestRecordTypeParser.TestFieldAndClassVar;
 begin
+  Scanner.CurrentModeSwitches:=Scanner.CurrentModeSwitches+[msAdvancedRecords];
   TestFields(['x : integer;','class var y : integer;'],'',False);
   AssertField1([]);
   AssertTrue('Second field is class var',vmClass in Field2.VarModifiers);
@@ -2064,6 +2176,7 @@ end;
 
 procedure TTestRecordTypeParser.TestFieldAndVar;
 begin
+  Scanner.CurrentModeSwitches:=Scanner.CurrentModeSwitches+[msAdvancedRecords];
   TestFields(['x : integer;','var y : integer;'],'',False);
   AssertField1([]);
   AssertTrue('Second field is regular var',not (vmClass in Field2.VarModifiers));
@@ -2408,6 +2521,91 @@ begin
   AssertEquals('Field 1 name','operator',Field1.Name);
 end;
 
+procedure TTestRecordTypeParser.TestPropertyFail;
+begin
+  AddMember('Property Something');
+  ParseRecordFail(SErrRecordPropertiesNotAllowed,nErrRecordPropertiesNotAllowed);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_TwoConst;
+var
+  aConst: TPasConst;
+begin
+  Scanner.Options:=[po_Delphi];
+  TestFields(['public','Const x =123;','y : integer = 456'],'',False);
+  AssertEquals('Two Const',2,TheRecord.Members.Count);
+  AssertConst1([]);
+  AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility);
+  AssertEquals('Member 2 type',TPasConst,TObject(TheRecord.Members[1]).ClassType);
+  aConst:=TPasConst(TheRecord.Members[1]);
+  AssertEquals('Const 2 name','y',aConst.Name);
+  AssertNotNull('Have 2 const expr',aConst.Expr);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_Property;
+begin
+  StartRecord(true);
+  AddMember('Property Something: word');
+  ParseRecord;
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_PropertyImplementsFail;
+begin
+  StartRecord(true);
+  AddMember('Property Something: word implements ISome;');
+  ParseRecordFail('Expected ";"',nParserExpectTokenError);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_PropertyNoTypeFail;
+begin
+  StartRecord(true);
+  AddMember('Property Something;');
+  ParseRecordFail('Expected ":"',nParserExpectTokenError);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ForwardFail;
+begin
+  StartRecord(true);
+  FDecl.Add(';TMyRecord = record');
+  ParseRecordFail('Syntax error in type',nParserTypeSyntaxError);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_PublishedFail;
+begin
+  StartRecord(true);
+  AddMember('published');
+  AddMember('A: word;');
+  ParseRecordFail(SParserInvalidRecordVisibility,nParserInvalidRecordVisibility);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ProcVirtualFail;
+begin
+  StartRecord(true);
+  AddMember('procedure DoIt; virtual;');
+  ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ProcOverrideFail;
+begin
+  StartRecord(true);
+  AddMember('procedure DoIt; override;');
+  ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ProcMessageFail;
+begin
+  StartRecord(true);
+  AddMember('procedure DoIt; message 2;');
+  ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_DestructorFail;
+begin
+  StartRecord(true);
+  AddMember('destructor Free;');
+  ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
+end;
+
 { TBaseTestTypeParser }
 
 Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;
@@ -2434,9 +2632,9 @@ begin
     AssertEquals('One type definition',1,Declarations.Classes.Count)
   else
     AssertEquals('One type definition',1,Declarations.Types.Count);
-  If (AtypeClass<>Nil) then
+  If ATypeClass<>Nil then
     begin
-    if ATypeClass.InHeritsFrom(TPasClassType) then
+    if ATypeClass.InheritsFrom(TPasClassType) then
       Result:=TPasType(Declarations.Classes[0])
     else
       Result:=TPasType(Declarations.Types[0]);
@@ -2446,7 +2644,7 @@ begin
   FType:=Result;
   Definition:=Result;
   if (Hint<>'') then
-    CheckHint(TPasMemberHint(Getenumvalue(typeinfo(TPasMemberHint),'h'+Hint)));
+    CheckHint(TPasMemberHint(GetEnumValue(TypeInfo(TPasMemberHint),'h'+Hint)));
 end;
 
 Procedure TBaseTestTypeParser.AssertParseTypeError(ASource: String);

+ 37 - 0
packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -72,6 +72,7 @@ type
     procedure TestM_NestedFuncResult;
     procedure TestM_Enums;
     procedure TestM_ProcedureType;
+    procedure TestM_AnonymousProc;
     procedure TestM_Params;
     procedure TestM_Class;
     procedure TestM_ClassForward;
@@ -127,6 +128,7 @@ type
     procedure TestM_Hint_FunctionResultRecord;
     procedure TestM_Hint_FunctionResultPassRecordElement;
     procedure TestM_Hint_FunctionResultAssembler;
+    procedure TestM_Hint_FunctionResultExit;
     procedure TestM_Hint_AbsoluteVar;
 
     // whole program optimization
@@ -999,6 +1001,27 @@ begin
   AnalyzeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestM_AnonymousProc;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  {#TProc_used}TProc = reference to procedure;',
+  'procedure {#DoIt_used}DoIt;',
+  'var',
+  '  {#p_used}p: TProc;',
+  '  {#i_used}i: longint;',
+  'begin',
+  '  p:=procedure',
+  '    begin',
+  '      i:=3;',
+  '    end;',
+  'end;',
+  'begin',
+  '  DoIt;']);
+  AnalyzeProgram;
+end;
+
 procedure TTestUseAnalyzer.TestM_Params;
 begin
   StartProgram(false);
@@ -2136,6 +2159,20 @@ begin
   CheckUseAnalyzerUnexpectedHints;
 end;
 
+procedure TTestUseAnalyzer.TestM_Hint_FunctionResultExit;
+begin
+  StartProgram(false);
+  Add([
+  'function GetIt: longint;',
+  'begin',
+  '  exit(3);',
+  'end;',
+  'begin',
+  '  GetIt;']);
+  AnalyzeProgram;
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
 procedure TTestUseAnalyzer.TestM_Hint_AbsoluteVar;
 begin
   StartProgram(false);

+ 13 - 1
packages/pastojs/fpmake.pp

@@ -44,7 +44,11 @@ begin
     T:=P.Targets.AddUnit('fppas2js.pp');
       T.ResourceStrings:=true;
     T:=P.Targets.AddUnit('fppjssrcmap.pp');
+    T:=P.Targets.AddUnit('pas2jsfs.pp');
+    T:=P.Targets.AddUnit('pas2jsutils.pp');
     T:=P.Targets.AddUnit('pas2jsfilecache.pp');
+      T.Dependencies.AddUnit('pas2jsfs');
+      T.Dependencies.AddUnit('pas2jsutils');
     T:=P.Targets.AddUnit('pas2jsfileutils.pp');
       T.Dependencies.AddInclude('pas2js_defines.inc');
       T.Dependencies.AddInclude('pas2jsfileutilsunix.inc',AllUnixOSes);
@@ -52,10 +56,18 @@ begin
     T:=P.Targets.AddUnit('pas2jslogger.pp');
     T:=P.Targets.AddUnit('pas2jspparser.pp');
     T:=P.Targets.AddUnit('pas2jscompiler.pp');
+    T:=P.Targets.AddUnit('pas2jsfscompiler.pp');
+      T.Dependencies.AddUnit('pas2jscompiler');
     T:=P.Targets.AddUnit('pas2jspcucompiler.pp');
+      T.Dependencies.AddUnit('pas2jsfscompiler');
+    T:=P.Targets.AddUnit('pas2jscompilercfg.pp');
       T.Dependencies.AddUnit('pas2jscompiler');
-    T:=P.Targets.AddUnit('pas2jslibcompiler.pp');
+    T:=P.Targets.AddUnit('pas2jscompilerpp.pp');
       T.Dependencies.AddUnit('pas2jscompiler');
+    T:=P.Targets.AddUnit('pas2jslibcompiler.pp');
+      T.Dependencies.AddUnit('pas2jspcucompiler');
+      T.Dependencies.AddUnit('pas2jscompilercfg');
+      T.Dependencies.AddUnit('pas2jscompilerpp');
 {$ifndef ALLPACKAGES}
     Run;
     end;

文件差异内容过多而无法显示
+ 373 - 107
packages/pastojs/src/fppas2js.pp


+ 5 - 0
packages/pastojs/src/pas2js_defines.inc

@@ -19,6 +19,11 @@
   {$DEFINE UTF8_RTL}
   {$DEFINE HasStdErr}
   {$DEFINE HasPas2jsFiler}
+  {$DEFINE HASFILESYSTEM}
+{$ENDIF}
+
+{$IFDEF NODEJS}
+{$DEFINE HASFILESYSTEM}
 {$ENDIF}
 
 

文件差异内容过多而无法显示
+ 325 - 570
packages/pastojs/src/pas2jscompiler.pp


+ 97 - 0
packages/pastojs/src/pas2jscompilercfg.pp

@@ -0,0 +1,97 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2018  Michael Van Canneyt
+
+    Pascal to Javascript converter class.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Abstract:
+    Config file handling for compiler, depends on filesystem.
+}
+unit Pas2JSCompilerCfg;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  {$IFDEF NodeJS}
+  NodeJSFS,
+  {$ENDIF}
+  Classes, SysUtils, Pas2jsFileUtils, Pas2JSFS, Pas2jsCompiler;
+
+Type
+  TPas2JSFileConfigSupport = Class(TPas2JSConfigSupport)
+    function FindDefaultConfig: String; override;
+    function GetReader(aFileName: string): TSourceLineReader; override;
+  end;
+
+implementation
+
+function TPas2JSFileConfigSupport.GetReader(aFileName: string): TSourceLineReader;
+
+Var
+  CacheFile: TPas2jsFile;
+
+begin
+  CacheFile:=Compiler.FS.LoadFile(aFilename);
+  Result:=CacheFile.CreateLineReader(true);
+end;
+
+Function TPas2JSFileConfigSupport.FindDefaultConfig : String;
+
+  function TryConfig(aFilename: string): boolean;
+  begin
+    Result:=false;
+    if aFilename='' then exit;
+    aFilename:=ExpandFileName(aFilename);
+    if Compiler.ShowDebug or Compiler.ShowTriedUsedFiles then
+      Compiler.Log.LogMsgIgnoreFilter(nConfigFileSearch,[aFilename]);
+    if not Compiler.FS.FileExists(aFilename) then exit;
+    FindDefaultConfig:=aFilename;
+    Result:=true;
+  end;
+
+var
+  aFilename: String;
+
+begin
+  Result:='';
+  // first try HOME directory
+  aFilename:=ChompPathDelim(GetEnvironmentVariablePJ('HOME'));
+  if aFilename<>'' then
+    begin
+    aFilename:=aFilename+PathDelim{$IFDEF UNIX}+'.'{$ENDIF}+DefaultConfigFile;
+    if TryConfig(aFileName) then
+      exit;
+    end;
+
+  // then try compiler directory
+  if (Compiler.CompilerExe<>'') then
+  begin
+    aFilename:=ExtractFilePath(Compiler.CompilerExe);
+    if aFilename<>'' then
+    begin
+      aFilename:=IncludeTrailingPathDelimiter(aFilename)+DefaultConfigFile;
+      if TryConfig(aFilename) then
+        exit;
+    end;
+  end;
+
+  // finally try global directory
+  {$IFDEF Unix}
+  if TryConfig('/etc/'+DefaultConfigFile) then
+    exit;
+  {$ENDIF}
+end;
+
+end.
+

+ 262 - 0
packages/pastojs/src/pas2jscompilerpp.pp

@@ -0,0 +1,262 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2018  Michael Van Canneyt
+
+    Pascal to Javascript converter class.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Abstract:
+    Pas2JS compiler Postprocessor support. Can depend on filesystem.
+}
+unit Pas2JSCompilerPP;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, pas2jscompiler, jswriter, FPPJSSrcMap, contnrs;
+
+Type
+
+  { TPas2JSFSPostProcessorSupport }
+
+  TPas2JSFSPostProcessorSupport = Class(TPas2JSPostProcessorSupport)
+  Private
+    FPostProcs: TObjectList;
+    function CmdListAsStr(CmdList: TStrings): string;
+  Public
+    Constructor Create(aCompiler: TPas2JSCompiler); override;
+    Destructor Destroy; override;
+    Procedure Clear; override;
+    Procedure WriteUsedTools; override;
+    Procedure AddPostProcessor(const Cmd: String); override;
+    Procedure CallPostProcessors(const JSFileName: String; aWriter: TPas2JSMapper); override;
+    function Execute(const JSFilename: String; Cmd: TStringList; JS: TJSWriterString): TJSWriterString;
+  end;
+
+implementation
+
+uses process, pas2jslogger, pas2jsutils, pas2jsfileutils;
+
+function TPas2JSFSPostProcessorSupport.CmdListAsStr(CmdList: TStrings): string;
+var
+  i: Integer;
+begin
+  Result:='';
+  for i:=0 to CmdList.Count-1 do
+  begin
+    if Result<>'' then Result+=' ';
+    Result+=QuoteStr(CmdList[i]);
+  end;
+end;
+
+constructor TPas2JSFSPostProcessorSupport.Create(aCompiler: TPas2JSCompiler);
+begin
+  inherited Create(aCompiler);
+  FPostProcs:=TObjectList.Create; // Owns objects
+end;
+
+destructor TPas2JSFSPostProcessorSupport.Destroy;
+begin
+  FreeAndNil(FPostProcs);
+  inherited Destroy;
+end;
+
+procedure TPas2JSFSPostProcessorSupport.Clear;
+begin
+  FPostProcs.Clear;
+end;
+
+procedure TPas2JSFSPostProcessorSupport.WriteUsedTools;
+
+Var
+  I : integer;
+  PostProc : TStringList;
+
+begin
+  // post processors
+  for i:=0 to FPostProcs.Count-1 do
+  begin
+    PostProc:=TStringList(FPostProcs[i]);
+    Compiler.Log.LogMsgIgnoreFilter(nPostProcessorInfoX,[CmdListAsStr(PostProc)]);
+  end;
+end;
+
+procedure TPas2JSFSPostProcessorSupport.AddPostProcessor(const Cmd: String);
+
+Var
+  PostProc : TStringList;
+  S : String;
+
+begin
+  PostProc:=TStringList.Create;
+  FPostProcs.Add(PostProc);
+  SplitCmdLineParams(Cmd,PostProc);
+  if PostProc.Count<1 then
+    Compiler.ParamFatal('-Jpcmd executable missing');
+  // check executable
+  S:=Compiler.FS.ExpandExecutable(PostProc[0]);
+  if (S='') then
+    Compiler.ParamFatal('-Jpcmd executable "'+S+'" not found');
+  PostProc[0]:=S;
+end;
+
+procedure TPas2JSFSPostProcessorSupport.CallPostProcessors(const JSFileName: String; aWriter: TPas2JSMapper);
+
+var
+  i: Integer;
+  JS, OrigJS: TJSWriterString;
+
+begin
+  if FPostProcs.Count=0 then exit;
+  OrigJS:=aWriter.AsString;
+  JS:=OrigJS;
+  for i:=0 to FPostProcs.Count-1 do
+    JS:=Execute(JSFilename,TStringList(FPostProcs[i]),JS);
+  if JS<>OrigJS then
+  begin
+    aWriter.AsString:=JS;
+    if aWriter.SrcMap<>nil then
+      aWriter.SrcMap.Clear;
+  end;
+
+end;
+
+function TPas2JSFSPostProcessorSupport.Execute(const JSFilename: String; Cmd: TStringList; JS: TJSWriterString): TJSWriterString;
+
+const
+  BufSize = 65536;
+var
+  Exe: String;
+  TheProcess: TProcess;
+  WrittenBytes, ReadBytes: LongInt;
+  Buf, s, ErrBuf: string;
+  OutputChunks: TStringList;
+  CurExitCode, i, InPos: Integer;
+begin
+  Result:='';
+  Buf:='';
+  Exe:=Cmd[0];
+  if Compiler.ShowDebug or Compiler.ShowUsedTools then
+    Compiler.Log.LogMsgIgnoreFilter(nPostProcessorRunX,[QuoteStr(JSFilename)+' | '+CmdListAsStr(Cmd)]);
+  if Compiler.FS.DirectoryExists(Exe) then
+    raise EFOpenError.Create('post processor "'+Exe+'" is a directory');
+  if not FileIsExecutable(Exe) then
+    raise EFOpenError.Create('post processor "'+Exe+'" is a not executable');
+  try
+    TheProcess := TProcess.Create(nil);
+    OutputChunks:=TStringList.Create;
+    try
+      TheProcess.Executable := Exe;
+      for i:=1 to Cmd.Count-1 do
+        TheProcess.Parameters.Add(Cmd[i]);
+      TheProcess.Options:= [poUsePipes];
+      TheProcess.ShowWindow := swoHide;
+      //TheProcess.CurrentDirectory:=WorkingDirectory;
+      TheProcess.Execute;
+      ErrBuf:='';
+      SetLength(Buf,BufSize);
+      InPos:=1;
+      repeat
+        // read stderr and log immediately as warnings
+        repeat
+          if TheProcess.Stderr.NumBytesAvailable=0 then break;
+          ReadBytes:=TheProcess.Stderr.Read(Buf[1],BufSize);
+          if ReadBytes=0 then break;
+          ErrBuf+=LeftStr(Buf,ReadBytes);
+          repeat
+            i:=1;
+            while (i<=length(ErrBuf)) and (i<128) and not (ErrBuf[i] in [#10,#13]) do
+              inc(i);
+            if i>length(ErrBuf) then break;
+            Compiler.Log.LogMsg(nPostProcessorWarnX,[LeftStr(ErrBuf,i)]);
+            if (i<=length(ErrBuf)) and (ErrBuf[i] in [#10,#13]) then
+            begin
+              // skip linebreak
+              if (i<length(ErrBuf)) and (ErrBuf[i+1] in [#10,#13])
+                  and (ErrBuf[i]<>ErrBuf[i+1]) then
+                inc(i,2)
+              else
+                inc(i);
+            end;
+            Delete(ErrBuf,1,i-1);
+          until false;
+        until false;
+        // write to stdin
+        if InPos<length(JS) then
+        begin
+          i:=length(JS)-InPos+1;
+          if i>BufSize then i:=BufSize;
+          WrittenBytes:=TheProcess.Input.Write(JS[InPos],i);
+          inc(InPos,WrittenBytes);
+          if InPos>length(JS) then
+            TheProcess.CloseInput;
+        end else
+          WrittenBytes:=0;
+        // read stdout
+        if TheProcess.Output.NumBytesAvailable=0 then
+          ReadBytes:=0
+        else
+          ReadBytes:=TheProcess.Output.Read(Buf[1],BufSize);
+        if ReadBytes>0 then
+          OutputChunks.Add(LeftStr(Buf,ReadBytes));
+
+        if (WrittenBytes=0) and (ReadBytes=0) then
+        begin
+          if not TheProcess.Running then break;
+          Sleep(10); // give tool some time
+        end;
+      until false;
+      TheProcess.WaitOnExit;
+      CurExitCode:=TheProcess.ExitCode;
+
+      // concatenate output chunks
+      ReadBytes:=0;
+      for i:=0 to OutputChunks.Count-1 do
+        inc(ReadBytes,length(OutputChunks[i]));
+      SetLength(Result,ReadBytes);
+      ReadBytes:=0;
+      for i:=0 to OutputChunks.Count-1 do
+      begin
+        s:=OutputChunks[i];
+        if s='' then continue;
+        System.Move(s[1],Result[ReadBytes+1],length(s));
+        inc(ReadBytes,length(s));
+      end;
+    finally
+      OutputChunks.Free;
+      TheProcess.Free;
+    end;
+  except
+    on E: Exception do begin
+      if Compiler.ShowDebug then
+        Compiler.Log.LogExceptionBackTrace(E);
+      Compiler.Log.LogPlain('Error: '+E.Message);
+      Compiler.Log.LogMsg(nPostProcessorFailX,[CmdListAsStr(Cmd)]);
+      Compiler.Terminate(ExitCodeToolError);
+    end
+    {$IFDEF Pas2js}
+    else HandleJSException('[20181118170506] TPas2jsCompiler.CallPostProcessor Cmd: '+CmdListAsStr(Cmd),JSExceptValue,true);
+    {$ENDIF}
+  end;
+  if CurExitCode<>0 then
+  begin
+    Compiler.Log.LogMsg(nPostProcessorFailX,[CmdListAsStr(Cmd)]);
+    Compiler.Terminate(ExitCodeToolError);
+  end;
+  if Compiler.ShowDebug or Compiler.ShowUsedTools then
+    Compiler.Log.LogMsgIgnoreFilter(nPostProcessorFinished,[]);
+end;
+
+
+end.
+

+ 206 - 340
packages/pastojs/src/pas2jsfilecache.pp

@@ -32,20 +32,12 @@ uses
   {$ENDIF}
   Classes, SysUtils,
   fpjson,
-  PScanner, PasUseAnalyzer, PasResolver, Pas2jsLogger, Pas2jsFileUtils;
-
-const // Messages
-  nIncludeSearch = 201; sIncludeSearch = 'Include file search: %s';
-  nUnitSearch = 202; sUnitSearch = 'Unitsearch: %s';
-  nSearchingFileFound = 203; sSearchingFileFound = 'Searching file: %s... found';
-  nSearchingFileNotFound = 204; sSearchingFileNotFound = 'Searching file: %s... not found';
-  nDuplicateFileFound = 205; sDuplicateFileFound = 'Duplicate file found: "%s" and "%s"';
-  nCustomJSFileNotFound = 206; sCustomJSFileNotFound = 'custom JS file not found: "%s"';
-  nUsingPath = 104; sUsingPath = 'Using %s: "%s"';
-  nFolderNotFound = 105; sFolderNotFound = '%s not found: %s';
+  PScanner, PasResolver, PasUseAnalyzer,
+  Pas2jsLogger, Pas2jsFileUtils, Pas2JSFS;
+
 
 type
-  EPas2jsFileCache = class(Exception);
+  EPas2jsFileCache = class(EPas2JSFS);
 
 type
   TPas2jsFileAgeTime = longint;
@@ -87,7 +79,7 @@ type
     function Count: integer;
     procedure Clear;
     property ChangeStamp: TChangeStamp read FChangeStamp write FChangeStamp;// set on Update to Pool.ChangeStamp
-    function NeedsUpdate: boolean; inline;
+    function NeedsUpdate: boolean;
     procedure Update;
     procedure Reference;
     procedure Release;
@@ -159,93 +151,58 @@ type
     property OnReadDirectory: TReadDirectoryEvent read FOnReadDirectory write FOnReadDirectory;
   end;
 
-type
-  TP2jsFileCacheOption = (
-    caoShowFullFilenames,
-    caoShowTriedUsedFiles,
-    caoSearchLikeFPC,
-    caoStrictFileCase
-    );
-  TP2jsFileCacheOptions = set of TP2jsFileCacheOption;
-
-const
-  DefaultPas2jsFileCacheOptions = [];
-
-  p2jsfcoCaption: array[TP2jsFileCacheOption] of string = (
-    // only used by experts, no need for resourcestrings
-    'Show full filenames',
-    'Show tried/used files',
-    'Search files like FPC',
-    'Strict file case'
-    );
-  // 'Combine all JavaScript into main file',
-
-  EncodingBinary = 'Binary';
 type
   TPas2jsFilesCache = class;
   TPas2jsCachedFile = class;
 
   { TPas2jsFileResolver }
 
-  TPas2jsFileResolver = class(TFileResolver)
+  TPas2jsFileResolver = class(TPas2JSFSResolver)
   private
-    FCache: TPas2jsFilesCache;
+    function GetCache: TPas2jsFilesCache;
   public
     constructor Create(aCache: TPas2jsFilesCache); reintroduce;
     // Redirect all calls to cache.
-    function FindIncludeFileName(const aFilename: string): String; override;
-    function FindIncludeFile(const aFilename: string): TLineReader; override;
-    function FindSourceFile(const aFilename: string): TLineReader; override;
-    property Cache: TPas2jsFilesCache read FCache;
+    property Cache: TPas2jsFilesCache read GetCache;
   end;
 
   { TPas2jsFileLineReader }
 
-  TPas2jsFileLineReader = class(TLineReader)
+  TPas2jsFileLineReader = class(TSourceLineReader)
   private
     FCachedFile: TPas2jsCachedFile;
-    FIsEOF: boolean;
-    FLineNumber: integer;
-    FSource: string;
-    FSrcPos: integer;
+  Protected
+    Procedure IncLineNumber; override;
+    property CachedFile: TPas2jsCachedFile read FCachedFile;
   public
     constructor Create(const AFilename: string); override;
     constructor Create(aFile: TPas2jsCachedFile); reintroduce;
-    function IsEOF: Boolean; override;
-    function ReadLine: string; override;
-    property LineNumber: integer read FLineNumber;
-    property CachedFile: TPas2jsCachedFile read FCachedFile;
-    property Source: string read FSource;
-    property SrcPos: integer read FSrcPos;
   end;
 
   { TPas2jsCachedFile }
 
-  TPas2jsCachedFile = class
+  TPas2jsCachedFile = class(TPas2JSFile)
   private
-    FCache: TPas2jsFilesCache;
     FChangeStamp: TChangeStamp;
     FFileEncoding: string;
-    FFilename: string;
     FLastErrorMsg: string;
     FLoaded: boolean;
     FLoadedFileAge: longint;
-    FSource: string;
     FCacheStamp: TChangeStamp; // Cache.ResetStamp when file was loaded
+    function GetCache: TPas2jsFilesCache;
     function GetIsBinary: boolean; inline;
-  public
-    constructor Create(aCache: TPas2jsFilesCache; const aFilename: string); reintroduce;
-    function Load(RaiseOnError: boolean; Binary: boolean = false): boolean;
-    function CreateLineReader(RaiseOnError: boolean): TPas2jsFileLineReader;
+  Protected
     property IsBinary: boolean read GetIsBinary;
     property FileEncoding: string read FFileEncoding;
-    property Filename: string read FFilename;
-    property Source: string read FSource; // UTF-8 without BOM or Binary
-    property Cache: TPas2jsFilesCache read FCache;
+    property Cache: TPas2jsFilesCache read GetCache;
     property ChangeStamp: TChangeStamp read FChangeStamp;// changed when Source changed
     property Loaded: boolean read FLoaded; // Source valid, but may contain an old version
     property LastErrorMsg: string read FLastErrorMsg;
     property LoadedFileAge: longint read FLoadedFileAge;// only valid if Loaded=true
+  public
+    constructor Create(aCache: TPas2jsFilesCache; const aFilename: string); reintroduce;
+    function Load(RaiseOnError: boolean; Binary: boolean = false): boolean; override;
+    function CreateLineReader(RaiseOnError: boolean): TSourceLineReader; override;
   end;
 
   TPas2jsReadFileEvent = function(aFilename: string; var aSource: string): boolean of object;
@@ -258,10 +215,9 @@ type
 
   { TPas2jsFilesCache }
 
-  TPas2jsFilesCache = class
+  TPas2jsFilesCache = class (TPas2JSFS)
   private
     FBaseDirectory: string;
-    FDefaultOutputPath: string;
     FDirectoryCache: TPas2jsCachedDirectories;
     FFiles: TPasAnalyzerKeySet; // set of TPas2jsCachedFile, key is Filename
     FForeignUnitPaths: TStringList;
@@ -269,94 +225,78 @@ type
     FIncludePaths: TStringList;
     FIncludePathsFromCmdLine: integer;
     FLog: TPas2jsLogger;
-    FNamespaces: TStringList;
-    FNamespacesFromCmdLine: integer;
     FOnReadFile: TPas2jsReadFileEvent;
     FOnWriteFile: TPas2jsWriteFileEvent;
-    FOptions: TP2jsFileCacheOptions;
-    FReadLineCounter: SizeInt;
     FResetStamp: TChangeStamp;
-    FUnitOutputPath: string;
     FUnitPaths: TStringList;
     FUnitPathsFromCmdLine: integer;
+    FPCUPaths: TStringList;
     function FileExistsILogged(var Filename: string): integer;
     function FileExistsLogged(const Filename: string): boolean;
-    function FindSourceFileName(const aFilename: string): String;
-    function GetSearchLikeFPC: boolean;
-    function GetShowFullFilenames: boolean;
-    function GetShowTriedUsedFiles: boolean;
-    function GetStrictFileCase: Boolean;
+    function GetOnReadDirectory: TReadDirectoryEvent;
     procedure RegisterMessages;
     procedure SetBaseDirectory(AValue: string);
     function AddSearchPaths(const Paths: string; Kind: TPas2jsSearchPathKind;
       FromCmdLine: boolean; var List: TStringList; var CmdLineCount: integer): string;
-    procedure SetDefaultOutputPath(AValue: string);
-    procedure SetOptions(AValue: TP2jsFileCacheOptions);
-    procedure SetSearchLikeFPC(const AValue: boolean);
-    procedure SetShowFullFilenames(const AValue: boolean);
-    procedure SetShowTriedUsedFiles(const AValue: boolean);
-    procedure SetStrictFileCase(AValue: Boolean);
-    procedure SetUnitOutputPath(AValue: string);
-    procedure SetOption(Flag: TP2jsFileCacheOption; Enable: boolean);
+    procedure SetOnReadDirectory(AValue: TReadDirectoryEvent);
   protected
+    function FindSourceFileName(const aFilename: string): String; override;
     function GetHasPCUSupport: Boolean; virtual;
     function ReadFile(Filename: string; var Source: string): boolean; virtual;
     procedure FindMatchingFiles(Mask: string; MaxCount: integer; Files: TStrings);// find files, matching * and ?
   public
-    constructor Create(aLog: TPas2jsLogger);
+    constructor Create(aLog: TPas2jsLogger); overload;
     destructor Destroy; override;
-    procedure Reset; virtual;
-    procedure WriteFoldersAndSearchPaths; virtual;
+    procedure Reset; override;
+    procedure WriteFoldersAndSearchPaths; override;
+    procedure GetPCUDirs(aList: TStrings; const aBaseDir: String); override;
+    function PCUExists(var aFileName: string): Boolean; override;
+    Function SameFileName(Const File1,File2 : String) : Boolean;  override;
+    Function File1IsNewer(const File1, File2: String): Boolean; override;
     function SearchLowUpCase(var Filename: string): boolean;
-    function FindCustomJSFileName(const aFilename: string): String;
-    function FindUnitJSFileName(const aUnitFilename: string): String;
-    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; virtual;
-    function FindIncludeFileName(const aFilename: string): String; virtual;
+    function FindCustomJSFileName(const aFilename: string): String; override;
+    function FindUnitJSFileName(const aUnitFilename: string): String; override;
+    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; override;
+    function FindIncludeFileName(const aFilename: string): String; override;
     function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
-    function AddNamespaces(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
     function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
     function AddSrcUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
-    function CreateResolver: TPas2jsFileResolver;
-    function FormatPath(const aPath: string): string;
-    Function DirectoryExists(Filename: string): boolean; virtual;
-    function FileExists(Filename: string): boolean; virtual;
+    function CreateResolver: TPas2jsFSResolver; override;
+    function FormatPath(const aPath: string): string; override;
+    Function DirectoryExists(Const Filename: string): boolean; override;
+    function FileExists(const Filename: string): boolean; override;
     function FileExistsI(var Filename: string): integer; // returns number of found files
     function FileAge(const Filename: string): TPas2jsFileAgeTime; virtual;
     function FindFile(Filename: string): TPas2jsCachedFile;
-    function LoadFile(Filename: string; Binary: boolean = false): TPas2jsCachedFile;
+    function LoadFile(Filename: string; Binary: boolean = false): TPas2jsFile; override;
     function NormalizeFilename(const Filename: string; RaiseOnError: boolean): string;
     procedure GetListing(const aDirectory: string; var Files: TStrings;
                          FullPaths: boolean = true);
     procedure RaiseDuplicateFile(aFilename: string);
-    procedure SaveToFile(ms: TFPJSStream; Filename: string);
-    function ExpandDirectory(const Filename, BaseDir: string): string;
-    function ExpandExecutable(const Filename, BaseDir: string): string;
+    procedure SaveToFile(ms: TFPJSStream; Filename: string); override;
+    function ExpandDirectory(const Filename: string): string; override;
+    function ExpandFileName(const Filename: string): string; override;
+    function ExpandExecutable(const Filename: string): string; override;
+    function HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): String; override;
+    Function AddForeignUnitPath(const aValue: String; FromCmdLine: Boolean): String; override;
+    function TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out RelPath: String): Boolean; override;
+  Protected
+    property DirectoryCache: TPas2jsCachedDirectories read FDirectoryCache;
   public
     property BaseDirectory: string read FBaseDirectory write SetBaseDirectory; // includes trailing pathdelim
-    property MainOutputPath: string read FDefaultOutputPath write SetDefaultOutputPath; // includes trailing pathdelim
-    property DirectoryCache: TPas2jsCachedDirectories read FDirectoryCache;
     property ForeignUnitPaths: TStringList read FForeignUnitPaths;
     property ForeignUnitPathsFromCmdLine: integer read FForeignUnitPathsFromCmdLine;
     property IncludePaths: TStringList read FIncludePaths;
     property IncludePathsFromCmdLine: integer read FIncludePathsFromCmdLine;
     property Log: TPas2jsLogger read FLog;
-    property Namespaces: TStringList read FNamespaces;
-    property NamespacesFromCmdLine: integer read FNamespacesFromCmdLine;
-    property Options: TP2jsFileCacheOptions read FOptions write SetOptions default DefaultPas2jsFileCacheOptions;
-    property ReadLineCounter: SizeInt read FReadLineCounter write FReadLineCounter;
     property ResetStamp: TChangeStamp read FResetStamp;
-    property SearchLikeFPC: boolean read GetSearchLikeFPC write SetSearchLikeFPC;
-    property ShowFullPaths: boolean read GetShowFullFilenames write SetShowFullFilenames;
-    property ShowTriedUsedFiles: boolean read GetShowTriedUsedFiles write SetShowTriedUsedFiles;
-    property UnitOutputPath: string read FUnitOutputPath write SetUnitOutputPath; // includes trailing pathdelim
     property UnitPaths: TStringList read FUnitPaths;
     property UnitPathsFromCmdLine: integer read FUnitPathsFromCmdLine;
+    property OnReadDirectory: TReadDirectoryEvent read GetOnReadDirectory write SetOnReadDirectory;
     property OnReadFile: TPas2jsReadFileEvent read FOnReadFile write FOnReadFile;
     property OnWriteFile: TPas2jsWriteFileEvent read FOnWriteFile write FOnWriteFile;
-    Property StrictFileCase : Boolean Read GetStrictFileCase Write SetStrictFileCase;
   end;
 
-
 {$IFDEF Pas2js}
 function PtrStrToStr(StrAsPtr: Pointer): string;
 function PtrFilenameToKeyName(FilenameAsPtr: Pointer): string;
@@ -409,6 +349,7 @@ var
 begin
   Result:=FilenameToKey(Dir.Path);
 end;
+
 {$ELSE}
 function CompareFilenameWithCachedFile(Filename, CachedFile: Pointer): integer;
 var
@@ -439,6 +380,7 @@ var
 begin
   Result:=CompareFilenames(AnsiString(Path),Directory.Path);
 end;
+
 {$ENDIF}
 
 function ComparePas2jsDirectoryEntries(Entry1, Entry2: {$IFDEF Pas2js}jsvalue{$ELSE}Pointer{$ENDIF}): integer;
@@ -614,6 +556,7 @@ begin
   FPath:=IncludeTrailingPathDelimiter(aPath);
   FEntries:=TFPList.Create;
   FPool:=aPool;
+  FChangeStamp:=InvalidChangeStamp;
 end;
 
 destructor TPas2jsCachedDirectory.Destroy;
@@ -1105,6 +1048,13 @@ end;
 
 { TPas2jsFileLineReader }
 
+procedure TPas2jsFileLineReader.IncLineNumber;
+begin
+  if (CachedFile<>nil) and (CachedFile.Cache<>nil) then
+    CachedFile.Cache.IncReadLineCounter;
+  inherited IncLineNumber;
+end;
+
 constructor TPas2jsFileLineReader.Create(const AFilename: string);
 begin
   raise Exception.Create('TPas2jsFileLineReader.Create [20180126090825] no cache "'+AFilename+'"');
@@ -1112,60 +1062,10 @@ end;
 
 constructor TPas2jsFileLineReader.Create(aFile: TPas2jsCachedFile);
 begin
-  inherited Create(aFile.Filename);
+  inherited Create(aFile.Filename,aFile.Source);
   FCachedFile:=aFile;
-  FSource:=aFile.Source;
-  FSrcPos:=1;
-  FIsEOF:=FSource='';
-end;
-
-function TPas2jsFileLineReader.IsEOF: Boolean;
-begin
-  Result:=FIsEOF;
 end;
 
-function TPas2jsFileLineReader.ReadLine: string;
-var
-  S: string;
-  p, SrcLen: integer;
-
-  procedure GetLine;
-  var
-    l: SizeInt;
-  begin
-    l:=p-FSrcPos;
-    Result:=copy(S,FSrcPos,l);
-    FSrcPos:=p;
-    inc(FLineNumber);
-    if (CachedFile<>nil) and (CachedFile.Cache<>nil) then
-      inc(CachedFile.Cache.FReadLineCounter);
-    //writeln('GetLine "',Result,'"');
-  end;
-
-begin
-  if FIsEOF then exit('');
-  S:=Source;
-  SrcLen:=length(S);
-  p:=FSrcPos;
-  while p<=SrcLen do
-    case S[p] of
-    #10,#13:
-      begin
-        GetLine;
-        inc(p);
-        if (p<=SrcLen) and (S[p] in [#10,#13]) and (S[p]<>S[p-1]) then
-          inc(p);
-        if p>SrcLen then
-          FIsEOF:=true;
-        FSrcPos:=p;
-        exit;
-      end;
-    else
-      inc(p);
-    end;
-  FIsEOF:=true;
-  GetLine;
-end;
 
 { TPas2jsCachedFile }
 
@@ -1175,13 +1075,17 @@ begin
   Result:=FFileEncoding=EncodingBinary;
 end;
 
+function TPas2jsCachedFile.GetCache: TPas2jsFilesCache;
+begin
+  Result:=TPas2jsFilesCache(FS);
+end;
+
 constructor TPas2jsCachedFile.Create(aCache: TPas2jsFilesCache;
   const aFilename: string);
 begin
+  inHerited Create(aCache,aFileName);
   FChangeStamp:=InvalidChangeStamp;
-  FCache:=aCache;
   FCacheStamp:=Cache.ResetStamp;
-  FFilename:=aFilename;
 end;
 
 function TPas2jsCachedFile.Load(RaiseOnError: boolean; Binary: boolean
@@ -1254,14 +1158,14 @@ begin
   {$ENDIF}
   if Binary then
   begin
-    FSource:=NewSource;
+    SetSource(NewSource);
     FFileEncoding:=EncodingBinary;
   end else
   begin
     {$IFDEF FPC_HAS_CPSTRING}
-    FSource:=ConvertTextToUTF8(NewSource,FFileEncoding);
+    SetSource(ConvertTextToUTF8(NewSource,FFileEncoding));
     {$ELSE}
-    FSource:=NewSource;
+    SetSource(NewSource);
     {$ENDIF}
   end;
   FLoaded:=true;
@@ -1273,7 +1177,7 @@ begin
 end;
 
 function TPas2jsCachedFile.CreateLineReader(RaiseOnError: boolean
-  ): TPas2jsFileLineReader;
+  ): TSourceLineReader;
 begin
   if not Load(RaiseOnError) then
     exit(nil);
@@ -1282,44 +1186,16 @@ end;
 
 { TPas2jsFileResolver }
 
-constructor TPas2jsFileResolver.Create(aCache: TPas2jsFilesCache);
-begin
-  inherited Create;
-  FCache:=aCache;
-end;
-
-function TPas2jsFileResolver.FindIncludeFile(const aFilename: string): TLineReader;
-var
-  Filename: String;
-begin
-  Result:=nil;
-  Filename:=Cache.FindIncludeFileName(aFilename);
-  if Filename='' then exit;
-  try
-    Result:=FindSourceFile(Filename);
-  except
-    // error is shown in the scanner, which has the context information
-  end;
-end;
-
-function TPas2jsFileResolver.FindIncludeFileName(const aFilename: string): String;
-
+function TPas2jsFileResolver.GetCache: TPas2jsFilesCache;
 begin
-  Result:=Cache.FindIncludeFileName(aFilename);
+  Result:=TPas2jsFilesCache(FS);
 end;
 
-
-function TPas2jsFileResolver.FindSourceFile(const aFilename: string): TLineReader;
-
-var
-  CurFilename: String;
-
+constructor TPas2jsFileResolver.Create(aCache: TPas2jsFilesCache);
 begin
-  CurFilename:=Cache.FindSourceFileName(aFileName);
-  Result:=Cache.LoadFile(CurFilename).CreateLineReader(false);
+  inherited Create(aCache);
 end;
 
-
 { TPas2jsFilesCache }
 
 procedure TPas2jsFilesCache.RegisterMessages;
@@ -1337,28 +1213,6 @@ begin
   Result:=False;
 end;
 
-function TPas2jsFilesCache.GetStrictFileCase : Boolean;
-
-begin
-  Result:=caoStrictFileCase in FOptions;
-end;
-
-function TPas2jsFilesCache.GetSearchLikeFPC: boolean;
-begin
-  Result:=caoSearchLikeFPC in FOptions;
-end;
-
-function TPas2jsFilesCache.GetShowFullFilenames: boolean;
-begin
-  Result:=caoShowFullFilenames in FOptions;
-end;
-
-function TPas2jsFilesCache.GetShowTriedUsedFiles: boolean;
-begin
-  Result:=caoShowTriedUsedFiles in FOptions;
-end;
-
-
 procedure TPas2jsFilesCache.SetBaseDirectory(AValue: string);
 begin
   AValue:=Pas2jsFileUtils.ExpandDirectory(AValue);
@@ -1456,7 +1310,7 @@ begin
       if aPath='' then continue;
       if Kind=spkPath then
       begin
-        aPath:=ExpandDirectory(aPath,BaseDirectory);
+        aPath:=ExpandDirectory(aPath);
         if aPath='' then continue;
       end;
       aPaths.Clear;
@@ -1474,55 +1328,9 @@ begin
   end;
 end;
 
-procedure TPas2jsFilesCache.SetDefaultOutputPath(AValue: string);
-begin
-  AValue:=ExpandDirectory(AValue,BaseDirectory);
-  if FDefaultOutputPath=AValue then Exit;
-  FDefaultOutputPath:=AValue;
-end;
-
-
-procedure TPas2jsFilesCache.SetOptions(AValue: TP2jsFileCacheOptions);
-begin
-  if FOptions=AValue then Exit;
-  FOptions:=AValue;
-end;
-
-procedure TPas2jsFilesCache.SetSearchLikeFPC(const AValue: boolean);
-begin
-  SetOption(caoSearchLikeFPC,AValue);
-end;
-
-procedure TPas2jsFilesCache.SetShowFullFilenames(const AValue: boolean);
+procedure TPas2jsFilesCache.SetOnReadDirectory(AValue: TReadDirectoryEvent);
 begin
-  SetOption(caoShowFullFilenames,AValue);
-end;
-
-procedure TPas2jsFilesCache.SetShowTriedUsedFiles(const AValue: boolean);
-begin
-  SetOption(caoShowTriedUsedFiles,AValue);
-end;
-
-procedure TPas2jsFilesCache.SetStrictFileCase(AValue: Boolean);
-begin
-  SetOption(caoStrictFileCase,aValue)
-end;
-
-
-procedure TPas2jsFilesCache.SetUnitOutputPath(AValue: string);
-begin
-  AValue:=ExpandDirectory(AValue,BaseDirectory);
-  if FUnitOutputPath=AValue then Exit;
-  FUnitOutputPath:=AValue;
-end;
-
-procedure TPas2jsFilesCache.SetOption(Flag: TP2jsFileCacheOption; Enable: boolean
-  );
-begin
-  if Enable then
-    Include(FOptions,Flag)
-  else
-    Exclude(FOptions,Flag);
+  DirectoryCache.OnReadDirectory:=AValue;
 end;
 
 function TPas2jsFilesCache.ReadFile(Filename: string; var Source: string
@@ -1629,10 +1437,8 @@ begin
   inherited Create;
   FResetStamp:=InvalidChangeStamp;
   FLog:=aLog;
-  FOptions:=DefaultPas2jsFileCacheOptions;
   FIncludePaths:=TStringList.Create;
   FForeignUnitPaths:=TStringList.Create;
-  FNamespaces:=TStringList.Create;
   FUnitPaths:=TStringList.Create;
   FFiles:=TPasAnalyzerKeySet.Create(
     {$IFDEF Pas2js}
@@ -1652,28 +1458,25 @@ begin
   FreeAndNil(FFiles);
   FreeAndNil(FIncludePaths);
   FreeAndNil(FForeignUnitPaths);
-  FreeAndNil(FNamespaces);
   FreeAndNil(FUnitPaths);
+  FreeAndNil(FPCUPaths);
   inherited Destroy;
 end;
 
 procedure TPas2jsFilesCache.Reset;
 begin
+  Inherited;
   IncreaseChangeStamp(FResetStamp);
   FDirectoryCache.Invalidate;
   // FFiles: keep data, files are checked against LoadedFileAge
-  FOptions:=DefaultPas2jsFileCacheOptions;
   FBaseDirectory:='';
-  FUnitOutputPath:='';
-  FReadLineCounter:=0;
   FForeignUnitPaths.Clear;
   FForeignUnitPathsFromCmdLine:=0;
   FUnitPaths.Clear;
   FUnitPathsFromCmdLine:=0;
   FIncludePaths.Clear;
   FIncludePathsFromCmdLine:=0;
-  FNamespaces.Clear;
-  FNamespacesFromCmdLine:=0;
+  FreeAndNil(FPCUPaths);
   // FOnReadFile: TPas2jsReadFileEvent; keep
   // FOnWriteFile: TPas2jsWriteFileEvent; keep
 end;
@@ -1695,25 +1498,47 @@ begin
     WriteFolder('foreign unit path',ForeignUnitPaths[i]);
   for i:=0 to UnitPaths.Count-1 do
     WriteFolder('unit path',UnitPaths[i]);
-  for i:=0 to Namespaces.Count-1 do
-    Log.LogMsgIgnoreFilter(nUsingPath,['unit scope',Namespaces[i]]);
   for i:=0 to IncludePaths.Count-1 do
     WriteFolder('include path',IncludePaths[i]);
   WriteFolder('unit output path',UnitOutputPath);
   WriteFolder('main output path',MainOutputPath);
 end;
 
-function TPas2jsFilesCache.AddIncludePaths(const Paths: string;
-  FromCmdLine: boolean; out ErrorMsg: string): boolean;
+procedure TPas2jsFilesCache.GetPCUDirs(aList: TStrings; const aBaseDir: String);
+var
+  i: Integer;
 begin
-  ErrorMsg:=AddSearchPaths(Paths,spkPath,FromCmdLine,FIncludePaths,FIncludePathsFromCmdLine);
-  Result:=ErrorMsg='';
+  if FPCUPaths=nil then
+    begin
+    FPCUPaths:=TStringList.Create;
+    inherited GetPCUDirs(FPCUPaths, aBaseDir);
+    FPCUPaths.AddStrings(UnitPaths);
+    for i:=0 to FPCUPaths.Count-1 do
+      FPCUPaths[i]:=IncludeTrailingPathDelimiter(FPCUPaths[i]);
+    DeleteDuplicateFiles(FPCUPaths);
+    end;
+  aList.Assign(FPCUPaths);
+end;
+
+function TPas2jsFilesCache.PCUExists(var aFileName: string): Boolean;
+begin
+  Result:=SearchLowUpCase(aFileName);
 end;
 
-function TPas2jsFilesCache.AddNamespaces(const Paths: string;
+function TPas2jsFilesCache.SameFileName(const File1, File2: String): Boolean;
+begin
+  Result:=Pas2jsFileUtils.CompareFilenames(File1,File2)=0;
+end;
+
+function TPas2jsFilesCache.File1IsNewer(const File1, File2: String): Boolean;
+begin
+  Result:=FileAge(File1)>FileAge(File2);
+end;
+
+function TPas2jsFilesCache.AddIncludePaths(const Paths: string;
   FromCmdLine: boolean; out ErrorMsg: string): boolean;
 begin
-  ErrorMsg:=AddSearchPaths(Paths,spkIdentifier,FromCmdLine,FNamespaces,FNamespacesFromCmdLine);
+  ErrorMsg:=AddSearchPaths(Paths,spkPath,FromCmdLine,FIncludePaths,FIncludePathsFromCmdLine);
   Result:=ErrorMsg='';
 end;
 
@@ -1731,7 +1556,8 @@ begin
   Result:=ErrorMsg='';
 end;
 
-function TPas2jsFilesCache.CreateResolver: TPas2jsFileResolver;
+function TPas2jsFilesCache.CreateResolver: TPas2jsFSResolver;
+
 begin
   Result := TPas2jsFileResolver.Create(Self);
   {$IFDEF HasStreams}
@@ -1759,12 +1585,12 @@ end;
 
 
 
-function TPas2jsFilesCache.DirectoryExists(Filename: string): boolean;
+function TPas2jsFilesCache.DirectoryExists(const Filename: string): boolean;
 begin
   Result:=DirectoryCache.DirectoryExists(FileName);
 end;
 
-function TPas2jsFilesCache.FileExists(Filename: string): boolean;
+function TPas2jsFilesCache.FileExists(const Filename: string): boolean;
 begin
   Result:=DirectoryCache.FileExists(FileName);
 end;
@@ -1786,7 +1612,7 @@ begin
 end;
 
 function TPas2jsFilesCache.LoadFile(Filename: string; Binary: boolean
-  ): TPas2jsCachedFile;
+  ): TPas2jsFile;
 begin
   Result:=FindFile(FileName);
   if Result=nil then
@@ -1811,7 +1637,6 @@ begin
       raise EFileNotFoundError.Create('invalid file name "'+Filename+'"');
 end;
 
-
 procedure TPas2jsFilesCache.GetListing(const aDirectory: string;
   var Files: TStrings; FullPaths: boolean);
 begin
@@ -1899,20 +1724,20 @@ begin
   end;
 end;
 
-function TPas2jsFilesCache.ExpandDirectory(const Filename, BaseDir: string
-  ): string;
+function TPas2jsFilesCache.ExpandDirectory(const Filename: string): string;
 begin
   if Filename='' then exit('');
-  if BaseDir<>'' then
-    Result:=ExpandFileNamePJ(Filename,BaseDir)
-  else
-    Result:=ExpandFileNamePJ(Filename,BaseDirectory);
+  Result:=ExpandFileNamePJ(Filename,BaseDirectory);
   if Result='' then exit;
   Result:=IncludeTrailingPathDelimiter(Result);
 end;
 
-function TPas2jsFilesCache.ExpandExecutable(const Filename, BaseDir: string
-  ): string;
+function TPas2jsFilesCache.ExpandFileName(const Filename: string): string;
+begin
+  Result:=ExpandFileNamePJ(Filename,BaseDirectory);
+end;
+
+function TPas2jsFilesCache.ExpandExecutable(const Filename: string): string;
 
   function TryFile(CurFilename: string): boolean;
   begin
@@ -1933,10 +1758,7 @@ begin
     // no file path -> search
     {$IFDEF Windows}
     // search in BaseDir
-    if BaseDir<>'' then
-    begin
-      if TryFile(IncludeTrailingPathDelimiter(BaseDir)+Filename) then exit;
-    end else if BaseDirectory<>'' then
+    if BaseDirectory<>'' then
     begin
       if TryFile(IncludeTrailingPathDelimiter(BaseDirectory)+Filename) then exit;
     end;
@@ -1955,10 +1777,38 @@ begin
       if CurPath='' then continue;
       if TryFile(IncludeTrailingPathDelimiter(CurPath)+Filename) then exit;
     end;
-  end else if BaseDir<>'' then
-    Result:=ExpandFileNamePJ(Filename,BaseDir)
+  end else
+    Result:=ExpandFileName(Filename);
+end;
+
+function TPas2jsFilesCache.HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): String;
+
+Var
+  ErrorMsg : String;
+
+begin
+  Result:='';
+  case C of
+    'E': MainOutputPath:=aValue;
+    'i': if not AddIncludePaths(aValue,FromCmdLine,ErrorMsg) then
+           Result:='invalid include path (-Fi) "'+ErrorMsg+'"';
+    'u': if not AddUnitPaths(aValue,FromCmdLine,ErrorMsg) then
+           Result:='invalid unit path (-Fu) "'+ErrorMsg+'"';
+    'U': UnitOutputPath:=aValue;
   else
-    Result:=ExpandFileNamePJ(Filename,BaseDirectory);
+    Result:=inherited HandleOptionPaths(C, aValue, FromCmdLine);
+  end;
+end;
+
+function TPas2jsFilesCache.AddForeignUnitPath(const aValue: String; FromCmdLine: Boolean): String;
+begin
+  AddSrcUnitPaths(aValue,FromCmdLine,Result);
+end;
+
+function TPas2jsFilesCache.TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out
+  RelPath: String): Boolean;
+begin
+  Result:=Pas2jsFileUtils.TryCreateRelativePath(Filename, BaseDirectory, UsePointDirectory, RelPath);
 end;
 
 function TPas2jsFilesCache.FindIncludeFileName(const aFilename: string): String;
@@ -2039,11 +1889,15 @@ end;
 
 
 function TPas2jsFilesCache.FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String;
+var
+  SearchedDirs: TStringList;
 
   function SearchInDir(Dir: string; var Filename: string): boolean;
   // search in Dir for pp, pas, p times given case, lower case, upper case
   begin
     Dir:=IncludeTrailingPathDelimiter(Dir);
+    if IndexOfFile(SearchedDirs,Dir)>=0 then exit(false);
+    SearchedDirs.Add(Dir);
     Filename:=Dir+aUnitname+'.pp';
     if SearchLowUpCase(Filename) then exit(true);
     Filename:=Dir+aUnitname+'.pas';
@@ -2059,38 +1913,42 @@ var
 begin
   Result:='';
   IsForeign:=false;
-
-  if InFilename<>'' then
-  begin
-    aFilename:=SetDirSeparators(InFilename);
-    Result:=ResolveDots(aFilename);
-    if FilenameIsAbsolute(Result) then
-    begin
-      if SearchLowUpCase(Result) then exit;
-    end else
+  SearchedDirs:=TStringList.Create;
+  try
+    if InFilename<>'' then
     begin
-      Result:=ResolveDots(BaseDirectory+Result);
-      if SearchLowUpCase(Result) then exit;
+      aFilename:=SetDirSeparators(InFilename);
+      Result:=ResolveDots(aFilename);
+      if FilenameIsAbsolute(Result) then
+      begin
+        if SearchLowUpCase(Result) then exit;
+      end else
+      begin
+        Result:=ResolveDots(BaseDirectory+Result);
+        if SearchLowUpCase(Result) then exit;
+      end;
+      exit('');
     end;
-    exit('');
-  end;
 
-  // first search in foreign unit paths
-  IsForeign:=true;
-  for i:=0 to ForeignUnitPaths.Count-1 do
-    if SearchInDir(ForeignUnitPaths[i],Result) then
-    begin
-      IsForeign:=true;
-      exit;
-    end;
+    // first search in foreign unit paths
+    IsForeign:=true;
+    for i:=0 to ForeignUnitPaths.Count-1 do
+      if SearchInDir(ForeignUnitPaths[i],Result) then
+      begin
+        IsForeign:=true;
+        exit;
+      end;
 
-  // then in BaseDirectory
-  IsForeign:=false;
-  if SearchInDir(BaseDirectory,Result) then exit;
+    // then in BaseDirectory
+    IsForeign:=false;
+    if SearchInDir(BaseDirectory,Result) then exit;
 
-  // finally search in unit paths
-  for i:=0 to UnitPaths.Count-1 do
-    if SearchInDir(UnitPaths[i],Result) then exit;
+    // finally search in unit paths
+    for i:=0 to UnitPaths.Count-1 do
+      if SearchInDir(UnitPaths[i],Result) then exit;
+  finally
+    SearchedDirs.Free;
+  end;
 
   Result:='';
 end;
@@ -2112,12 +1970,15 @@ end;
 
 function TPas2jsFilesCache.FindCustomJSFileName(const aFilename: string): String;
 
+Var
+  FN : String;
+
   function SearchInDir(Dir: string): boolean;
   var
     CurFilename: String;
   begin
     Dir:=IncludeTrailingPathDelimiter(Dir);
-    CurFilename:=Dir+aFilename;
+    CurFilename:=Dir+FN;
     Result:=FileExistsLogged(CurFilename);
     if Result then
       FindCustomJSFileName:=CurFilename;
@@ -2127,18 +1988,18 @@ var
   i: Integer;
 begin
   Result:='';
-
-  if FilenameIsAbsolute(aFilename) then
+  FN:=ResolveDots(aFileName);
+  if FilenameIsAbsolute(FN) then
     begin
-    Result:=aFilename;
+    Result:=FN;
     if not FileExistsLogged(Result) then
       Result:='';
     exit;
     end;
 
-  if ExtractFilePath(aFilename)<>'' then
+  if ExtractFilePath(FN)<>'' then
     begin
-    Result:=ExpandFileNamePJ(aFilename,BaseDirectory);
+    Result:=ExpandFileNamePJ(FN,BaseDirectory);
     if not FileExistsLogged(Result) then
       Result:='';
     exit;
@@ -2169,6 +2030,11 @@ begin
       Log.LogMsgIgnoreFilter(nSearchingFileNotFound,[FormatPath(Filename)]);
 end;
 
+function TPas2jsFilesCache.GetOnReadDirectory: TReadDirectoryEvent;
+begin
+  Result:=DirectoryCache.OnReadDirectory;
+end;
+
 function TPas2jsFilesCache.FileExistsILogged(var Filename: string): integer;
 begin
   Result:=DirectoryCache.FileExistsI(Filename);

+ 28 - 20
packages/pastojs/src/pas2jsfiler.pp

@@ -295,7 +295,8 @@ const
     'List',
     'Inherited',
     'Self',
-    'Specialize');
+    'Specialize',
+    'Procedure');
 
   PCUExprOpCodeNames: array[TExprOpCode] of string = (
     'None',
@@ -842,6 +843,7 @@ type
     procedure Set_SetType_EnumType(RefEl: TPasElement; Data: TObject);
     procedure Set_Variant_Members(RefEl: TPasElement; Data: TObject);
     procedure Set_RecordType_VariantEl(RefEl: TPasElement; Data: TObject);
+    procedure Set_RecordScope_DefaultProperty(RefEl: TPasElement; Data: TObject);
     procedure Set_Argument_ArgType(RefEl: TPasElement; Data: TObject);
     procedure Set_ClassScope_NewInstanceFunction(RefEl: TPasElement; Data: TObject);
     procedure Set_ClassScope_DirectAncestor(RefEl: TPasElement; Data: TObject);
@@ -1699,11 +1701,11 @@ var
   El: TPasElement;
 begin
   El:=Scope.Element;
-  if El is TPasClassType then
+  if El is TPasMembersType then
     Result:=El
   else if El is TPasModule then
     Result:=El
-  else if (Scope is TPasProcedureScope) and (Scope.Element.Parent is TPasClassType) then
+  else if (Scope is TPasProcedureScope) and (Scope.Element.Parent is TPasMembersType) then
     Result:=Scope.Element.Parent
   else
     Result:=nil;
@@ -2130,7 +2132,7 @@ begin
   WriteModeSwitches(Obj,'FinalModeSwitches',Scanner.CurrentModeSwitches,InitialFlags.Modeswitches);
   WriteBoolSwitches(Obj,'FinalBoolSwitches',Scanner.CurrentBoolSwitches,InitialFlags.BoolSwitches);
   if InitialFlags.ConverterOptions<>Converter.Options then
-    RaiseMsg(20180314185555);
+    RaiseMsg(20180314185555,'InitialFlags='+dbgs(InitialFlags.ConverterOptions)+' Converter='+dbgs(Converter.Options));
   // ToDo: write final flags: used defines, used macros
 end;
 
@@ -3324,6 +3326,7 @@ end;
 procedure TPCUWriter.WriteRecordTypeScope(Obj: TJSONObject;
   Scope: TPasRecordScope; aContext: TPCUWriterContext);
 begin
+  AddReferenceToObj(Obj,'DefaultProperty',Scope.DefaultProperty);
   WriteIdentifierScope(Obj,Scope,aContext);
 end;
 
@@ -3829,10 +3832,9 @@ begin
   C:=Parent.ClassType;
   if C.InheritsFrom(TPasDeclarations) then
     WriteMemberIndex(TPasDeclarations(Parent).Declarations,Ref.Element,Ref.Obj)
-  else if C=TPasClassType then
-    WriteMemberIndex(TPasClassType(Parent).Members,Ref.Element,Ref.Obj)
-  else if C=TPasRecordType then
-    WriteMemberIndex(TPasRecordType(Parent).Members,Ref.Element,Ref.Obj)
+  else if (C=TPasClassType)
+      or (C=TPasRecordType) then
+    WriteMemberIndex(TPasMembersType(Parent).Members,Ref.Element,Ref.Obj)
   else if C=TPasEnumType then
     WriteMemberIndex(TPasEnumType(Parent).Values,Ref.Element,Ref.Obj)
   else if C.InheritsFrom(TPasModule) then
@@ -4212,6 +4214,17 @@ begin
     RaiseMsg(20180210205031,El,GetObjName(RefEl));
 end;
 
+procedure TPCUReader.Set_RecordScope_DefaultProperty(RefEl: TPasElement;
+  Data: TObject);
+var
+  Scope: TPasRecordScope absolute Data;
+begin
+  if RefEl is TPasProperty then
+    Scope.DefaultProperty:=TPasProperty(RefEl) // no AddRef
+  else
+    RaiseMsg(20190106213412,Scope.Element,GetObjName(RefEl));
+end;
+
 procedure TPCUReader.Set_Argument_ArgType(RefEl: TPasElement; Data: TObject);
 var
   El: TPasArgument absolute Data;
@@ -5230,10 +5243,8 @@ begin
     begin
     if El is TPasDeclarations then
       ReadExternalMembers(El,Arr,TPasDeclarations(El).Declarations)
-    else if El is TPasClassType then
-      ReadExternalMembers(El,Arr,TPasClassType(El).Members)
-    else if El is TPasRecordType then
-      ReadExternalMembers(El,Arr,TPasRecordType(El).Members)
+    else if El is TPasMembersType then
+      ReadExternalMembers(El,Arr,TPasMembersType(El).Members)
     else if El is TPasEnumType then
       ReadExternalMembers(El,Arr,TPasEnumType(El).Values)
     else if El is TPasModule then
@@ -5459,9 +5470,7 @@ begin
       Section.ResStrings.Add(El)
     else if C=TPasConst then
       Section.Consts.Add(El)
-    else if C=TPasClassType then
-      Section.Classes.Add(El)
-    else if C=TPasRecordType then
+    else if (C=TPasClassType) or (C=TPasRecordType) then
       Section.Classes.Add(El)
     else if C.InheritsFrom(TPasType) then
       // not TPasClassType, TPasRecordType !
@@ -6615,6 +6624,7 @@ end;
 procedure TPCUReader.ReadRecordScope(Obj: TJSONObject; Scope: TPasRecordScope;
   aContext: TPCUReaderContext);
 begin
+  ReadElementReference(Obj,Scope,'DefaultProperty',@Set_RecordScope_DefaultProperty);
   ReadIdentifierScope(Obj,Scope,aContext);
 end;
 
@@ -7313,8 +7323,8 @@ begin
   // Scope.OverloadName is already set in ReadProcedure
   ReadElementReference(Obj,Scope,'ImplProc',@Set_ProcedureScope_ImplProc);
   ReadElementReference(Obj,Scope,'Overridden',@Set_ProcedureScope_Overridden);
-  if Proc.Parent is TPasClassType then
-    Scope.ClassScope:=Proc.Parent.CustomData as TPas2JSClassScope; // no AddRef
+  if Proc.Parent is TPasMembersType then
+    Scope.ClassOrRecordScope:=Proc.Parent.CustomData as TPasClassOrRecordScope; // no AddRef
   // ClassScope: TPasClassScope; auto derived
   // Scope.SelfArg only valid for method implementation
 
@@ -7853,9 +7863,7 @@ end;
 
 initialization
   PrecompileFormats:=TPas2JSPrecompileFormats.Create;
-  {$IFDEF EnablePas2jsPrecompiled}
-  PrecompileFormats.Add('pcu','all used units must be pcu too',TPCUReader,TPCUWriter);
-  {$ENDIF}
+  PrecompileFormats.Add('pcu','all used pcu must match exactly',TPCUReader,TPCUWriter);
 finalization
   PrecompileFormats.Free;
   PrecompileFormats:=nil;

+ 0 - 88
packages/pastojs/src/pas2jsfileutils.pp

@@ -66,8 +66,6 @@ function GetEnvironmentVariablePJ(const EnvVar: string): String;
 
 function GetNextDelimitedItem(const List: string; Delimiter: char;
                               var Position: integer): string;
-procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
-                             ReadBackslash: boolean = false);
 
 type TChangeStamp = SizeInt;
 const InvalidChangeStamp = low(TChangeStamp);
@@ -732,92 +730,6 @@ begin
   if Position<=length(List) then inc(Position); // skip Delimiter
 end;
 
-procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
-                             ReadBackslash: boolean = false);
-// split spaces, quotes are parsed as single parameter
-// if ReadBackslash=true then \" is replaced to " and not treated as quote
-// #0 is always end
-type
-  TMode = (mNormal,mApostrophe,mQuote);
-var
-  p: Integer;
-  Mode: TMode;
-  Param: String;
-begin
-  p:=1;
-  while p<=length(Params) do
-  begin
-    // skip whitespace
-    while (p<=length(Params)) and (Params[p] in [' ',#9,#10,#13]) do inc(p);
-    if (p>length(Params)) or (Params[p]=#0) then
-      break;
-    // read param
-    Param:='';
-    Mode:=mNormal;
-    while p<=length(Params) do
-    begin
-      case Params[p] of
-      #0:
-        break;
-      '\':
-        begin
-          inc(p);
-          if ReadBackslash then
-            begin
-            // treat next character as normal character
-            if (p>length(Params)) or (Params[p]=#0) then
-              break;
-            if ord(Params[p])<128 then
-            begin
-              Param+=Params[p];
-              inc(p);
-            end else begin
-              // next character is already a normal character
-            end;
-          end else begin
-            // treat backslash as normal character
-            Param+='\';
-          end;
-        end;
-      '''':
-        begin
-          inc(p);
-          case Mode of
-          mNormal:
-            Mode:=mApostrophe;
-          mApostrophe:
-            Mode:=mNormal;
-          mQuote:
-            Param+='''';
-          end;
-        end;
-      '"':
-        begin
-          inc(p);
-          case Mode of
-          mNormal:
-            Mode:=mQuote;
-          mApostrophe:
-            Param+='"';
-          mQuote:
-            Mode:=mNormal;
-          end;
-        end;
-      ' ',#9,#10,#13:
-        begin
-          if Mode=mNormal then break;
-          Param+=Params[p];
-          inc(p);
-        end;
-      else
-        Param+=Params[p];
-        inc(p);
-      end;
-    end;
-    //writeln('SplitCmdLineParams Param=#'+Param+'#');
-    ParamList.Add(Param);
-  end;
-end;
 
 procedure IncreaseChangeStamp(var Stamp: TChangeStamp);
 begin

+ 453 - 0
packages/pastojs/src/pas2jsfs.pp

@@ -0,0 +1,453 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2018  Michael Van Canneyt
+
+    Pascal to Javascript converter class.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Abstract:
+    FileSystem abstraction layer for compiler.
+    Has only abstract classes with no actual implementation, so it does not actually
+    interacts with the filesystem.
+    See Pas2JSFileCache for an actual implementation.
+}
+unit Pas2JSFS;
+
+{$mode objfpc}{$H+}
+{$I pas2js_defines.inc}
+
+interface
+
+uses
+  // No filesystem-dependent units here !
+  Classes, SysUtils, PScanner, fpjson;
+
+const // Messages
+  nIncludeSearch = 201; sIncludeSearch = 'Include file search: %s';
+  nUnitSearch = 202; sUnitSearch = 'Unitsearch: %s';
+  nSearchingFileFound = 203; sSearchingFileFound = 'Searching file: %s... found';
+  nSearchingFileNotFound = 204; sSearchingFileNotFound = 'Searching file: %s... not found';
+  nDuplicateFileFound = 205; sDuplicateFileFound = 'Duplicate file found: "%s" and "%s"';
+  nCustomJSFileNotFound = 206; sCustomJSFileNotFound = 'custom JS file not found: "%s"';
+  nUsingPath = 104; sUsingPath = 'Using %s: "%s"';
+  nFolderNotFound = 105; sFolderNotFound = '%s not found: %s';
+
+Type
+  // Forward definitions
+  EPas2jsFS = Class(Exception);
+  TPas2jsFile = class;
+  TSourceLineReader = class;
+  TPas2jsFSResolver = class;
+  TPas2JSFS = Class;
+
+  { TSourceLineReader }
+
+  TSourceLineReader = class(TLineReader)
+  private
+    FIsEOF: boolean;
+    FLineNumber: integer;
+    FSource: string;
+    FSrcPos: integer;
+  Protected
+    Procedure IncLineNumber; virtual;
+    property Source: string read FSource;
+    property SrcPos: integer read FSrcPos;
+  public
+    Constructor Create(Const aFileName, aSource: String); overload;
+    function IsEOF: Boolean; override;
+    function ReadLine: string; override;
+    property LineNumber: integer read FLineNumber;
+  end;
+
+  TP2jsFSOption = (
+    caoShowFullFilenames,
+    caoShowTriedUsedFiles,
+    caoSearchLikeFPC,
+    caoStrictFileCase
+    );
+  TP2jsFSOptions = set of TP2jsFSOption;
+  TKeyCompareType = (kcFilename,kcUnitName);
+
+  { TPas2JSFS }
+
+  TPas2JSFS = Class
+  Private
+    FOptions: TP2jsFSOptions;
+    FReadLineCounter: SizeInt;
+    FDefaultOutputPath: string;
+    FUnitOutputPath: string;
+    procedure SetOptionFromIndex(AIndex: Integer; AValue: boolean);
+    procedure SetDefaultOutputPath(AValue: string);
+    procedure SetUnitOutputPath(AValue: string);
+  Protected
+    // Not to be overridden
+    procedure SetOption(Flag: TP2jsFSOption; Enable: boolean);
+    Function OptionIsSet(Index: Integer):  Boolean;
+  Protected
+    // Protected Abstract. Must be overridden
+    function FindSourceFileName(const aFilename: string): String; virtual; abstract;
+  Public
+    // Public Abstract. Must be overridden
+    function FindIncludeFileName(const aFilename: string): String; virtual; abstract;
+    function LoadFile(Filename: string; Binary: boolean = false): TPas2jsFile; virtual; abstract;
+    Function FileExists(Const aFileName: String): Boolean; virtual; abstract;
+    function FindUnitJSFileName(const aUnitFilename: string): String; virtual; abstract;
+    function FindCustomJSFileName(const aFilename: string): String; virtual; abstract;
+    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; virtual; abstract;
+    procedure SaveToFile(ms: TFPJSStream; Filename: string); virtual; abstract;
+    function PCUExists(var aFileName: string): Boolean; virtual;
+    procedure GetPCUDirs(aList: TStrings; const aBaseDir: String); virtual;
+  Public
+    // Public, may be overridden
+    Function SameFileName(Const File1,File2: String): Boolean; virtual;
+    Function File1IsNewer(Const File1,File2: String): Boolean; virtual;
+    function ExpandDirectory(const Filename: string): string; virtual;
+    function ExpandFileName(const Filename: string): string; virtual;
+    function ExpandExecutable(const Filename: string): string; virtual;
+    Function FormatPath(Const aFileName: string): String; virtual;
+    Function DirectoryExists(Const aDirectory: string): boolean; virtual;
+    function TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out RelPath: String): Boolean; virtual;
+    procedure DeleteDuplicateFiles(List: TStrings); virtual;
+    function IndexOfFile(FileList: TStrings; aFilename: string; Start: integer = 0): integer; virtual;// -1 if not found
+    Procedure WriteFoldersAndSearchPaths; virtual;
+    function CreateResolver: TPas2jsFSResolver; virtual;
+    // On success, return '', On error, return error message.
+    Function AddForeignUnitPath(Const aValue: String; FromCmdLine: Boolean): String; virtual;
+    Function HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): String; virtual;
+  Public
+    Constructor Create; virtual;
+    Procedure Reset; virtual;
+    Procedure IncReadLineCounter;
+    property ReadLineCounter: SizeInt read FReadLineCounter write FReadLineCounter;
+    property Options: TP2jsFSOptions read FOptions write FOptions;
+    property ShowFullPaths: boolean Index 0 Read OptionIsSet Write SetOptionFromIndex;
+    property ShowTriedUsedFiles: boolean Index 1 read OptionIsSet Write SetOptionFromIndex;
+    property SearchLikeFPC: boolean index 2 read OptionIsSet Write SetOptionFromIndex;
+    Property StrictFileCase: Boolean Index 3 Read OptionIsSet Write SetOptionFromIndex;
+    property MainOutputPath: string read FDefaultOutputPath write SetDefaultOutputPath; // includes trailing pathdelim
+    property UnitOutputPath: string read FUnitOutputPath write SetUnitOutputPath; // includes trailing pathdelim
+  end;
+
+  { TPas2jsFile }
+
+  TPas2jsFile = class
+  private
+    FFilename: string;
+    FFS: TPas2JSFS;
+    FSource: string;
+  Protected
+    Procedure SetSource(aSource: String);
+  public
+    constructor Create(aFS: TPas2jsFS; const aFilename: string);
+    function CreateLineReader(RaiseOnError: boolean): TSourceLineReader; virtual; abstract;
+    function Load(RaiseOnError: boolean; Binary: boolean): boolean; virtual; abstract;
+    property Source: string read FSource; // UTF-8 without BOM or Binary
+    Property FS: TPas2JSFS Read FFS;
+    property Filename: string read FFilename;
+  end;
+
+  { TPas2jsFSResolver }
+
+  TPas2jsFSResolver = class({$IFDEF HASFILESYSTEM}TFileResolver{$ELSE}TBaseFileResolver{$ENDIF})
+  private
+    FFS: TPas2jsFS;
+  public
+    constructor Create(aFS: TPas2jsFS); reintroduce;
+    // Redirect all calls to FS.
+    function FindIncludeFileName(const aFilename: string): String; override;
+    function FindIncludeFile(const aFilename: string): TLineReader; override;
+    function FindSourceFile(const aFilename: string): TLineReader; override;
+    property FS: TPas2jsFS read FFS;
+  end;
+
+
+Const
+  p2jsfcoCaption: array[TP2jsFSOption] of string = (
+      // only used by experts, no need for resourcestrings
+      'Show full filenames',
+      'Show tried/used files',
+      'Search files like FPC',
+      'Strict file case'
+      );
+    // 'Combine all JavaScript into main file',
+    EncodingBinary = 'Binary';
+
+  DefaultPas2jsFSOptions = [];
+
+implementation
+
+// No filesystem-dependent units here !
+
+{ TPas2JSFS }
+
+procedure TPas2JSFS.SetOptionFromIndex(AIndex: Integer; AValue: boolean);
+begin
+  SetOption(TP2jsFSOption(aIndex),aValue);
+end;
+
+procedure TPas2JSFS.SetOption(Flag: TP2jsFSOption; Enable: boolean);
+begin
+  if Enable then
+    Include(FOptions,Flag)
+  else
+    Exclude(FOptions,Flag);
+end;
+
+function TPas2JSFS.OptionIsSet(Index: Integer): Boolean;
+begin
+  Result:=TP2jsFSOption(Index) in FOptions;
+end;
+
+function TPas2JSFS.PCUExists(var aFileName: string): Boolean;
+begin
+  Result:=Self.FileExists(aFileName);
+end;
+
+procedure TPas2JSFS.GetPCUDirs(aList: TStrings; const aBaseDir: String);
+begin
+  if UnitOutputPath<>'' then
+    aList.Add(UnitOutputPath);
+  aList.Add(aBaseDir);
+end;
+
+function TPas2JSFS.SameFileName(const File1, File2: String): Boolean;
+begin
+  Result:=CompareText(File1,File2)=0;
+end;
+
+function TPas2JSFS.File1IsNewer(const File1, File2: String): Boolean;
+begin
+  Result:=False;
+  if File1=File2 then ;
+end;
+
+function TPas2JSFS.ExpandDirectory(const Filename: string): string;
+begin
+  Result:=FileName;
+end;
+
+function TPas2JSFS.ExpandFileName(const Filename: string): string;
+begin
+  Result:=FileName;
+end;
+
+function TPas2JSFS.ExpandExecutable(const Filename: string): string;
+begin
+  Result:=FileName
+end;
+
+function TPas2JSFS.FormatPath(const aFileName: string): String;
+begin
+  Result:=aFileName;
+end;
+
+function TPas2JSFS.DirectoryExists(const aDirectory: string): boolean;
+begin
+  Result:=aDirectory='';
+end;
+
+function TPas2JSFS.TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out RelPath: String
+  ): Boolean;
+begin
+  Result:=True;
+  RelPath:=FileName;
+  if (BaseDirectory='') or UsePointDirectory then ;
+end;
+
+procedure TPas2JSFS.DeleteDuplicateFiles(List: TStrings);
+var
+  i, j: Integer;
+begin
+  for i:=0 to List.Count-2 do
+    for j:=List.Count-1 downto i+1 do
+      if SameFileName(List[i],List[j]) then
+        List.Delete(j);
+end;
+
+function TPas2JSFS.IndexOfFile(FileList: TStrings; aFilename: string;
+  Start: integer): integer;
+var
+  i: Integer;
+begin
+  if FileList<>nil then
+    for i:=Start to FileList.Count-1 do
+      if SameFileName(FileList[i],aFilename) then exit(i);
+  Result:=-1;
+end;
+
+procedure TPas2JSFS.WriteFoldersAndSearchPaths;
+begin
+  // Do nothing
+end;
+
+function TPas2JSFS.CreateResolver: TPas2jsFSResolver;
+begin
+  Result:=TPas2jsFSResolver.Create(Self);
+end;
+
+function TPas2JSFS.AddForeignUnitPath(const aValue: String; FromCmdLine: Boolean): String;
+begin
+  Result:='';
+  if (aValue='') or FromCmdLine then ;
+end;
+
+function TPas2JSFS.HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): String;
+begin
+  Result:='Invalid parameter: -F'+C+aValue;
+  if FromCmdLine then ;
+end;
+
+constructor TPas2JSFS.Create;
+begin
+  FOptions:=DefaultPas2jsFSOptions;
+end;
+
+procedure TPas2JSFS.Reset;
+begin
+  FReadLineCounter:=0;
+  FUnitOutputPath:='';
+  FDefaultOutputPath:='';
+end;
+
+procedure TPas2JSFS.IncReadLineCounter;
+begin
+  Inc(FReadLineCounter);
+end;
+
+procedure TPas2JSFS.SetDefaultOutputPath(AValue: string);
+begin
+  AValue:=ExpandDirectory(AValue);
+  if FDefaultOutputPath=AValue then Exit;
+  FDefaultOutputPath:=AValue;
+end;
+
+procedure TPas2JSFS.SetUnitOutputPath(AValue: string);
+
+begin
+  AValue:=ExpandDirectory(AValue);
+  if FUnitOutputPath=AValue then Exit;
+  FUnitOutputPath:=AValue;
+end;
+
+
+{ TPas2jsFile }
+
+procedure TPas2jsFile.SetSource(aSource: String);
+begin
+  FSource:=ASource;
+end;
+
+constructor TPas2jsFile.Create(aFS: TPas2jsFS; const aFilename: string);
+begin
+  FFS:=aFS;
+  FFileName:=aFileName;
+end;
+
+procedure TSourceLineReader.IncLineNumber;
+begin
+  inc(FLineNumber);
+end;
+
+Constructor TSourceLineReader.Create(Const aFileName, aSource: String);
+begin
+  Inherited Create(aFileName);
+  FSource:=aSource;
+  FSrcPos:=1;
+  FIsEOF:=FSource='';
+end;
+
+function TSourceLineReader.IsEOF: Boolean;
+begin
+  Result:=FIsEOF;
+end;
+
+function TSourceLineReader.ReadLine: string;
+var
+  S: string;
+  p, SrcLen: integer;
+
+  procedure GetLine;
+  var
+    l: SizeInt;
+  begin
+    l:=p-FSrcPos;
+    Result:=copy(S,FSrcPos,l);
+    FSrcPos:=p;
+    IncLineNumber;
+    //writeln('GetLine "',Result,'"');
+  end;
+
+begin
+  if FIsEOF then exit('');
+  S:=Source;
+  SrcLen:=length(S);
+  p:=FSrcPos;
+  while p<=SrcLen do
+    case S[p] of
+    #10,#13:
+      begin
+        GetLine;
+        inc(p);
+        if (p<=SrcLen) and (S[p] in [#10,#13]) and (S[p]<>S[p-1]) then
+          inc(p);
+        if p>SrcLen then
+          FIsEOF:=true;
+        FSrcPos:=p;
+        exit;
+      end;
+    else
+      inc(p);
+    end;
+  FIsEOF:=true;
+  GetLine;
+end;
+
+
+function TPas2jsFSResolver.FindIncludeFile(const aFilename: string): TLineReader;
+var
+  Filename: String;
+begin
+  Result:=nil;
+  Filename:=FS.FindIncludeFileName(aFilename);
+  if Filename='' then exit;
+  try
+    Result:=FindSourceFile(Filename);
+  except
+    // error is shown in the scanner, which has the context information
+  end;
+end;
+
+constructor TPas2jsFSResolver.Create(aFS: TPas2jsFS);
+begin
+  FFS:=aFS;
+end;
+
+function TPas2jsFSResolver.FindIncludeFileName(const aFilename: string): String;
+
+begin
+  Result:=FS.FindIncludeFileName(aFilename);
+end;
+
+
+function TPas2jsFSResolver.FindSourceFile(const aFilename: string): TLineReader;
+
+var
+  CurFilename: String;
+
+begin
+  CurFilename:=FS.FindSourceFileName(aFileName);
+  Result:=FS.LoadFile(CurFilename).CreateLineReader(false);
+end;
+
+
+
+end.
+

+ 166 - 0
packages/pastojs/src/pas2jsfscompiler.pp

@@ -0,0 +1,166 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2018  Michael Van Canneyt
+
+    Pascal to Javascript converter class.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Abstract:
+    FileSystem aware compiler descendent. No support for PCU.
+}
+unit Pas2JSFSCompiler;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils,
+  PasUseAnalyzer,
+  Pas2jsFileCache, Pas2jsCompiler,
+  Pas2JSFS,
+  Pas2jsFileUtils;
+
+Type
+  TPas2jsFSCompiler = Class(TPas2JSCompiler)
+  private
+    function GetFileCache: TPas2jsFilesCache;
+    function OnMacroEnv(Sender: TObject; var Params: string; Lvl: integer): boolean;
+  Public
+    Procedure SetWorkingDir(const aDir: String); override;
+    function CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet; override;
+    Function CreateFS : TPas2JSFS; override;
+    Procedure InitParamMacros; override;
+    Property FileCache : TPas2jsFilesCache Read GetFileCache;
+  end;
+
+implementation
+
+{$IFDEF PAS2JS}
+function Pas2jsCompilerFile_FilenameToKeyName(Item: Pointer): String;
+var
+  aFile: TPas2jsCompilerFile absolute Item;
+begin
+  Result:=FilenameToKey(aFile.PasFilename);
+end;
+
+function PtrUnitnameToKeyName(Item: Pointer): String;
+var
+  aUnitName: string absolute Item;
+begin
+  Result:=LowerCase(aUnitName);
+end;
+
+function Pas2jsCompilerFile_UnitnameToKeyName(Item: Pointer): String;
+var
+  aFile: TPas2jsCompilerFile absolute Item;
+begin
+  Result:=LowerCase(aFile.PasUnitName);
+end;
+{$ELSE}
+function CompareCompilerFiles_UnitFilename(Item1, Item2: Pointer): integer;
+var
+  File1: TPas2JSCompilerFile absolute Item1;
+  File2: TPas2JSCompilerFile absolute Item2;
+begin
+  Result:=CompareFilenames(File1.UnitFilename,File2.UnitFilename);
+end;
+
+function CompareFileAndCompilerFile_UnitFilename(Filename, Item: Pointer): integer;
+var
+  aFile: TPas2JSCompilerFile absolute Item;
+  aFilename: String;
+begin
+  aFilename:=AnsiString(Filename);
+  Result:=CompareFilenames(aFilename,aFile.UnitFilename);
+end;
+
+function CompareCompilerFilesPasUnitname(Item1, Item2: Pointer): integer;
+var
+  File1: TPas2JSCompilerFile absolute Item1;
+  File2: TPas2JSCompilerFile absolute Item2;
+begin
+  Result:=CompareText(File1.PasUnitName,File2.PasUnitName);
+end;
+
+function CompareUnitnameAndCompilerFile_PasUnitName(TheUnitname, Item: Pointer): integer;
+var
+  aFile: TPas2JSCompilerFile absolute Item;
+  anUnitname: String;
+begin
+  anUnitname:=AnsiString(TheUnitname);
+  Result:=CompareText(anUnitname,aFile.PasUnitName);
+end;
+{$ENDIF}
+
+function TPas2jsFSCompiler.CreateFS: TPas2JSFS;
+
+Var
+  C :  TPas2jsFilesCache;
+
+begin
+  C:=TPas2jsFilesCache.Create(Log);
+  C.BaseDirectory:=GetCurrentDirPJ;
+  Result:=C;
+end;
+
+function TPas2jsFSCompiler.GetFileCache: TPas2jsFilesCache;
+begin
+  Result:=FS as TPas2jsFilesCache;
+end;
+
+function TPas2jsFSCompiler.OnMacroEnv(Sender: TObject; var Params: string;
+  Lvl: integer): boolean;
+begin
+  if Lvl=0 then ;
+  if Sender=nil then ;
+  Params:=GetEnvironmentVariablePJ(Params);
+  Result:=true;
+end;
+
+procedure TPas2jsFSCompiler.SetWorkingDir(const aDir: String);
+begin
+  inherited SetWorkingDir(aDir);
+  FileCache.BaseDirectory:=aDir;
+end;
+
+function TPas2jsFSCompiler.CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet;
+begin
+  Case keyType of
+    kcFileName:
+      Result:=TPasAnalyzerKeySet.Create(
+          {$IFDEF Pas2js}
+          @Pas2jsCompilerFile_FilenameToKeyName,@PtrFilenameToKeyName
+          {$ELSE}
+          @CompareCompilerFiles_UnitFilename,@CompareFileAndCompilerFile_UnitFilename
+          {$ENDIF});
+    kcUnitName:
+      Result:=TPasAnalyzerKeySet.Create(
+        {$IFDEF Pas2js}
+        @Pas2jsCompilerFile_UnitnameToKeyName,@PtrUnitnameToKeyName
+        {$ELSE}
+        @CompareCompilerFilesPasUnitname,@CompareUnitnameAndCompilerFile_PasUnitName
+        {$ENDIF});
+  else
+    Raise EPas2jsFileCache.CreateFmt('Internal Unknown key type: %d',[Ord(KeyType)]);
+  end;
+end;
+
+procedure TPas2jsFSCompiler.InitParamMacros;
+begin
+  inherited InitParamMacros;
+  ParamMacros.AddFunction('Env','environment variable, e.g. $Env(HOME)',@OnMacroEnv,true);
+end;
+
+
+
+end.
+

+ 8 - 4
packages/pastojs/src/pas2jslibcompiler.pp

@@ -2,7 +2,7 @@
     This file is part of the Free Component Library (FCL)
     Copyright (c) 2018  Michael Van Canneyt
 
-    Pascal to Javascript converter class.
+    Pascal to Javascript converter class. Library version
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -21,7 +21,9 @@ unit pas2jslibcompiler;
 interface
 
 uses
-  SysUtils, Classes, FPPJsSrcMap, Pas2jsFileCache, Pas2jsCompiler;
+  SysUtils, Classes,
+  FPPJsSrcMap, Pas2jsFileCache, Pas2JSCompiler, Pas2jsPCUCompiler,
+  Pas2JSCompilerCfg, Pas2JSCompilerPP;
 
 { ---------------------------------------------------------------------
   Compiler descendant, usable in library
@@ -44,7 +46,7 @@ Type
 
   { TLibraryPas2JSCompiler }
 
-  TLibraryPas2JSCompiler = Class(TPas2JSCompiler)
+  TLibraryPas2JSCompiler = Class(TPas2JSPCUCompiler)
   private
     FLastError: String;
     FLastErrorClass: String;
@@ -181,7 +183,9 @@ begin
   Log.OnLog:=@DoLibraryLog;
   FileCache.OnReadFile:=@ReadFile;
   FReadBufferLen:=DefaultReadBufferSize;
-  FileCache.DirectoryCache.OnReadDirectory:=@ReadDirectory;
+  FileCache.OnReadDirectory:=@ReadDirectory;
+  ConfigSupport:=TPas2JSFileConfigSupport.Create(Self);
+  PostProcessorSupport:=TPas2JSFSPostProcessorSupport.Create(Self);
 end;
 
 procedure TLibraryPas2JSCompiler.DoLibraryLog(Sender: TObject; const Msg: String);

+ 64 - 8
packages/pastojs/src/pas2jslogger.pp

@@ -28,10 +28,16 @@ interface
 
 uses
   {$IFDEF Pas2JS}
-  JS, NodeJSFS,
+  JS,
+  {$IFDEF NodeJS}
+  NodeJSFS,
+  {$ENDIF}
   {$ENDIF}
-  Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, fpjson,
-  Pas2jsFileUtils;
+  pas2jsutils,
+  {$IFDEF HASFILESYSTEM}
+  pas2jsfileutils,
+  {$ENDIF}
+  Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, fpjson;
 
 const
   ExitCodeErrorInternal = 1; // internal error
@@ -95,6 +101,16 @@ type
 
   TPas2jsLogEvent = Procedure (Sender : TObject; Const Msg : String) Of Object;
 
+
+  { TConsoleFileWriter }
+
+  TConsoleFileWriter = Class(TTextWriter)
+  Public
+    Constructor Create(aFileName : String); reintroduce;
+    Function DoWrite(Const S : TJSWriterString) : Integer; override;
+    Procedure Flush;
+  end;
+
   { TPas2jsLogger }
 
   TPas2jsLogger = class
@@ -111,7 +127,7 @@ type
     FMsg: TFPList; // list of TPas2jsMessage
     FOnFormatPath: TPScannerFormatPathEvent;
     FOnLog: TPas2jsLogEvent;
-    FOutputFile: TFileWriter;
+    FOutputFile: TTextWriter; // TFileWriter;
     FOutputFilename: string;
     FShowMsgNumbers: boolean;
     FShowMsgTypes: TMessageTypes;
@@ -129,6 +145,9 @@ type
     procedure SetSorted(AValue: boolean);
     procedure DoLogRaw(const Msg: string; SkipEncoding : Boolean);
     function Concatenate(Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
+  Protected
+    // so it can be overridden
+    function CreateTextWriter(const aFileName: string): TTextWriter; virtual;
   public
     constructor Create;
     destructor Destroy; override;
@@ -484,6 +503,29 @@ begin
   end;
 end;
 
+{ TConsoleFileWriter }
+
+constructor TConsoleFileWriter.Create(aFileName: String);
+begin
+  Inherited Create;
+  Write('Opening console log: '+aFileName);
+end;
+
+Function TConsoleFileWriter.DoWrite(Const S : TJSWriterString) : Integer;
+
+begin
+  Result:=Length(S);
+  {AllowWriteln}
+  Writeln(S);
+  {AllowWriteln-}
+end;
+
+procedure TConsoleFileWriter.FLush;
+
+begin
+end;
+
+
 {$IFDEF Pas2JS}
 { TPas2jsFileStream }
 
@@ -1017,14 +1059,26 @@ begin
   end;
 end;
 
+Function TPas2jsLogger.CreateTextWriter(const aFileName : string) : TTextWriter;
+
+begin
+{$IFDEF HASFILESYSTEM}
+  Result:=TFileWriter.Create(aFilename);
+{$ELSE}
+  Result:=TConsoleFileWriter.Create(aFileName);
+{$ENDIF}
+end;
+
 procedure TPas2jsLogger.OpenOutputFile;
 begin
+{$IFDEF HASFILESYSTEM}
   if FOutputFile<>nil then exit;
   if OutputFilename='' then
     raise Exception.Create('Log has empty OutputFilename');
   if DirectoryExists(OutputFilename) then
     raise Exception.Create('Log is directory: "'+OutputFilename+'"');
-  FOutputFile:=TFileWriter.Create(OutputFilename);
+{$ENDIF}
+  FOutputFile:=CreateTextWriter(OutputFileName);
   {$IFDEF FPC_HAS_CPSTRING}
   if (Encoding='') or (Encoding='utf8') then
     FOutputFile.Write(UTF8BOM);
@@ -1033,14 +1087,16 @@ end;
 
 procedure TPas2jsLogger.Flush;
 begin
-  if FOutputFile<>nil then
-    FOutputFile.Flush;
+{$IFDEF HASFILESYSTEM}
+  if Assigned(FOutputFile) and (FoutputFile is TFileWriter) then
+    TFileWriter(FOutputFile).Flush;
+{$ENDIF}
 end;
 
 procedure TPas2jsLogger.CloseOutputFile;
 begin
   if FOutputFile=nil then exit;
-  FOutputFile.Flush;
+  Flush;
   FreeAndNil(FOutputFile);
 end;
 

+ 103 - 79
packages/pastojs/src/pas2jspcucompiler.pp

@@ -1,4 +1,22 @@
-unit pas2jspcucompiler;
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2018  Michael Van Canneyt
+
+    Pascal to Javascript converter class.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Abstract:
+    FileSystem aware compiler descendent with support for PCU files.
+}
+unit Pas2JSPCUCompiler;
 
 {$mode objfpc}{$H+}
 
@@ -11,17 +29,20 @@ unit pas2jspcucompiler;
 interface
 
 uses
-  Classes, SysUtils, pastree, pas2jscompiler, Pas2JsFiler;
+  SysUtils, Classes,
+  jstree,
+  PasTree, PScanner, PasResolveEval,
+  FPPas2Js,
+  Pas2jsCompiler, Pas2JSFS, Pas2JSFSCompiler, Pas2JsFiler,
+  Pas2jsLogger, Pas2jsFileUtils;
 
 Type
+
   { TFilerPCUSupport }
 
   TFilerPCUSupport = Class(TPCUSupport)
   Private
-    // This is the format that will be written.
-    FPCUFormat : TPas2JSPrecompileFormat;
-    // This is the format that will be read.
-    FFoundFormat : TPas2JSPrecompileFormat;
+    FPCUFormat: TPas2JSPrecompileFormat;
     FPrecompileInitialFlags: TPCUInitialFlags;
     FPCUReader: TPCUCustomReader;
     FPCUReaderStream: TStream;
@@ -30,41 +51,42 @@ Type
     function OnWriterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
     procedure OnFilerGetSrc(Sender: TObject; aFilename: string; out p: PChar; out Count: integer);
   Public
-    constructor create(aCompilerFile: TPas2JSCompilerFile; aFormat: TPas2JSPrecompileFormat);
-    Destructor destroy; override;
-    Function Compiler : TPas2JSCompiler;
-    Function HandleException(E: exception) : Boolean; override;
-    function FindPCU(const UseUnitName: string): string;override;
+    constructor Create(aCompilerFile: TPas2JSCompilerFile; aFormat: TPas2JSPrecompileFormat); reintroduce;
+    destructor Destroy; override;
+    function Compiler: TPas2JSCompiler;
+    function HandleException(E: Exception): Boolean; override;
+    function FindPCU(const UseUnitName: string): string; override;
     function FindPCU(const UseUnitName: string; out aFormat: TPas2JSPrecompileFormat): string;
-    Function HasReader : Boolean; override;
-    Function ReadContinue: Boolean; override;
-    Function ReadCanContinue : Boolean; override;
-    Procedure SetInitialCompileFlags; override;
-    Procedure WritePCU; override;
+    function HasReader: Boolean; override;
+    function ReadContinue: Boolean; override;
+    function ReadCanContinue: Boolean; override;
+    procedure SetInitialCompileFlags; override;
+    procedure WritePCU; override;
     procedure CreatePCUReader; override;
-    Procedure ReadUnit; override;
+    procedure ReadUnit; override;
     property PrecompileInitialFlags: TPCUInitialFlags read FPrecompileInitialFlags;
   end;
 
-  { TPas2jsPCUCompiler }
-
   { TPas2jsPCUCompilerFile }
 
   TPas2jsPCUCompilerFile = Class(TPas2jsCompilerFile)
-    Function CreatePCUSupport: TPCUSupport; override;
+    function CreatePCUSupport: TPCUSupport; override;
   end;
 
-  TPas2jsPCUCompiler = Class(TPas2JSCompiler)
-    FPrecompileFormat : TPas2JSPrecompileFormat;
+  { TPas2jsPCUCompiler }
+
+  TPas2jsPCUCompiler = Class(TPas2JSFSCompiler)
+  Private
+    FPrecompileFormat: TPas2JSPrecompileFormat;
   Protected
     procedure WritePrecompiledFormats; override;
-    function CreateCompilerFile(const UnitFileName: String): TPas2jsCompilerFile; override;
-    Procedure HandleOptionPCUFormat(Value : string) ; override;
+    function CreateCompilerFile(const PasFileName, PCUFilename: String): TPas2jsCompilerFile; override;
+    procedure HandleOptionPCUFormat(Value: string) ; override;
   end;
 
 implementation
 
-uses fppas2js, pscanner, pas2jslogger, pas2jsfilecache, pasresolveeval, jstree, pas2jsfileutils;
+{$IFDEF HASPAS2JSFILER}
 
 { ---------------------------------------------------------------------
   TFilerPCUSupport
@@ -72,19 +94,21 @@ uses fppas2js, pscanner, pas2jslogger, pas2jsfilecache, pasresolveeval, jstree,
 
 { TFilerPCUSupport }
 
-constructor TFilerPCUSupport.create(aCompilerFile: TPas2JSCompilerFile; aFormat: TPas2JSPrecompileFormat);
+constructor TFilerPCUSupport.Create(aCompilerFile: TPas2JSCompilerFile; aFormat: TPas2JSPrecompileFormat);
 begin
   Inherited Create(aCompilerFile);
   FPCUFormat:=AFormat;
+  if FPCUFormat=nil then
+    RaiseInternalError(20181207143653,aCompilerFile.UnitFilename);
   FPrecompileInitialFlags:=TPCUInitialFlags.Create;
 end;
 
-destructor TFilerPCUSupport.destroy;
+destructor TFilerPCUSupport.Destroy;
 begin
   FreeAndNil(FPrecompileInitialFlags);
   FreeAndNil(FPCUReader);
   FreeAndNil(FPCUReaderStream);
-  inherited destroy;
+  inherited Destroy;
 end;
 
 function TFilerPCUSupport.Compiler: TPas2JSCompiler;
@@ -92,7 +116,7 @@ begin
   Result:=MyFile.Compiler;
 end;
 
-Function TFilerPCUSupport.HandleException(E: Exception) : Boolean;
+function TFilerPCUSupport.HandleException(E: Exception): Boolean;
 
 begin
   Result:=False;
@@ -100,11 +124,9 @@ begin
     begin
     Result:=True;
     if EPas2JsReadError(E).Owner is TPCUCustomReader then
-      begin
-        MyFile.Log.Log(mtError,E.Message,0,MyFile.PCUFilename);
-      end else begin
-        MyFile.Log.Log(mtError,E.Message);
-      end;
+      MyFile.Log.Log(mtError,E.Message,0,MyFile.PCUFilename)
+    else
+      MyFile.Log.Log(mtError,E.Message);
     Compiler.Terminate(ExitCodePCUError);
     end
   else if (E is EPas2JsWriteError) then
@@ -117,8 +139,12 @@ end;
 
 function TFilerPCUSupport.FindPCU(const UseUnitName: string): string;
 
+var
+  aPCUFormat: TPas2JSPrecompileFormat;
 begin
-  Result:=FindPCU(UseUnitName,FFoundFormat);
+  Result:=FindPCU(UseUnitName,aPCUFormat);
+  if (Result<>'') and (FPCUFormat<>aPCUFormat) then
+    RaiseInternalError(20181207143826,UseUnitName);
 end;
 
 function TFilerPCUSupport.HasReader: Boolean;
@@ -148,21 +174,21 @@ end;
 
 procedure TFilerPCUSupport.CreatePCUReader;
 var
-  aFile: TPas2jsCachedFile;
+  aFile: TPas2jsFile;
   s: String;
 begin
   if MyFile.PCUFilename='' then
     RaiseInternalError(20180312144742,MyFile.PCUFilename);
   if FPCUReader<>nil then
     RaiseInternalError(20180312142938,GetObjName(FPCUReader));
-  if FFoundFormat=nil then
+  if FPCUFormat=nil then
     RaiseInternalError(20180312142954,'');
-  FPCUReader:=FFoundFormat.ReaderClass.Create;
+  FPCUReader:=FPCUFormat.ReaderClass.Create;
   FPCUReader.SourceFilename:=ExtractFileName(MyFile.PCUFilename);
 
   if MyFile.ShowDebug then
     MyFile.Log.LogMsg(nParsingFile,[QuoteStr(MyFile.PCUFilename)]);
-  aFile:=Compiler.FileCache.LoadFile(MyFile.PCUFilename,true);
+  aFile:=Compiler.FS.LoadFile(MyFile.PCUFilename,true);
   if aFile=nil then
     RaiseInternalError(20180312145941,MyFile.PCUFilename);
   FPCUReaderStream:=TMemoryStream.Create;
@@ -184,7 +210,8 @@ begin
   SetReaderState(prsCanContinue);
 end;
 
-function TFilerPCUSupport.FindPCU(const UseUnitName: string; out  aFormat: TPas2JSPrecompileFormat): string;
+function TFilerPCUSupport.FindPCU(const UseUnitName: string;
+  out aFormat: TPas2JSPrecompileFormat): string;
 
   function SearchInDir(DirPath: string): boolean;
   var
@@ -199,7 +226,7 @@ function TFilerPCUSupport.FindPCU(const UseUnitName: string; out  aFormat: TPas2
       CurFormat:=PrecompileFormats[i];
       if not CurFormat.Enabled then continue;
       Filename:=DirPath+UseUnitName+'.'+CurFormat.Ext;
-      if Compiler.FileCache.SearchLowUpCase(Filename) then
+      if Compiler.FS.PCUExists(Filename) then
       begin
         FindPCU:=Filename;
         aFormat:=CurFormat;
@@ -210,23 +237,20 @@ function TFilerPCUSupport.FindPCU(const UseUnitName: string; out  aFormat: TPas2
   end;
 
 var
-  Cache: TPas2jsFilesCache;
+  L: TstringList;
   i: Integer;
+
 begin
   Result:='';
   aFormat:=nil;
-  Cache:=Compiler.FileCache;
-
-  // search in output directory
-  if Cache.UnitOutputPath<>'' then
-    if SearchInDir(Cache.UnitOutputPath) then exit;
-
-  // then in BaseDirectory
-  if SearchInDir(MyFile.FileResolver.BaseDirectory) then exit;
-
-  // finally search in unit paths
-  for i:=0 to Cache.UnitPaths.Count-1 do
-    if SearchInDir(Cache.UnitPaths[i]) then exit;
+  L:=TStringList.Create;
+  try
+    Compiler.FS.GetPCUDirs(L,MyFile.FileResolver.BaseDirectory);
+    for i:=0 to L.Count-1 do
+      if SearchInDir(L[i]) then exit;
+  finally
+    L.Free;
+  end;
 end;
 
 function TFilerPCUSupport.OnWriterIsElementUsed(Sender: TObject;
@@ -246,7 +270,7 @@ var
   ms: TMemoryStream;
   DestDir: String;
   JS: TJSElement;
-  FN : String;
+  FN: String;
 
 begin
   if FPCUFormat=Nil then
@@ -269,8 +293,8 @@ begin
 
   // Determine output filename
   FN:=ExtractFilenameOnly(MyFile.PasFilename)+'.'+FPCUFormat.Ext;
-  if Compiler.FileCache.UnitOutputPath<>'' then
-    FN:=Compiler.FileCache.UnitOutputPath+FN
+  if Compiler.FS.UnitOutputPath<>'' then
+    FN:=Compiler.FS.UnitOutputPath+FN
   else
     FN:=ExtractFilePath(MyFile.PasFilename)+FN;
   // Set as our filename
@@ -294,38 +318,40 @@ begin
     MyFile.Converter.OnIsTypeInfoUsed:=@OnPCUConverterIsTypeInfoUsed;
     JS:=MyFile.Converter.ConvertPasElement(MyFile.PasModule,MyFile.PascalResolver);
     MyFile.Converter.Options:=MyFile.Converter.Options-[coStoreImplJS];
+    MyFile.PCUSupport.SetInitialCompileFlags;
     {$IFDEF REALLYVERBOSE}
     writeln('TPas2jsCompilerFile.WritePCU create pcu ... ',MyFile.PCUFilename);
     {$ENDIF}
-    Writer.WritePCU(MyFile.PascalResolver,MyFile.Converter,PrecompileInitialFlags,ms,AllowCompressed);
+    Writer.WritePCU(MyFile.PascalResolver,MyFile.Converter,
+                    PrecompileInitialFlags,ms,AllowCompressed);
     {$IFDEF REALLYVERBOSE}
     writeln('TPas2jsCompilerFile.WritePCU precompiled ',MyFile.PCUFilename);
     {$ENDIF}
 
-    MyFile.Log.LogMsg(nWritingFile,[QuoteStr(Compiler.FileCache.FormatPath(MyFile.PCUFilename))],'',0,0,
+    MyFile.Log.LogMsg(nWritingFile,[QuoteStr(Compiler.FS.FormatPath(MyFile.PCUFilename))],'',0,0,
                not (coShowLineNumbers in Compiler.Options));
 
     // check output directory
     DestDir:=ChompPathDelim(ExtractFilePath(MyFile.PCUFilename));
-    if (DestDir<>'') and not Compiler.FileCache.DirectoryExists(DestDir) then
+    if (DestDir<>'') and not Compiler.FS.DirectoryExists(DestDir) then
     begin
       {$IFDEF REALLYVERBOSE}
       writeln('TPas2jsCompilerFile.WritePCU output dir not found "',DestDir,'"');
       {$ENDIF}
-      MyFile.Log.LogMsg(nOutputDirectoryNotFound,[QuoteStr(Compiler.FileCache.FormatPath(DestDir))]);
+      MyFile.Log.LogMsg(nOutputDirectoryNotFound,[QuoteStr(Compiler.FS.FormatPath(DestDir))]);
       Compiler.Terminate(ExitCodeFileNotFound);
     end;
-    if Compiler.FileCache.DirectoryExists(MyFile.PCUFilename) then
+    if Compiler.FS.DirectoryExists(MyFile.PCUFilename) then
     begin
       {$IFDEF REALLYVERBOSE}
       writeln('TPas2jsCompilerFile.WritePCU file is folder "',DestDir,'"');
       {$ENDIF}
-      MyFile.Log.LogMsg(nFileIsFolder,[QuoteStr(Compiler.FileCache.FormatPath(MyFile.PCUFilename))]);
+      MyFile.Log.LogMsg(nFileIsFolder,[QuoteStr(Compiler.FS.FormatPath(MyFile.PCUFilename))]);
       Compiler.Terminate(ExitCodeWriteError);
     end;
 
     ms.Position:=0;
-    Compiler.FileCache.SaveToFile(ms,MyFile.PCUFilename);
+    Compiler.FS.SaveToFile(ms,MyFile.PCUFilename);
     {$IFDEF REALLYVERBOSE}
     writeln('TPas2jsCompilerFile.WritePCU written ',MyFile.PCUFilename);
     {$ENDIF}
@@ -339,11 +365,11 @@ end;
 procedure TFilerPCUSupport.OnFilerGetSrc(Sender: TObject; aFilename: string;
   out p: PChar; out Count: integer);
 var
-  SrcFile: TPas2jsCachedFile;
+  SrcFile: TPas2jsFile;
 begin
   if Sender=nil then
     RaiseInternalError(20180311135558,aFilename);
-  SrcFile:=MyFile.Compiler.FileCache.LoadFile(aFilename);
+  SrcFile:=MyFile.Compiler.FS.LoadFile(aFilename);
   if SrcFile=nil then
     RaiseInternalError(20180311135329,aFilename);
   p:=PChar(SrcFile.Source);
@@ -371,31 +397,29 @@ end;
 { TPas2jsPCUCompiler }
 
 procedure TPas2jsPCUCompiler.WritePrecompiledFormats;
-
 Var
-  I : Integer;
-
+  I: Integer;
 begin
   if PrecompileFormats.Count>0 then
   begin
-    writeHelpLine('   -JU<x> : Create precompiled units in format x.');
+    writeHelpLine('   -JU<x>: Create precompiled units in format x.');
     for i:=0 to PrecompileFormats.Count-1 do
       with PrecompileFormats[i] do
-        writeHelpLine('     -JU'+Ext+' : '+Description);
-    writeHelpLine('     -JU- : Disable prior -JU<x> option. Do not create precompiled units.');
+        writeHelpLine('     -JU'+Ext+': '+Description);
+    writeHelpLine('     -JU-: Disable prior -JU<x> option. Do not create precompiled units.');
   end;
 end;
 
-function TPas2jsPCUCompiler.CreateCompilerFile(const UnitFileName: String): TPas2jsCompilerFile;
+function TPas2jsPCUCompiler.CreateCompilerFile(const PasFileName,
+  PCUFilename: String): TPas2jsCompilerFile;
 begin
-  Result:=TPas2JSPCUCompilerFile.Create(Self,UnitFileName);
+  Result:=TPas2JSPCUCompilerFile.Create(Self,PasFileName,PCUFilename);
 end;
 
 procedure TPas2jsPCUCompiler.HandleOptionPCUFormat(Value: string);
-
 Var
-  Found : Boolean;
-  I : integer;
+  Found: Boolean;
+  I: integer;
   PF: TPas2JSPrecompileFormat;
 begin
   Found:=false;
@@ -403,7 +427,7 @@ begin
   begin
     PF:=PrecompileFormats[i];
     if not SameText(Value,PF.Ext) then continue;
-      FPrecompileFormat:=PrecompileFormats[i];
+    FPrecompileFormat:=PrecompileFormats[i];
     Found:=true;
   end;
   if not Found then
@@ -425,7 +449,7 @@ begin
   else
     Result:=Nil;
 end;
-
+{$ENDIF}
 
 end.
 

+ 430 - 0
packages/pastojs/src/pas2jsutils.pp

@@ -0,0 +1,430 @@
+unit pas2jsutils;
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2018  Mattias Gaertner  [email protected]
+
+    Pascal to Javascript converter class.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Abstract:
+    Utility routines that do not need a filesystem or OS functionality.
+    Filesystem-specific things should go to pas2jsfileutils instead.
+}
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+function ChompPathDelim(const Path: string): string;
+function GetNextDelimitedItem(const List: string; Delimiter: char;
+                              var Position: integer): string;
+type
+   TChangeStamp = SizeInt;
+
+const
+  InvalidChangeStamp = low(TChangeStamp);
+
+Function IncreaseChangeStamp(Stamp: TChangeStamp) : TChangeStamp;
+const
+  EncodingUTF8 = 'UTF-8';
+  EncodingSystem = 'System';
+
+function NormalizeEncoding(const Encoding: string): string;
+function IsASCII(const s: string): boolean; inline;
+{$IFDEF FPC_HAS_CPSTRING}
+const
+  UTF8BOM = #$EF#$BB#$BF;
+function UTF8CharacterStrictLength(P: PChar): integer;
+
+function UTF8ToUTF16(const s: string): UnicodeString;
+function UTF16ToUTF8(const s: UnicodeString): string;
+
+{$ENDIF FPC_HAS_CPSTRING}
+
+function IsNonUTF8System: boolean;// true if system encoding is not UTF-8
+{$IFDEF Windows}
+// AConsole - If false, it is the general system encoding,
+//            if true, it is the console encoding
+function GetWindowsEncoding(AConsole: Boolean = False): string;
+{$ENDIF}
+{$IF defined(Unix) and not defined(Darwin)}
+function GetUnixEncoding: string;
+{$ENDIF}
+
+Function NonUTF8System: boolean;
+function GetDefaultTextEncoding: string;
+
+procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
+                             ReadBackslash: boolean = false);
+
+implementation
+
+{$IFDEF Windows}
+uses Windows;
+{$ENDIF}
+
+Var
+  {$IFDEF Unix}
+  {$IFNDEF Darwin}
+  Lang: string = '';
+  {$ENDIF}
+  {$ENDIF}
+  EncodingValid: boolean = false;
+  DefaultTextEncoding: string = EncodingSystem;
+  gNonUTF8System : Boolean = {$IFDEF FPC_HAS_CPSTRING}false{$ELSE}true{$ENDIF};
+
+Function NonUTF8System: boolean;
+
+begin
+  Result:=gNonUTF8System;
+end;
+
+function GetNextDelimitedItem(const List: string; Delimiter: char;
+  var Position: integer): string;
+var
+  StartPos: Integer;
+begin
+  StartPos:=Position;
+  while (Position<=length(List)) and (List[Position]<>Delimiter) do
+    inc(Position);
+  Result:=copy(List,StartPos,Position-StartPos);
+  if Position<=length(List) then inc(Position); // skip Delimiter
+end;
+
+function IncreaseChangeStamp(Stamp: TChangeStamp): TChangeStamp;
+begin
+  if Stamp<High(TChangeStamp) then
+    Result:=Stamp+1
+  else
+    Result:=InvalidChangeStamp+1;
+end;
+
+function ChompPathDelim(const Path: string): string;
+var
+  Len, MinLen: Integer;
+begin
+  Result:=Path;
+  if Path = '' then
+    exit;
+  Len:=length(Result);
+  if (Result[1] in AllowDirectorySeparators) then
+  begin
+    MinLen := 1;
+    {$IFDEF HasUNCPaths}
+    if (Len >= 2) and (Result[2] in AllowDirectorySeparators) then
+      MinLen := 2; // keep UNC '\\', chomp 'a\' to 'a'
+    {$ENDIF}
+    {$IFDEF Pas2js}
+    if (Len >= 2) and (Result[2]=Result[1]) and (PathDelim='\') then
+      MinLen := 2; // keep UNC '\\', chomp 'a\' to 'a'
+    {$ENDIF}
+  end
+  else begin
+    MinLen := 0;
+    {$IFdef MSWindows}
+    if (Len >= 3) and (Result[1] in ['a'..'z', 'A'..'Z'])  and
+       (Result[2] = ':') and (Result[3] in AllowDirectorySeparators)
+    then
+      MinLen := 3;
+    {$ENDIF}
+    {$IFdef Pas2js}
+    if (PathDelim='\')
+        and (Len >= 3) and (Result[1] in ['a'..'z', 'A'..'Z'])
+        and (Result[2] = ':') and (Result[3] in AllowDirectorySeparators)
+    then
+      MinLen := 3;
+    {$ENDIF}
+  end;
+
+  while (Len > MinLen) and (Result[Len] in AllowDirectorySeparators) do dec(Len);
+  if Len<length(Result) then
+    SetLength(Result,Len);
+end;
+
+function NormalizeEncoding(const Encoding: string): string;
+var
+  i: Integer;
+begin
+  Result:=LowerCase(Encoding);
+  for i:=length(Result) downto 1 do
+    if Result[i]='-' then Delete(Result,i,1);
+end;
+
+{$IFDEF WINDOWS}
+function GetWindowsEncoding(AConsole: Boolean = False): string;
+var
+  cp : UINT;
+{$IFDEF WinCE}
+// CP_UTF8 is missing in the windows unit of the Windows CE RTL
+const
+  CP_UTF8 = 65001;
+{$ENDIF}
+begin
+  if AConsole then cp := GetOEMCP
+  else cp := GetACP;
+
+  case cp of
+    CP_UTF8: Result := EncodingUTF8;
+  else
+    Result:='cp'+IntToStr(cp);
+  end;
+end;
+{$ENDIF}
+
+function IsASCII(const s: string): boolean; inline;
+{$IFDEF Pas2js}
+var
+  i: Integer;
+begin
+  for i:=1 to length(s) do
+    if s[i]>#127 then exit(false);
+  Result:=true;
+end;
+{$ELSE}
+var
+  p: PChar;
+begin
+  if s='' then exit(true);
+  p:=PChar(s);
+  repeat
+    case p^ of
+    #0: if p-PChar(s)=length(s) then exit(true);
+    #128..#255: exit(false);
+    end;
+    inc(p);
+  until false;
+end;
+{$ENDIF}
+
+{$IFDEF FPC_HAS_CPSTRING}
+function UTF8CharacterStrictLength(P: PChar): integer;
+begin
+  if p=nil then exit(0);
+  if ord(p^)<%10000000 then
+  begin
+    // regular single byte character
+    exit(1);
+  end
+  else if ord(p^)<%11000000 then
+  begin
+    // invalid single byte character
+    exit(0);
+  end
+  else if ((ord(p^) and %11100000) = %11000000) then
+  begin
+    // should be 2 byte character
+    if (ord(p[1]) and %11000000) = %10000000 then
+      exit(2)
+    else
+      exit(0);
+  end
+  else if ((ord(p^) and %11110000) = %11100000) then
+  begin
+    // should be 3 byte character
+    if ((ord(p[1]) and %11000000) = %10000000)
+    and ((ord(p[2]) and %11000000) = %10000000) then
+      exit(3)
+    else
+      exit(0);
+  end
+  else if ((ord(p^) and %11111000) = %11110000) then
+  begin
+    // should be 4 byte character
+    if ((ord(p[1]) and %11000000) = %10000000)
+    and ((ord(p[2]) and %11000000) = %10000000)
+    and ((ord(p[3]) and %11000000) = %10000000) then
+      exit(4)
+    else
+      exit(0);
+  end else
+    exit(0);
+end;
+
+function UTF8ToUTF16(const s: string): UnicodeString;
+begin
+  Result:=UTF8Decode(s);
+end;
+
+function UTF16ToUTF8(const s: UnicodeString): string;
+begin
+  if s='' then exit('');
+  Result:=UTF8Encode(s);
+  // prevent UTF8 codepage appear in the strings - we don't need codepage
+  // conversion magic
+  SetCodePage(RawByteString(Result), CP_ACP, False);
+end;
+{$ENDIF}
+
+function IsNonUTF8System: boolean;
+begin
+  Result:=NonUTF8System;
+end;
+
+{$IFDEF UNIX}
+{$IFNDEF Darwin}
+function GetUnixEncoding: string;
+var
+  i: integer;
+begin
+  Result:=EncodingSystem;
+  i:=pos('.',Lang);
+  if (i>0) and (i<=length(Lang)) then
+    Result:=copy(Lang,i+1,length(Lang)-i);
+end;
+{$ENDIF}
+{$ENDIF}
+
+function GetDefaultTextEncoding: string;
+
+
+begin
+  if EncodingValid then
+  begin
+    Result:=DefaultTextEncoding;
+    exit;
+  end;
+
+  {$IFDEF Pas2js}
+  Result:=EncodingUTF8;
+  {$ELSE}
+    {$IFDEF Windows}
+    Result:=GetWindowsEncoding;
+    {$ELSE}
+      {$IFDEF Darwin}
+      Result:=EncodingUTF8;
+      {$ELSE}
+      // unix
+      Lang := GetEnvironmentVariable('LC_ALL');
+      if Lang='' then
+      begin
+        Lang := GetEnvironmentVariable('LC_MESSAGES');
+        if Lang='' then
+          Lang := GetEnvironmentVariable('LANG');
+      end;
+      Result:=GetUnixEncoding;
+      {$ENDIF}
+    {$ENDIF}
+  {$ENDIF}
+  Result:=NormalizeEncoding(Result);
+
+  DefaultTextEncoding:=Result;
+  EncodingValid:=true;
+end;
+
+procedure InternalInit;
+begin
+  {$IFDEF FPC_HAS_CPSTRING}
+  SetMultiByteConversionCodePage(CP_UTF8);
+  // SetMultiByteFileSystemCodePage(CP_UTF8); not needed, this is the default under Windows
+  SetMultiByteRTLFileSystemCodePage(CP_UTF8);
+
+  GetDefaultTextEncoding;
+  {$IFDEF Windows}
+  gNonUTF8System:=true;
+  {$ELSE}
+  gNonUTF8System:=SysUtils.CompareText(DefaultTextEncoding,'UTF8')<>0;
+  {$ENDIF}
+  {$ENDIF}
+end;
+procedure SplitCmdLineParams(const Params: string; ParamList: TStrings;
+                             ReadBackslash: boolean = false);
+// split spaces, quotes are parsed as single parameter
+// if ReadBackslash=true then \" is replaced to " and not treated as quote
+// #0 is always end
+type
+  TMode = (mNormal,mApostrophe,mQuote);
+var
+  p: Integer;
+  Mode: TMode;
+  Param: String;
+begin
+  p:=1;
+  while p<=length(Params) do
+  begin
+    // skip whitespace
+    while (p<=length(Params)) and (Params[p] in [' ',#9,#10,#13]) do inc(p);
+    if (p>length(Params)) or (Params[p]=#0) then
+      break;
+    // read param
+    Param:='';
+    Mode:=mNormal;
+    while p<=length(Params) do
+    begin
+      case Params[p] of
+      #0:
+        break;
+      '\':
+        begin
+          inc(p);
+          if ReadBackslash then
+            begin
+            // treat next character as normal character
+            if (p>length(Params)) or (Params[p]=#0) then
+              break;
+            if ord(Params[p])<128 then
+            begin
+              Param+=Params[p];
+              inc(p);
+            end else begin
+              // next character is already a normal character
+            end;
+          end else begin
+            // treat backslash as normal character
+            Param+='\';
+          end;
+        end;
+      '''':
+        begin
+          inc(p);
+          case Mode of
+          mNormal:
+            Mode:=mApostrophe;
+          mApostrophe:
+            Mode:=mNormal;
+          mQuote:
+            Param+='''';
+          end;
+        end;
+      '"':
+        begin
+          inc(p);
+          case Mode of
+          mNormal:
+            Mode:=mQuote;
+          mApostrophe:
+            Param+='"';
+          mQuote:
+            Mode:=mNormal;
+          end;
+        end;
+      ' ',#9,#10,#13:
+        begin
+          if Mode=mNormal then break;
+          Param+=Params[p];
+          inc(p);
+        end;
+      else
+        Param+=Params[p];
+        inc(p);
+      end;
+    end;
+    //writeln('SplitCmdLineParams Param=#'+Param+'#');
+    ParamList.Add(Param);
+  end;
+end;
+
+
+initialization
+  InternalInit;
+end.
+

+ 1 - 0
packages/pastojs/tests/tcconverter.pp

@@ -1259,6 +1259,7 @@ end;
 procedure TTestConverter.SetUp;
 begin
   FConverter:=TPasToJSConverter.Create;
+  FConverter.Globals:=TPasToJSConverterGlobals.Create(FConverter);
 end;
 
 procedure TTestConverter.TearDown;

+ 146 - 4
packages/pastojs/tests/tcfiler.pas

@@ -24,7 +24,7 @@ interface
 
 uses
   Classes, SysUtils, fpcunit, testregistry,
-  PasTree, PScanner, PasResolver, PasResolveEval, PParser, PasUseAnalyzer,
+  PasTree, PScanner, PParser, PasResolveEval, PasResolver, PasUseAnalyzer,
   FPPas2Js, Pas2JsFiler,
   tcmodules, jstree;
 
@@ -90,6 +90,7 @@ type
     procedure CheckRestoredPrimitiveExpr(const Path: string; Orig, Rest: TPrimitiveExpr); virtual;
     procedure CheckRestoredBoolConstExpr(const Path: string; Orig, Rest: TBoolConstExpr); virtual;
     procedure CheckRestoredParamsExpr(const Path: string; Orig, Rest: TParamsExpr); virtual;
+    procedure CheckRestoredProcedureExpr(const Path: string; Orig, Rest: TProcedureExpr); virtual;
     procedure CheckRestoredRecordValues(const Path: string; Orig, Rest: TRecordValues); virtual;
     procedure CheckRestoredPasExprArray(const Path: string; Orig, Rest: TPasExprArray); virtual;
     procedure CheckRestoredArrayValues(const Path: string; Orig, Rest: TArrayValues); virtual;
@@ -138,17 +139,22 @@ type
     procedure TestPC_Var;
     procedure TestPC_Enum;
     procedure TestPC_Set;
+    procedure TestPC_Set_InFunction;
     procedure TestPC_SetOfAnonymousEnumType;
     procedure TestPC_Record;
+    procedure TestPC_Record_InFunction;
+    procedure TestPC_RecordAdv;
     procedure TestPC_JSValue;
     procedure TestPC_Array;
     procedure TestPC_ArrayOfAnonymous;
+    procedure TestPC_Array_InFunction;
     procedure TestPC_Proc;
     procedure TestPC_Proc_Nested;
     procedure TestPC_Proc_LocalConst;
     procedure TestPC_Proc_UTF8;
     procedure TestPC_Proc_Arg;
     procedure TestPC_ProcType;
+    procedure TestPC_Proc_Anonymous;
     procedure TestPC_Class;
     procedure TestPC_ClassForward;
     procedure TestPC_ClassConstructor;
@@ -444,8 +450,8 @@ begin
   FInitialFlags.ModeSwitches:=Scanner.CurrentModeSwitches;
   FInitialFlags.BoolSwitches:=Scanner.CurrentBoolSwitches;
   FInitialFlags.ConverterOptions:=Converter.Options;
-  FInitialFlags.TargetPlatform:=Converter.TargetPlatform;
-  FInitialFlags.TargetProcessor:=Converter.TargetProcessor;
+  FInitialFlags.TargetPlatform:=Converter.Globals.TargetPlatform;
+  FInitialFlags.TargetProcessor:=Converter.Globals.TargetProcessor;
   // ToDo: defines
 end;
 
@@ -700,6 +706,7 @@ end;
 procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string;
   Orig, Rest: TPasRecordScope);
 begin
+  CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
   CheckRestoredIdentifierScope(Path,Orig,Rest);
 end;
 
@@ -803,7 +810,7 @@ begin
     AssertEquals(Path+'.ResultVarName',Orig.ResultVarName,Rest.ResultVarName);
     CheckRestoredReference(Path+'.OverriddenProc',Orig.OverriddenProc,Rest.OverriddenProc);
 
-    CheckRestoredScopeReference(Path+'.ClassScope',Orig.ClassScope,Rest.ClassScope);
+    CheckRestoredScopeReference(Path+'.ClassScope',Orig.ClassOrRecordScope,Rest.ClassOrRecordScope);
     CheckRestoredElement(Path+'.SelfArg',Orig.SelfArg,Rest.SelfArg);
     if Orig.Flags<>Rest.Flags then
       Fail(Path+'.Flags');
@@ -1078,6 +1085,8 @@ begin
     CheckRestoredPasExpr(Path,TPasExpr(Orig),TPasExpr(Rest))
   else if C=TParamsExpr then
     CheckRestoredParamsExpr(Path,TParamsExpr(Orig),TParamsExpr(Rest))
+  else if C=TProcedureExpr then
+    CheckRestoredProcedureExpr(Path,TProcedureExpr(Orig),TProcedureExpr(Rest))
   else if C=TRecordValues then
     CheckRestoredRecordValues(Path,TRecordValues(Orig),TRecordValues(Rest))
   else if C=TArrayValues then
@@ -1259,6 +1268,13 @@ begin
   CheckRestoredPasExpr(Path,Orig,Rest);
 end;
 
+procedure TCustomTestPrecompile.CheckRestoredProcedureExpr(const Path: string;
+  Orig, Rest: TProcedureExpr);
+begin
+  CheckRestoredProcedure(Path+'$Ano',Orig.Proc,Rest.Proc);
+  CheckRestoredPasExpr(Path,Orig,Rest);
+end;
+
 procedure TCustomTestPrecompile.CheckRestoredRecordValues(const Path: string;
   Orig, Rest: TRecordValues);
 var
@@ -1662,6 +1678,32 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Set_InFunction;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'procedure DoIt;',
+  'implementation',
+  'procedure DoIt;',
+  'type',
+  '  TEnum = (red,green,blue);',
+  '  TEnumRg = green..blue;',
+  '  TEnumAlias = TEnum;', // alias
+  '  TSetOfEnum = set of TEnum;',
+  '  TSetOfEnumRg = set of TEnumRg;',
+  '  TSetOfDir = set of (west,east);',
+  'var',
+  '  Empty: TSetOfEnum = [];', // empty set lit
+  '  All: TSetOfEnum = [low(TEnum)..pred(high(TEnum)),high(TEnum)];', // full set lit, range in set
+  '  Dirs: TSetOfDir;',
+  'begin',
+  '  Dirs:=[east];',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_SetOfAnonymousEnumType;
 begin
   StartUnit(false);
@@ -1691,6 +1733,61 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Record_InFunction;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'procedure DoIt;',
+  'implementation',
+  'procedure DoIt;',
+  'type',
+  '  TRec = record',
+  '    i: longint;',
+  '    s: string;',
+  '  end;',
+  '  P = ^TRec;',
+  '  TArrOfRec = array of TRec;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  'end;']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_RecordAdv;
+begin
+  StartUnit(false);
+  Add([
+  '{$ModeSwitch advancedrecords}',
+  'interface',
+  'type',
+  '  TRec = record',
+  '  private',
+  '    FInt: longint;',
+  '    procedure SetInt(Value: longint);',
+  '    function GetItems(Value: word): word;',
+  '    procedure SetItems(Index, Value: word);',
+  '  public',
+  '    property Int: longint read FInt write SetInt default 3;',
+  '    property Items[Index: word]: word read GetItems write SetItems; default;',
+  '  end;',
+  'var',
+  '  r: trec;',
+  'implementation',
+  'procedure TRec.SetInt(Value: longint);',
+  'begin',
+  'end;',
+  'function TRec.GetItems(Value: word): word;',
+  'begin',
+  'end;',
+  'procedure TRec.SetItems(Index, Value: word);',
+  'begin',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_JSValue;
 begin
   StartUnit(false);
@@ -1729,6 +1826,25 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Array_InFunction;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'procedure DoIt;',
+  'implementation',
+  'procedure DoIt;',
+  'type',
+  '  TArr = array[1..2] of word;',
+  'var',
+  '  arr: TArr;',
+  'begin',
+  '  arr[2]:=arr[1];',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_Proc;
 begin
   StartUnit(false);
@@ -1866,6 +1982,32 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Proc_Anonymous;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  TFunc = reference to function(w: word): word;',
+  '  function GetIt(f: TFunc): longint;',
+  'implementation',
+  'var k: byte;',
+  'function GetIt(f: TFunc): longint;',
+  'begin',
+  '  f:=function(w: word): word',
+  '    var j: byte;',
+  '      function GetMul(a,b: longint): longint; ',
+  '      begin',
+  '        Result:=a*b;',
+  '      end;',
+  '    begin',
+  '      Result:=j*GetMul(1,2)*k;',
+  '    end;',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_Class;
 begin
   StartUnit(false);

文件差异内容过多而无法显示
+ 643 - 73
packages/pastojs/tests/tcmodules.pas


+ 9 - 9
packages/pastojs/tests/tcoptimizations.pas

@@ -387,17 +387,17 @@ begin
   ConvertProgram;
   CheckSource('TestWPO_OmitRecordMember',
     LinesToStr([
-    'this.TRec = function (s) {',
-    '  if (s) {',
-    '    this.a = s.a;',
-    '  } else {',
-    '    this.a = 0;',
-    '  };',
-    '  this.$equal = function (b) {',
+    'rtl.createTRecord($mod, "TRec", function () {',
+    '  this.a = 0;',
+    '  this.$eq = function (b) {',
     '    return this.a === b.a;',
     '  };',
-    '};',
-    'this.r = new $mod.TRec();',
+    '  this.$assign = function (s) {',
+    '    this.a = s.a;',
+    '    return this;',
+    '  };',
+    '});',
+    'this.r = $mod.TRec.$new();',
     '']),
     LinesToStr([
     '$mod.r.a = 3;',

+ 6 - 6
packages/pastojs/tests/tcprecompile.pas

@@ -17,7 +17,7 @@
     ./testpas2js --suite=TTestCLI_Precompile
     ./testpas2js --suite=TTestModule.TestEmptyUnit
 }
-unit tcprecompile;
+unit TCPrecompile;
 
 {$mode objfpc}{$H+}
 
@@ -26,7 +26,7 @@ interface
 uses
   Classes, SysUtils,
   fpcunit, testregistry, Pas2jsFileUtils, Pas2JsFiler, Pas2jsCompiler,
-  tcunitsearch, tcmodules;
+  TCUnitSearch, TCModules;
 
 type
 
@@ -115,6 +115,8 @@ begin
     JSFile:=FindFile(JSFilename);
     OrigSrc:=JSFile.Source;
     // compile, using .pcu files
+    //for i:=0 to FileCount-1 do
+    //  writeln('TCustomTestCLI_Precompile.CheckPrecompile ',i,' ',Files[i].Filename);
     {$IFDEF VerbosePCUFiler}
     writeln('TTestCLI_Precompile.CheckPrecompile compile using pcu files==================');
     {$ENDIF}
@@ -285,7 +287,7 @@ begin
    'end;']);
   AddUnit('src/unit2.pp',
   ['uses unit1;',
-  'procedure Do2(j: integer);'],
+   'procedure Do2(j: integer);'],
   ['procedure Do2(j: integer);',
    'begin',
    '  unit1.i:=j;',
@@ -550,7 +552,7 @@ begin
   ExpectedSrc:=LinesToStr([
     UTF8BOM+'rtl.module("system",[],function () {',
     '  "use strict";',
-    '  rtl.checkVersion(10101);',
+    '  rtl.checkVersion(10301);',
     '  var $mod = this;',
     '});']);
   if not CheckSrcDiff(ExpectedSrc,aFile.Source,s) then
@@ -558,8 +560,6 @@ begin
 end;
 
 Initialization
-  {$IFDEF EnablePas2jsPrecompiled}
   RegisterTests([TTestCLI_Precompile]);
-  {$ENDIF}
 end.
 

+ 6 - 5
packages/pastojs/tests/tcunitsearch.pas

@@ -18,7 +18,7 @@
     ./testpas2js --suite=TestUS_Program
     ./testpas2js --suite=TestUS_UsesEmptyFileFail
 }
-unit tcunitsearch;
+unit TCUnitSearch;
 
 {$mode objfpc}{$H+}
 
@@ -29,14 +29,14 @@ uses
   fpcunit, testregistry,
   PScanner, PasTree,
   {$IFDEF CheckPasTreeRefCount}PasResolveEval,{$ENDIF}
-  Pas2jsFileUtils, Pas2jsCompiler, Pas2jsFileCache, Pas2jsLogger,
+  Pas2jsFileUtils, Pas2jsCompiler, Pas2JSPCUCompiler, Pas2jsFileCache, Pas2jsLogger,
   tcmodules;
 
 type
 
   { TTestCompiler }
 
-  TTestCompiler = class(TPas2jsCompiler)
+  TTestCompiler = class(TPas2jsPCUCompiler)
   private
     FExitCode: longint;
   protected
@@ -209,7 +209,7 @@ procedure TCustomTestCLI.SetWorkDir(const AValue: string);
 var
   NewValue: String;
 begin
-  NewValue:=IncludeTrailingPathDelimiter(ResolveDots(AValue));
+  NewValue:=IncludeTrailingPathDelimiter(ExpandFileNamePJ(ResolveDots(AValue)));
   if FWorkDir=NewValue then Exit;
   FWorkDir:=NewValue;
 end;
@@ -228,8 +228,9 @@ begin
   CompilerExe:='/usr/bin/pas2js';
   {$ENDIF}
   FCompiler:=TTestCompiler.Create;
+  //FCompiler.ConfigSupport:=TPas2JSFileConfigSupport.Create(FCompiler);
   Compiler.Log.OnLog:=@DoLog;
-  Compiler.FileCache.DirectoryCache.OnReadDirectory:=@OnReadDirectory;
+  Compiler.FileCache.OnReadDirectory:=@OnReadDirectory;
   Compiler.FileCache.OnReadFile:=@OnReadFile;
   Compiler.FileCache.OnWriteFile:=@OnWriteFile;
 end;

+ 7 - 8
packages/pastojs/tests/testpas2js.lpi

@@ -19,16 +19,9 @@
       <Version Value="2"/>
     </PublishOptions>
     <RunParams>
-      <local>
-        <CommandLineParams Value="--suite=TTestCLI_UnitSearch"/>
-      </local>
       <FormatVersion Value="2"/>
       <Modes Count="1">
-        <Mode0 Name="default">
-          <local>
-            <CommandLineParams Value="--suite=TTestCLI_UnitSearch"/>
-          </local>
-        </Mode0>
+        <Mode0 Name="default"/>
       </Modes>
     </RunParams>
     <RequiredPackages Count="2">
@@ -56,6 +49,7 @@
       <Unit3>
         <Filename Value="tcmodules.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="TCModules"/>
       </Unit3>
       <Unit4>
         <Filename Value="tcoptimizations.pas"/>
@@ -82,10 +76,12 @@
       <Unit9>
         <Filename Value="tcunitsearch.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="TCUnitSearch"/>
       </Unit9>
       <Unit10>
         <Filename Value="tcprecompile.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="TCPrecompile"/>
       </Unit10>
     </Units>
   </ProjectOptions>
@@ -110,6 +106,9 @@
     </CodeGeneration>
     <Other>
       <CustomOptions Value="-dVerbosePas2JS"/>
+      <OtherDefines Count="1">
+        <Define0 Value="VerbosePas2JS"/>
+      </OtherDefines>
     </Other>
   </CompilerOptions>
   <Debugging>

+ 67 - 19
utils/pas2js/dist/rtl.js

@@ -2,7 +2,7 @@
 
 var rtl = {
 
-  version: 10101,
+  version: 10301,
 
   quiet: false,
   debug_load_units: false,
@@ -71,6 +71,10 @@ var rtl = {
     return ((typeof(o)==="object") || (typeof(o)==='function')) ? o : null;
   },
 
+  isTRecord: function(type){
+    return (rtl.isObject(type) && type.hasOwnProperty('$new') && (typeof(type.$new)==='function'));
+  },
+
   isPasClass: function(type){
     return (rtl.isObject(type) && type.hasOwnProperty('$classname') && rtl.isObject(type.$module));
   },
@@ -141,7 +145,7 @@ var rtl = {
       try{
         doRun();
       } catch(re) {
-        var errMsg = re.hasOwnProperty('$class') ? re.$class.$classname : '';
+        var errMsg = rtl.hasString(re.$classname) ? re.$classname : '';
 	    errMsg +=  ((errMsg) ? ': ' : '') + (re.hasOwnProperty('fMessage') ? re.fMessage : re);
         alert('Uncaught Exception : '+errMsg);
         rtl.exitCode = 216;
@@ -233,23 +237,28 @@ var rtl = {
     }
   },
 
-  initClass: function(c,parent,name,initfn){
-    parent[name] = c;
-    c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
-    c.$classname = name;
+  initStruct: function(c,parent,name){
     if ((parent.$module) && (parent.$module.$impl===parent)) parent=parent.$module;
     c.$parent = parent;
-    c.$fullname = parent.$name+'.'+name;
     if (rtl.isModule(parent)){
       c.$module = parent;
       c.$name = name;
     } else {
       c.$module = parent.$module;
-      c.$name = parent.name+'.'+name;
+      c.$name = parent.$name+'.'+name;
     };
+    return parent;
+  },
+
+  initClass: function(c,parent,name,initfn){
+    parent[name] = c;
+    c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
+    c.$classname = name;
+    parent = rtl.initStruct(c,parent,name);
+    c.$fullname = parent.$name+'.'+name;
     // rtti
     if (rtl.debug_rtti) rtl.debug('initClass '+c.$fullname);
-    var t = c.$module.$rtti.$Class(c.$name,{ "class": c, module: parent });
+    var t = c.$module.$rtti.$Class(c.$name,{ "class": c });
     c.$rtti = t;
     if (rtl.isObject(c.$ancestor)) t.ancestor = c.$ancestor.$rtti;
     if (!t.ancestor) t.ancestor = null;
@@ -298,8 +307,7 @@ var rtl = {
     // Create a class using an external ancestor.
     // If newinstancefnname is given, use that function to create the new object.
     // If exist call BeforeDestruction and AfterConstruction.
-    var c = null;
-    c = Object.create(ancestor);
+    var c = Object.create(ancestor);
     c.$create = function(fnname,args){
       if (args == undefined) args = [];
       var o = null;
@@ -342,6 +350,32 @@ var rtl = {
     return null;
   },
 
+  createTRecord: function(parent,name,initfn,full){
+    var t = {};
+    if (parent) parent[name] = t;
+    function hide(prop){
+      Object.defineProperty(t,prop,{enumerable:false});
+    }
+    if (full){
+      rtl.initStruct(t,parent,name);
+      t.$record = t;
+      hide('$record');
+      hide('$name');
+      hide('$parent');
+      hide('$module');
+    }
+    initfn.call(t);
+    if (!t.$new){
+      t.$new = function(){ return Object.create(this); };
+    }
+    t.$clone = function(r){ return this.$new().$assign(r); };
+    hide('$new');
+    hide('$clone');
+    hide('$eq');
+    hide('$assign');
+    return t;
+  },
+
   is: function(instance,type){
     return type.isPrototypeOf(instance) || (instance===type);
   },
@@ -465,7 +499,7 @@ var rtl = {
 
   createTGUID: function(guid){
     var TGuid = (pas.System)?pas.System.TGuid:pas.system.tguid;
-    var g = rtl.strToGUIDR(guid,new TGuid());
+    var g = rtl.strToGUIDR(guid,TGuid.$new());
     return g;
   },
 
@@ -730,10 +764,12 @@ var rtl = {
         if (argNo === p.length-1){
           if (rtl.isArray(defaultvalue)){
             for (var i=oldlen; i<newlen; i++) a[i]=[]; // nested array
-          } else if (rtl.isFunction(defaultvalue)){
-            for (var i=oldlen; i<newlen; i++) a[i]=new defaultvalue(); // e.g. record
           } else if (rtl.isObject(defaultvalue)) {
-            for (var i=oldlen; i<newlen; i++) a[i]={}; // e.g. set
+            if (rtl.isTRecord(defaultvalue)){
+              for (var i=oldlen; i<newlen; i++) a[i]=defaultvalue.$new(); // e.g. record
+            } else {
+              for (var i=oldlen; i<newlen; i++) a[i]={}; // e.g. set
+            }
           } else {
             for (var i=oldlen; i<newlen; i++) a[i]=defaultvalue;
           }
@@ -762,10 +798,10 @@ var rtl = {
     // type: 0 for references, "refset" for calling refSet(), a function for new type()
     // src must not be null
     // This function does not range check.
-    if (rtl.isFunction(type)){
-      for (; srcpos<endpos; srcpos++) dst[dstpos++] = new type(src[srcpos]); // clone record
-    } else if(type === 'refSet') {
+    if(type === 'refSet') {
       for (; srcpos<endpos; srcpos++) dst[dstpos++] = rtl.refSet(src[srcpos]); // ref set
+    } else if (rtl.isTRecord(type)){
+      for (; srcpos<endpos; srcpos++) dst[dstpos++] = type.$clone(src[srcpos]); // clone record
     }  else {
       for (; srcpos<endpos; srcpos++) dst[dstpos++] = src[srcpos]; // reference
     };
@@ -950,7 +986,7 @@ var rtl = {
     };
   },
 
-  floatToStr : function(d,w,p){
+  floatToStr: function(d,w,p){
     // input 1-3 arguments: double, width, precision
     if (arguments.length>2){
       return rtl.spaceLeft(d.toFixed(p),w);
@@ -975,6 +1011,18 @@ var rtl = {
     }
   },
 
+  valEnum: function(s, enumType, setCodeFn){
+    s = s.toLowerCase();
+    for (var key in enumType){
+      if((typeof(key)==='string') && (key.toLowerCase()===s)){
+        setCodeFn(0);
+        return enumType[key];
+      }
+    }
+    setCodeFn(1);
+    return 0;
+  },
+
   initRTTI: function(){
     if (rtl.debug_rtti) rtl.debug('initRTTI');
 

+ 65 - 8
utils/pas2js/docs/translation.html

@@ -133,6 +133,7 @@ Put + after a boolean switch option to enable it, - to disable it
     -ic   : Write list of supported JS processors usable by -P&lt;x&gt;
     -io   : Write list of supported optimizations usable by -Oo&lt;x&gt;
     -it   : Write list of supported targets usable by -T&lt;x&gt;
+    -iJ   : Write list of supported JavaScript identifiers -JoRTL-&lt;x&gt;
   -C&lt;x&gt;   : Code generation options. &lt;x&gt; is a combination of the following letters:
     o     : Overflow checking
     r     : Range checking
@@ -164,6 +165,11 @@ Put + after a boolean switch option to enable it, - to disable it
    -Jo&lt;x&gt; : Enable or disable extra option. The x is case insensitive:
      -JoSearchLikeFPC : search source files like FPC, default: search case insensitive.
      -JoUseStrict : add "use strict" to modules, default.
+     -JoCheckVersion-: do not add rtl version check, default. (since 1.1)
+     -JoCheckVersion=main: insert rtl version check into main. (since 1.1)
+     -JoCheckVersion=system: insert rtl version check into system unit init. (since 1.1)
+     -JoCheckVersion=unit: insert rtl version check into every unit init. (since 1.1)
+     -JoRTL-&lt;x&gt;=&lt;y&gt;: set RTL identifier x to value y. See -iJ. (since 1.1)
    -Jpcmd&lt;command&gt; : Run postprocessor. For each generated js execute
                   command passing the js as stdin and read the new js from stdout.
                   This option can be added multiple times to call several
@@ -622,7 +628,8 @@ End.
       <tbody>
         <tr>
           <th>Pascal</th>
-          <th>JavaScript</th>
+          <th>JS Pas2js 1.2</th>
+          <th>JS Pas2js 1.3</th>
         </tr>
         <tr>
           <td>
@@ -671,6 +678,35 @@ function(){
   },
 },
 []);
+</pre>
+          </td>
+          <td>
+<pre>rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  rtl.createTRecord($mod, "TMyRecord", function() {
+    this.i = 0;
+    this.s = "";
+    this.d = 0.0;
+    this.$eq = function (b) {
+      return (this.i == b.i) && (this.s == b.i) && (this.d == b.d);
+    };
+    this.$assign = function (s) {
+      this.i = s.i;
+      this.s = s.s;
+      this.d = s.d;
+      return this;
+    };
+  };
+  this.r = this.TMyRecord.$new();
+  $mod.$init = function() {
+    $mod.r.i=123;
+    $mod.r.$assign($mod.s);
+    if ($mod.r.$eq($mod.s)) ;
+  },
+},
+[]);
 </pre>
           </td>
         </tr>
@@ -680,9 +716,20 @@ function(){
       <li>The record variable creates a JavaScript object.</li>
       <li>Variant records are not supported.</li>
       <li>Supported: Assign, pass as argument, equal, not equal,
-      array of record, pointer of record, const, default().</li>
-      <li>Not yet implemented: advanced records, operators.</li>
-      <li>When assigning a record it is cloned. This is compatible with Delphi and FPC.</li>
+      array of record, pointer of record, const, default(), RTTI.</li>
+      <li>Advanced record (since pas2js 1.3):
+        <ul>
+          <li>visibility private, strict private, public, default is public</li>
+          <li>methods, class methods (must be static like in Delphi/FPC)</li>
+          <li>class vars</li>
+          <li>const fields</li>
+          <li>property, class property, array property, default property</li>
+        </ul>
+      </li>
+      <li>Not yet implemented: constructors, operators.</li>
+      <li>Until Pas2js 1.2 when assigning a record it is cloned, creating a new
+        JS object. Since Pas2js 1.3 only values are copied,
+        keeping the object, so pointer of record is compatible.</li>
       <li>Since record types are JS objects it is possible to typecast a record type
       to the JS Object, e.g. TJSObject(TPoint)</li>
       <li>A pointer of record is simply a reference.
@@ -2031,8 +2078,9 @@ rtl = {
 
     <div class="section">
     <h2 id="anonymousfunctions">Translating anonymous functions</h2>
-    Anonymous functions are not yet supported by pas2js. The next best thing are
-    local procedures. For example:
+    Anonymous functions are supported since pas2js 1.1.<br>
+    Note that in pas2js local procedures are closures as well. See below.<br>
+    For pas2js 1.0 the next best thing are local procedures. For example:
     <table class="sample">
       <tbody>
         <tr>
@@ -2803,12 +2851,20 @@ End.
     <li>{$I %param%}:
       <ul>
         <li>%date%: current date as string literal, '[yyyy/mm/dd]'</li>
-        <li>%time%: current time as string literal, 'hh:mm:ss'</li>
-        <li>%line%: current source line number as string literal, e.g. '123'</li>
+        <li>%time%: current time as string literal, 'hh:mm:ss'. Note that the
+          inclusion of %date% and %time% will not cause the compiler to
+          recompile the unit every time it is used:
+          the date and time will be the date and time when the unit was last compiled.</li>
+        <li>%file%: current source filename as string literal, e.g. <i>'unit1.pas'</i></li>
+        <li>%line%: current source line number as string literal, e.g. <i>'123'</i></li>
+        <li>%linenum%: current source line number as integer, e.g. <i>123</i></li>
         <li>%currentroutine%: name of current routine as string literal</li>
         <li>%pas2jstarget%, %pas2jstargetos%, %fpctarget%, %fpctargetos%: target os as string literal, e.g. 'Browser'</li>
         <li>%pas2jstargetcpu%, %fpctargetcpu%: target cpu as string literal, e.g. 'ECMAScript5'</li>
         <li>%pas2jsversion%, %fpcversion%: compiler version as strnig literal, e.g. '1.0.2'</li>
+        <li>If param is none of the above it will use the environment variable.
+        Keep in mind that depending on the platform the name may be case sensitive.
+        If there is no such variable an empty string <i>''</i> is inserted.</li>
       </ul>
     </li>
     <li>{$Warnings on|off}</li>
@@ -2925,6 +2981,7 @@ End.
     <li>Intrinsic procedure WriteStr(out s: string; params...)</li>
     <li><i>Debugger;</i> converts to <i>debugger;</i>. If a debugger is running
       it will break on this line just like a break point.</li>
+    <li><i>concat(string1,string2,...)</i> since 1.3</li>
     </ul>
     </div>
 

+ 6 - 4
utils/pas2js/nodepas2js.pp

@@ -6,7 +6,8 @@ program nodepas2js;
 uses
   JS, NodeJSApp,
   Classes, SysUtils,
-  Pas2jsFileUtils, Pas2jsLogger, Pas2jsCompiler;
+  Pas2jsFileUtils, Pas2jsLogger,
+  Pas2jsCompiler, Pas2JSFSCompiler, Pas2JSCompilerCfg;
 
 type
 
@@ -14,13 +15,13 @@ type
 
   TPas2jsCLI = class(TNodeJSApplication)
   private
-    FCompiler: TPas2jsCompiler;
+    FCompiler: TPas2jsFSCompiler;
   protected
     procedure DoRun; override;
   public
     constructor Create(TheOwner: TComponent); override;
     destructor Destroy; override;
-    property Compiler: TPas2jsCompiler read FCompiler;
+    property Compiler: TPas2jsFsCompiler read FCompiler;
   end;
 
 procedure TPas2jsCLI.DoRun;
@@ -65,7 +66,8 @@ constructor TPas2jsCLI.Create(TheOwner: TComponent);
 begin
   inherited Create(TheOwner);
   StopOnException:=True;
-  FCompiler:=TPas2jsCompiler.Create;
+  FCompiler:=TPas2jsFSCompiler.Create;
+  FCompiler.ConfigSupport:=TPas2JSFileConfigSupport.Create(FCompiler);
 end;
 
 destructor TPas2jsCLI.Destroy;

+ 25 - 3
utils/pas2js/pas2js.lpi

@@ -23,15 +23,37 @@
     <RunParams>
       <FormatVersion Value="2"/>
       <Modes Count="1">
-        <Mode0 Name="default">
-        </Mode0>
+        <Mode0 Name="default"/>
       </Modes>
     </RunParams>
-    <Units Count="1">
+    <Units Count="6">
       <Unit0>
         <Filename Value="pas2js.pp"/>
         <IsPartOfProject Value="True"/>
       </Unit0>
+      <Unit1>
+        <Filename Value="../../packages/pastojs/src/pas2jspcucompiler.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="Pas2JSPCUCompiler"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="../../packages/pastojs/src/pas2jscompilercfg.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="../../packages/pastojs/src/pas2jsfs.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="Pas2JSFS"/>
+      </Unit3>
+      <Unit4>
+        <Filename Value="../../packages/pastojs/src/pas2jscompilerpp.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit4>
+      <Unit5>
+        <Filename Value="../../packages/pastojs/src/pas2jsfscompiler.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="Pas2JSFSCompiler"/>
+      </Unit5>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

+ 7 - 4
utils/pas2js/pas2js.pp

@@ -12,7 +12,8 @@ uses
   cthreads, cwstring,
   {$ENDIF}
   Classes, SysUtils, CustApp,
-  Pas2jsFileUtils, Pas2jsLogger, Pas2jsCompiler;
+  Pas2jsFileUtils, Pas2jsLogger, Pas2jsCompiler,
+  Pas2JSFSCompiler, Pas2JSCompilerPP, Pas2JSCompilerCfg;
 
 Type
 
@@ -20,14 +21,14 @@ Type
 
   TPas2jsCLI = class(TCustomApplication)
   private
-    FCompiler: TPas2jsCompiler;
+    FCompiler: TPas2JSFSCompiler;
     FWriteOutputToStdErr: Boolean;
   protected
     procedure DoRun; override;
   public
     constructor Create(TheOwner: TComponent); override;
     destructor Destroy; override;
-    property Compiler: TPas2jsCompiler read FCompiler;
+    property Compiler: TPas2JSFSCompiler read FCompiler;
     property WriteOutputToStdErr: Boolean read FWriteOutputToStdErr write FWriteOutputToStdErr;
   end;
 
@@ -66,7 +67,9 @@ constructor TPas2jsCLI.Create(TheOwner: TComponent);
 begin
   inherited Create(TheOwner);
   StopOnException:=True;
-  FCompiler:=TPas2jsCompiler.Create;
+  FCompiler:=TPas2JSFSCompiler.Create;
+  FCompiler.ConfigSupport:=TPas2JSFileConfigSupport.Create(FCompiler);
+  FCompiler.PostProcessorSupport:=TPas2JSFSPostProcessorSupport.Create(FCompiler);
 end;
 
 destructor TPas2jsCLI.Destroy;

+ 97 - 0
utils/pas2js/pas2jswebcompiler.pp

@@ -0,0 +1,97 @@
+unit pas2jswebcompiler;
+
+{$mode objfpc}
+
+interface
+
+uses
+  Classes, SysUtils, pas2jsfs, pasuseanalyzer, pas2jscompiler, FPPJsSrcMap, webfilecache;
+
+Type
+
+  { TPas2JSWebcompiler }
+
+  TPas2JSWebcompiler = Class(TPas2JSCompiler)
+  private
+    function GetWebFS: TPas2JSWebFS;
+  Protected
+    function DoWriteJSFile(const DestFilename: String; aWriter: TPas2JSMapper): Boolean; override;
+    function CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet; override;
+    function CreateFS : TPas2JSFS; override;
+  Public
+    Property WebFS : TPas2JSWebFS read GetWebFS;
+  end;
+
+implementation
+
+uses js;
+
+function Pas2jsCompilerFile_FilenameToKeyName(Item: Pointer): String;
+var
+  aFile: TPas2jsCompilerFile absolute Item;
+begin
+  Result:=LowerCase(aFile.PasFilename);
+end;
+
+function PtrUnitnameToKeyName(Item: Pointer): String;
+var
+  aUnitName: string absolute Item;
+begin
+  Result:=LowerCase(aUnitName);
+end;
+
+function Pas2jsCompilerFile_UnitnameToKeyName(Item: Pointer): String;
+var
+  aFile: TPas2jsCompilerFile absolute Item;
+begin
+  Result:=LowerCase(aFile.PasUnitName);
+end;
+
+function PtrFilenameToKeyName(FilenameAsPtr: Pointer): string;
+var
+  Filename: String absolute FilenameAsPtr;
+begin
+  Result:=LowerCase(Filename);
+end;
+
+
+{ TPas2JSWebcompiler }
+
+function TPas2JSWebcompiler.GetWebFS: TPas2JSWebFS;
+begin
+  Result:=TPas2JSWebFS(FS)
+end;
+
+function TPas2JSWebcompiler.DoWriteJSFile(const DestFilename: String; aWriter: TPas2JSMapper): Boolean;
+
+Var
+  S : String;
+  T : String;
+
+begin
+//  Writeln('aWriter',AWriter.BufferLength,', array size ',Length(AWriter.Buffer));
+  S:=TJSArray(AWriter.Buffer).Join('');
+//  Writeln('TPas2JSWebcompiler.DoWriteJSFile(',DestFileName,') (',Length(S),' chars): ',S);
+  WebFS.SetFileContent(DestFileName,S);
+  Result:=True;
+end;
+
+function TPas2JSWebcompiler.CreateSetOfCompilerFiles(keyType: TKeyCompareType): TPasAnalyzerKeySet;
+begin
+  Case keyType of
+    kcFileName:
+      Result:=TPasAnalyzerKeySet.Create(@Pas2jsCompilerFile_FilenameToKeyName,@PtrFilenameToKeyName);
+    kcUnitName:
+      Result:=TPasAnalyzerKeySet.Create(@Pas2jsCompilerFile_UnitnameToKeyName,@PtrUnitnameToKeyName);
+  else
+    Raise EPas2jsFS.CreateFmt('Internal Unknown key type: %d',[Ord(KeyType)]);
+  end;
+end;
+
+function TPas2JSWebcompiler.CreateFS: TPas2JSFS;
+begin
+  Result:=TPas2JSWebFS.Create;
+end;
+
+end.
+

+ 530 - 0
utils/pas2js/webfilecache.pp

@@ -0,0 +1,530 @@
+unit webfilecache;
+
+{$mode objfpc}
+
+// Enable this to write lots of debugging info to the browser console.
+{ $DEFINE VERBOSEWEBCACHE}
+
+interface
+
+uses
+  Classes, SysUtils, JS, Web, fpjson, pas2jsfs, pscanner, contnrs;
+
+type
+  TPas2jsWebFS = Class;
+
+  { TWebFileContent }
+
+  TWebFileContent = Class(TObject)
+  private
+    FContents: string;
+    FFileName: String;
+    FModified: Boolean;
+    procedure SetContents(AValue: string);
+  Public
+    Constructor Create(const aFileName,aContents : String);
+    Property FileName : String Read FFileName Write FFileName;
+    Property Contents : string Read FContents Write SetContents;
+    Property Modified : Boolean Read FModified;
+  end;
+  { TWebFilesCache }
+
+  TWebFilesCache = Class(TObject)
+  Private
+    FFiles : TFPObjectHashTable;
+    Function FindFile(aFileName : String) : TWebFileContent;
+  Public
+    Constructor Create;
+    Destructor Destroy; override;
+    Function HasFile(aFileName : String) : Boolean;
+    Function GetFileContent(Const aFileName : String) : String;
+    function SetFileContent(const aFileName, aContent: String): Boolean;
+  end;
+
+  { TPas2jsWebFile }
+
+  TPas2jsWebFile = Class(TPas2jsFile)
+  public
+    function CreateLineReader(RaiseOnError: boolean): TSourceLineReader; override;
+    function Load(RaiseOnError: boolean; Binary: boolean): boolean; override;
+  end;
+
+  { TWebSourceLineReader }
+
+  TWebSourceLineReader = Class(TSourceLineReader)
+  private
+    FFS: TPas2jsFS;
+  Protected
+    Property FS : TPas2jsFS Read FFS;
+    Procedure IncLineNumber; override;
+  end;
+
+  // aFileName is the original filename, not normalized one
+  TLoadFileEvent = Reference to Procedure(Sender : TObject; aFileName : String; aError : string);
+
+  { TLoadFileRequest }
+
+  TLoadFileRequest = Class(TObject)
+    FFS : TPas2jsWebFS;
+    FFileName : string;
+    FXML : TJSXMLHttpRequest;
+    FOnLoaded : TLoadFileEvent;
+  private
+    procedure DoChange;
+  Public
+    constructor Create(aFS: TPas2jsWebFS; const aFileName : string; aOnLoaded: TLoadFileEvent);
+    Procedure DoLoad(const aURL : String);
+  end;
+
+
+  { TPas2jsWebFS }
+
+  TPas2jsWebFS = Class(TPas2jsFS)
+  Private
+    FCache : TWebFilesCache;
+    FLoadBaseURL: String;
+    FOnLoadedFile: TLoadFileEvent;
+  protected
+    // Only for names, no paths
+    Class Function NormalizeFileName(Const aFileName : String) : String;
+    function FindSourceFileName(const aFilename: string): String; override;
+  public
+    Constructor Create; override;
+    // Overrides
+    function CreateResolver: TPas2jsFSResolver; override;
+    function FileExists(const aFileName: String): Boolean; override;
+    function FindCustomJSFileName(const aFilename: string): String; override;
+    function FindIncludeFileName(const aFilename: string): String; override;
+    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; override;
+    function FindUnitJSFileName(const aUnitFilename: string): String; override;
+    function LoadFile(Filename: string; Binary: boolean=false): TPas2jsFile; override;
+    procedure SaveToFile(ms: TFPJSStream; Filename: string); override;
+    Function SetFileContent(Const aFileName,aContents : String) : Boolean;
+    Function GetFileContent(Const aFileName : String) : String;
+    // Returns false if the file was already loaded. OnLoaded is called in either case.
+    Function LoadFile(aFileName : String; OnLoaded : TLoadFileEvent = Nil) : Boolean;
+    // Returns number of load requests. OnLoaded is called for each file in the list
+    Function LoadFiles(aList : TStrings;OnLoaded : TLoadFileEvent = Nil) : Integer;
+    Function LoadFiles(aList : array of String;OnLoaded : TLoadFileEvent = Nil) : integer;
+    Property OnLoadedFile : TLoadFileEvent Read FOnLoadedFile Write FOnLoadedFile;
+    Property LoadBaseURL : String Read FLoadBaseURL Write FLoadBaseURL;
+  end;
+
+  { TPas2jsFileResolver }
+
+  { TPas2jsWebResolver }
+
+  TPas2jsWebResolver = class(TPas2jsFSResolver)
+  private
+    function GetWebFS: TPas2jsWebFS;
+  public
+    Property WebFS : TPas2jsWebFS Read GetWebFS;
+  end;
+
+implementation
+
+{ TWebSourceLineReader }
+
+procedure TWebSourceLineReader.IncLineNumber;
+begin
+  if (FFS<>nil) then
+    FFS.IncReadLineCounter;
+  inherited IncLineNumber;
+end;
+
+{ TLoadFileRequest }
+
+procedure TLoadFileRequest.DoChange;
+
+Var
+  Err : String;
+begin
+  Case FXML.readyState of
+    TJSXMLHttpRequest.UNSENT : ;
+    TJSXMLHttpRequest.OPENED : ;
+    TJSXMLHttpRequest.HEADERS_RECEIVED : ;
+    TJSXMLHttpRequest.LOADING : ;
+    TJSXMLHttpRequest.DONE :
+      begin
+      if (FXML.Status div 100)=2 then
+        begin
+        Err:='';
+        // FS will normalize filename
+        FFS.SetFileContent(FFileName,FXML.responsetext)
+        end
+      else
+        Err:='Error loading file: '+FXML.StatusText;
+      If Assigned(FOnLoaded) then
+        FOnLoaded(FFS,FFileName,Err);
+      if Assigned(FFS.OnLoadedFile) then
+        FFS.OnLoadedFile(FFS,FFileName,Err);
+      Free;
+      end;
+  end
+end;
+
+constructor TLoadFileRequest.Create(aFS: TPas2jsWebFS; const aFileName : string; aOnLoaded: TLoadFileEvent);
+begin
+  FFS:=aFS;
+  FOnLoaded:=aOnLoaded;
+  FFileName:=aFileName;
+end;
+
+Procedure TLoadFileRequest.DoLoad(const aURL: String);
+begin
+  FXML:=TJSXMLHttpRequest.new;
+  FXML.onreadystatechange:=@DoChange;
+  // Maybe one day allow do this sync, so the compiler can load files on demand.
+  FXML.Open('GET',aURL);
+  FXML.Send;
+end;
+
+{ TPas2jsWebFile }
+
+function TPas2jsWebFile.CreateLineReader(RaiseOnError: boolean): TSourceLineReader;
+begin
+  {$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': Creating line reader for ',FileName);
+  {$ENDIF}
+  if Load(RaiseOnError,False) then
+    begin
+    Result:=TWebSourceLineReader.Create(FileName,Source);
+    TWebSourceLineReader(Result).FFS:=Self.FS;
+    end
+  else
+    Result:=Nil;
+end;
+
+function TPas2jsWebFile.Load(RaiseOnError: boolean; Binary: boolean): boolean;
+begin
+  Result:=False;
+  {$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': Loading for ',FileName);
+  {$ENDIF}
+  With (FS as TPas2jsWebFS).FCache do
+    if HasFile(FileName) then
+      begin
+      SetSource(GetFileContent(FileName));
+      Result:=True;
+      end;
+  if Not Result then
+    if RaiseOnError then
+      Raise EFileNotFoundError.Create('File not loaded '+FileName)
+{$IFDEF VERBOSEWEBCACHE}
+    else Writeln('File not loaded '+FileName);
+{$ENDIF}
+end;
+
+{ TWebFilesCache }
+
+function TWebFilesCache.FindFile(aFileName: String): TWebFileContent;
+
+Var
+  N : THTCustomNode;
+
+begin
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': Looking for file : ',aFileName);
+{$ENDIF}
+  N:=FFiles.Find(aFileName);
+  if N=Nil then
+    result:=Nil
+  else
+    Result:=TWebFileContent(THTObjectNode(N).Data);
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': Looking for file : ',aFileName, ': ',Assigned(Result));
+{$ENDIF}
+end;
+
+constructor TWebFilesCache.Create;
+begin
+  FFiles:=TFPObjectHashTable.Create(True);
+end;
+
+destructor TWebFilesCache.Destroy;
+begin
+  FreeAndNil(FFiles);
+  inherited Destroy;
+end;
+
+function TWebFilesCache.HasFile(aFileName: String): Boolean;
+begin
+  Result:=FindFile(aFileName)<>Nil;
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': HasFile(',aFileName,') : ',Result);
+{$ENDIF}
+end;
+
+function TWebFilesCache.GetFileContent(const aFileName: String): String;
+
+Var
+  W : TWebFileContent;
+
+begin
+  {$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': GetFileContent(',aFileName,')');
+  {$ENDIF}
+  W:=FindFile(aFileName);
+  if Assigned(W) then
+    Result:=W.Contents
+  else
+    Raise EFileNotFoundError.Create('No such file '+AFileName);
+end;
+
+function TWebFilesCache.SetFileContent(const aFileName, aContent: String) : Boolean;
+
+Var
+  W : TWebFileContent;
+
+begin
+  {$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': SetFileContent(',aFileName,')');
+  {$ENDIF}
+  W:=FindFile(aFileName);
+  Result:=Assigned(W);
+  if Result then
+    W.Contents:=aContent
+  else
+    FFiles.Add(aFileName,TWebFileContent.Create(aFileName,aContent));
+end;
+
+{ TWebFileContent }
+
+procedure TWebFileContent.SetContents(AValue: string);
+begin
+  if FContents=AValue then Exit;
+  FContents:=AValue;
+  FModified:=True;
+end;
+
+constructor TWebFileContent.Create(const aFileName, aContents: String);
+begin
+  FContents:=aContents;
+  FFileName:=aFileName;
+end;
+
+
+{ TPas2jsWebFS }
+
+function TPas2jsWebFS.FileExists(const aFileName: String): Boolean;
+begin
+  {$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FileExists(',aFileName,')');
+  {$ENDIF}
+  Result:=FCache.HasFile(NormalizeFileName(aFileName));
+  {$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FileExists(',aFileName,') : ',Result);
+  {$ENDIF}
+end;
+
+function TPas2jsWebFS.FindCustomJSFileName(const aFilename: string): String;
+begin
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindCustomJSFileName(',aFileName,')');
+{$ENDIF}
+  Result:=NormalizeFileName(aFileName);
+  If not FCache.HasFile(Result) then
+    Result:='';
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindCustomJSFileName(',aFileName,'): ',Result);
+{$ENDIF}
+end;
+
+function TPas2jsWebFS.FindIncludeFileName(const aFilename: string): String;
+begin
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindIncludeFileName(',aFileName,')');
+{$ENDIF}
+  Result:=NormalizeFileName(aFileName);
+  If not FCache.HasFile(Result) then
+    Result:='';
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindIncludeFileName(',aFileName,') : ',Result);
+{$ENDIF}
+end;
+
+class function TPas2jsWebFS.NormalizeFileName(const aFileName: String): String;
+begin
+  Result:=LowerCase(ExtractFileName(aFileName));
+end;
+
+function TPas2jsWebFS.FindSourceFileName(const aFilename: string): String;
+begin
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindSourceFileName(',aFileName,')');
+{$ENDIF}
+  Result:=NormalizeFileName(aFileName);
+  If not FCache.HasFile(Result) then
+    Result:='';
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindSourceFileName(',aFileName,') : ',Result);
+{$ENDIF}
+end;
+
+constructor TPas2jsWebFS.Create;
+begin
+  inherited Create;
+  FCache:=TWebFilesCache.Create;
+end;
+
+function TPas2jsWebFS.CreateResolver: TPas2jsFSResolver;
+begin
+  Result:=TPas2jsWebResolver.Create(Self);
+end;
+
+function TPas2jsWebFS.FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String;
+begin
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindUnitFileName(',aUnitName,')');
+{$ENDIF}
+  Result:=NormalizeFileName(aUnitName+'.pas');
+  isForeign:=False;
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindUnitFileName(',aUnitName,') : ',Result);
+{$ENDIF}
+end;
+
+function TPas2jsWebFS.FindUnitJSFileName(const aUnitFilename: string): String;
+begin
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindUnitJSFileName(',aUnitFileName,')');
+{$ENDIF}
+  Result:=NormalizeFileName(aUnitFileName);
+{$IFDEF VERBOSEWEBCACHE}
+  Writeln(ClassName,': FindUnitJSFileName(',aUnitFileName,') : ',Result);
+{$ENDIF}
+end;
+
+function TPas2jsWebFS.LoadFile(Filename: string; Binary: boolean): TPas2jsFile;
+
+begin
+  Result:=TPas2jsWebFile.Create(Self,FileName);
+  Result.Load(True,False);
+end;
+
+(*
+  // Check if we should not be using this instead, as the compiler outputs UTF8 ?
+  // Found on
+  // https://weblog.rogueamoeba.com/2017/02/27/javascript-correctly-converting-a-byte-array-to-a-utf-8-string/
+function stringFromUTF8Array(data)
+  {
+    const extraByteMap = [ 1, 1, 1, 1, 2, 2, 3, 0 ];
+    var count = data.length;
+    var str = "";
+
+    for (var index = 0;index < count;)
+    {
+      var ch = data[index++];
+      if (ch & 0x80)
+      {
+        var extra = extraByteMap[(ch >> 3) & 0x07];
+        if (!(ch & 0x40) || !extra || ((index + extra) > count))
+          return null;
+
+        ch = ch & (0x3F >> extra);
+        for (;extra > 0;extra -= 1)
+        {
+          var chx = data[index++];
+          if ((chx & 0xC0) != 0x80)
+            return null;
+
+          ch = (ch << 6) | (chx & 0x3F);
+        }
+      }
+
+      str += String.fromCharCode(ch);
+    }
+
+    return str;
+  }
+*)
+procedure TPas2jsWebFS.SaveToFile(ms: TFPJSStream; Filename: string);
+
+Var
+  aContent : String;
+  i : Integer;
+  v : JSValue;
+
+begin
+  aContent:='';
+  for I:=0 to MS.Length-1 do
+    begin
+    v:=MS[i];
+    {AllowWriteln}
+    Writeln('Char ',i,'(',v,') : ',TJSString.fromCharCode(v));
+    {AllowWriteln-}
+    aContent:=aContent+TJSString.fromCharCode(MS[i]);
+    end;
+  SetFileContent(FileName,aContent);
+end;
+
+function TPas2jsWebFS.SetFileContent(const aFileName, aContents: String): Boolean;
+begin
+  Result:=FCache.SetFileContent(NormalizeFileName(aFileName),aContents);
+end;
+
+function TPas2jsWebFS.GetFileContent(const aFileName: String): String;
+begin
+  Result:=FCache.GetFileContent(NormalizeFileName(aFileName));
+end;
+
+function TPas2jsWebFS.LoadFile(aFileName: String; OnLoaded: TLoadFileEvent): Boolean;
+
+Var
+  FN : String;
+  aURL : String;
+  LF : TLoadFileRequest;
+
+begin
+  FN:=NormalizeFileName(aFileName);
+  Result:=Not FCache.HasFile(FN);
+  if Not result then
+    begin
+    // It is already loaded
+    if Assigned(OnLoaded) then
+      OnLoaded(Self,aFileName,'')
+    end
+  else
+    begin
+    // Not yet already loaded
+    aURL:=IncludeTrailingPathDelimiter(LoadBaseURL)+FN;
+    LF:=TLoadFileRequest.Create(Self,aFileName,OnLoaded);
+    LF.DoLoad(aURL);
+    end;
+end;
+
+Function TPas2jsWebFS.LoadFiles(aList: TStrings; OnLoaded: TLoadFileEvent): Integer;
+
+Var
+  i: Integer;
+
+begin
+  Result:=0;
+  For I:=0 to aList.Count-1 do
+    if LoadFile(aList[i],OnLoaded) then
+      Inc(Result);
+end;
+
+function TPas2jsWebFS.LoadFiles(aList: array of String; OnLoaded: TLoadFileEvent): Integer;
+
+Var
+  i: Integer;
+
+begin
+  Result:=0;
+  For I:=0 to Length(aList)-1 do
+    if LoadFile(aList[i],OnLoaded) then
+      Inc(Result);
+end;
+
+{ TPas2jsWebResolver }
+
+function TPas2jsWebResolver.GetWebFS: TPas2jsWebFS;
+begin
+  Result:=TPas2jsWebFS(FS)
+end;
+
+
+
+end.
+

部分文件因为文件数量过多而无法显示