* synchronised with trunk till r40503

git-svn-id: branches/debug_eh@40504 -

.gitattributes

@@ -1186,6 +1186,7 @@ packages/arosunits/src/layers.pas svneol=native#text/plain
 packages/arosunits/src/locale.pas svneol=native#text/pascal
 packages/arosunits/src/longarray.pas svneol=native#text/plain
 packages/arosunits/src/mui.pas svneol=native#text/plain
+packages/arosunits/src/serial.pas svneol=native#text/plain
 packages/arosunits/src/tagsarray.pas svneol=native#text/plain
 packages/arosunits/src/timer.pas svneol=native#text/plain
 packages/arosunits/src/utility.pas svneol=native#text/plain
@@ -6291,6 +6292,7 @@ packages/morphunits/src/keymap.pas svneol=native#text/plain
 packages/morphunits/src/layers.pas svneol=native#text/plain
 packages/morphunits/src/locale.pas svneol=native#text/pascal
 packages/morphunits/src/mui.pas svneol=native#text/plain
+packages/morphunits/src/serial.pas svneol=native#text/plain
 packages/morphunits/src/timer.pas svneol=native#text/plain
 packages/morphunits/src/tinygl.pas svneol=native#text/plain
 packages/morphunits/src/utility.pas svneol=native#text/plain
@@ -6778,6 +6780,7 @@ packages/os4units/src/layers.pas svneol=native#text/pascal
 packages/os4units/src/locale.pas svneol=native#text/pascal
 packages/os4units/src/mui.pas svneol=native#text/pascal
 packages/os4units/src/picasso96api.pas svneol=native#text/pascal
+packages/os4units/src/serial.pas svneol=native#text/plain
 packages/os4units/src/timer.pas svneol=native#text/pascal
 packages/os4units/src/utility.pas svneol=native#text/pascal
 packages/os4units/src/workbench.pas svneol=native#text/pascal
@@ -17452,6 +17455,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
@@ -17459,6 +17463,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

compiler/dbgdwarf.pas

@@ -2265,7 +2265,7 @@ implementation
 
       var
         procendlabel   : tasmlabel;
-        procentry      : string;
+        procentry,s    : string;
         cc             : Tdwarf_calling_convention;
         st             : tsymtable;
         vmtoffset      : pint;
@@ -2318,6 +2318,19 @@ implementation
           append_entry(DW_TAG_subprogram,true,
             [DW_AT_name,DW_FORM_string,def.mangledname+#0]);
 
+        if (ds_dwarf_cpp in current_settings.debugswitches) and (def.owner.symtabletype in [objectsymtable,recordsymtable]) then
+          begin
+            { If C++ emulation is enabled, add DW_AT_linkage_name attribute for methods.
+              LLDB uses it to display fully qualified method names.
+              Add a simple C++ mangled name without params to achieve at least "Class::Method()"
+              instead of just "Method" in LLDB. }
+            s:=tabstractrecorddef(def.owner.defowner).objrealname^;
+            procentry:=Format('_ZN%d%s', [Length(s), s]);
+            s:=symname(def.procsym, false);
+            procentry:=Format('%s%d%sEv'#0, [procentry, Length(s), s]);
+            append_attribute(DW_AT_linkage_name,DW_FORM_string, [procentry]);
+          end;
+
         append_proc_frame_base(list,def);
 
         { Append optional flags. }
@@ -4303,6 +4316,13 @@ implementation
         end;
 
       begin
+        if (ds_dwarf_cpp in current_settings.debugswitches) then
+          begin
+            // At least LLDB 6.0.0 does not like this implementation of string types.
+            // Call the inherited DWARF 2 implementation, which works fine.
+            inherited;
+            exit;
+          end;
         case def.stringtype of
           st_shortstring:
             begin

compiler/hlcgobj.pas

@@ -5216,7 +5216,9 @@ implementation
             gen_load_loc_function_result(list,retdef,ressym.localloc);
         end
       else
-        gen_load_uninitialized_function_result(list,current_procinfo.procdef,retdef,current_procinfo.procdef.funcretloc[calleeside])
+        gen_load_uninitialized_function_result(list,current_procinfo.procdef,retdef,current_procinfo.procdef.funcretloc[calleeside]);
+      if ressym.localloc.loc=LOC_REFERENCE then
+        tg.UnGetLocal(list,ressym.localloc.reference);
     end;
 
   procedure thlcgobj.gen_stack_check_size_para(list: TAsmList);

compiler/llvm/hlcgllvm.pas

@@ -47,6 +47,7 @@ uses
       procedure getcpuregister(list: TAsmList; r: Tregister); override;
       procedure ungetcpuregister(list: TAsmList; r: Tregister); override;
       procedure alloccpuregisters(list: TAsmList; rt: Tregistertype; const r: Tcpuregisterset); override;
+      procedure allocallcpuregisters(list: TAsmList); override;
       procedure deallocallcpuregisters(list: TAsmList); override;
 
       procedure a_bit_test_reg_reg_reg(list: TAsmList; bitnumbersize, valuesize, destsize: tdef; bitnumber, value, destreg: tregister); override;
@@ -344,6 +345,12 @@ implementation
     end;
 
 
+  procedure thlcgllvm.allocallcpuregisters(list: TAsmList);
+    begin
+      { don't do anything }
+    end;
+
+
   procedure thlcgllvm.deallocallcpuregisters(list: TAsmList);
     begin
       { don't do anything }

compiler/llvm/llvmdef.pas

@@ -726,6 +726,41 @@ implementation
                 encodedstr:=encodedstr+'* byval'
               else
                 encodedstr:=encodedstr+'*';
+            end
+          else if withattributes and
+             paramanager.push_addr_param(hp.varspez,hp.vardef,proccalloption) then
+            begin
+              { it's not valid to take the address of a parameter and store it for
+                use past the end of the function call (since the address can always
+                be on the stack and become invalid later) }
+              encodedstr:=encodedstr+' nocapture';
+              { open array/array of const/variant array may be a valid pointer but empty }
+              if not is_special_array(hp.vardef) and
+                 { e.g. empty records }
+                 (hp.vardef.size<>0) then
+                begin
+                  case hp.varspez of
+                    vs_value,
+                    vs_const:
+                      begin
+                        encodedstr:=encodedstr+' nocapture dereferenceable('
+                      end;
+                    vs_var,
+                    vs_out,
+                    vs_constref:
+                      begin
+                        { while normally these are not nil, it is technically possible
+                          to pass nil via ptrtype(nil)^ }
+                        encodedstr:=encodedstr+' nocapture dereferenceable_or_null('
+                      end;
+                    else
+                      internalerror(2018120801);
+                  end;
+                  if hp.vardef.typ<>formaldef then
+                    encodedstr:=encodedstr+tostr(hp.vardef.size)+')'
+                  else
+                    encodedstr:=encodedstr+'1)';
+                end;
             end;
           if withparaname then
             begin

compiler/llvm/tgllvm.pas

@@ -57,6 +57,9 @@ unit tgllvm;
        protected
         procedure alloctemp(list: TAsmList; size: asizeint; alignment: shortint; temptype: ttemptype; def: tdef; fini: boolean; out ref: treference); override;
         procedure gethltempintern(list: TAsmList; def: tdef; alignment: shortint; forcesize: asizeint; temptype: ttemptype; out ref: treference);
+        procedure freetemphook(list: TAsmList; temp: ptemprecord); override;
+
+        procedure emit_lifetime(list: TAsmList; const procname: string; temp: ptemprecord);
        public
         alloclist: tasmlist;
 
@@ -79,8 +82,8 @@ implementation
        systems,verbose,
        procinfo,
        llvmbase,aasmllvm,
-       symconst,symdef,
-       cgobj
+       symconst,symtable,symdef,defutil,
+       paramgr,parabase,cgobj,hlcgobj
        ;
 
 
@@ -106,8 +109,8 @@ implementation
         templist:=tl;
         temp_to_ref(tl,ref);
         list.concat(tai_tempalloc.alloc(tl^.pos,tl^.size));
-        { TODO: add llvm.lifetime.start() for this allocation and afterwards
-            llvm.lifetime.end() for freetemp (if the llvm version supports it) }
+
+        emit_lifetime(list,'llvm_lifetime_start',tl);
         inc(lasttemp);
         { allocation for the temp -- should have lineinfo of the start of the
           routine }
@@ -136,6 +139,37 @@ implementation
       end;
 
 
+    procedure ttgllvm.freetemphook(list: TAsmList; temp: ptemprecord);
+      begin
+        inherited;
+        emit_lifetime(list,'llvm_lifetime_end',temp);
+      end;
+
+
+    procedure ttgllvm.emit_lifetime(list: TAsmList; const procname: string; temp: ptemprecord);
+      var
+        sizepara, ptrpara: tcgpara;
+        pd: tprocdef;
+        ref: treference;
+      begin
+        if (temp^.size<>0) and
+           not is_managed_type(temp^.def) then
+          begin
+            temp_to_ref(temp,ref);
+            sizepara.init;
+            ptrpara.init;
+            pd:=search_system_proc(procname);
+            paramanager.getintparaloc(list,pd,1,sizepara);
+            paramanager.getintparaloc(list,pd,2,ptrpara);
+            hlcg.a_load_const_cgpara(list,sizepara.def,temp^.size,sizepara);
+            hlcg.a_loadaddr_ref_cgpara(list,temp^.def,ref,ptrpara);
+            hlcg.g_call_system_proc(list,pd,[@sizepara,@ptrpara],nil).resetiftemp;
+            sizepara.reset;
+            ptrpara.reset;
+          end;
+      end;
+
+
     procedure ttgllvm.temp_to_ref(p: ptemprecord; out ref: treference);
       var
         temppos: treftemppos;
@@ -178,7 +212,7 @@ implementation
 
     procedure ttgllvm.gethltemp(list: TAsmList; def: tdef; forcesize: asizeint; temptype: ttemptype; out ref: treference);
       begin
-        gethltempintern(list,def,def.alignment,forcesize,tt_persistent,ref);
+        gethltempintern(list,def,def.alignment,forcesize,temptype,ref);
       end;
 
 

compiler/ncgutil.pas

@@ -1812,7 +1812,11 @@ implementation
                           cg.a_reg_sync(list,localloc.register);
                       LOC_REFERENCE :
                         begin
-                          if typ in [localvarsym,paravarsym] then
+                          { can't free the result, because we load it after
+                            this call into the function result location
+                            (gets freed in thlcgobj.gen_load_return_value() }
+                          if (typ in [localvarsym,paravarsym]) and
+                             (([vo_is_funcret,vo_is_result]*varoptions)=[]) then
                             tg.Ungetlocal(list,localloc.reference);
                         end;
                     end;

compiler/tgobj.pas

@@ -64,6 +64,7 @@ unit tgobj;
           procedure alloctemp(list: TAsmList; size: asizeint; alignment: shortint; temptype: ttemptype; def: tdef; fini: boolean; out ref: treference); virtual;
           procedure freetemp(list: TAsmList; pos: treftemppos; temptypes: ttemptypeset);virtual;
           procedure gettempinternal(list: TAsmList; size: asizeint; alignment: shortint; temptype: ttemptype; def: tdef; fini: boolean; out ref : treference);
+          procedure freetemphook(list: TAsmList; temp: ptemprecord); virtual;
        public
           { contains all temps }
           templist      : ptemprecord;
@@ -502,7 +503,7 @@ implementation
 {$endif}
                   exit;
                 end;
-               list.concat(tai_tempalloc.dealloc(hp^.pos,hp^.size));
+               freetemphook(list,hp);
                { set this block to free }
                hp^.temptype:=Used2Free[hp^.temptype];
                { Update tempfreelist }
@@ -573,7 +574,6 @@ implementation
       end;
 
 
-
     procedure ttgobj.gettemp(list: TAsmList; size: asizeint; alignment: shortint; temptype: ttemptype; out ref : treference);
       begin
         gettempinternal(list,size,alignment,temptype,nil,false,ref);
@@ -589,6 +589,12 @@ implementation
       end;
 
 
+    procedure ttgobj.freetemphook(list: TAsmList; temp: ptemprecord);
+      begin
+        list.concat(tai_tempalloc.dealloc(temp^.pos,temp^.size));
+      end;
+
+
     procedure ttgobj.gettempmanaged(list: TAsmList; def:tdef;temptype:ttemptype;out ref : treference);
       begin
         gettempinternal(list,def.size,def.alignment,temptype,def,true,ref);

installer/Makefile.fpc

@@ -19,10 +19,9 @@ files_linux=installer.pas
 files_freebsd=installer.pas
 
 [require]
-packages=rtl-console fv unzip rtl-extra
+packages=rtl-console fv unzip rtl-extra ide
 
 [compiler]
-unitdir=../ide
 
 [install]
 fpcpackage=y

packages/amunits/src/coreunits/serial.pas

@@ -16,25 +16,23 @@
 
 unit serial;
 
-INTERFACE
+interface
+{$PACKRECORDS 2}
 
-uses exec;
+uses
+  exec;
 
+type
 
-Type
+  // array of termination char's to use,see serial.doc setparams
+  PIOTArray = ^TIOTArray;
+  TIOTArray = record
+    TermArray0: LongWord;
+    TermArray1: LongWord;
+  end;
 
-                   { array of termination char's }
-                   { to use,see serial.doc setparams }
-
-    pIOTArray = ^tIOTArray;
-    tIOTArray = record
-        TermArray0 : ULONG;
-        TermArray1 : ULONG;
-    end;
-
-Const
-
-    SER_DEFAULT_CTLCHAR = $11130000;    { default chars for xON,xOFF }
+const
+  SER_DEFAULT_CTLCHAR = $11130000; // default chars for xON,xOFF
 
 { You may change these via SETPARAMS.   At this time, parity is not
    calculated for xON/xOFF characters.  You must supply them with the
@@ -45,151 +43,123 @@ Const
    IOExtSer-sized structure or you may overlay innocent memory !! }
 {****************************************************************}
 
-Type
-
-    pIOExtSer = ^tIOExtSer;
-    tIOExtSer = record
-        IOSer   : tIOStdReq;
-
-{     STRUCT    MsgNode
-*   0   APTR     Succ
-*   4   APTR     Pred
-*   8   UBYTE    Type
-*   9   UBYTE    Pri
-*   A   APTR     Name
-*   E   APTR     ReplyPort
-*  12   UWORD    MNLength
-*     STRUCT   IOExt
-*  14   APTR     io_Device
-*  18   APTR     io_Unit
-*  1C   UWORD    io_Command
-*  1E   UBYTE    io_Flags
-*  1F   UBYTE    io_Error
-*     STRUCT   IOStdExt
-*  20   ULONG    io_Actual
-*  24   ULONG    io_Length
-*  28   APTR     io_Data
-*  2C   ULONG    io_Offset
-*
-*  30 }
-
-        io_CtlChar      : ULONG; { control char's (order = xON,xOFF,INQ,ACK) }
-        io_RBufLen      : ULONG; { length in bytes of serial port's read buffer }
-        io_ExtFlags     : ULONG; { additional serial flags (see bitdefs below) }
-        io_Baud         : ULONG; { baud rate requested (true baud) }
-        io_BrkTime      : ULONG; { duration of break signal in MICROseconds }
-        io_TermArray    : tIOTArray; { termination character array }
-        io_ReadLen      : Byte;   { bits per read character (# of bits) }
-        io_WriteLen     : Byte;   { bits per write character (# of bits) }
-        io_StopBits     : Byte;   { stopbits for read (# of bits) }
-        io_SerFlags     : Byte;   { see SerFlags bit definitions below   }
-        io_Status       : Word;
-    end;
-
-   { status of serial port, as follows:
-*                  BIT  ACTIVE  FUNCTION
-*                   0    ---    reserved
-*                   1    ---    reserved
-*                   2    high   Connected to parallel "select" on the A1000.
-*                               Connected to both the parallel "select" and
-*                               serial "ring indicator" pins on the A500 &
-*                               A2000.  Take care when making cables.
-*                   3    low    Data Set Ready
-*                   4    low    Clear To Send
-*                   5    low    Carrier Detect
-*                   6    low    Ready To Send
-*                   7    low    Data Terminal Ready
-*                   8    high   read overrun
-*                   9    high   break sent
-*                  10    high   break received
-*                  11    high   transmit x-OFFed
-*                  12    high   receive x-OFFed
-*               13-15           reserved
-}
-
-Const
-
-    SDCMD_QUERY         = CMD_NONSTD;
-    SDCMD_BREAK         = CMD_NONSTD + 1;
-    SDCMD_SETPARAMS     = CMD_NONSTD + 2;
-
-
-    SERB_XDISABLED      = 7;    { io_SerFlags xOn-xOff feature disabled bit }
-    SERF_XDISABLED      = 128;  {    "      xOn-xOff feature disabled mask }
-    SERB_EOFMODE        = 6;    {    "      EOF mode enabled bit }
-    SERF_EOFMODE        = 64;   {    "      EOF mode enabled mask }
-    SERB_SHARED         = 5;    {    "      non-exclusive access bit }
-    SERF_SHARED         = 32;   {    "      non-exclusive access mask }
-    SERB_RAD_BOOGIE     = 4;    {    "      high-speed mode active bit }
-    SERF_RAD_BOOGIE     = 16;   {    "      high-speed mode active mask }
-    SERB_QUEUEDBRK      = 3;    {    "      queue this Break ioRqst }
-    SERF_QUEUEDBRK      = 8;    {    "      queue this Break ioRqst }
-    SERB_7WIRE          = 2;    {    "      RS232 7-wire protocol }
-    SERF_7WIRE          = 4;    {    "      RS232 7-wire protocol }
-    SERB_PARTY_ODD      = 1;    {    "      parity feature enabled bit }
-    SERF_PARTY_ODD      = 2;    {    "      parity feature enabled mask }
-    SERB_PARTY_ON       = 0;    {    "      parity-enabled bit }
-    SERF_PARTY_ON       = 1;    {    "      parity-enabled mask }
-
-{ These now refect the actual bit positions in the io_Status UWORD }
-
-    IO_STATB_XOFFREAD   = 12;      { io_Status receive currently xOFF'ed bit }
-    IO_STATF_XOFFREAD   = $1000;   {     "     receive currently xOFF'ed mask }
-    IO_STATB_XOFFWRITE  = 11;      {     "     transmit currently xOFF'ed bit }
-    IO_STATF_XOFFWRITE  = $0800;   {     "     transmit currently xOFF'ed mask }
-    IO_STATB_READBREAK  = 10;      {     "     break was latest input bit }
-    IO_STATF_READBREAK  = $0400;   {     "     break was latest input mask }
-    IO_STATB_WROTEBREAK = 9;       {     "     break was latest output bit }
-    IO_STATF_WROTEBREAK = $0200;   {     "     break was latest output mask }
-    IO_STATB_OVERRUN    = 8;       {     "     status word RBF overrun bit }
-    IO_STATF_OVERRUN    = $0100;   {     "     status word RBF overrun mask }
-
-
-    SEXTB_MSPON         = 1;    { io_ExtFlags. Use mark-space parity, }
-                                {           instead of odd-even. }
-    SEXTF_MSPON         = 2;    {    "      mark-space parity mask }
-    SEXTB_MARK          = 0;    {    "      if mark-space, use mark }
-    SEXTF_MARK          = 1;    {    "      if mark-space, use mark mask }
-
-
-    SerErr_DevBusy      = 1;
-    SerErr_BaudMismatch = 2;    { baud rate not supported by hardware }
-    SerErr_BufErr       = 4;    { Failed to allocate new read buffer }
-    SerErr_InvParam     = 5;
-    SerErr_LineErr      = 6;
-    SerErr_ParityErr    = 9;
-    SerErr_TimerErr     = 11;   {(See the serial/OpenDevice autodoc)}
-    SerErr_BufOverflow  = 12;
-    SerErr_NoDSR        = 13;
-    SerErr_DetectedBreak = 15;
+type
+  TIOExtSer = record
+    IOSer: TIOStdReq;
+    io_CtlChar: LongWord;    // control characters
+    io_RBufLen: LongWord;    // length in bytes of serial read buffer
+    io_ExtFlags: LongWord;   // additional serial flags (SEXTB_*)
+    io_Baud: LongWord;       // baud rate
+    io_BrkTime: LongWord;    // duration of break in microseconds
+    io_TermArray: TIOTArray; // termination character array
+    io_ReadLen: Byte;        // number of bits per read character
+    io_WriteLen: Byte;       // number of bits per write character
+    io_StopBits: Byte;       // number of stopbits for read
+    io_SerFlags: Byte;       // serial device flags (SERB_*)
+    io_Status: Word;         // status of serial port and lines (IO_STATF_*, IOSTF_*)
+  end;
+  PIOExtSer = ^TIOExtSer;
+
+ { status of serial port, as follows:
+      BIT  ACTIVE  FUNCTION
+       0    ---    reserved
+       1    ---    reserved
+       2    high   Connected to parallel "select" on the A1000.
+                   Connected to both the parallel "select" and
+                   serial "ring indicator" pins on the A500 &
+                   A2000.  Take care when making cables.
+       3    low    Data Set Ready
+       4    low    Clear To Send
+       5    low    Carrier Detect
+       6    low    Ready To Send
+       7    low    Data Terminal Ready
+       8    high   read overrun
+       9    high   break sent
+      10    high   break received
+      11    high   transmit x-OFFed
+      12    high   receive x-OFFed
+   13-15           reserved}
+
+const
+  SDCMD_QUERY     = CMD_NONSTD;
+  SDCMD_BREAK     = CMD_NONSTD + 1;
+  SDCMD_SETPARAMS = CMD_NONSTD + 2;
+
+  // flags of TIOExtSer.io_SerFlags
+  SERB_XDISABLED      = 7;                     // xOn-xOff feature disabled
+  SERF_XDISABLED      = 1 shl SERB_XDISABLED;
+  SERB_EOFMODE        = 6;                     // EOF mode enabled
+  SERF_EOFMODE        = 1 shl SERB_EOFMODE;
+  SERB_SHARED         = 5;                     // non-exclusive access
+  SERF_SHARED         = 1 shl SERB_SHARED;
+  SERB_RAD_BOOGIE     = 4;                     // high-speed mode active
+  SERF_RAD_BOOGIE     = 1 shl SERB_RAD_BOOGIE;
+  SERB_QUEUEDBRK      = 3;                     // queue this Break ioRqst
+  SERF_QUEUEDBRK      = 1 shl SERB_QUEUEDBRK;
+  SERB_7WIRE          = 2;                     // RS232 7-wire protocol
+  SERF_7WIRE          = 1 shl SERB_7WIRE;
+  SERB_PARTY_ODD      = 1;                     // parity feature enabled
+  SERF_PARTY_ODD      = 1 shl SERB_PARTY_ODD;
+  SERB_PARTY_ON       = 0;                     // parity-enabled
+  SERF_PARTY_ON       = 1 shl SERB_PARTY_ON;
+
+// These now refect the actual bit positions in the TIOExtSer.io_Status LongWord
+  IO_STATB_XOFFREAD   = 12;                       // receive currently xOFF'ed
+  IO_STATF_XOFFREAD   = 1 shl IO_STATB_XOFFREAD;
+  IO_STATB_XOFFWRITE  = 11;                       // transmit currently xOFF'ed
+  IO_STATF_XOFFWRITE  = 1 shl IO_STATB_XOFFWRITE;
+  IO_STATB_READBREAK  = 10;                       // break was latest input
+  IO_STATF_READBREAK  = 1 shl IO_STATB_READBREAK;
+  IO_STATB_WROTEBREAK = 9;                        // break was latest output
+  IO_STATF_WROTEBREAK = 1 shl IO_STATB_WROTEBREAK;
+  IO_STATB_OVERRUN    = 8;                        // status word RBF overrun
+  IO_STATF_OVERRUN    = 1 shl IO_STATB_OVERRUN;
+
+// TIOExtSer.io_ExtFlags
+  SEXTB_MSPON = 1;                 // Use mark-space parity, instead of odd-even.
+  SEXTF_MSPON = 1 shl SEXTB_MSPON;
+  SEXTB_MARK  = 0;                 // if mark-space, use mark
+  SEXTF_MARK  = 1 shl SEXTB_MARK;
+
+  SerErr_DevBusy       = 1;
+  SerErr_BaudMismatch  = 2;  // baud rate not supported by hardware
+  SerErr_BufErr        = 4;  // Failed to allocate new read buffer
+  SerErr_InvParam      = 5;
+  SerErr_LineErr       = 6;
+  SerErr_ParityErr     = 9;
+  SerErr_TimerErr      = 11; // (See the serial/OpenDevice autodoc)
+  SerErr_BufOverflow   = 12;
+  SerErr_NoDSR         = 13;
+  SerErr_DetectedBreak = 15;
 
 
 { These defines refer to the HIGH ORDER byte of io_Status.  They have
    been replaced by the new, corrected ones above }
-    IOSTB_XOFFREAD  = 4;       { iost_hob receive currently xOFF'ed bit }
-    IOSTF_XOFFREAD  = 16;      {    "     receive currently xOFF'ed mask }
-    IOSTB_XOFFWRITE = 3;       {    "     transmit currently xOFF'ed bit }
-    IOSTF_XOFFWRITE = 8;       {    "     transmit currently xOFF'ed mask }
-    IOSTB_READBREAK = 2;       {    "     break was latest input bit }
-    IOSTF_READBREAK = 4;       {    "     break was latest input mask }
-    IOSTB_WROTEBREAK= 1;       {    "     break was latest output bit }
-    IOSTF_WROTEBREAK= 2;       {    "     break was latest output mask }
-    IOSTB_OVERRUN   = 0;       {    "     status word RBF overrun bit }
-    IOSTF_OVERRUN   = 1;       {    "     status word RBF overrun mask }
-
-    IOSERB_BUFRREAD = 7  ;     { io_Flags from read buffer bit }
-    IOSERF_BUFRREAD = 128;  {    "     from read buffer mask }
-    IOSERB_QUEUED   = 6  ;     {    "     rqst-queued bit }
-    IOSERF_QUEUED   = 64 ; {    "     rqst-queued mask }
-    IOSERB_ABORT    = 5  ;     {    "     rqst-aborted bit }
-    IOSERF_ABORT    = 32 ; {    "     rqst-aborted mask }
-    IOSERB_ACTIVE   = 4  ;     {    "     rqst-qued-OR-current bit }
-    IOSERF_ACTIVE   = 16 ; {    "     rqst-qued-OR-current mask }
-
-
-
-    SERIALNAME          : PChar = 'serial.device';
-
-IMPLEMENTATION
+  IOSTB_XOFFREAD  = 4;                      // receive currently xOFF'ed
+  IOSTF_XOFFREAD  = 1 shl IOSTB_XOFFREAD;
+  IOSTB_XOFFWRITE = 3;                      // transmit currently xOFF'ed
+  IOSTF_XOFFWRITE = 1 shl IOSTB_XOFFWRITE;
+  IOSTB_READBREAK = 2;                      // break was latest input
+  IOSTF_READBREAK = 1 shl IOSTB_READBREAK;
+  IOSTB_WROTEBREAK= 1;                      // break was latest output
+  IOSTF_WROTEBREAK= 1 shl IOSTB_WROTEBREAK;
+  IOSTB_OVERRUN   = 0;                      // status word RBF overrun
+  IOSTF_OVERRUN   = 1 shl IOSTB_OVERRUN;
+
+// TIOExtSer.io_Flags
+  IOSERB_BUFRREAD = 7;                     // from read buffer
+  IOSERF_BUFRREAD = 1 shl IOSERB_BUFRREAD;
+  IOSERB_QUEUED   = 6;                     // rqst-queued
+  IOSERF_QUEUED   = 1 shl IOSERB_QUEUED;
+  IOSERB_ABORT    = 5;                     // rqst-aborted
+  IOSERF_ABORT    = 1 shl IOSERB_ABORT;
+  IOSERB_ACTIVE   = 4;                     // rqst-qued-OR-current
+  IOSERF_ACTIVE   = 1 shl IOSERB_ACTIVE;
+
+  SERIALNAME: PChar = 'serial.device';
+
+implementation
+
+
 
 end.

packages/arosunits/fpmake.pp

@@ -55,6 +55,7 @@ begin
     T:=P.Targets.AddUnit('locale.pas');
     T:=P.Targets.AddUnit('commodities.pas');
     T:=P.Targets.AddUnit('datatypes.pas');
+    T:=P.Targets.AddUnit('serial.pas');
 
 {$ifndef ALLPACKAGES}
     Run;

packages/arosunits/src/exec.pas

@@ -1416,6 +1416,8 @@ type
 procedure ForEachNode(List:PList; NodeProc: TNodeProcedure);
 procedure ForEachNodeSafe(List:PList; NodeProc: TNodeProcedure);
 
+function CreateExtIO(const Mp: PMsgPort; Size: Integer): PIORequest;
+procedure DeleteExtIO(ioReq: PIORequest);
 
 implementation
 
@@ -1563,7 +1565,32 @@ begin
    BitMask := 1 shl no;
 end;
 
-end. (* UNIT EXEC *)
+function CreateExtIO(const Mp: PMsgPort; Size: Integer): PIORequest;
+begin
+  CreateExtIO := nil;
+  if not Assigned(mp) then
+    Exit;
+  CreateExtIO := System.AllocMem(Size);
+  if Assigned(CreateExtIO) then
+  begin
+    CreateExtIO^.io_Message.mn_Node.ln_Type := NT_REPLYMSG;
+    CreateExtIO^.io_Message.mn_ReplyPort := Mp;
+    CreateExtIO^.io_Message.mn_Length := Size;
+  end;
+end;
+
+procedure DeleteExtIO(ioReq: PIORequest);
+begin
+  if Assigned(ioReq) then
+  begin
+    ioReq^.io_Message.mn_Node.ln_Type := Byte(-1);
+    ioReq^.io_Device := Pointer(-1);
+    ioReq^.io_Unit := Pointer(-1);
+    System.FreeMem(ioReq);
+  end;
+end;
+
+end.
 
 
 

packages/arosunits/src/serial.pas

@@ -0,0 +1,165 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    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.
+
+ **********************************************************************}
+
+unit serial;
+
+interface
+{$PACKRECORDS 2}
+
+uses
+  exec;
+
+type
+
+  // array of termination char's to use,see serial.doc setparams
+  PIOTArray = ^TIOTArray;
+  TIOTArray = record
+    TermArray0: LongWord;
+    TermArray1: LongWord;
+  end;
+
+const
+  SER_DEFAULT_CTLCHAR = $11130000; // default chars for xON,xOFF
+
+{ You may change these via SETPARAMS.   At this time, parity is not
+   calculated for xON/xOFF characters.  You must supply them with the
+   desired parity. }
+
+{****************************************************************}
+{ CAUTION !!  IF YOU ACCESS the serial.device, you MUST (!!!!) use an
+   IOExtSer-sized structure or you may overlay innocent memory !! }
+{****************************************************************}
+
+type
+  TIOExtSer = record
+    IOSer: TIOStdReq;
+    io_CtlChar: LongWord;    // control characters
+    io_RBufLen: LongWord;    // length in bytes of serial read buffer
+    io_ExtFlags: LongWord;   // additional serial flags (SEXTB_*)
+    io_Baud: LongWord;       // baud rate
+    io_BrkTime: LongWord;    // duration of break in microseconds
+    io_TermArray: TIOTArray; // termination character array
+    io_ReadLen: Byte;        // number of bits per read character
+    io_WriteLen: Byte;       // number of bits per write character
+    io_StopBits: Byte;       // number of stopbits for read
+    io_SerFlags: Byte;       // serial device flags (SERB_*)
+    io_Status: Word;         // status of serial port and lines (IO_STATF_*, IOSTF_*)
+  end;
+  PIOExtSer = ^TIOExtSer;
+
+ { status of serial port, as follows:
+      BIT  ACTIVE  FUNCTION
+       0    ---    reserved
+       1    ---    reserved
+       2    high   Connected to parallel "select" on the A1000.
+                   Connected to both the parallel "select" and
+                   serial "ring indicator" pins on the A500 &
+                   A2000.  Take care when making cables.
+       3    low    Data Set Ready
+       4    low    Clear To Send
+       5    low    Carrier Detect
+       6    low    Ready To Send
+       7    low    Data Terminal Ready
+       8    high   read overrun
+       9    high   break sent
+      10    high   break received
+      11    high   transmit x-OFFed
+      12    high   receive x-OFFed
+   13-15           reserved}
+
+const
+  SDCMD_QUERY     = CMD_NONSTD;
+  SDCMD_BREAK     = CMD_NONSTD + 1;
+  SDCMD_SETPARAMS = CMD_NONSTD + 2;
+
+  // flags of TIOExtSer.io_SerFlags
+  SERB_XDISABLED      = 7;                     // xOn-xOff feature disabled
+  SERF_XDISABLED      = 1 shl SERB_XDISABLED;
+  SERB_EOFMODE        = 6;                     // EOF mode enabled
+  SERF_EOFMODE        = 1 shl SERB_EOFMODE;
+  SERB_SHARED         = 5;                     // non-exclusive access
+  SERF_SHARED         = 1 shl SERB_SHARED;
+  SERB_RAD_BOOGIE     = 4;                     // high-speed mode active
+  SERF_RAD_BOOGIE     = 1 shl SERB_RAD_BOOGIE;
+  SERB_QUEUEDBRK      = 3;                     // queue this Break ioRqst
+  SERF_QUEUEDBRK      = 1 shl SERB_QUEUEDBRK;
+  SERB_7WIRE          = 2;                     // RS232 7-wire protocol
+  SERF_7WIRE          = 1 shl SERB_7WIRE;
+  SERB_PARTY_ODD      = 1;                     // parity feature enabled
+  SERF_PARTY_ODD      = 1 shl SERB_PARTY_ODD;
+  SERB_PARTY_ON       = 0;                     // parity-enabled
+  SERF_PARTY_ON       = 1 shl SERB_PARTY_ON;
+
+// These now refect the actual bit positions in the TIOExtSer.io_Status LongWord
+  IO_STATB_XOFFREAD   = 12;                       // receive currently xOFF'ed
+  IO_STATF_XOFFREAD   = 1 shl IO_STATB_XOFFREAD;
+  IO_STATB_XOFFWRITE  = 11;                       // transmit currently xOFF'ed
+  IO_STATF_XOFFWRITE  = 1 shl IO_STATB_XOFFWRITE;
+  IO_STATB_READBREAK  = 10;                       // break was latest input
+  IO_STATF_READBREAK  = 1 shl IO_STATB_READBREAK;
+  IO_STATB_WROTEBREAK = 9;                        // break was latest output
+  IO_STATF_WROTEBREAK = 1 shl IO_STATB_WROTEBREAK;
+  IO_STATB_OVERRUN    = 8;                        // status word RBF overrun
+  IO_STATF_OVERRUN    = 1 shl IO_STATB_OVERRUN;
+
+// TIOExtSer.io_ExtFlags
+  SEXTB_MSPON = 1;                 // Use mark-space parity, instead of odd-even.
+  SEXTF_MSPON = 1 shl SEXTB_MSPON;
+  SEXTB_MARK  = 0;                 // if mark-space, use mark
+  SEXTF_MARK  = 1 shl SEXTB_MARK;
+
+  SerErr_DevBusy       = 1;
+  SerErr_BaudMismatch  = 2;  // baud rate not supported by hardware
+  SerErr_BufErr        = 4;  // Failed to allocate new read buffer
+  SerErr_InvParam      = 5;
+  SerErr_LineErr       = 6;
+  SerErr_ParityErr     = 9;
+  SerErr_TimerErr      = 11; // (See the serial/OpenDevice autodoc)
+  SerErr_BufOverflow   = 12;
+  SerErr_NoDSR         = 13;
+  SerErr_DetectedBreak = 15;
+
+
+{ These defines refer to the HIGH ORDER byte of io_Status.  They have
+   been replaced by the new, corrected ones above }
+  IOSTB_XOFFREAD  = 4;                      // receive currently xOFF'ed
+  IOSTF_XOFFREAD  = 1 shl IOSTB_XOFFREAD;
+  IOSTB_XOFFWRITE = 3;                      // transmit currently xOFF'ed
+  IOSTF_XOFFWRITE = 1 shl IOSTB_XOFFWRITE;
+  IOSTB_READBREAK = 2;                      // break was latest input
+  IOSTF_READBREAK = 1 shl IOSTB_READBREAK;
+  IOSTB_WROTEBREAK= 1;                      // break was latest output
+  IOSTF_WROTEBREAK= 1 shl IOSTB_WROTEBREAK;
+  IOSTB_OVERRUN   = 0;                      // status word RBF overrun
+  IOSTF_OVERRUN   = 1 shl IOSTB_OVERRUN;
+
+// TIOExtSer.io_Flags
+  IOSERB_BUFRREAD = 7;                     // from read buffer
+  IOSERF_BUFRREAD = 1 shl IOSERB_BUFRREAD;
+  IOSERB_QUEUED   = 6;                     // rqst-queued
+  IOSERF_QUEUED   = 1 shl IOSERB_QUEUED;
+  IOSERB_ABORT    = 5;                     // rqst-aborted
+  IOSERF_ABORT    = 1 shl IOSERB_ABORT;
+  IOSERB_ACTIVE   = 4;                     // rqst-qued-OR-current
+  IOSERF_ACTIVE   = 1 shl IOSERB_ACTIVE;
+
+  SERIALNAME: PChar = 'serial.device';
+
+implementation
+
+
+
+end.

packages/fcl-net/src/netdb.pp

@@ -478,6 +478,17 @@ var
   s: string;
   H : THostAddr;
 begin
+  if SystemApiLevel >= 26 then
+    begin
+      // Since Android 8 the net.dnsX properties can't be read.
+      // Use Google Public DNS servers
+      Result:=2;
+      SetLength(DNSServers, Result);
+      DNSServers[0]:=StrToNetAddr('8.8.8.8');
+      DNSServers[1]:=StrToNetAddr('8.8.4.4');
+      exit;
+    end;
+
   Result:=0;
   SetLength(DNSServers, 9);
   for i:=1 to 9 do
@@ -504,6 +515,13 @@ var
 begin
   if not CheckResolveFileAge then
     exit;
+
+  if (Length(DNSServers) = 0) and (SystemApiLevel >= 26) then
+    begin
+      GetDNSServers;
+      exit;
+    end;
+
   n:=GetSystemProperty('net.change');
   if n <> '' then
     v:=GetSystemProperty(PAnsiChar(n))

packages/fcl-passrc/src/pasresolveeval.pas

@@ -4081,9 +4081,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 +4111,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

packages/fcl-passrc/src/pasresolver.pp

@@ -1824,6 +1824,7 @@ type
     function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
     function GetPasPropertyDefaultExpr(El: TPasProperty): TPasExpr;
     function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
+    function GetParentProcBody(El: TPasElement): TProcedureBody;
     function ProcHasImplElements(Proc: TPasProcedure): boolean; virtual;
     function IndexOfImplementedInterface(ClassEl: TPasClassType; aType: TPasType): integer;
     function GetLoop(El: TPasElement): TPasImplElement;
@@ -2072,8 +2073,8 @@ begin
       dec(Indent,2);
       end;
     Result:=Result+')';
-    if El is TPasFunction then
-      Result:=Result+':'+GetTreeDbg(TPasFunctionType(TPasFunction(El).ProcType).ResultEl,Indent);
+    if (El is TPasProcedure) and (TPasProcedure(El).ProcType is TPasFunctionType) then
+      Result:=Result+':'+GetTreeDbg(TPasFunctionType(TPasProcedure(El).ProcType).ResultEl,Indent);
     if TPasProcedureType(El).IsOfObject then
       Result:=Result+' '+ProcTypeModifiers[ptmOfObject];
     if TPasProcedureType(El).IsNested then
@@ -2273,6 +2274,10 @@ begin
     Result:='class procedure'
   else if C=TPasClassFunction then
     Result:='class function'
+  else if C=TPasAnonymousProcedure then
+    Result:='anonymous procedure'
+  else if C=TPasAnonymousFunction then
+    Result:='anonymous function'
   else if C=TPasMethodResolution then
     Result:='method resolution'
   else if C=TInterfaceSection then
@@ -5310,13 +5315,17 @@ var
   pm: TProcedureModifier;
   ptm: TProcTypeModifier;
   ObjKind: TPasObjKind;
+  ParentBody: TProcedureBody;
 begin
-  if (El.Parent is TPasProcedure) and (TPasProcedure(El.Parent).ProcType=El) then
+  if El.Parent is TPasProcedure then
+    Proc:=TPasProcedure(El.Parent)
+  else
+    Proc:=nil;
+  if (Proc<>nil) and (Proc.ProcType=El) then
     begin
     // finished header of a procedure declaration
     // -> search the best fitting proc
     CheckTopScope(FScopeClass_Proc);
-    Proc:=TPasProcedure(El.Parent);
     {$IFDEF VerbosePasResolver}
     writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDbg(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent));
     {$ENDIF}
@@ -5325,13 +5334,14 @@ begin
     if (proProcTypeWithoutIsNested in Options) and El.IsNested then
       RaiseInvalidProcTypeModifier(20170402120811,El,ptmIsNested,El);
 
-    if (Proc.Parent.ClassType=TProcedureBody) then
+    ParentBody:=GetParentProcBody(Proc.Parent);
+    if (ParentBody<>nil) then
       begin
       // nested sub proc
       if not (proProcTypeWithoutIsNested in Options) then
         El.IsNested:=true;
       // inherit 'of Object'
-      ParentProc:=Proc.Parent.Parent as TPasProcedure;
+      ParentProc:=ParentBody.Parent as TPasProcedure;
       if ParentProc.ProcType.IsOfObject then
         El.IsOfObject:=true;
       end;
@@ -5393,7 +5403,7 @@ begin
       end
     else
       begin
-      // intf proc, forward proc, proc body, method body
+      // intf proc, forward proc, proc body, method body, anonymous proc
       if Proc.IsAbstract then
         RaiseInvalidProcModifier(20170216151634,Proc,pmAbstract,Proc);
       if Proc.IsVirtual then
@@ -5405,8 +5415,12 @@ begin
       if Proc.IsStatic then
         RaiseInvalidProcTypeModifier(20170216151640,El,ptmStatic,El);
       if (not HasDots)
-          and (Proc.ClassType<>TPasProcedure)
-          and (Proc.ClassType<>TPasFunction) then
+          and (Proc.GetProcTypeEnum in [
+               ptClassOperator,
+               ptConstructor, ptDestructor,
+               ptClassProcedure, ptClassFunction,
+               ptClassConstructor, ptClassDestructor
+               ]) then
         RaiseXExpectedButYFound(20170419232724,'full method name','short name',El);
       end;
 
@@ -5418,7 +5432,8 @@ begin
 
     // finish interface/implementation/nested procedure/method declaration
 
-    if not IsValidIdent(ProcName) then
+    if not (Proc.GetProcTypeEnum in [ptAnonymousProcedure,ptAnonymousFunction])
+        and not IsValidIdent(ProcName) then
       RaiseNotYetImplemented(20160922163407,El);
 
     if El is TPasFunctionType then
@@ -5436,7 +5451,7 @@ begin
       end;
 
     // finish interface/implementation/nested procedure
-    if ProcNeedsBody(Proc) then
+    if (ProcName<>'') and ProcNeedsBody(Proc) then
       begin
       // check if there is a forward declaration
       ParentScope:=Scopes[ScopeCount-2];
@@ -5483,13 +5498,16 @@ begin
       StoreScannerFlagsInProc(ProcScope);
       end;
 
-    // check for invalid overloads
-    FindData:=Default(TFindOverloadProcData);
-    FindData.Proc:=Proc;
-    FindData.Args:=Proc.ProcType.Args;
-    FindData.Kind:=fopkProc;
-    Abort:=false;
-    IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort);
+    if ProcName<>'' then
+      begin
+      // check for invalid overloads
+      FindData:=Default(TFindOverloadProcData);
+      FindData.Proc:=Proc;
+      FindData.Args:=Proc.ProcType.Args;
+      FindData.Kind:=fopkProc;
+      Abort:=false;
+      IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort);
+      end;
     end
   else if El.Name<>'' then
     begin
@@ -6836,12 +6854,12 @@ begin
     else
       RaiseNotYetImplemented(20170203161826,ImplProc);
     end;
-  if DeclProc is TPasFunction then
+  if DeclProc.ProcType is TPasFunctionType then
     begin
     // redirect implementation 'Result' to declaration FuncType.ResultEl
     Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar);
     if Identifier.Element is TPasResultElement then
-      Identifier.Element:=TPasFunction(DeclProc).FuncType.ResultEl;
+      Identifier.Element:=TPasFunctionType(DeclProc.ProcType).ResultEl;
     end;
 end;
 
@@ -6899,11 +6917,11 @@ begin
     RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc);
   if ImplProc.CallingConvention<>DeclProc.CallingConvention then
     RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
-  if ImplProc is TPasFunction then
+  if ImplProc.ProcType is TPasFunctionType then
     begin
     // check result type
-    ImplResult:=TPasFunction(ImplProc).FuncType.ResultEl.ResultType;
-    DeclResult:=TPasFunction(DeclProc).FuncType.ResultEl.ResultType;
+    ImplResult:=TPasFunctionType(ImplProc.ProcType).ResultEl.ResultType;
+    DeclResult:=TPasFunctionType(DeclProc.ProcType).ResultEl.ResultType;
 
     if not CheckElTypeCompatibility(ImplResult,DeclResult,prraSimple) then
       RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound,
@@ -7827,6 +7845,7 @@ begin
         [],El);
     ResolveRecordValues(TRecordValues(El));
     end
+  else if ElClass=TProcedureExpr then
   else
     RaiseNotYetImplemented(20170222184329,El);
 
@@ -7882,7 +7901,7 @@ begin
       begin
       // examples: funca or @proca or a.funca or @a.funca ...
       Proc:=TPasProcedure(DeclEl);
-      if (Access=rraAssign) and (Proc is TPasFunction)
+      if (Access=rraAssign) and (Proc.ProcType is TPasFunctionType)
           and (El.ClassType=TPrimitiveExpr)
           and (El.Parent.ClassType=TPasImplAssign)
           and (TPasImplAssign(El.Parent).left=El) then
@@ -7895,7 +7914,7 @@ begin
         if El.HasParent(ImplProc) then
           begin
           // "FuncA:=" within FuncA  -> redirect to ResultEl
-          Ref.Declaration:=(Proc as TPasFunction).FuncType.ResultEl;
+          Ref.Declaration:=TPasFunctionType(Proc.ProcType).ResultEl;
           exit;
           end;
         end;
@@ -8499,7 +8518,7 @@ var
     if DeclEl is TPasProcedure then
       begin
       Proc:=TPasProcedure(DeclEl);
-      if (Access=rraAssign) and (Proc is TPasFunction)
+      if (Access=rraAssign) and (Proc.ProcType is TPasFunctionType)
           and (Value.ClassType=TPrimitiveExpr)
           and (Params.Parent.ClassType=TPasImplAssign)
           and (TPasImplAssign(Params.Parent).left=Params) then
@@ -8512,7 +8531,7 @@ var
         if Params.HasParent(ImplProc) then
           begin
           // "FuncA[]:=" within FuncA -> redirect to ResultEl
-          Ref.Declaration:=(Proc as TPasFunction).FuncType.ResultEl;
+          Ref.Declaration:=TPasFunctionType(Proc.ProcType).ResultEl;
           end;
         end;
       end;
@@ -8930,7 +8949,8 @@ begin
   else if (Access in [rraRead,rraParamToUnknownProc])
       and ((C=TPrimitiveExpr)
         or (C=TNilExpr)
-        or (C=TBoolConstExpr)) then
+        or (C=TBoolConstExpr)
+        or (C=TProcedureExpr)) then
     // ok
   else if C=TUnaryExpr then
     AccessExpr(TUnaryExpr(Expr).Operand,Access)
@@ -9350,10 +9370,10 @@ begin
   {$ENDIF}
   if not (TopScope is TPasIdentifierScope) then
     RaiseInvalidScopeForElement(20160922163522,El);
-  // Note: El.ProcType is nil !
+  // Note: El.ProcType is nil !  It is parsed later.
   ProcName:=El.Name;
   HasDot:=Pos('.',ProcName)>1;
-  if not HasDot then
+  if (not HasDot) and (ProcName<>'') then
     AddIdentifier(TPasIdentifierScope(TopScope),ProcName,El,pikProc);
   ProcScope:=TPasProcedureScope(PushScope(El,FScopeClass_Proc));
   ProcScope.ModeSwitches:=CurrentParser.CurrentModeswitches;
@@ -9420,7 +9440,7 @@ begin
 
     ProcScope.VisibilityContext:=CurClassType;
     ProcScope.ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope;
-    end;
+    end;// HasDot=true
 end;
 
 procedure TPasResolver.AddArgument(El: TPasArgument);
@@ -10500,9 +10520,9 @@ begin
         Proc:=TPasProcedure(ResolvedEl.IdentEl);
         if rcConstant in Flags then
           RaiseConstantExprExp(20170216152637,Params);
-        if Proc is TPasFunction then
+        if Proc.ProcType is TPasFunctionType then
           // function call => return result
-          ComputeElement(TPasFunction(Proc).FuncType.ResultEl,ResolvedEl,
+          ComputeElement(TPasFunctionType(Proc.ProcType).ResultEl,ResolvedEl,
             Flags+[rcNoImplicitProc],StartEl)
         else if (Proc.ClassType=TPasConstructor)
             and (rrfNewInstance in Ref.Flags) then
@@ -12498,6 +12518,7 @@ var
   ProcScope: TPasProcedureScope;
   ResultEl: TPasResultElement;
   Flags: TPasResolverComputeFlags;
+  CtxProc: TPasProcedure;
 begin
   if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then
     exit(cExact);
@@ -12515,14 +12536,15 @@ begin
     begin
     // first param is function result
     ProcScope:=TPasProcedureScope(Scopes[i]);
-    if not (ProcScope.Element is TPasFunction) then
+    CtxProc:=TPasProcedure(ProcScope.Element);
+    if not (CtxProc.ProcType is TPasFunctionType) then
       begin
       if RaiseOnError then
         RaiseMsg(20170216152312,nWrongNumberOfParametersForCallTo,
           sWrongNumberOfParametersForCallTo,['procedure exit'],Params.Params[0]);
       exit(cIncompatible);
       end;
-    ResultEl:=(ProcScope.Element as TPasFunction).FuncType.ResultEl;
+    ResultEl:=TPasFunctionType(CtxProc.ProcType).ResultEl;
     ComputeElement(ResultEl,ResultResolved,[rcType]);
     end
   else
@@ -12937,9 +12959,9 @@ begin
           begin
           Expr:=TPasVariable(ParamResolved.IdentEl).Expr;
           if Expr is TArrayValues then
-            Evaluated:=TResEvalInt.CreateValue(length(TArrayValues(Expr).Values)-1)
+            Evaluated:=TResEvalInt.CreateValue(TMaxPrecInt(length(TArrayValues(Expr).Values))-1)
           else if (Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
-            Evaluated:=TResEvalInt.CreateValue(length(TParamsExpr(Expr).Params)-1);
+            Evaluated:=TResEvalInt.CreateValue(TMaxPrecInt(length(TParamsExpr(Expr).Params))-1);
           if Evaluated=nil then
             RaiseXExpectedButYFound(20170601191003,'array constant','expression',Params);
           end
@@ -13635,8 +13657,9 @@ begin
       aType:=TPasArgument(Decl).ArgType
     else if Decl.ClassType=TPasResultElement then
       aType:=TPasResultElement(Decl).ResultType
-    else if Decl is TPasFunction then
-      aType:=TPasFunction(Decl).FuncType.ResultEl.ResultType;
+    else if (Decl is TPasProcedure)
+        and (TPasProcedure(Decl).ProcType is TPasFunctionType) then
+      aType:=TPasFunctionType(TPasProcedure(Decl).ProcType).ResultEl.ResultType;
     {$IFDEF VerbosePasResolver}
     {AllowWriteln}
     if aType=nil then
@@ -16446,7 +16469,7 @@ begin
         begin
         EnumType:=TPasEnumType(LTypeEl);
         LRangeValue:=TResEvalRangeInt.CreateValue(revskEnum,EnumType,
-          0,EnumType.Values.Count-1);
+          0,TMaxPrecInt(EnumType.Values.Count)-1);
         end
       else if C=TPasUnresolvedSymbolRef then
         begin
@@ -17047,7 +17070,15 @@ begin
         if CheckProcTypeCompatibility(TPasProcedureType(LHS.LoTypeEl),
             TPasProcedure(RHS.IdentEl).ProcType,true,ErrorEl,RaiseOnIncompatible) then
           exit(cExact);
-        end;
+        end
+      else if (LHS.LoTypeEl is TPasProcedureType)
+          and (RHS.ExprEl is TProcedureExpr) then
+        begin
+        // for example  ProcVar:=anonymous-procedure...
+        if CheckProcTypeCompatibility(TPasProcedureType(LHS.LoTypeEl),
+            TProcedureExpr(RHS.ExprEl).Proc.ProcType,true,ErrorEl,RaiseOnIncompatible) then
+          exit(cExact);
+        end
       end
     else if LBT=btPointer then
       begin
@@ -19846,7 +19877,7 @@ begin
     begin
     TypeEl:=TPasProcedure(El).ProcType;
     SetResolverIdentifier(ResolvedEl,btProc,El,TypeEl,TypeEl,[rrfCanBeStatement]);
-    if El is TPasFunction then
+    if TPasProcedure(El).ProcType is TPasFunctionType then
       Include(ResolvedEl.Flags,rrfReadable);
     // Note: the readability of TPasConstructor depends on the context
     // Note: implicit calls are handled in TPrimitiveExpr
@@ -19857,6 +19888,11 @@ begin
                TPasProcedureType(El),TPasProcedureType(El),[rrfCanBeStatement]);
     // Note: implicit calls are handled in TPrimitiveExpr
     end
+  else if ElClass=TProcedureExpr then
+    begin
+    TypeEl:=TProcedureExpr(El).Proc.ProcType;
+    SetResolverValueExpr(ResolvedEl,btProc,TypeEl,TypeEl,TProcedureExpr(El),[rrfReadable]);
+    end
   else if ElClass=TPasArrayType then
     SetResolverIdentifier(ResolvedEl,btContext,El,TPasArrayType(El),TPasArrayType(El),[])
   else if ElClass=TArrayValues then
@@ -20001,6 +20037,17 @@ begin
     end;
 end;
 
+function TPasResolver.GetParentProcBody(El: TPasElement): TProcedureBody;
+begin
+  while El<>nil do
+    begin
+    if El is TProcedureBody then
+      exit(TProcedureBody(El));
+    El:=El.Parent;
+    end;
+  Result:=nil;
+end;
+
 function TPasResolver.ProcHasImplElements(Proc: TPasProcedure): boolean;
 begin
   Result:=GetProcFirstImplEl(Proc)<>nil;
@@ -20558,7 +20605,7 @@ begin
   else if C=TPasEnumType then
     begin
     Result:=TResEvalRangeInt.CreateValue(revskEnum,TPasEnumType(Decl),
-                                         0,TPasEnumType(Decl).Values.Count-1);
+                              0,TMaxPrecInt(TPasEnumType(Decl).Values.Count)-1);
     Result.IdentEl:=Decl;
     exit;
     end

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
@@ -969,7 +971,8 @@ type
                ptOperator, ptClassOperator,
                ptConstructor, ptDestructor,
                ptClassProcedure, ptClassFunction,
-               ptClassConstructor, ptClassDestructor);
+               ptClassConstructor, ptClassDestructor,
+               ptAnonymousProcedure, ptAnonymousFunction);
 
   { TPasProcedureBase }
 
@@ -1004,6 +1007,8 @@ type
                         
   TProcedureBody = class;
 
+  { TPasProcedure - named procedure, not anonymous }
+
   TPasProcedure = class(TPasProcedureBase)
   Private
     FModifiers : TProcedureModifiers;
@@ -1020,13 +1025,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;
@@ -1039,6 +1044,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;
@@ -1048,14 +1054,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 }
@@ -1082,17 +1090,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;
 
 
@@ -1102,6 +1111,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassConstructor }
@@ -1110,6 +1120,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasDestructor }
@@ -1118,6 +1129,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassDestructor }
@@ -1126,6 +1138,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassProcedure }
@@ -1134,6 +1147,7 @@ Type
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
+    function GetProcTypeEnum: TProcType; override;
   end;
 
   { TPasClassFunction }
@@ -1142,8 +1156,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 }
@@ -1577,7 +1626,8 @@ const
       'ListOfExp',
       'Inherited',
       'Self',
-      'Specialize');
+      'Specialize',
+      'Procedure');
 
   OpcodeStrings : Array[TExprOpCode] of string = (
         '','+','-','*','/','div','mod','**',
@@ -1643,6 +1693,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
@@ -1843,6 +1913,11 @@ begin
   Result:='class operator';
 end;
 
+function TPasClassOperator.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptClassOperator;
+end;
+
 { TPasImplAsmStatement }
 
 constructor TPasImplAsmStatement.Create(const AName: string;
@@ -1865,6 +1940,79 @@ 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);
+  if Proc<>nil then
+    Proc.ForEachCall(aMethodCall,Arg);
+end;
+
 { TPasImplRaise }
 
 destructor TPasImplRaise.Destroy;
@@ -2157,7 +2305,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;
@@ -2167,6 +2315,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;
@@ -3229,12 +3382,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;
 
@@ -3764,29 +3917,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
@@ -4278,8 +4408,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);
@@ -4347,36 +4477,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:=' : ';
@@ -4398,6 +4520,11 @@ begin
   Result:='function';
 end;
 
+function TPasFunction.GetProcTypeEnum: TProcType;
+begin
+  Result:=ptFunction;
+end;
+
 function TPasOperator.GetOperatorDeclaration(Full : Boolean) : string;
 
 begin
@@ -4450,26 +4577,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

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -390,9 +390,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;
@@ -2335,6 +2333,7 @@ var
   UsedModule, aModule: TPasModule;
   UsesClause: TPasUsesClause;
   Use: TPasUsesUnit;
+  PosEl: TPasElement;
 begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.EmitSectionHints ',GetElModName(Section));
@@ -2350,8 +2349,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;
 

packages/fcl-passrc/src/pparser.pp

@@ -314,7 +314,7 @@ type
     function ReadDottedIdentifier(Parent: TPasElement; out Expr: TPasExpr; NeedAsString: boolean): String;
     function CheckProcedureArgs(Parent: TPasElement;
       Args: TFPList; // list of TPasArgument
-      Mandatory: Boolean): boolean;
+      ProcType: TProcType): boolean;
     function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility): Boolean;
     procedure ParseExc(MsgNumber: integer; const Msg: String);
     procedure ParseExc(MsgNumber: integer; const Fmt: String; Args : Array of {$ifdef pas2js}jsvalue{$else}const{$endif});
@@ -349,12 +349,15 @@ type
     function CreateRecordValues(AParent : TPasElement): TRecordValues;
     Function IsCurTokenHint(out AHint : TPasMemberHint) : Boolean; overload;
     Function IsCurTokenHint: Boolean; overload;
-    Function TokenIsCallingConvention(const S : String; out CC : TCallingConvention) : Boolean; virtual;
-    Function TokenIsProcedureModifier(Parent : TPasElement; const S : String; Out PM : TProcedureModifier) : Boolean; virtual;
+    Function TokenIsCallingConvention(const S: String; out CC : TCallingConvention) : Boolean; virtual;
+    Function TokenIsProcedureModifier(Parent: TPasElement; const S: String; Out PM : TProcedureModifier): Boolean; virtual;
+    Function TokenIsAnonymousProcedureModifier(Parent: TPasElement; S: String; Out PM: TProcedureModifier): Boolean; virtual;
     Function TokenIsProcedureTypeModifier(Parent : TPasElement; const S : String; Out PTM : TProcTypeModifier) : Boolean; virtual;
     Function CheckHint(Element : TPasElement; ExpectSemiColon : Boolean) : TPasMemberHints;
+    function IsAnonymousProcAllowed(El: TPasElement): boolean; virtual;
     function ParseParams(AParent : TPasElement; ParamsKind: TPasExprKind; AllowFormatting : Boolean = False): TParamsExpr;
-    function ParseExpIdent(AParent : TPasElement): TPasExpr;
+    function ParseExprOperand(AParent : TPasElement): TPasExpr;
+    function ParseExpIdent(AParent : TPasElement): TPasExpr; deprecated 'use ParseExprOperand instead'; // since fpc 3.3.1
     procedure DoParseClassType(AType: TPasClassType);
     function DoParseExpression(AParent: TPaselement;InitExpr: TPasExpr=nil; AllowEqual : Boolean = True): TPasExpr;
     function DoParseConstValueExpression(AParent: TPasElement): TPasExpr;
@@ -1241,6 +1244,21 @@ begin
     end;
 end;
 
+function TPasParser.TokenIsAnonymousProcedureModifier(Parent: TPasElement;
+  S: String; out PM: TProcedureModifier): Boolean;
+begin
+  S:=LowerCase(S);
+  case S of
+  'assembler':
+    begin
+    PM:=pmAssembler;
+    exit(true);
+    end;
+  end;
+  Result:=false;
+  if Parent=nil then ;
+end;
+
 function TPasParser.TokenIsProcedureTypeModifier(Parent: TPasElement;
   const S: String; out PTM: TProcTypeModifier): Boolean;
 begin
@@ -1291,6 +1309,17 @@ begin
     ExpectToken(tkSemiColon);
 end;
 
+function TPasParser.IsAnonymousProcAllowed(El: TPasElement): boolean;
+begin
+  while El is TPasExpr do
+    El:=El.Parent;
+  if not (El is TPasImplBlock) then
+    exit(false); // only in statements
+  while El is TPasImplBlock do
+    El:=El.Parent;
+  Result:=El is TProcedureBody; // needs a parent procedure
+end;
+
 function TPasParser.CheckPackMode: TPackMode;
 
 begin
@@ -2081,7 +2110,7 @@ begin
   end;
 end;
 
-function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
+function TPasParser.ParseExprOperand(AParent: TPasElement): TPasExpr;
 
   Function IsWriteOrStr(P : TPasExpr) : boolean;
 
@@ -2109,7 +2138,7 @@ function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
       begin // self.Write(EscapeText(AText));
       optk:=CurToken;
       NextToken;
-      b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk));
+      b:=CreateBinaryExpr(AParent,Last, ParseExprOperand(AParent), TokenToExprOp(optk));
       if not Assigned(b.right) then
         begin
         b.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
@@ -2180,15 +2209,16 @@ var
   ISE: TInlineSpecializeExpr;
   ST: TPasSpecializeType;
   SrcPos, ScrPos: TPasSourcePos;
+  ProcType: TProcType;
 
 begin
   Result:=nil;
   CanSpecialize:=false;
   aName:='';
   case CurToken of
-    tkString:           Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenString);
-    tkChar:             Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenText);
-    tkNumber:           Last:=CreatePrimitiveExpr(AParent,pekNumber,CurTokenString);
+    tkString: Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenString);
+    tkChar:   Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenText);
+    tkNumber: Last:=CreatePrimitiveExpr(AParent,pekNumber,CurTokenString);
     tkIdentifier:
       begin
       CanSpecialize:=true;
@@ -2212,7 +2242,7 @@ begin
       if (CurToken=tkIdentifier) then
         begin
         SrcPos:=CurTokenPos;
-        Bin:=CreateBinaryExpr(AParent,Last,ParseExpIdent(AParent),eopNone,SrcPos);
+        Bin:=CreateBinaryExpr(AParent,Last,ParseExprOperand(AParent),eopNone,SrcPos);
         if not Assigned(Bin.right) then
           begin
           Bin.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
@@ -2230,6 +2260,27 @@ begin
       Last:=CreateSelfExpr(AParent);
       HandleSelf(Last);
       end;
+    tkprocedure,tkfunction:
+      begin
+      if CurToken=tkprocedure then
+        ProcType:=ptAnonymousProcedure
+      else
+        ProcType:=ptAnonymousFunction;
+      if not IsAnonymousProcAllowed(AParent) then
+        ParseExcExpectedIdentifier;
+      ok:=false;
+      try
+        Result:=TProcedureExpr(CreateElement(TProcedureExpr,'',AParent,visPublic));
+        TProcedureExpr(Result).Proc:=TPasAnonymousProcedure(ParseProcedureOrFunctionDecl(Result,ProcType));
+        if CurToken=tkSemicolon then
+          NextToken; // skip optional semicolon
+        ok:=true;
+      finally
+        if not ok then
+          Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
+      end;
+      exit; // do not allow postfix operators . ^. [] ()
+      end;
     tkCaret:
       begin
       // is this still needed?
@@ -2329,6 +2380,11 @@ begin
   end;
 end;
 
+function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
+begin
+  Result:=ParseExprOperand(AParent);
+end;
+
 function TPasParser.OpLevel(t: TToken): Integer;
 begin
   case t of
@@ -2491,12 +2547,12 @@ begin
           if (CurToken=tkDot) then
             begin
             NextToken;
-            x:=CreateBinaryExpr(AParent,x, ParseExpIdent(AParent), TokenToExprOp(tkDot));
+            x:=CreateBinaryExpr(AParent,x, ParseExprOperand(AParent), TokenToExprOp(tkDot));
             end;
           end
         else
           begin
-          x:=ParseExpIdent(AParent);
+          x:=ParseExprOperand(AParent);
           if not Assigned(x) then
             ParseExcSyntaxError;
           end;
@@ -4584,12 +4640,11 @@ end;
 
 
 function TPasParser.CheckProcedureArgs(Parent: TPasElement; Args: TFPList;
-  Mandatory: Boolean): boolean;
+  ProcType: TProcType): boolean;
 
 begin
   NextToken;
-  case CurToken of
-  tkBraceOpen:
+  if CurToken=tkBraceOpen then
     begin
     Result:=true;
     NextToken;
@@ -4598,18 +4653,34 @@ begin
       UngetToken;
       ParseArgList(Parent, Args, tkBraceClose);
       end;
-    end;
-  tkSemicolon,tkColon,tkof,tkis,tkIdentifier:
+    end
+  else
     begin
     Result:=false;
-    if Mandatory then
-      ParseExc(nParserExpectedLBracketColon,SParserExpectedLBracketColon)
+    case ProcType of
+    ptOperator,ptClassOperator:
+      ParseExc(nParserExpectedLBracketColon,SParserExpectedLBracketColon);
+    ptAnonymousProcedure,ptAnonymousFunction:
+      case CurToken of
+      tkIdentifier, // e.g. procedure assembler
+      tkbegin,tkvar,tkconst,tktype,tkprocedure,tkfunction:
+        UngetToken;
+      else
+        ParseExcTokenError('begin');
+      end;
     else
-      UngetToken;
-    end
-  else
-    ParseExcTokenError(';');
-  end;
+      case CurToken of
+        tkSemicolon, // e.g. procedure;
+        tkColon, // e.g. function: id
+        tkof, // e.g. procedure of object
+        tkis, // e.g. procedure is nested
+        tkIdentifier: // e.g. procedure cdecl;
+          UngetToken;
+      else
+        ParseExcTokenError(';');
+      end;
+    end;
+    end;
 end;
 
 procedure TPasParser.HandleProcedureModifier(Parent: TPasElement; pm: TProcedureModifier);
@@ -4800,20 +4871,22 @@ Var
   Tok : String;
   CC : TCallingConvention;
   PM : TProcedureModifier;
-  Done: Boolean;
   ResultEl: TPasResultElement;
-  OK,IsProc : Boolean;
+  OK: Boolean;
+  IsProc: Boolean; // true = procedure, false = procedure type
+  IsAnonymProc: Boolean;
   PTM: TProcTypeModifier;
-  ModCount: Integer;
+  ModTokenCount: Integer;
   LastToken: TToken;
 
 begin
   // Element must be non-nil. Removed all checks for not-nil.
   // If it is nil, the following fails anyway.
-  CheckProcedureArgs(Element,Element.Args,ProcType in [ptOperator,ptClassOperator]);
+  CheckProcedureArgs(Element,Element.Args,ProcType);
   IsProc:=Parent is TPasProcedure;
+  IsAnonymProc:=IsProc and (ProcType in [ptAnonymousProcedure,ptAnonymousFunction]);
   case ProcType of
-    ptFunction,ptClassFunction:
+    ptFunction,ptClassFunction,ptAnonymousFunction:
       begin
       NextToken;
       if CurToken = tkColon then
@@ -4882,13 +4955,13 @@ begin
     else
       UnGetToken;
     end;
-  ModCount:=0;
+  ModTokenCount:=0;
   Repeat
-    inc(ModCount);
-    // Writeln(modcount, curtokentext);
+    inc(ModTokenCount);
+    // Writeln(ModTokenCount, curtokentext);
     LastToken:=CurToken;
     NextToken;
-    if (ModCount<=3) and (CurToken = tkEqual) and not (Parent is TPasProcedure) then
+    if (CurToken = tkEqual) and not IsProc and (ModTokenCount<=3) then
       begin
       // for example: const p: procedure = nil;
       UngetToken;
@@ -4899,6 +4972,7 @@ begin
       begin
       if LastToken=tkSemicolon then
         ParseExcSyntaxError;
+      continue;
       end
     else if TokenIsCallingConvention(CurTokenString,cc) then
       begin
@@ -4917,11 +4991,18 @@ begin
           NextToken; // remove offset
           end;
       end;
-      ExpectTokens([tkSemicolon,tkEqual]);
-      if CurToken=tkEqual then
-        UngetToken;
+      if IsProc then
+        ExpectTokens([tkSemicolon])
+      else
+        begin
+        ExpectTokens([tkSemicolon,tkEqual]);
+        if CurToken=tkEqual then
+          UngetToken;
+        end;
       end
-    else if IsProc and TokenIsProcedureModifier(Parent,CurTokenString,PM) then
+    else if IsAnonymProc and TokenIsAnonymousProcedureModifier(Parent,CurTokenString,PM) then
+      HandleProcedureModifier(Parent,PM)
+    else if IsProc and not IsAnonymProc and TokenIsProcedureModifier(Parent,CurTokenString,PM) then
       HandleProcedureModifier(Parent,PM)
     else if TokenIsProcedureTypeModifier(Parent,CurTokenString,PTM) then
       HandleProcedureTypeModifier(Element,PTM)
@@ -4930,16 +5011,22 @@ begin
       Tok:=UpperCase(CurTokenString);
       NextToken;
       If (tok<>'NAME') then
-        Element.Hints:=Element.Hints+[hLibrary]
+        begin
+        if hLibrary in Element.Hints then
+          ParseExcSyntaxError;
+        Element.Hints:=Element.Hints+[hLibrary];
+        end
       else
         begin
-        NextToken;  // Should be export name string.
+        NextToken;  // Should be "export name astring".
         ExpectToken(tkSemicolon);
         end;
       end
-    else if DoCheckHint(Element) then
+    else if (not IsAnonymProc) and DoCheckHint(Element) then
+      // deprecated,platform,experimental,library, unimplemented etc
       ConsumeSemi
-    else if (CurToken=tkIdentifier) and (CompareText(CurTokenText,'alias')=0) then
+    else if (CurToken=tkIdentifier) and (not IsAnonymProc)
+        and (CompareText(CurTokenText,'alias')=0) then
       begin
       ExpectToken(tkColon);
       ExpectToken(tkString);
@@ -4959,44 +5046,48 @@ begin
         begin
         // ToDo: read FPC's [] modifiers, e.g. [public,alias:'']
         repeat
-          NextToken
+          NextToken;
+          if CurToken in [tkSquaredBraceOpen,tkSemicolon] then
+            CheckToken(tkSquaredBraceClose);
         until CurToken = tkSquaredBraceClose;
         ExpectToken(tkSemicolon);
         end;
       end
     else
-      CheckToken(tkSemicolon);
-    Done:=(CurToken=tkSemiColon);
-    if Done then
       begin
-      NextToken;
-      Done:=Not ((Curtoken=tkSquaredBraceOpen) or
-                  TokenIsProcedureModifier(Parent,CurtokenString,PM) or
-                  TokenIsProcedureTypeModifier(Parent,CurtokenString,PTM) or
-                  IsCurTokenHint() or
-                  TokenIsCallingConvention(CurTokenString,cc) or
-                  (CurToken=tkIdentifier) and (CompareText(CurTokenText,'alias')=0));
-      {$ifdef VerbosePasParser}
-      DumpCurToken('Done '+IntToStr(Ord(Done)));
-      {$endif}
-      UngetToken;
+      // not a modifier/hint/calling convention
+      if LastToken=tkSemicolon then
+        begin
+        UngetToken;
+        if IsAnonymProc and (ModTokenCount<=1) then
+          ParseExcSyntaxError;
+        break;
+        end
+      else if IsAnonymProc then
+        begin
+        UngetToken;
+        break;
+        end
+      else
+        begin
+        CheckToken(tkSemicolon);
+        continue;
+        end;
       end;
-
-//    Writeln('Done: ',TokenInfos[Curtoken],' ',CurtokenString);
-  Until Done;
-  if DoCheckHint(Element) then  // deprecated,platform,experimental,library, unimplemented etc
-    ConsumeSemi;
+    // Writeln('Done: ',TokenInfos[Curtoken],' ',CurtokenString);
+  Until false;
   if (ProcType in [ptOperator,ptClassOperator]) and (Parent is TPasOperator) then
     TPasOperator(Parent).CorrectName;
   Engine.FinishScope(stProcedureHeader,Element);
-  if (Parent is TPasProcedure)
+  if IsProc
   and (not TPasProcedure(Parent).IsForward)
   and (not TPasProcedure(Parent).IsExternal)
   and ((Parent.Parent is TImplementationSection)
-     or (Parent.Parent is TProcedureBody))
+     or (Parent.Parent is TProcedureBody)
+     or IsAnonymProc)
   then
     ParseProcedureBody(Parent);
-  if Parent is TPasProcedure then
+  if IsProc then
     Engine.FinishScope(stProcedure,Parent);
 end;
 
@@ -5257,6 +5348,7 @@ procedure TPasParser.ParseProcBeginBlock(Parent: TProcedureBody);
 var
   BeginBlock: TPasImplBeginBlock;
   SubBlock: TPasImplElement;
+  Proc: TPasProcedure;
 begin
   BeginBlock := TPasImplBeginBlock(CreateElement(TPasImplBeginBlock, '', Parent));
   Parent.Body := BeginBlock;
@@ -5273,7 +5365,11 @@ begin
         ExpectToken(tkend);
     end;
   until false;
-  ExpectToken(tkSemicolon);
+  Proc:=Parent.Parent as TPasProcedure;
+  if Proc.GetProcTypeEnum in [ptAnonymousProcedure,ptAnonymousFunction] then
+    NextToken
+  else
+    ExpectToken(tkSemicolon);
 //  writeln('TPasParser.ParseProcBeginBlock ended ',curtokenstring);
 end;
 
@@ -5974,12 +6070,15 @@ begin
     ptDestructor     : Result:=TPasDestructor;
     ptOperator       : Result:=TPasOperator;
     ptClassOperator  : Result:=TPasClassOperator;
+    ptAnonymousProcedure: Result:=TPasAnonymousProcedure;
+    ptAnonymousFunction: Result:=TPasAnonymousFunction;
   else
     ParseExc(nParserUnknownProcedureType,SParserUnknownProcedureType,[Ord(ProcType)]);
   end;
 end;
 
-function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement; ProcType: TProcType;AVisibility : TPasMemberVisibility = VisDefault): TPasProcedure;
+function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement;
+  ProcType: TProcType; AVisibility: TPasMemberVisibility): TPasProcedure;
 
   function ExpectProcName: string;
 
@@ -6023,9 +6122,8 @@ var
   IsTokenBased , ok: Boolean;
 
 begin
-  If (Not (ProcType in [ptOperator,ptClassOperator])) then
-    Name:=ExpectProcName
-  else
+  case ProcType of
+  ptOperator,ptClassOperator:
     begin
     NextToken;
     IsTokenBased:=Curtoken<>tkIdentifier;
@@ -6037,14 +6135,19 @@ begin
       ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]);
     Name:=OperatorNames[Ot];
     end;
+  ptAnonymousProcedure,ptAnonymousFunction:
+    Name:='';
+  else
+    Name:=ExpectProcName;
+  end;
   PC:=GetProcedureClass(ProcType);
-  Parent:=CheckIfOverLoaded(Parent,Name);
+  if Name<>'' then
+    Parent:=CheckIfOverLoaded(Parent,Name);
   Result:=TPasProcedure(CreateElement(PC,Name,Parent,AVisibility));
   ok:=false;
   try
-    if Not (ProcType in [ptFunction, ptClassFunction, ptOperator, ptClassOperator]) then
-      Result.ProcType := TPasProcedureType(CreateElement(TPasProcedureType, '', Result))
-    else
+    case ProcType of
+    ptFunction, ptClassFunction, ptOperator, ptClassOperator, ptAnonymousFunction:
       begin
       Result.ProcType := CreateFunctionType('', 'Result', Result, False, CurTokenPos);
       if (ProcType in [ptOperator, ptClassOperator]) then
@@ -6054,6 +6157,9 @@ begin
         TPasOperator(Result).CorrectName;
         end;
       end;
+    else
+      Result.ProcType := TPasProcedureType(CreateElement(TPasProcedureType, '', Result));
+    end;
     ParseProcedureOrFunctionHeader(Result, Result.ProcType, ProcType, False);
     Result.Hints:=Result.ProcType.Hints;
     Result.HintMessage:=Result.ProcType.HintMessage;

packages/fcl-passrc/tests/tcresolver.pas

@@ -32,7 +32,7 @@ type
   TSrcMarker = record
     Kind: TSrcMarkerKind;
     Filename: string;
-    Row: integer;
+    Row: cardinal;
     StartCol, EndCol: integer; // token start, end column
     Identifier: string;
     Next: PSrcMarker;
@@ -447,6 +447,25 @@ type
     Procedure TestProc_ImplicitCalls;
     Procedure TestProc_Absolute;
 
+    // anonymous procs
+    // ToDo: fppas2js: check "is TPasFunction", ".FuncType", "parent is TPasProcedureBody"
+    Procedure TestAnonymousProc_Assign;
+    // ToDo: does Delphi allow/require semicolon in assign?
+    Procedure TestAnonymousProc_Arg;
+    // ToDo: does Delphi allow/require semicolon in arg?
+    // ToDo: does Delphi allow calling directly?: function(i: word):word begin end(3)
+    Procedure TestAnonymousProc_EqualFail;
+    // ToDo: does Delphi allow ano proc in const?
+    Procedure TestAnonymousProc_ConstFail;
+    // ToDo: does Delphi allow assembler or calling conventions?
+    Procedure TestAnonymousProc_Assembler;
+    Procedure TestAnonymousProc_NameFail;
+    Procedure TestAnonymousProc_StatementFail;
+    Procedure TestAnonymousProc_Typecast;// ToDo
+    // ToDo: ano in with
+    // ToDo: ano in nested
+    // ToDo: ano in ano
+
     // record
     Procedure TestRecord;
     Procedure TestRecordVariant;
@@ -1411,7 +1430,7 @@ var
           DeclEl:=TPasAliasType(El).DestType;
           ResolverEngine.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol);
           if (aLabel^.Filename=DeclEl.SourceFilename)
-          and (aLabel^.Row=LabelLine)
+          and (integer(aLabel^.Row)=LabelLine)
           and (aLabel^.StartCol<=LabelCol)
           and (aLabel^.EndCol>=LabelCol) then
             exit; // success
@@ -1491,8 +1510,8 @@ begin
     if (Marker<>nil) then
       begin
       if Item.SourcePos.Row<>Marker^.Row then continue;
-      if (Item.SourcePos.Column<Marker^.StartCol)
-          or (Item.SourcePos.Column>Marker^.EndCol) then continue;
+      if (integer(Item.SourcePos.Column)<Marker^.StartCol)
+          or (integer(Item.SourcePos.Column)>Marker^.EndCol) then continue;
       end;
     // found
     FResolverGoodMsgs.Add(Item);
@@ -7135,6 +7154,137 @@ begin
   'begin']);
 end;
 
+procedure TTestResolver.TestAnonymousProc_Assign;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TFunc = reference to function(x: word): word;',
+  'var Func: TFunc;',
+  'procedure DoIt(a: word);',
+  'begin',
+  '  Func:=function(b:word): word',
+  '  begin',
+  '    Result:=a+b;',
+  '    exit(b);',
+  '    exit(Result);',
+  '  end;',
+  '  a:=3;',// test semicolon
+  'end;',
+  'begin']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAnonymousProc_Arg;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProc = reference to procedure;',
+  '  TFunc = reference to function(x: word): word;',
+  'procedure DoMore(f,g: TProc);',
+  'begin',
+  'end;',
+  'procedure DoIt(f: TFunc);',
+  'begin',
+  '  DoIt(function(b:word): word',
+  '    begin',
+  '      Result:=1+b;',
+  '    end;);',
+  '  DoMore(procedure begin end;, procedure begin end);',
+  'end;',
+  'begin']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAnonymousProc_EqualFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TFunc = reference to function(x: word): word;',
+  'procedure DoIt(f: TFunc);',
+  'var w: word;',
+  'begin',
+  '  if w=function(b:word): word',
+  '    begin',
+  '      Result:=1+b;',
+  '    end; then ;',
+  'end;',
+  'begin']);
+  CheckResolverException('Incompatible types: got "Procedure/Function" expected "Word"',nIncompatibleTypesGotExpected);
+end;
+
+procedure TTestResolver.TestAnonymousProc_ConstFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProc = reference to procedure;',
+  'const',
+  '  p: TProc = procedure begin end;',
+  'begin']);
+  CheckParserException('Identifier expected at token "procedure" in file afile.pp at line 5 column 14',nParserExpectedIdentifier);
+end;
+
+procedure TTestResolver.TestAnonymousProc_Assembler;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProc = reference to procedure;',
+  'procedure DoIt(p: TProc);',
+  'begin',
+  '  p:=procedure assembler; asm end;',
+  '  p:=procedure() assembler; asm end;',
+  'end;',
+  'begin']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAnonymousProc_NameFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProc = reference to procedure;',
+  'procedure DoIt(p: TProc);',
+  'begin',
+  '  p:=procedure Bla() begin end;',
+  'end;',
+  'begin']);
+  CheckParserException(SParserSyntaxError,nParserSyntaxError);
+end;
+
+procedure TTestResolver.TestAnonymousProc_StatementFail;
+begin
+  StartProgram(false);
+  Add([
+  'procedure DoIt;',
+  'begin',
+  '  procedure () begin end;',
+  'end;',
+  'begin']);
+  CheckParserException(SParserSyntaxError,nParserSyntaxError);
+end;
+
+procedure TTestResolver.TestAnonymousProc_Typecast;
+begin
+  exit;
+
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProc = reference to procedure(w: word);',
+  'procedure DoIt(p: TProc);',
+  'begin',
+  '  p:=TProc(procedure(b: byte) begin end);',
+  '  p:=TProc(procedure(b: byte) begin end;);',
+  'end;',
+  'begin']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestRecord;
 begin
   StartProgram(false);

packages/ide/Makefile.fpc

@@ -1,8 +1,13 @@
 #
 #   Makefile.fpc for running fpmake
 #
+[package]
+name=ide
+version=3.3.1
+
 [require]
-packages=rtl fpmkunit
+packages=rtl fpmkunit rtl-extra fv chm regexpr
+packages_go32v2=graph
 
 [install]
 fpcpackage=y
@@ -67,7 +72,7 @@ ifdef GDBMI
 FPMAKE_OPT+=--GDBMI=1
 # If the rtl does not require libc, then
 # IDE compiled with GDBMI should be a static executable
-# and can thus be cross-compiled 
+# and can thus be cross-compiled
 ifeq ($(findstring $(OS_TARGET),aix beos darwin haiku solaris),)
 GDBMI_IS_STATIC=1
 endif

packages/morphunits/fpmake.pp

@@ -60,6 +60,7 @@ begin
     T:=P.Targets.AddUnit('icon.pas');
     T:=P.Targets.AddUnit('locale.pas');
     T:=P.Targets.AddUnit('commodities.pas');
+    T:=P.Targets.AddUnit('serial.pas');
 
 {$ifndef ALLPACKAGES}
     Run;

packages/morphunits/src/exec.pas

@@ -2342,6 +2342,9 @@ function AddExecNode(InNode: APTR; const Tags: array of PtrUInt): APTR; inline;
 function NewGetTaskPIDAttrs(PID: LongWord; Data: APTR; DataSize, Type_: LongWord; const Tags: array of PtrUInt): LongWord; inline;
 function NewSetTaskPIDAttrs(PID: LongWord; Data: APTR; DataSize, Type_: LongWord; const Tags: array of PtrUInt): LongWord; inline;
 
+function CreateExtIO(const Mp: PMsgPort; Size: Integer): PIORequest;
+procedure DeleteExtIO(ioReq: PIORequest);
+
 implementation
 
 function NewGetTaskAttrs(Task: PTask; Data: APTR; DataSize, TType: LongWord; const Tags: array of PtrUInt): LongWord; Inline;
@@ -2486,6 +2489,30 @@ asm
   lwz r3,68(r2)
 end;
 
+function CreateExtIO(const Mp: PMsgPort; Size: Integer): PIORequest;
+begin
+  CreateExtIO := nil;
+  if not Assigned(mp) then
+    Exit;
+  CreateExtIO := System.AllocMem(Size);
+  if Assigned(CreateExtIO) then
+  begin
+    CreateExtIO^.io_Message.mn_Node.ln_Type := NT_REPLYMSG;
+    CreateExtIO^.io_Message.mn_ReplyPort := Mp;
+    CreateExtIO^.io_Message.mn_Length := Size;
+  end;
+end;
+
+procedure DeleteExtIO(ioReq: PIORequest);
+begin
+  if Assigned(ioReq) then
+  begin
+    ioReq^.io_Message.mn_Node.ln_Type := Byte(-1);
+    ioReq^.io_Device := Pointer(-1);
+    ioReq^.io_Unit := Pointer(-1);
+    System.FreeMem(ioReq);
+  end;
+end;
 
 begin
   ExecBase:=MOS_ExecBase;

packages/morphunits/src/serial.pas

@@ -0,0 +1,165 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    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.
+
+ **********************************************************************}
+
+unit serial;
+
+interface
+{$PACKRECORDS 2}
+
+uses
+  exec;
+
+type
+
+  // array of termination char's to use,see serial.doc setparams
+  PIOTArray = ^TIOTArray;
+  TIOTArray = record
+    TermArray0: LongWord;
+    TermArray1: LongWord;
+  end;
+
+const
+  SER_DEFAULT_CTLCHAR = $11130000; // default chars for xON,xOFF
+
+{ You may change these via SETPARAMS.   At this time, parity is not
+   calculated for xON/xOFF characters.  You must supply them with the
+   desired parity. }
+
+{****************************************************************}
+{ CAUTION !!  IF YOU ACCESS the serial.device, you MUST (!!!!) use an
+   IOExtSer-sized structure or you may overlay innocent memory !! }
+{****************************************************************}
+
+type
+  TIOExtSer = record
+    IOSer: TIOStdReq;
+    io_CtlChar: LongWord;    // control characters
+    io_RBufLen: LongWord;    // length in bytes of serial read buffer
+    io_ExtFlags: LongWord;   // additional serial flags (SEXTB_*)
+    io_Baud: LongWord;       // baud rate
+    io_BrkTime: LongWord;    // duration of break in microseconds
+    io_TermArray: TIOTArray; // termination character array
+    io_ReadLen: Byte;        // number of bits per read character
+    io_WriteLen: Byte;       // number of bits per write character
+    io_StopBits: Byte;       // number of stopbits for read
+    io_SerFlags: Byte;       // serial device flags (SERB_*)
+    io_Status: Word;         // status of serial port and lines (IO_STATF_*, IOSTF_*)
+  end;
+  PIOExtSer = ^TIOExtSer;
+
+ { status of serial port, as follows:
+      BIT  ACTIVE  FUNCTION
+       0    ---    reserved
+       1    ---    reserved
+       2    high   Connected to parallel "select" on the A1000.
+                   Connected to both the parallel "select" and
+                   serial "ring indicator" pins on the A500 &
+                   A2000.  Take care when making cables.
+       3    low    Data Set Ready
+       4    low    Clear To Send
+       5    low    Carrier Detect
+       6    low    Ready To Send
+       7    low    Data Terminal Ready
+       8    high   read overrun
+       9    high   break sent
+      10    high   break received
+      11    high   transmit x-OFFed
+      12    high   receive x-OFFed
+   13-15           reserved}
+
+const
+  SDCMD_QUERY     = CMD_NONSTD;
+  SDCMD_BREAK     = CMD_NONSTD + 1;
+  SDCMD_SETPARAMS = CMD_NONSTD + 2;
+
+  // flags of TIOExtSer.io_SerFlags
+  SERB_XDISABLED      = 7;                     // xOn-xOff feature disabled
+  SERF_XDISABLED      = 1 shl SERB_XDISABLED;
+  SERB_EOFMODE        = 6;                     // EOF mode enabled
+  SERF_EOFMODE        = 1 shl SERB_EOFMODE;
+  SERB_SHARED         = 5;                     // non-exclusive access
+  SERF_SHARED         = 1 shl SERB_SHARED;
+  SERB_RAD_BOOGIE     = 4;                     // high-speed mode active
+  SERF_RAD_BOOGIE     = 1 shl SERB_RAD_BOOGIE;
+  SERB_QUEUEDBRK      = 3;                     // queue this Break ioRqst
+  SERF_QUEUEDBRK      = 1 shl SERB_QUEUEDBRK;
+  SERB_7WIRE          = 2;                     // RS232 7-wire protocol
+  SERF_7WIRE          = 1 shl SERB_7WIRE;
+  SERB_PARTY_ODD      = 1;                     // parity feature enabled
+  SERF_PARTY_ODD      = 1 shl SERB_PARTY_ODD;
+  SERB_PARTY_ON       = 0;                     // parity-enabled
+  SERF_PARTY_ON       = 1 shl SERB_PARTY_ON;
+
+// These now refect the actual bit positions in the TIOExtSer.io_Status LongWord
+  IO_STATB_XOFFREAD   = 12;                       // receive currently xOFF'ed
+  IO_STATF_XOFFREAD   = 1 shl IO_STATB_XOFFREAD;
+  IO_STATB_XOFFWRITE  = 11;                       // transmit currently xOFF'ed
+  IO_STATF_XOFFWRITE  = 1 shl IO_STATB_XOFFWRITE;
+  IO_STATB_READBREAK  = 10;                       // break was latest input
+  IO_STATF_READBREAK  = 1 shl IO_STATB_READBREAK;
+  IO_STATB_WROTEBREAK = 9;                        // break was latest output
+  IO_STATF_WROTEBREAK = 1 shl IO_STATB_WROTEBREAK;
+  IO_STATB_OVERRUN    = 8;                        // status word RBF overrun
+  IO_STATF_OVERRUN    = 1 shl IO_STATB_OVERRUN;
+
+// TIOExtSer.io_ExtFlags
+  SEXTB_MSPON = 1;                 // Use mark-space parity, instead of odd-even.
+  SEXTF_MSPON = 1 shl SEXTB_MSPON;
+  SEXTB_MARK  = 0;                 // if mark-space, use mark
+  SEXTF_MARK  = 1 shl SEXTB_MARK;
+
+  SerErr_DevBusy       = 1;
+  SerErr_BaudMismatch  = 2;  // baud rate not supported by hardware
+  SerErr_BufErr        = 4;  // Failed to allocate new read buffer
+  SerErr_InvParam      = 5;
+  SerErr_LineErr       = 6;
+  SerErr_ParityErr     = 9;
+  SerErr_TimerErr      = 11; // (See the serial/OpenDevice autodoc)
+  SerErr_BufOverflow   = 12;
+  SerErr_NoDSR         = 13;
+  SerErr_DetectedBreak = 15;
+
+
+{ These defines refer to the HIGH ORDER byte of io_Status.  They have
+   been replaced by the new, corrected ones above }
+  IOSTB_XOFFREAD  = 4;                      // receive currently xOFF'ed
+  IOSTF_XOFFREAD  = 1 shl IOSTB_XOFFREAD;
+  IOSTB_XOFFWRITE = 3;                      // transmit currently xOFF'ed
+  IOSTF_XOFFWRITE = 1 shl IOSTB_XOFFWRITE;
+  IOSTB_READBREAK = 2;                      // break was latest input
+  IOSTF_READBREAK = 1 shl IOSTB_READBREAK;
+  IOSTB_WROTEBREAK= 1;                      // break was latest output
+  IOSTF_WROTEBREAK= 1 shl IOSTB_WROTEBREAK;
+  IOSTB_OVERRUN   = 0;                      // status word RBF overrun
+  IOSTF_OVERRUN   = 1 shl IOSTB_OVERRUN;
+
+// TIOExtSer.io_Flags
+  IOSERB_BUFRREAD = 7;                     // from read buffer
+  IOSERF_BUFRREAD = 1 shl IOSERB_BUFRREAD;
+  IOSERB_QUEUED   = 6;                     // rqst-queued
+  IOSERF_QUEUED   = 1 shl IOSERB_QUEUED;
+  IOSERB_ABORT    = 5;                     // rqst-aborted
+  IOSERF_ABORT    = 1 shl IOSERB_ABORT;
+  IOSERB_ACTIVE   = 4;                     // rqst-qued-OR-current
+  IOSERF_ACTIVE   = 1 shl IOSERB_ACTIVE;
+
+  SERIALNAME: PChar = 'serial.device';
+
+implementation
+
+
+
+end.

packages/os4units/fpmake.pp

@@ -51,6 +51,7 @@ begin
     T:=P.Targets.AddUnit('cybergraphics.pas');
     T:=P.Targets.AddUnit('locale.pas');
     T:=P.Targets.AddUnit('datatypes.pas');
+    T:=P.Targets.AddUnit('serial.pas');
 
 {$ifndef ALLPACKAGES}
     Run;

packages/os4units/src/exec.pas

@@ -1987,6 +1987,9 @@ function IsMinListEmpty(List: PMinList): Boolean; inline;
 function IsMsgPortEmpty(mp: PMsgPort): Boolean; inline;
 procedure NewListType(var List: PList; NType: Byte); inline;
 
+function CreateExtIO(const Mp: PMsgPort; Size: Integer): PIORequest;
+procedure DeleteExtIO(ioReq: PIORequest);
+
 implementation
 
 function BitMask(No: ShortInt): LongInt; inline;
@@ -2016,4 +2019,29 @@ begin
   List^.lh_Type := NType;
 end;
 
+function CreateExtIO(const Mp: PMsgPort; Size: Integer): PIORequest;
+begin
+  CreateExtIO := nil;
+  if not Assigned(mp) then
+    Exit;
+  CreateExtIO := System.AllocMem(Size);
+  if Assigned(CreateExtIO) then
+  begin
+    CreateExtIO^.io_Message.mn_Node.ln_Type := NT_REPLYMSG;
+    CreateExtIO^.io_Message.mn_ReplyPort := Mp;
+    CreateExtIO^.io_Message.mn_Length := Size;
+  end;
+end;
+
+procedure DeleteExtIO(ioReq: PIORequest);
+begin
+  if Assigned(ioReq) then
+  begin
+    ioReq^.io_Message.mn_Node.ln_Type := Byte(-1);
+    ioReq^.io_Device := Pointer(-1);
+    ioReq^.io_Unit := Pointer(-1);
+    System.FreeMem(ioReq);
+  end;
+end;
+
 end.

packages/os4units/src/serial.pas

@@ -0,0 +1,165 @@
+{
+    This file is part of the Free Pascal run time library.
+
+    A file in Amiga system run time library.
+    Copyright (c) 1998 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    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.
+
+ **********************************************************************}
+
+unit serial;
+
+interface
+{$PACKRECORDS 2}
+
+uses
+  exec;
+
+type
+
+  // array of termination char's to use,see serial.doc setparams
+  PIOTArray = ^TIOTArray;
+  TIOTArray = record
+    TermArray0: LongWord;
+    TermArray1: LongWord;
+  end;
+
+const
+  SER_DEFAULT_CTLCHAR = $11130000; // default chars for xON,xOFF
+
+{ You may change these via SETPARAMS.   At this time, parity is not
+   calculated for xON/xOFF characters.  You must supply them with the
+   desired parity. }
+
+{****************************************************************}
+{ CAUTION !!  IF YOU ACCESS the serial.device, you MUST (!!!!) use an
+   IOExtSer-sized structure or you may overlay innocent memory !! }
+{****************************************************************}
+
+type
+  TIOExtSer = record
+    IOSer: TIOStdReq;
+    io_CtlChar: LongWord;    // control characters
+    io_RBufLen: LongWord;    // length in bytes of serial read buffer
+    io_ExtFlags: LongWord;   // additional serial flags (SEXTB_*)
+    io_Baud: LongWord;       // baud rate
+    io_BrkTime: LongWord;    // duration of break in microseconds
+    io_TermArray: TIOTArray; // termination character array
+    io_ReadLen: Byte;        // number of bits per read character
+    io_WriteLen: Byte;       // number of bits per write character
+    io_StopBits: Byte;       // number of stopbits for read
+    io_SerFlags: Byte;       // serial device flags (SERB_*)
+    io_Status: Word;         // status of serial port and lines (IO_STATF_*, IOSTF_*)
+  end;
+  PIOExtSer = ^TIOExtSer;
+
+ { status of serial port, as follows:
+      BIT  ACTIVE  FUNCTION
+       0    ---    reserved
+       1    ---    reserved
+       2    high   Connected to parallel "select" on the A1000.
+                   Connected to both the parallel "select" and
+                   serial "ring indicator" pins on the A500 &
+                   A2000.  Take care when making cables.
+       3    low    Data Set Ready
+       4    low    Clear To Send
+       5    low    Carrier Detect
+       6    low    Ready To Send
+       7    low    Data Terminal Ready
+       8    high   read overrun
+       9    high   break sent
+      10    high   break received
+      11    high   transmit x-OFFed
+      12    high   receive x-OFFed
+   13-15           reserved}
+
+const
+  SDCMD_QUERY     = CMD_NONSTD;
+  SDCMD_BREAK     = CMD_NONSTD + 1;
+  SDCMD_SETPARAMS = CMD_NONSTD + 2;
+
+  // flags of TIOExtSer.io_SerFlags
+  SERB_XDISABLED      = 7;                     // xOn-xOff feature disabled
+  SERF_XDISABLED      = 1 shl SERB_XDISABLED;
+  SERB_EOFMODE        = 6;                     // EOF mode enabled
+  SERF_EOFMODE        = 1 shl SERB_EOFMODE;
+  SERB_SHARED         = 5;                     // non-exclusive access
+  SERF_SHARED         = 1 shl SERB_SHARED;
+  SERB_RAD_BOOGIE     = 4;                     // high-speed mode active
+  SERF_RAD_BOOGIE     = 1 shl SERB_RAD_BOOGIE;
+  SERB_QUEUEDBRK      = 3;                     // queue this Break ioRqst
+  SERF_QUEUEDBRK      = 1 shl SERB_QUEUEDBRK;
+  SERB_7WIRE          = 2;                     // RS232 7-wire protocol
+  SERF_7WIRE          = 1 shl SERB_7WIRE;
+  SERB_PARTY_ODD      = 1;                     // parity feature enabled
+  SERF_PARTY_ODD      = 1 shl SERB_PARTY_ODD;
+  SERB_PARTY_ON       = 0;                     // parity-enabled
+  SERF_PARTY_ON       = 1 shl SERB_PARTY_ON;
+
+// These now refect the actual bit positions in the TIOExtSer.io_Status LongWord
+  IO_STATB_XOFFREAD   = 12;                       // receive currently xOFF'ed
+  IO_STATF_XOFFREAD   = 1 shl IO_STATB_XOFFREAD;
+  IO_STATB_XOFFWRITE  = 11;                       // transmit currently xOFF'ed
+  IO_STATF_XOFFWRITE  = 1 shl IO_STATB_XOFFWRITE;
+  IO_STATB_READBREAK  = 10;                       // break was latest input
+  IO_STATF_READBREAK  = 1 shl IO_STATB_READBREAK;
+  IO_STATB_WROTEBREAK = 9;                        // break was latest output
+  IO_STATF_WROTEBREAK = 1 shl IO_STATB_WROTEBREAK;
+  IO_STATB_OVERRUN    = 8;                        // status word RBF overrun
+  IO_STATF_OVERRUN    = 1 shl IO_STATB_OVERRUN;
+
+// TIOExtSer.io_ExtFlags
+  SEXTB_MSPON = 1;                 // Use mark-space parity, instead of odd-even.
+  SEXTF_MSPON = 1 shl SEXTB_MSPON;
+  SEXTB_MARK  = 0;                 // if mark-space, use mark
+  SEXTF_MARK  = 1 shl SEXTB_MARK;
+
+  SerErr_DevBusy       = 1;
+  SerErr_BaudMismatch  = 2;  // baud rate not supported by hardware
+  SerErr_BufErr        = 4;  // Failed to allocate new read buffer
+  SerErr_InvParam      = 5;
+  SerErr_LineErr       = 6;
+  SerErr_ParityErr     = 9;
+  SerErr_TimerErr      = 11; // (See the serial/OpenDevice autodoc)
+  SerErr_BufOverflow   = 12;
+  SerErr_NoDSR         = 13;
+  SerErr_DetectedBreak = 15;
+
+
+{ These defines refer to the HIGH ORDER byte of io_Status.  They have
+   been replaced by the new, corrected ones above }
+  IOSTB_XOFFREAD  = 4;                      // receive currently xOFF'ed
+  IOSTF_XOFFREAD  = 1 shl IOSTB_XOFFREAD;
+  IOSTB_XOFFWRITE = 3;                      // transmit currently xOFF'ed
+  IOSTF_XOFFWRITE = 1 shl IOSTB_XOFFWRITE;
+  IOSTB_READBREAK = 2;                      // break was latest input
+  IOSTF_READBREAK = 1 shl IOSTB_READBREAK;
+  IOSTB_WROTEBREAK= 1;                      // break was latest output
+  IOSTF_WROTEBREAK= 1 shl IOSTB_WROTEBREAK;
+  IOSTB_OVERRUN   = 0;                      // status word RBF overrun
+  IOSTF_OVERRUN   = 1 shl IOSTB_OVERRUN;
+
+// TIOExtSer.io_Flags
+  IOSERB_BUFRREAD = 7;                     // from read buffer
+  IOSERF_BUFRREAD = 1 shl IOSERB_BUFRREAD;
+  IOSERB_QUEUED   = 6;                     // rqst-queued
+  IOSERF_QUEUED   = 1 shl IOSERB_QUEUED;
+  IOSERB_ABORT    = 5;                     // rqst-aborted
+  IOSERF_ABORT    = 1 shl IOSERB_ABORT;
+  IOSERB_ACTIVE   = 4;                     // rqst-qued-OR-current
+  IOSERF_ACTIVE   = 1 shl IOSERB_ACTIVE;
+
+  SERIALNAME: PChar = 'serial.device';
+
+implementation
+
+
+
+end.

packages/pastojs/src/fppas2js.pp

@@ -290,8 +290,8 @@ Works:
   - for key in JSObject do
   - for value in JSArray do
 - Assert(bool[,string])
-  - without sysutils: if(bool) throw string
-  - with sysutils: if(bool) throw pas.sysutils.EAssertionFailed.$create("Create",[string])
+  - without sysutils: if(!bool) throw string
+  - with sysutils: if(!bool) throw pas.sysutils.EAssertionFailed.$create("Create",[string])
 - Object checks:
   - Method call EInvalidCast, rtl.checkMethodCall
   - type cast to class-type and class-of-type, rtl.asExt, EInvalidCast
@@ -354,6 +354,7 @@ Works:
 - typecast byte(longword) -> value & $ff
 - typecast TJSFunction(func)
 - modeswitch OmitRTTI
+- debugger;
 
 ToDos:
 - do not rename property Date
@@ -1262,8 +1263,11 @@ type
     procedure ComputeBinaryExprRes(Bin: TBinaryExpr; out
       ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
       var LeftResolved, RightResolved: TPasResolverResult); override;
+    // built-in functions
     procedure BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc;
       Params: TParamsExpr; out ResolvedEl: TPasResolverResult); override;
+    function BI_Debugger_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
+      Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
   public
     constructor Create; reintroduce;
     destructor Destroy; override;
@@ -1613,6 +1617,7 @@ type
     Function CreateLiteralUndefined(El: TPasElement): TJSLiteral; virtual;
     Function CreateLiteralCustomValue(El: TPasElement; const s: TJSString): TJSLiteral; virtual;
     Function CreateSetLiteralElement(Expr: TPasExpr; AContext: TConvertContext): TJSElement; virtual;
+    Function CreateUnaryNot(El: TJSElement; Src: TPasElement): TJSUnaryNotExpression; virtual;
     Procedure ConvertCharLiteralToInt(Lit: TJSLiteral; ErrorEl: TPasElement; AContext: TConvertContext); virtual;
     Function ClonePrimaryExpression(El: TJSPrimaryExpression; Src: TPasElement): TJSPrimaryExpression;
     // simple JS expressions
@@ -1748,6 +1753,7 @@ type
     Function ConvertBuiltIn_New(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_Dispose(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_Default(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
+    Function ConvertBuiltIn_Debugger(El: TPasExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertRecordValues(El: TRecordValues; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertSelfExpression(El: TSelfExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBinaryExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; virtual;
@@ -1863,6 +1869,8 @@ function PosLast(c: char; const s: string): integer;
 
 function JSEquals(A, B: TJSElement): boolean;
 
+function dbgs(opts: TPasToJsConverterOptions): string; overload;
+
 implementation
 
 const
@@ -1907,6 +1915,21 @@ begin
     exit(false);
 end;
 
+function dbgs(opts: TPasToJsConverterOptions): string;
+var
+  o: TPasToJsConverterOption;
+  h: string;
+begin
+  Result:='';
+  for o in opts do
+    begin
+    if Result<>'' then Result:=Result+',';
+    str(o,h);
+    Result:=Result+h;
+    end;
+  Result:='['+Result+']';
+end;
+
 { TPas2JSSectionScope }
 
 procedure TPas2JSSectionScope.InternalAddElevatedLocal(Item: TPasIdentifier);
@@ -2048,10 +2071,40 @@ end;
 
 function TPas2jsPasScanner.HandleInclude(const Param: String): TToken;
 
-  procedure SetStr(const s: string);
+  procedure SetStr(s: string);
+  var
+    i: Integer;
+    h: String;
   begin
     Result:=tkString;
-    SetCurTokenString(''''+s+'''');
+    if s='' then
+      s:=''''''
+    else
+      for i:=length(s) downto 1 do
+        case s[i] of
+        #0..#31,#127:
+          begin
+          h:='#'+IntToStr(ord(s[i]));
+          if i>1 then h:=''''+h;
+          if (i<length(s)) and (s[i+1]<>'#') then
+            h:=h+'''';
+          s:=LeftStr(s,i-1)+h+copy(s,i+1,length(s));
+          end;
+        else
+          if i=length(s) then
+            s:=s+'''';
+          if s[i]='''' then
+            Insert('''',s,i);
+          if i=1 then
+            s:=''''+s;
+        end;
+    SetCurTokenString(s);
+  end;
+
+  procedure SetInteger(const i: TMaxPrecInt);
+  begin
+    Result:=tkNumber;
+    SetCurTokenString(IntToStr(i));
   end;
 
 var
@@ -2061,15 +2114,31 @@ var
 begin
   if (Param<>'') and (Param[1]='%') then
   begin
+    if (length(Param)<3) or (Param[length(Param)]<>'%') then
+      begin
+      SetStr('');
+      DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,SWarnIllegalCompilerDirectiveX,
+        ['$i '+Param]);
+      exit;
+      end;
+    if length(Param)>255 then
+      begin
+      SetStr('');
+      DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,SWarnIllegalCompilerDirectiveX,
+        ['$i '+copy(Param,1,255)+'...']);
+      exit;
+      end;
     case lowercase(Param) of
     '%date%':
       begin
+        // 'Y/M/D'
         DecodeDate(Now,Year,Month,Day);
         SetStr(IntToStr(Year)+'/'+IntToStr(Month)+'/'+IntToStr(Day));
         exit;
       end;
     '%time%':
       begin
+        // 'hh:mm:ss'
         DecodeTime(Now,Hour,Minute,Second,MilliSecond);
         SetStr(Format('%2d:%2d:%2d',[Hour,Minute,Second]));
         exit;
@@ -2090,11 +2159,21 @@ begin
         SetStr(CompilerVersion);
         exit;
       end;
+    '%file%':
+      begin
+        SetStr(CurFilename);
+        exit;
+      end;
     '%line%':
       begin
         SetStr(IntToStr(CurRow));
         exit;
       end;
+    '%linenum%':
+      begin
+        SetInteger(CurRow);
+        exit;
+      end;
     '%currentroutine%':
       begin
         if Resolver<>nil then
@@ -2112,8 +2191,8 @@ begin
         exit;
       end;
     else
-      DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,SWarnIllegalCompilerDirectiveX,
-        ['$i '+Param]);
+      SetStr(GetEnvironmentVariable(copy(Param,2,length(Param)-2)));
+      exit;
     end;
   end;
   Result:=inherited HandleInclude(Param);
@@ -4231,6 +4310,16 @@ begin
   if Proc=nil then ;
 end;
 
+function TPas2JSResolver.BI_Debugger_OnGetCallCompatibility(
+  Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
+// debugger;
+begin
+  if Expr is TParamsExpr then
+    Result:=CheckBuiltInMaxParamCount(Proc,TParamsExpr(Expr),0,RaiseOnError)
+  else
+    Result:=cExact;
+end;
+
 constructor TPas2JSResolver.Create;
 var
   bt: TPas2jsBaseType;
@@ -4321,6 +4410,9 @@ begin
     AddBaseType(Pas2JSBuiltInNames[pbitnUIntDouble],btUIntDouble);
   if btIntDouble in TheBaseTypes then
     AddBaseType(Pas2JSBuiltInNames[pbitnIntDouble],btIntDouble);
+  AddBuiltInProc('Debugger','procedure Debugger',
+      @BI_Debugger_OnGetCallCompatibility,nil,
+      nil,nil,bfCustom,[bipfCanBeStatement]);
 end;
 
 function TPas2JSResolver.CheckTypeCastRes(const FromResolved,
@@ -5804,10 +5896,12 @@ begin
         BitwiseNot:=ResolvedOp.BaseType in btAllJSInteger;
         end;
       if BitwiseNot then
-        U:=TJSUnaryInvExpression(CreateElement(TJSUnaryInvExpression,El))
+        begin
+        U:=TJSUnaryInvExpression(CreateElement(TJSUnaryInvExpression,El));
+        U.A:=E;
+        end
       else
-        U:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
-      U.A:=E;
+        U:=CreateUnaryNot(E,El);
       end;
     eopAddress:
       begin
@@ -6276,7 +6370,6 @@ function TPasToJSConverter.ConvertBinaryExpressionRes(El: TBinaryExpr;
   function CreateEqualCallback: TJSElement;
   var
     Call: TJSCallExpression;
-    NotEl: TJSUnaryNotExpression;
   begin
     // convert "proctypeA = proctypeB" to "rtl.eqCallback(proctypeA,proctypeB)"
     Call:=CreateCallExpression(El);
@@ -6288,9 +6381,7 @@ function TPasToJSConverter.ConvertBinaryExpressionRes(El: TBinaryExpr;
     if El.OpCode=eopNotEqual then
       begin
       // convert "proctypeA <> proctypeB" to "!rtl.eqCallback(proctypeA,proctypeB)"
-      NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
-      NotEl.A:=Call;
-      Result:=NotEl;
+      Result:=CreateUnaryNot(Call,El);
       end
     else
       Result:=Call;
@@ -6311,7 +6402,6 @@ var
   FunName: String;
   Call: TJSCallExpression;
   DotExpr: TJSDotMemberExpression;
-  NotEl: TJSUnaryNotExpression;
   InOp: TJSRelationalExpressionIn;
   TypeEl, LeftTypeEl, RightTypeEl: TPasType;
   SNE: TJSEqualityExpressionSNE;
@@ -6634,11 +6724,7 @@ begin
             Call.AddArg(A);
             A:=nil;
             if El.OpCode=eopNotEqual then
-              begin
-              NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
-              NotEl.A:=Call;
-              Result:=NotEl;
-              end
+              Result:=CreateUnaryNot(Call,El)
             else
               Result:=Call;
             exit;
@@ -6674,9 +6760,7 @@ begin
             if El.OpCode=eopNotEqual then
               begin
               // convert "recordA <> recordB" to "!recordA.$equal(recordB)"
-              NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
-              NotEl.A:=Call;
-              Result:=NotEl;
+              Result:=CreateUnaryNot(Call,El);
               end
             else
               Result:=Call;
@@ -6697,11 +6781,7 @@ begin
             Call.AddArg(B);
             B:=nil;
             if El.OpCode=eopNotEqual then
-              begin
-              NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
-              NotEl.A:=Call;
-              Result:=NotEl;
-              end
+              Result:=CreateUnaryNot(Call,El)
             else
               Result:=Call;
             exit;
@@ -6721,11 +6801,7 @@ begin
           Call.AddArg(B);
           B:=nil;
           if El.OpCode=eopNotEqual then
-            begin
-            NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
-            NotEl.A:=Call;
-            Result:=NotEl;
-            end
+            Result:=CreateUnaryNot(Call,El)
           else
             Result:=Call;
           exit;
@@ -6760,11 +6836,7 @@ begin
               Call.AddArg(A);
               A:=nil;
               if El.OpCode=eopNotEqual then
-                begin
-                NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
-                NotEl.A:=Call;
-                Result:=NotEl;
-                end
+                Result:=CreateUnaryNot(Call,El)
               else
                 Result:=Call;
               exit;
@@ -7284,6 +7356,12 @@ begin
       bfBreak: Result:=ConvertBuiltInBreak(El,AContext);
       bfContinue: Result:=ConvertBuiltInContinue(El,AContext);
       bfExit: Result:=ConvertBuiltIn_Exit(El,AContext);
+      bfCustom:
+        case BuiltInProc.Element.Name of
+        'Debugger': Result:=ConvertBuiltIn_Debugger(El,AContext);
+        else
+          RaiseNotSupported(El,AContext,20181126102554,'built in custom proc '+BuiltInProc.Element.Name);
+        end
     else
       RaiseNotSupported(El,AContext,20161130164955,'built in proc '+ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
     end;
@@ -8383,6 +8461,12 @@ begin
             if Result=nil then exit;
             end;
           bfDefault: Result:=ConvertBuiltIn_Default(El,AContext);
+          bfCustom:
+            case BuiltInProc.Element.Name of
+            'Debugger': Result:=ConvertBuiltIn_Debugger(El,AContext);
+            else
+              RaiseNotSupported(El,AContext,20181126101801,'built in custom proc '+BuiltInProc.Element.Name);
+            end;
         else
           RaiseNotSupported(El,AContext,20161130164955,'built in proc '+ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
         end;
@@ -10672,7 +10756,8 @@ begin
   IfSt:=TJSIfStatement(CreateElement(TJSIfStatement,El));
   try
     PosEl:=El.Params[0];
-    IfSt.Cond:=ConvertExpression(El.Params[0],AContext);
+    IfSt.Cond:=CreateUnaryNot(ConvertExpression(PosEl,AContext),PosEl);
+
     ThrowSt:=TJSThrowStatement(CreateElement(TJSThrowStatement,PosEl));
     IfSt.BTrue:=ThrowSt;
 
@@ -10973,6 +11058,13 @@ begin
     AContext.Resolver.GetResolverResultDescription(ResolvedEl)],Param);
 end;
 
+function TPasToJSConverter.ConvertBuiltIn_Debugger(El: TPasExpr;
+  AContext: TConvertContext): TJSElement;
+begin
+  Result:=CreateLiteralCustomValue(El,'debugger');
+  if AContext=nil then ;
+end;
+
 function TPasToJSConverter.ConvertRecordValues(El: TRecordValues;
   AContext: TConvertContext): TJSElement;
 var
@@ -11388,8 +11480,8 @@ Var
       IfSt:=TJSIfStatement(CreateElement(TJSIfStatement,ProcBody));
       AddFunctionFinallySt(IfSt,ProcBody,FuncContext);
       // !$ok
-      IfSt.Cond:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,ProcBody));
-      TJSUnaryNotExpression(IfSt.Cond).A:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnProcOk],ProcBody);
+      IfSt.Cond:=CreateUnaryNot(
+          CreatePrimitiveDotExpr(FBuiltInNames[pbivnProcOk],ProcBody),ProcBody);
       // rtl._Release(Result)
       Call:=CreateCallExpression(ProcBody);
       IfSt.BTrue:=Call;
@@ -16020,7 +16112,6 @@ function TPasToJSConverter.ConvertRepeatStatement(El: TPasImplRepeatUntil;
 // do{implblock}while(!untilcondition);
 var
   C : TJSElement;
-  N : TJSUnaryNotExpression;
   W : TJSDoWhileStatement;
   B : TJSElement;
 begin
@@ -16040,11 +16131,7 @@ begin
       B:=nil;
       end
     else
-      begin
-      N:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El.ConditionExpr));
-      N.A:=C;
-      C:=N;
-      end;
+      C:=CreateUnaryNot(C,El.ConditionExpr);
     B:=ConvertImplBlockElements(El,AContext,false);
     W:=TJSDoWhileStatement(CreateElement(TJSDoWhileStatement,El));
     W.Cond:=C;
@@ -17562,6 +17649,13 @@ begin
     end;
 end;
 
+function TPasToJSConverter.CreateUnaryNot(El: TJSElement; Src: TPasElement
+  ): TJSUnaryNotExpression;
+begin
+  Result:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,Src));
+  Result.A:=El;
+end;
+
 procedure TPasToJSConverter.ConvertCharLiteralToInt(Lit: TJSLiteral;
   ErrorEl: TPasElement; AContext: TConvertContext);
 var

packages/pastojs/src/pas2jscompilercfg.pp

@@ -47,7 +47,6 @@ end;
 
 Function TPas2JSFileConfigSupport.FindDefaultConfig : String;
 
-
   function TryConfig(aFilename: string): boolean;
   begin
     Result:=false;
@@ -56,6 +55,7 @@ Function TPas2JSFileConfigSupport.FindDefaultConfig : String;
     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;
 
@@ -63,13 +63,14 @@ 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(aFileName);
+      exit;
     end;
 
   // then try compiler directory
@@ -80,14 +81,14 @@ begin
     begin
       aFilename:=IncludeTrailingPathDelimiter(aFilename)+DefaultConfigFile;
       if TryConfig(aFilename) then
-        exit(aFileName);
+        exit;
     end;
   end;
 
   // finally try global directory
   {$IFDEF Unix}
   if TryConfig('/etc/'+DefaultConfigFile) then
-    exit(aFileName);
+    exit;
   {$ENDIF}
 end;
 

packages/pastojs/src/pas2jsfilecache.pp

@@ -32,7 +32,8 @@ uses
   {$ENDIF}
   Classes, SysUtils,
   fpjson,
-  PScanner, PasUseAnalyzer, PasResolver, Pas2jsLogger, Pas2jsFileUtils, pas2jsfs;
+  PScanner, PasResolver, PasUseAnalyzer,
+  Pas2jsLogger, Pas2jsFileUtils, Pas2JSFS;
 
 
 type
@@ -229,6 +230,7 @@ type
     FResetStamp: TChangeStamp;
     FUnitPaths: TStringList;
     FUnitPathsFromCmdLine: integer;
+    FPCUPaths: TStringList;
     function FileExistsILogged(var Filename: string): integer;
     function FileExistsLogged(const Filename: string): boolean;
     function GetOnReadDirectory: TReadDirectoryEvent;
@@ -256,6 +258,7 @@ type
     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;
@@ -302,7 +305,6 @@ type
     property OnWriteFile: TPas2jsWriteFileEvent read FOnWriteFile write FOnWriteFile;
   end;
 
-
 {$IFDEF Pas2js}
 function PtrStrToStr(StrAsPtr: Pointer): string;
 function PtrFilenameToKeyName(FilenameAsPtr: Pointer): string;
@@ -1202,7 +1204,6 @@ begin
   inherited Create(aCache);
 end;
 
-
 { TPas2jsFilesCache }
 
 procedure TPas2jsFilesCache.RegisterMessages;
@@ -1221,7 +1222,6 @@ begin
 end;
 
 function TPas2jsFilesCache.GetStrictFileCase : Boolean;
-
 begin
   Result:=caoStrictFileCase in Options;
 end;
@@ -1241,7 +1241,6 @@ begin
   Result:=caoShowTriedUsedFiles in Options;
 end;
 
-
 procedure TPas2jsFilesCache.SetBaseDirectory(AValue: string);
 begin
   AValue:=Pas2jsFileUtils.ExpandDirectory(AValue);
@@ -1508,6 +1507,7 @@ begin
   FreeAndNil(FIncludePaths);
   FreeAndNil(FForeignUnitPaths);
   FreeAndNil(FUnitPaths);
+  FreeAndNil(FPCUPaths);
   inherited Destroy;
 end;
 
@@ -1524,6 +1524,7 @@ begin
   FUnitPathsFromCmdLine:=0;
   FIncludePaths.Clear;
   FIncludePathsFromCmdLine:=0;
+  FreeAndNil(FPCUPaths);
   // FOnReadFile: TPas2jsReadFileEvent; keep
   // FOnWriteFile: TPas2jsWriteFileEvent; keep
 end;
@@ -1552,9 +1553,24 @@ begin
 end;
 
 procedure TPas2jsFilesCache.GetPCUDirs(aList: TStrings; const aBaseDir: String);
+var
+  i: Integer;
 begin
-  inherited GetPCUDirs(aList, aBaseDir);
-  aList.AddStrings(UnitPaths);
+  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.SameFileName(const File1, File2: String): Boolean;
@@ -1574,7 +1590,6 @@ begin
   Result:=ErrorMsg='';
 end;
 
-
 function TPas2jsFilesCache.AddUnitPaths(const Paths: string;
   FromCmdLine: boolean; out ErrorMsg: string): boolean;
 begin
@@ -1618,7 +1633,7 @@ end;
 
 
 
-function TPas2jsFilesCache.DirectoryExists(Const Filename: string): boolean;
+function TPas2jsFilesCache.DirectoryExists(const Filename: string): boolean;
 begin
   Result:=DirectoryCache.DirectoryExists(FileName);
 end;
@@ -1670,7 +1685,6 @@ begin
       raise EFileNotFoundError.Create('invalid file name "'+Filename+'"');
 end;
 
-
 procedure TPas2jsFilesCache.GetListing(const aDirectory: string;
   var Files: TStrings; FullPaths: boolean);
 begin
@@ -1923,11 +1937,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;
+    SearchedDirs.Add(Dir);
     Filename:=Dir+aUnitname+'.pp';
     if SearchLowUpCase(Filename) then exit(true);
     Filename:=Dir+aUnitname+'.pas';
@@ -1943,38 +1961,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;

packages/pastojs/src/pas2jsfiler.pp

@@ -295,7 +295,8 @@ const
     'List',
     'Inherited',
     'Self',
-    'Specialize');
+    'Specialize',
+    'Procedure');
 
   PCUExprOpCodeNames: array[TExprOpCode] of string = (
     'None',
@@ -2129,7 +2130,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;
 
@@ -7852,9 +7853,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;

packages/pastojs/src/pas2jsfs.pp

@@ -19,7 +19,7 @@
     interacts with the filesystem.
     See Pas2JSFileCache for an actual implementation.
 }
-unit pas2jsfs;
+unit Pas2JSFS;
 
 {$mode objfpc}{$H+}
 {$I pas2js_defines.inc}
@@ -28,7 +28,7 @@ interface
 
 uses
   // No filesystem-dependent units here !
-  Classes, SysUtils, pscanner, fpjson;
+  Classes, SysUtils, PScanner, fpjson;
 
 const // Messages
   nIncludeSearch = 201; sIncludeSearch = 'Include file search: %s';
@@ -61,7 +61,7 @@ Type
     property Source: string read FSource;
     property SrcPos: integer read FSrcPos;
   public
-    Constructor Create(Const aFileName, aSource : String); overload;
+    Constructor Create(Const aFileName, aSource: String); overload;
     function IsEOF: Boolean; override;
     function ReadLine: string; override;
     property LineNumber: integer read FLineNumber;
@@ -90,7 +90,7 @@ Type
   Protected
     // Not to be overridden
     procedure SetOption(Flag: TP2jsFSOption; Enable: boolean);
-    Function OptionIsSet(Index : Integer) :  Boolean;
+    Function OptionIsSet(Index: Integer):  Boolean;
   Protected
     // Protected Abstract. Must be overridden
     function FindSourceFileName(const aFilename: string): String; virtual; abstract;
@@ -98,28 +98,30 @@ Type
     // 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 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;
+    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 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 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;
+    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;
@@ -129,7 +131,7 @@ Type
     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 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;
@@ -142,13 +144,13 @@ Type
     FFS: TPas2JSFS;
     FSource: string;
   Protected
-    Procedure SetSource(aSource : String);
+    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 FS: TPas2JSFS Read FFS;
     property Filename: string read FFilename;
   end;
 
@@ -158,7 +160,7 @@ Type
   private
     FFS: TPas2jsFS;
   public
-    constructor Create(aFS : TPas2jsFS); reintroduce;
+    constructor Create(aFS: TPas2jsFS); reintroduce;
     // Redirect all calls to FS.
     function FindIncludeFileName(const aFilename: string): String; override;
     function FindIncludeFile(const aFilename: string): TLineReader; override;
@@ -199,7 +201,7 @@ begin
     Exclude(FOptions,Flag);
 end;
 
-function TPas2JSFS.OPtionIsSet(Index: Integer): Boolean;
+function TPas2JSFS.OptionIsSet(Index: Integer): Boolean;
 begin
   Result:=TP2jsFSOption(Index) in FOptions;
 end;
@@ -209,11 +211,11 @@ begin
   Result:=Self.FileExists(aFileName);
 end;
 
-procedure TPas2JSFS.GetPCUDirs(aList: TStrings; Const aBaseDir : String);
+procedure TPas2JSFS.GetPCUDirs(aList: TStrings; const aBaseDir: String);
 begin
   if UnitOutputPath<>'' then
-    Alist.Add(UnitOutputPath);
-  Alist.Add(aBaseDir);
+    aList.Add(UnitOutputPath);
+  aList.Add(aBaseDir);
 end;
 
 function TPas2JSFS.SameFileName(const File1, File2: String): Boolean;
@@ -224,9 +226,10 @@ end;
 function TPas2JSFS.File1IsNewer(const File1, File2: String): Boolean;
 begin
   Result:=False;
+  if File1=File2 then ;
 end;
 
-function TPas2JSFS.ExpandDirectory(const Filename : String): string;
+function TPas2JSFS.ExpandDirectory(const Filename: string): string;
 begin
   Result:=FileName;
 end;
@@ -236,7 +239,7 @@ begin
   Result:=FileName;
 end;
 
-function TPas2JSFS.ExpandExecutable(const Filename : string): string;
+function TPas2JSFS.ExpandExecutable(const Filename: string): string;
 begin
   Result:=FileName
 end;
@@ -248,7 +251,7 @@ end;
 
 function TPas2JSFS.DirectoryExists(const aDirectory: string): boolean;
 begin
-  Result:=False;
+  Result:=aDirectory='';
 end;
 
 function TPas2JSFS.TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out RelPath: String
@@ -256,6 +259,28 @@ function TPas2JSFS.TryCreateRelativePath(const Filename, BaseDirectory: String;
 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;
@@ -271,11 +296,13 @@ 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;
+  Result:='Invalid parameter: -F'+C+aValue;
+  if FromCmdLine then ;
 end;
 
 constructor TPas2JSFS.Create;
@@ -295,14 +322,14 @@ begin
   Inc(FReadLineCounter);
 end;
 
-procedure TPas2jsFS.SetDefaultOutputPath(AValue: string);
+procedure TPas2JSFS.SetDefaultOutputPath(AValue: string);
 begin
   AValue:=ExpandDirectory(AValue);
   if FDefaultOutputPath=AValue then Exit;
   FDefaultOutputPath:=AValue;
 end;
 
-procedure TPas2jsFS.SetUnitOutputPath(AValue: string);
+procedure TPas2JSFS.SetUnitOutputPath(AValue: string);
 
 begin
   AValue:=ExpandDirectory(AValue);
@@ -329,8 +356,7 @@ begin
   inc(FLineNumber);
 end;
 
-Constructor TSourceLineReader.Create(Const aFileName, aSource : String);
-
+Constructor TSourceLineReader.Create(Const aFileName, aSource: String);
 begin
   Inherited Create(aFileName);
   FSource:=aSource;

packages/pastojs/src/pas2jsfscompiler.pp

@@ -16,15 +16,17 @@
   Abstract:
     FileSystem aware compiler descendent. No support for PCU.
 }
-unit pas2jsfscompiler;
+unit Pas2JSFSCompiler;
 
 {$mode objfpc}{$H+}
 
 interface
 
 uses
-  Classes, SysUtils, pastree, pas2jscompiler,
-  pas2jsfs, pas2jsfilecache, pasuseanalyzer;
+  Classes, SysUtils, pastree, PScanner, PasUseAnalyzer,
+  Pas2jsFileCache, Pas2jsCompiler,
+  Pas2JSFS,
+  FPPas2Js, Pas2jsFileUtils;
 
 Type
   TPas2jsFSCompiler = Class(TPas2JSCompiler)
@@ -41,8 +43,6 @@ Type
 
 implementation
 
-uses fppas2js, pscanner, pas2jsfileutils;
-
 {$IFDEF PAS2JS}
 function Pas2jsCompilerFile_FilenameToKeyName(Item: Pointer): String;
 var
@@ -65,21 +65,21 @@ begin
   Result:=LowerCase(aFile.PasUnitName);
 end;
 {$ELSE}
-function CompareCompilerFilesPasFile(Item1, Item2: Pointer): integer;
+function CompareCompilerFiles_UnitFilename(Item1, Item2: Pointer): integer;
 var
   File1: TPas2JSCompilerFile absolute Item1;
   File2: TPas2JSCompilerFile absolute Item2;
 begin
-  Result:=CompareFilenames(File1.PasFilename,File2.PasFilename);
+  Result:=CompareFilenames(File1.UnitFilename,File2.UnitFilename);
 end;
 
-function CompareFileAndCompilerFilePasFile(Filename, Item: Pointer): integer;
+function CompareFileAndCompilerFile_UnitFilename(Filename, Item: Pointer): integer;
 var
   aFile: TPas2JSCompilerFile absolute Item;
   aFilename: String;
 begin
   aFilename:=AnsiString(Filename);
-  Result:=CompareFilenames(aFilename,aFile.PasFilename);
+  Result:=CompareFilenames(aFilename,aFile.UnitFilename);
 end;
 
 function CompareCompilerFilesPasUnitname(Item1, Item2: Pointer): integer;
@@ -90,7 +90,7 @@ begin
   Result:=CompareText(File1.PasUnitName,File2.PasUnitName);
 end;
 
-function CompareUnitnameAndCompilerFile(TheUnitname, Item: Pointer): integer;
+function CompareUnitnameAndCompilerFile_PasUnitName(TheUnitname, Item: Pointer): integer;
 var
   aFile: TPas2JSCompilerFile absolute Item;
   anUnitname: String;
@@ -116,8 +116,8 @@ begin
   Result:=FS as TPas2jsFilesCache;
 end;
 
-function TPas2jsFSCompiler.OnMacroEnv(Sender: TObject; var Params: string; Lvl: integer): boolean;
-
+function TPas2jsFSCompiler.OnMacroEnv(Sender: TObject; var Params: string;
+  Lvl: integer): boolean;
 begin
   if Lvl=0 then ;
   Params:=GetEnvironmentVariablePJ(Params);
@@ -138,14 +138,14 @@ begin
           {$IFDEF Pas2js}
           @Pas2jsCompilerFile_FilenameToKeyName,@PtrFilenameToKeyName
           {$ELSE}
-          @CompareCompilerFilesPasFile,@CompareFileAndCompilerFilePasFile
+          @CompareCompilerFiles_UnitFilename,@CompareFileAndCompilerFile_UnitFilename
           {$ENDIF});
     kcUnitName:
       Result:=TPasAnalyzerKeySet.Create(
         {$IFDEF Pas2js}
         @Pas2jsCompilerFile_UnitnameToKeyName,@PtrUnitnameToKeyName
         {$ELSE}
-        @CompareCompilerFilesPasUnitname,@CompareUnitnameAndCompilerFile
+        @CompareCompilerFilesPasUnitname,@CompareUnitnameAndCompilerFile_PasUnitName
         {$ENDIF});
   else
     Raise EPas2jsFileCache.CreateFmt('Internal Unknown key type: %d',[Ord(KeyType)]);

packages/pastojs/src/pas2jslogger.pp

@@ -512,7 +512,9 @@ Function TConsoleFileWriter.DoWrite(Const S : TJSWriterString) : Integer;
 
 begin
   Result:=Length(S);
+  {AllowWriteln}
   Writeln(S);
+  {AllowWriteln-}
 end;
 
 procedure TConsoleFileWriter.FLush;

packages/pastojs/src/pas2jspcucompiler.pp

@@ -16,7 +16,7 @@
   Abstract:
     FileSystem aware compiler descendent with support for PCU files.
 }
-unit pas2jspcucompiler;
+unit Pas2JSPCUCompiler;
 
 {$mode objfpc}{$H+}
 
@@ -29,17 +29,20 @@ unit pas2jspcucompiler;
 interface
 
 uses
-  SysUtils,Classes,
-  pastree,
-  pas2jscompiler, pas2jsfs, pas2jsfscompiler, 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;
@@ -48,46 +51,41 @@ 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;
 
   { TPas2jsPCUCompilerFile }
 
   TPas2jsPCUCompilerFile = Class(TPas2jsCompilerFile)
-    Function CreatePCUSupport: TPCUSupport; override;
+    function CreatePCUSupport: TPCUSupport; override;
   end;
 
-
   { TPas2jsPCUCompiler }
 
   TPas2jsPCUCompiler = Class(TPas2JSFSCompiler)
   Private
-    FPrecompileFormat : TPas2JSPrecompileFormat;
+    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, pasresolveeval, jstree, pas2jsfileutils;
-
-
-
 {$IFDEF HASPAS2JSFILER}
 
 { ---------------------------------------------------------------------
@@ -96,19 +94,21 @@ uses fppas2js, pscanner, pas2jslogger, pasresolveeval, jstree, pas2jsfileutils;
 
 { 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;
@@ -116,7 +116,7 @@ begin
   Result:=MyFile.Compiler;
 end;
 
-Function TFilerPCUSupport.HandleException(E: Exception) : Boolean;
+function TFilerPCUSupport.HandleException(E: Exception): Boolean;
 
 begin
   Result:=False;
@@ -124,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
@@ -141,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;
@@ -179,9 +181,9 @@ begin
     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
@@ -208,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
@@ -234,13 +237,13 @@ function TFilerPCUSupport.FindPCU(const UseUnitName: string; out  aFormat: TPas2
   end;
 
 var
-  L : TstringList;
+  L: TstringList;
   i: Integer;
 
 begin
   Result:='';
   aFormat:=nil;
-  L:=TstringList.Create;
+  L:=TStringList.Create;
   try
     Compiler.FS.GetPCUDirs(L,MyFile.FileResolver.BaseDirectory);
     for i:=0 to L.Count-1 do
@@ -267,7 +270,7 @@ var
   ms: TMemoryStream;
   DestDir: String;
   JS: TJSElement;
-  FN : String;
+  FN: String;
 
 begin
   if FPCUFormat=Nil then
@@ -315,10 +318,12 @@ 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}
@@ -391,34 +396,30 @@ 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;
@@ -426,15 +427,13 @@ 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
     ParamFatal('invalid precompile output format (-JU) "'+Value+'"');
 end;
 
-
-
 { TPas2jsPCUCompilerFile }
 
 function TPas2jsPCUCompilerFile.CreatePCUSupport: TPCUSupport;

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;
 

packages/pastojs/tests/tcmodules.pas

@@ -381,6 +381,7 @@ type
     Procedure TestCaseOfRange;
     Procedure TestCaseOfString;
     Procedure TestCaseOfExternalClassConst;
+    Procedure TestDebugger;
 
     // arrays
     Procedure TestArray_Dynamic;
@@ -2262,25 +2263,33 @@ procedure TTestModule.TestIncludeVersion;
 begin
   StartProgram(false);
   Add([
-  'var s: string;',
+  'var',
+  '  s: string;',
+  '  i: word;',
   'begin',
   '  s:={$I %line%};',
+  '  i:={$I %linenum%};',
   '  s:={$I %currentroutine%};',
   '  s:={$I %pas2jsversion%};',
   '  s:={$I %pas2jstarget%};',
   '  s:={$I %pas2jstargetos%};',
   '  s:={$I %pas2jstargetcpu%};',
+  '  s:={$I %file%};',
   '']);
   ConvertProgram;
   CheckSource('TestIncludeVersion',
+    LinesToStr([
     'this.s="";',
+    'this.i = 0;']),
     LinesToStr([
-    '$mod.s = "5";',
+    '$mod.s = "7";',
+    '$mod.i = 8;',
     '$mod.s = "<anonymous>";',
     '$mod.s = "Comp.Ver.tcmodules";',
     '$mod.s = "Browser";',
     '$mod.s = "Browser";',
     '$mod.s = "ECMAScript5";',
+    '$mod.s = "test1.pp";',
     '']));
 end;
 
@@ -7081,6 +7090,30 @@ begin
     ]));
 end;
 
+procedure TTestModule.TestDebugger;
+begin
+  StartProgram(false);
+  Add([
+  'procedure DoIt;',
+  'begin',
+  '  deBugger;',
+  '  DeBugger();',
+  'end;',
+  'begin',
+  '  Debugger;']);
+  ConvertProgram;
+  CheckSource('TestDebugger',
+    LinesToStr([ // statements
+    'this.DoIt = function () {',
+    '  debugger;',
+    '  debugger;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    'debugger;',
+    '']));
+end;
+
 procedure TTestModule.TestArray_Dynamic;
 begin
   StartProgram(false);
@@ -22228,7 +22261,7 @@ begin
     'this.DoIt = function () {',
     '  var b = false;',
     '  var s = "";',
-    '  if (b) throw "assert failed";',
+    '  if (!b) throw "assert failed";',
     '};',
     '']),
     LinesToStr([ // $mod.$main
@@ -22276,8 +22309,8 @@ begin
     'this.DoIt = function () {',
     '  var b = false;',
     '  var s = "";',
-    '  if (b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
-    '  if (b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
+    '  if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
+    '  if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
     '};',
     '']),
     LinesToStr([ // $mod.$main

packages/pastojs/tests/tcprecompile.pas

@@ -115,6 +115,9 @@ begin
     JSFile:=FindFile(JSFilename);
     OrigSrc:=JSFile.Source;
     // compile, using .pcu files
+    //for i:=0 to FileCount-1 do
+    //  writeln('AAA1 TCustomTestCLI_Precompile.CheckPrecompile ',i,' ',Files[i].Filename);
+
     {$IFDEF VerbosePCUFiler}
     writeln('TTestCLI_Precompile.CheckPrecompile compile using pcu files==================');
     {$ENDIF}
@@ -285,7 +288,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;',
@@ -558,8 +561,6 @@ begin
 end;
 
 Initialization
-  {$IFDEF EnablePas2jsPrecompiled}
   RegisterTests([TTestCLI_Precompile]);
-  {$ENDIF}
 end.
 

packages/pastojs/tests/tcunitsearch.pas

@@ -29,14 +29,14 @@ uses
   fpcunit, testregistry,
   PScanner, PasTree,
   {$IFDEF CheckPasTreeRefCount}PasResolveEval,{$ENDIF}
-  Pas2jsFileUtils, Pas2jsCompiler, Pas2jsfsCompiler, Pas2jsFileCache, Pas2jsLogger,
+  Pas2jsFileUtils, Pas2jsCompiler, Pas2JSPCUCompiler, Pas2jsFileCache, Pas2jsLogger,
   tcmodules;
 
 type
 
   { TTestCompiler }
 
-  TTestCompiler = class(TPas2jsFSCompiler)
+  TTestCompiler = class(TPas2jsPCUCompiler)
   private
     FExitCode: longint;
   protected

packages/tosunits/src/vdi.pas

@@ -148,16 +148,24 @@ procedure v_gtext(handle: smallint; x: smallint; y: smallint; _string: pchar);
 procedure v_bar(handle: smallint; pxyarray: psmallint);
 procedure v_circle (handle: smallint; x: smallint; y: smallint; radius: smallint);
 
+procedure vs_color(handle: smallint; index: smallint; rgb_in: psmallint);
+
 function vsl_color(handle: smallint; color_index: smallint): smallint;
 function vst_color(handle: smallint; color_index: smallint): smallint;
 function vsf_color(handle: smallint; color_index: smallint): smallint;
 
+function vswr_mode(handle: smallint; mode: smallint): smallint;
+
 procedure v_opnvwk(work_in: psmallint; handle: psmallint; work_out: psmallint);
 procedure v_clsvwk(handle: smallint);
 
 procedure v_get_pixel(handle: smallint; x: smallint; y: smallint;
                       pel: psmallint; index: psmallint);
 
+procedure vro_cpyfm(handle: smallint; vr_mode: smallint; pxyarray: psmallint; psrcMFDB: PMFDB; pdesMFDB: PMFDB);
+
+procedure vrt_cpyfm(handle: smallint; vr_mode: smallint; pxyarray: psmallint; psrcMFDB: PMFDB; pdesMFDB: PMFDB; color_index: psmallint);
+
 procedure v_show_c(handle: smallint; reset: smallint);
 procedure v_hide_c(handle: smallint);
 
@@ -309,6 +317,21 @@ begin
   vdi;
 end;
 
+procedure vs_color(handle: smallint; index: smallint; rgb_in: psmallint);
+begin
+  _intin[0]:=index;
+  _intin[1]:=rgb_in[0];
+  _intin[2]:=rgb_in[1];
+  _intin[3]:=rgb_in[2];
+
+  _contrl[0]:=14;
+  _contrl[1]:=0;
+  _contrl[3]:=4;
+  _contrl[6]:=handle;
+
+  vdi;
+end;
+
 function vsl_color(handle: smallint; color_index: smallint): smallint;
 begin
   _intin[0]:=color_index;
@@ -351,6 +374,19 @@ begin
   vsf_color:=_intout[0];
 end;
 
+function vswr_mode(handle: smallint; mode: smallint): smallint;
+begin
+  _intin[0]:=mode;
+
+  _contrl[0]:=32;
+  _contrl[1]:=0;
+  _contrl[3]:=1;
+  _contrl[6]:=handle;
+
+  vdi;
+
+  vswr_mode:=_intout[0];
+end;
 
 procedure v_opnvwk(work_in: psmallint; handle: psmallint; work_out: psmallint);
 begin
@@ -398,6 +434,42 @@ begin
   index^:=_intout[1];
 end;
 
+procedure vro_cpyfm(handle: smallint; vr_mode: smallint; pxyarray: psmallint; psrcMFDB: PMFDB; pdesMFDB: PMFDB);
+begin
+  _intin[0]:=vr_mode;
+  // ptsin[0..7] = pxyarray[0..7];
+  move(pxyarray[0],_ptsin[0],8*sizeof(smallint));
+
+  PPointer(@_contrl[7])^:=psrcMFDB;
+  PPointer(@_contrl[9])^:=pdesMFDB;
+
+  _contrl[0]:=109;
+  _contrl[1]:=4;
+  _contrl[3]:=1;
+  _contrl[6]:=handle;
+
+  vdi;
+end;
+
+procedure vrt_cpyfm(handle: smallint; vr_mode: smallint; pxyarray: psmallint; psrcMFDB: PMFDB; pdesMFDB: PMFDB; color_index: psmallint);
+begin
+  _intin[0]:=vr_mode;
+  _intin[1]:=color_index[0];
+  _intin[2]:=color_index[1];
+  // ptsin[0..7] = pxyarray[0..7];
+  move(pxyarray[0],_ptsin[0],8*sizeof(smallint));
+
+  PPointer(@_contrl[7])^:=psrcMFDB;
+  PPointer(@_contrl[9])^:=pdesMFDB;
+
+  _contrl[0]:=121;
+  _contrl[1]:=4;
+  _contrl[3]:=3;
+  _contrl[6]:=handle;
+
+  vdi;
+end;
+
 procedure v_show_c(handle: smallint; reset: smallint);
 begin
   _intin[0]:=reset;

rtl/inc/llvmintr.inc

@@ -19,3 +19,6 @@ procedure llvm_memcpy64(dest, source: pointer; len: qword; align: cardinal; isvo
 function llvm_frameaddress(level: longint): pointer; compilerproc; external name 'llvm.frameaddress';
 
 function llvm_eh_typeid_for(sym: pointer): longint; compilerproc; external name 'llvm.eh.typeid.for';
+
+procedure llvm_lifetime_start(size: int64; ptr: pointer); compilerproc; external name 'llvm.lifetime.start';
+procedure llvm_lifetime_end(size: int64; ptr: pointer); compilerproc; external name 'llvm.lifetime.end';

rtl/linux/i386/si_prc.inc

@@ -102,7 +102,9 @@ asm
   	movl    %esp,initialstkptr
   {$endif FPC_PIC}
 
+{$if FPC_FULLVERSION>30200}
   call    InitTLS
+{$endif FPC_FULLVERSION>30200}
 
   xorl    %ebp,%ebp
   call    PASCALMAIN

utils/pas2js/docs/translation.html

@@ -2803,12 +2803,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>
@@ -2923,6 +2931,8 @@ End.
     Width and precision is supported. str(i:10) will add spaces to the left to fill up to 10 characters.</b>
     str(aDouble:1:5) returns a string in decimal format with 5 digits for the fraction.</li>
     <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>
     </ul>
     </div>
 

utils/pas2js/pas2js.lpi

@@ -23,15 +23,34 @@
     <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"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="../../packages/pastojs/src/pas2jscompilercfg.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="../../packages/pastojs/src/pas2jsfs.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit3>
+      <Unit4>
+        <Filename Value="../../packages/pastojs/src/pas2jscompilerpp.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit4>
+      <Unit5>
+        <Filename Value="../../packages/pastojs/src/pas2jsfscompiler.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit5>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

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.
+

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.
+