* synchronised with trunk till r41159

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

.gitattributes

@@ -8786,6 +8786,7 @@ rtl/amicommon/README.TXT svneol=native#text/plain
 rtl/amicommon/athreads.pp svneol=native#text/plain
 rtl/amicommon/classes.pp svneol=native#text/plain
 rtl/amicommon/dos.pp svneol=native#text/plain
+rtl/amicommon/lineinfo.pp svneol=native#text/plain
 rtl/amicommon/osdebug.inc svneol=native#text/plain
 rtl/amicommon/osdebugh.inc svneol=native#text/plain
 rtl/amicommon/paramhandling.inc svneol=native#text/plain
@@ -9876,7 +9877,6 @@ rtl/morphos/doslibf.inc svneol=native#text/plain
 rtl/morphos/emuld.inc svneol=native#text/plain
 rtl/morphos/execd.inc svneol=native#text/plain
 rtl/morphos/execf.inc svneol=native#text/plain
-rtl/morphos/lineinfo.pp svneol=native#text/plain
 rtl/morphos/prt0.as svneol=native#text/plain
 rtl/morphos/si_prc.pp svneol=native#text/plain
 rtl/morphos/system.pp svneol=native#text/plain

compiler/arm/agarmgas.pas

@@ -205,6 +205,8 @@ unit agarmgas;
                        s:=s+', rrx'
                      else if shiftmode <> SM_None then
                        s:=s+', '+gas_shiftmode2str[shiftmode]+' #'+tostr(shiftimm);
+                     if offset<>0 then
+                       Internalerror(2019012601);
                   end
                 else if offset<>0 then
                   s:=s+', #'+tostr(offset);

compiler/arm/aoptcpub.pas

@@ -119,6 +119,15 @@ Implementation
       i : Longint;
     begin
       result:=false;
+      case taicpu(p1).opcode of
+        A_LDR:
+          { special handling for LDRD }
+          if (taicpu(p1).oppostfix=PF_D) and (getsupreg(taicpu(p1).oper[0]^.reg)+1=getsupreg(Reg)) then
+            begin
+              result:=true;
+              exit;
+            end;
+      end;
       for i:=0 to taicpu(p1).ops-1 do
         case taicpu(p1).oper[i]^.typ of
           top_reg:

compiler/arm/armins.dat

@@ -402,6 +402,7 @@ reg32,regf          \x10\x01\x0F                        ARM32,ARMv4
 regf,reg32          \x96\xF3\x80\x80\x0                 THUMB32,ARMv6
 
 regf,reg32          \x12\x01\x20\xF0                    ARM32,ARMv4
+regs,reg32          \x12\x01\x20\xF0                    ARM32,ARMv4
 regf,immshifter     \x13\x03\x20\xF0                    ARM32,ARMv4
 regs,immshifter     \x13\x03\x20\xF0                    ARM32,ARMv4
 

compiler/arm/armnop.inc

@@ -1,2 +1,2 @@
 { don't edit, this file is generated from armins.dat }
-958;
+959;

compiler/arm/armtab.inc

@@ -1351,6 +1351,13 @@
     code    : #18#1#32#240;
     flags   : if_arm32 or if_armv4
   ),
+  (
+    opcode  : A_MSR;
+    ops     : 2;
+    optypes : (ot_regs,ot_reg32,ot_none,ot_none,ot_none,ot_none);
+    code    : #18#1#32#240;
+    flags   : if_arm32 or if_armv4
+  ),
   (
     opcode  : A_MSR;
     ops     : 2;

compiler/arm/cgcpu.pas

@@ -2686,6 +2686,21 @@ unit cgcpu;
           list.concat(taicpu.op_reg_reg(A_MOV,destreg,destreg));
         end;
 
+      { save estimation, if a creating a separate ref is needed or
+        if we can keep the original reference while copying }
+      function SimpleRef(const ref : treference) : boolean;
+        begin
+          result:=((ref.base=NR_PC) and (ref.addressmode=AM_OFFSET) and (ref.refaddr=addr_full)) or
+              ((ref.symbol=nil) and
+               (ref.addressmode=AM_OFFSET) and
+               (((ref.offset>=0) and (ref.offset+len<=31)) or
+                (not(GenerateThumbCode) and (ref.offset>=-255) and (ref.offset+len<=255)) or
+                { ldrh has a limited offset range }
+                (not(GenerateThumbCode) and ((len mod 4) in [0,1]) and (ref.offset>=-4095) and (ref.offset+len<=4095))
+               )
+              );
+        end;
+
       { will never be called with count<=4 }
       procedure genloop_thumb(count : aword;size : byte);
 
@@ -2792,17 +2807,15 @@ unit cgcpu;
           begin
             tmpregi:=0;
 
-            srcreg:=getintregister(list,OS_ADDR);
-
-            { explicit pc relative addressing, could be
-              e.g. a floating point constant }
-            if source.base=NR_PC then
+            { loading address in a separate register needed? }
+            if SimpleRef(source) then
               begin
                 { ... then we don't need a loadaddr }
                 srcref:=source;
               end
             else
               begin
+                srcreg:=getintregister(list,OS_ADDR);
                 a_loadaddr_ref_reg(list,source,srcreg);
                 reference_reset_base(srcref,srcreg,0,source.temppos,source.alignment,source.volatility);
               end;
@@ -2816,9 +2829,15 @@ unit cgcpu;
                 dec(len,4);
               end;
 
-            destreg:=getintregister(list,OS_ADDR);
-            a_loadaddr_ref_reg(list,dest,destreg);
-            reference_reset_base(dstref,destreg,0,dest.temppos,dest.alignment,dest.volatility);
+            { loading address in a separate register needed? }
+            if SimpleRef(dest) then
+              dstref:=dest
+            else
+              begin
+                destreg:=getintregister(list,OS_ADDR);
+                a_loadaddr_ref_reg(list,dest,destreg);
+                reference_reset_base(dstref,destreg,0,dest.temppos,dest.alignment,dest.volatility);
+              end;
             tmpregi2:=1;
             while (tmpregi2<=tmpregi) do
               begin

compiler/arm/cpupara.pas

@@ -377,6 +377,11 @@ unit cpupara;
             if (p.proccalloption in cstylearrayofconst) and
                is_array_of_const(paradef) then
               begin
+                hp.paraloc[side].def:=paradef;
+                hp.paraloc[side].size:=OS_NO;
+                hp.paraloc[side].alignment:=std_param_align;
+                hp.paraloc[side].intsize:=0;
+
                 paraloc:=hp.paraloc[side].add_location;
                 { hack: the paraloc must be valid, but is not actually used }
                 paraloc^.loc:=LOC_REGISTER;

compiler/arm/narmld.pas

@@ -50,7 +50,7 @@ implementation
       procinfo;
 
 {*****************************************************************************
-                            TI386LOADNODE
+                            TARMLOADNODE
 *****************************************************************************}
 
     procedure tarmloadnode.generate_threadvar_access(gvs: tstaticvarsym);

compiler/arm/raarmgas.pas

@@ -147,6 +147,7 @@ Unit raarmgas;
           end;
       end;
 
+
     function tarmattreader.is_targetdirective(const s: string): boolean;
       begin
         case s of

compiler/cfileutl.pas

@@ -37,6 +37,9 @@ interface
 {$if defined(go32v2) or defined(watcom)}
       Dos,
 {$endif}
+{$ifdef macos}
+      macutils,
+{$endif macos}
 {$IFNDEF USE_FAKE_SYSUTILS}
       SysUtils,
 {$ELSE}

compiler/cgbase.pas

@@ -130,6 +130,10 @@ interface
          ,addr_ntpoff
          ,addr_tlsgd
          {$ENDIF}
+{$ifdef x86_64}
+          ,addr_tpoff
+          ,addr_tlsgd
+{$endif x86_64}
          );
 
 

compiler/cgutils.pas

@@ -135,15 +135,15 @@ unit cgutils;
 {$endif cpuflags}
             LOC_CONSTANT : (
               case longint of
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu) or defined(cpuhighleveltarget)}
                 1 : (value : Int64);
-{$else cpu64bitalu}
+{$else cpu64bitalu or cpuhighleveltarget}
     {$ifdef FPC_BIG_ENDIAN}
                 1 : (_valuedummy,value : longint);
     {$else FPC_BIG_ENDIAN}
                 1 : (value : longint);
     {$endif FPC_BIG_ENDIAN}
-{$endif cpu64bitalu}
+{$endif cpu64bitalu or cpuhighleveltarget}
                 2 : (value64 : Int64);
               );
             LOC_CREFERENCE,
@@ -164,10 +164,10 @@ unit cgutils;
 {$ifdef cpu64bitalu}
                 { overlay a 128 Bit register type }
                 2 : (register128 : tregister128);
-{$else cpu64bitalu}
+{$else if not defined(cpuhighleveltarget}
                 { overlay a 64 Bit register type }
                 2 : (register64 : tregister64);
-{$endif cpu64bitalu}
+{$endif cpu64bitalu and not cpuhighleveltarget}
 {$ifdef cpu8bitalu}
                 3 : (registers : array[0..3] of tregister);
 {$endif cpu8bitalu}

compiler/fpcdefs.inc

@@ -298,10 +298,6 @@
   {$define cpurequiresproperalignment}
 {$endif riscv64}
 
-{$IFDEF MACOS}
-{$DEFINE USE_FAKE_SYSUTILS}
-{$ENDIF MACOS}
-
 { Stabs is not officially supported on 64 bit targets by gdb, except on Mac OS X
   (but there we don't support it)
 }
@@ -322,9 +318,7 @@
 }
 {$ifdef llvm}
   {$undef SUPPORT_MMX}
-  {$undef cpu16bitalu}
-  {$undef cpu32bitalu}
-  {$define cpu64bitalu}
   {$define cpuhighleveltarget}
+  {$define cpucg64shiftsupport}
   {$define symansistr}
 {$endif}

compiler/hlcg2ll.pas

@@ -330,7 +330,8 @@ implementation
 
     uses
        globals,systems,
-       verbose,defutil,
+       verbose,defutil,symsym,
+       procinfo,paramgr,
        cgobj,tgobj,cutils,
        ncgutil;
 
@@ -1319,9 +1320,83 @@ implementation
     end;
 
   procedure thlcg2ll.gen_load_para_value(list: TAsmList);
-    begin
-      ncgutil.gen_load_para_value(list);
-    end;
+
+    procedure get_para(const paraloc:TCGParaLocation);
+      begin
+         case paraloc.loc of
+           LOC_REGISTER :
+             begin
+               if getsupreg(paraloc.register)<first_int_imreg then
+                 cg.getcpuregister(list,paraloc.register);
+             end;
+           LOC_MMREGISTER :
+             begin
+               if getsupreg(paraloc.register)<first_mm_imreg then
+                 cg.getcpuregister(list,paraloc.register);
+             end;
+           LOC_FPUREGISTER :
+             begin
+               if getsupreg(paraloc.register)<first_fpu_imreg then
+                 cg.getcpuregister(list,paraloc.register);
+             end;
+         end;
+      end;
+
+   var
+     i : longint;
+     currpara : tparavarsym;
+     paraloc  : pcgparalocation;
+   begin
+     if (po_assembler in current_procinfo.procdef.procoptions) or
+     { exceptfilters have a single hidden 'parentfp' parameter, which
+       is handled by tcg.g_proc_entry. }
+        (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
+       exit;
+
+     { Allocate registers used by parameters }
+     for i:=0 to current_procinfo.procdef.paras.count-1 do
+       begin
+         currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
+         paraloc:=currpara.paraloc[calleeside].location;
+         while assigned(paraloc) do
+           begin
+             if paraloc^.loc in [LOC_REGISTER,LOC_FPUREGISTER,LOC_MMREGISTER] then
+               get_para(paraloc^);
+             paraloc:=paraloc^.next;
+           end;
+       end;
+
+     { Copy parameters to local references/registers }
+     for i:=0 to current_procinfo.procdef.paras.count-1 do
+       begin
+         currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
+         { don't use currpara.vardef, as this will be wrong in case of
+           call-by-reference parameters (it won't contain the pointerdef) }
+         gen_load_cgpara_loc(list,currpara.paraloc[calleeside].def,currpara.paraloc[calleeside],currpara.initialloc,paramanager.param_use_paraloc(currpara.paraloc[calleeside]));
+         { gen_load_cgpara_loc() already allocated the initialloc
+           -> don't allocate again }
+         if currpara.initialloc.loc in [LOC_CREGISTER,LOC_CFPUREGISTER,LOC_CMMREGISTER] then
+           begin
+             gen_alloc_regvar(list,currpara,false);
+             hlcg.varsym_set_localloc(list,currpara);
+           end;
+       end;
+
+     { generate copies of call by value parameters, must be done before
+       the initialization and body is parsed because the refcounts are
+       incremented using the local copies }
+     current_procinfo.procdef.parast.SymList.ForEachCall(@hlcg.g_copyvalueparas,list);
+     if not(po_assembler in current_procinfo.procdef.procoptions) then
+       begin
+         { initialize refcounted paras, and trash others. Needed here
+           instead of in gen_initialize_code, because when a reference is
+           intialised or trashed while the pointer to that reference is kept
+           in a regvar, we add a register move and that one again has to
+           come after the parameter loading code as far as the register
+           allocator is concerned }
+         current_procinfo.procdef.parast.SymList.ForEachCall(@init_paras,list);
+       end;
+   end;
 
   procedure thlcg2ll.gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: tcgpara; locintsize: longint);
     var
@@ -1525,8 +1600,542 @@ implementation
     end;
 
   procedure thlcg2ll.gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean);
+
+    procedure unget_para(const paraloc:TCGParaLocation);
+      begin
+         case paraloc.loc of
+           LOC_REGISTER :
+             begin
+               if getsupreg(paraloc.register)<first_int_imreg then
+                 cg.ungetcpuregister(list,paraloc.register);
+             end;
+           LOC_MMREGISTER :
+             begin
+               if getsupreg(paraloc.register)<first_mm_imreg then
+                 cg.ungetcpuregister(list,paraloc.register);
+             end;
+           LOC_FPUREGISTER :
+             begin
+               if getsupreg(paraloc.register)<first_fpu_imreg then
+                 cg.ungetcpuregister(list,paraloc.register);
+             end;
+         end;
+      end;
+
+    var
+      paraloc   : pcgparalocation;
+      href      : treference;
+      sizeleft  : aint;
+      tempref   : treference;
+      loadsize  : tcgint;
+      tempreg  : tregister;
+{$ifdef mips}
+      //tmpreg   : tregister;
+{$endif mips}
+{$ifndef cpu64bitalu}
+      reg64    : tregister64;
+{$if defined(cpu8bitalu)}
+      curparaloc : PCGParaLocation;
+{$endif defined(cpu8bitalu)}
+{$endif not cpu64bitalu}
     begin
-      ncgutil.gen_load_cgpara_loc(list, vardef, para, destloc, reusepara);
+      paraloc:=para.location;
+      if not assigned(paraloc) then
+        internalerror(200408203);
+      { skip e.g. empty records }
+      if (paraloc^.loc = LOC_VOID) then
+        exit;
+      case destloc.loc of
+        LOC_REFERENCE :
+          begin
+            { If the parameter location is reused we don't need to copy
+              anything }
+            if not reusepara then
+              begin
+                href:=destloc.reference;
+                sizeleft:=para.intsize;
+                while assigned(paraloc) do
+                  begin
+                    if (paraloc^.size=OS_NO) then
+                      begin
+                        { Can only be a reference that contains the rest
+                          of the parameter }
+                        if (paraloc^.loc<>LOC_REFERENCE) or
+                           assigned(paraloc^.next) then
+                          internalerror(2005013010);
+                        cg.a_load_cgparaloc_ref(list,paraloc^,href,sizeleft,destloc.reference.alignment);
+                        inc(href.offset,sizeleft);
+                        sizeleft:=0;
+                      end
+                    else
+                      begin
+                        { the min(...) call ensures that we do not store more than place is left as
+                           paraloc^.size could be bigger than destloc.size of a parameter occupies a full register
+                           and as on big endian system the parameters might be left aligned, we have to work
+                           with the full register size for paraloc^.size }
+                        if tcgsize2size[destloc.size]<>0 then
+                          loadsize:=min(min(tcgsize2size[paraloc^.size],tcgsize2size[destloc.size]),sizeleft)
+                        else
+                          loadsize:=min(tcgsize2size[paraloc^.size],sizeleft);
+
+                        cg.a_load_cgparaloc_ref(list,paraloc^,href,loadsize,destloc.reference.alignment);
+                        inc(href.offset,loadsize);
+                        dec(sizeleft,loadsize);
+                      end;
+                    unget_para(paraloc^);
+                    paraloc:=paraloc^.next;
+                  end;
+              end;
+          end;
+        LOC_REGISTER,
+        LOC_CREGISTER :
+          begin
+{$ifdef cpu64bitalu}
+            if (para.size in [OS_128,OS_S128,OS_F128]) and
+               ({ in case of fpu emulation, or abi's that pass fpu values
+                  via integer registers }
+                (vardef.typ=floatdef) or
+                 is_methodpointer(vardef) or
+                 is_record(vardef)) then
+              begin
+                case paraloc^.loc of
+                  LOC_REGISTER,
+                  LOC_MMREGISTER:
+                    begin
+                      if not assigned(paraloc^.next) then
+                        internalerror(200410104);
+                      case tcgsize2size[paraloc^.size] of
+                        8:
+                          begin
+                            if (target_info.endian=ENDIAN_BIG) then
+                              begin
+                                { paraloc^ -> high
+                                  paraloc^.next -> low }
+                                unget_para(paraloc^);
+                                gen_alloc_regloc(list,destloc,vardef);
+                                { reg->reg, alignment is irrelevant }
+                                cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reghi,8);
+                                unget_para(paraloc^.next^);
+                                cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^.next^,destloc.register128.reglo,8);
+                              end
+                            else
+                              begin
+                                { paraloc^ -> low
+                                  paraloc^.next -> high }
+                                unget_para(paraloc^);
+                                gen_alloc_regloc(list,destloc,vardef);
+                                cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reglo,8);
+                                unget_para(paraloc^.next^);
+                                cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^.next^,destloc.register128.reghi,8);
+                              end;
+                          end;
+                        4:
+                          begin
+                            { The 128-bit parameter is located in 4 32-bit MM registers.
+                              It is needed to copy them to 2 64-bit int registers.
+                              A code generator or a target cpu must support loading of a 32-bit MM register to
+                              a 64-bit int register, zero extending it. }
+                            if target_info.endian=ENDIAN_BIG then
+                              internalerror(2018101702);  // Big endian support not implemented yet
+                            gen_alloc_regloc(list,destloc,vardef);
+                            tempreg:=cg.getintregister(list,OS_64);
+                            // Low part of the 128-bit param
+                            unget_para(paraloc^);
+                            cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,tempreg,4);
+                            paraloc:=paraloc^.next;
+                            if paraloc=nil then
+                              internalerror(2018101703);
+                            unget_para(paraloc^);
+                            cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reglo,4);
+                            cg.a_op_const_reg(list,OP_SHL,OS_64,32,destloc.register128.reglo);
+                            cg.a_op_reg_reg(list,OP_OR,OS_64,tempreg,destloc.register128.reglo);
+                            // High part of the 128-bit param
+                            paraloc:=paraloc^.next;
+                            if paraloc=nil then
+                              internalerror(2018101704);
+                            unget_para(paraloc^);
+                            cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,tempreg,4);
+                            paraloc:=paraloc^.next;
+                            if paraloc=nil then
+                              internalerror(2018101705);
+                            unget_para(paraloc^);
+                            cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reghi,4);
+                            cg.a_op_const_reg(list,OP_SHL,OS_64,32,destloc.register128.reghi);
+                            cg.a_op_reg_reg(list,OP_OR,OS_64,tempreg,destloc.register128.reghi);
+                          end
+                        else
+                          internalerror(2018101701);
+                      end;
+                    end;
+                  LOC_REFERENCE:
+                    begin
+                      gen_alloc_regloc(list,destloc,vardef);
+                      reference_reset_base(href,cpointerdef.getreusable(vardef),paraloc^.reference.index,paraloc^.reference.offset,ctempposinvalid,para.alignment,[]);
+                      cg128.a_load128_ref_reg(list,href,destloc.register128);
+                      unget_para(paraloc^);
+                    end;
+                  else
+                    internalerror(2012090607);
+                end
+              end
+            else
+{$else cpu64bitalu}
+            if (para.size in [OS_64,OS_S64,OS_F64]) and
+               (is_64bit(vardef) or
+                { in case of fpu emulation, or abi's that pass fpu values
+                  via integer registers }
+                (vardef.typ=floatdef) or
+                 is_methodpointer(vardef) or
+                 is_record(vardef)) then
+              begin
+                case paraloc^.loc of
+                  LOC_REGISTER:
+                    begin
+                      case para.locations_count of
+{$if defined(cpu8bitalu)}
+                        { 8 paralocs? }
+                        8:
+                          if (target_info.endian=ENDIAN_BIG) then
+                            begin
+                              { is there any big endian 8 bit ALU/16 bit Addr CPU? }
+                              internalerror(2015041003);
+                              { paraloc^ -> high
+                                paraloc^.next^.next^.next^.next -> low }
+                              unget_para(paraloc^);
+                              gen_alloc_regloc(list,destloc,vardef);
+                              { reg->reg, alignment is irrelevant }
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^,cg.GetNextReg(destloc.register64.reghi),1);
+                              unget_para(paraloc^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^,destloc.register64.reghi,1);
+                              unget_para(paraloc^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^,cg.GetNextReg(destloc.register64.reglo),1);
+                              unget_para(paraloc^.next^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^.next^,destloc.register64.reglo,1);
+                            end
+                          else
+                            begin
+                              { paraloc^ -> low
+                                paraloc^.next^.next^.next^.next -> high }
+                              curparaloc:=paraloc;
+                              unget_para(curparaloc^);
+                              gen_alloc_regloc(list,destloc,vardef);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^,destloc.register64.reglo,2);
+                              unget_para(curparaloc^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^,cg.GetNextReg(destloc.register64.reglo),1);
+                              unget_para(curparaloc^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^,cg.GetNextReg(cg.GetNextReg(destloc.register64.reglo)),1);
+                              unget_para(curparaloc^.next^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^.next^,cg.GetNextReg(cg.GetNextReg(cg.GetNextReg(destloc.register64.reglo))),1);
+
+                              curparaloc:=paraloc^.next^.next^.next^.next;
+                              unget_para(curparaloc^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^,destloc.register64.reghi,2);
+                              unget_para(curparaloc^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^,cg.GetNextReg(destloc.register64.reghi),1);
+                              unget_para(curparaloc^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^,cg.GetNextReg(cg.GetNextReg(destloc.register64.reghi)),1);
+                              unget_para(curparaloc^.next^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^.next^,cg.GetNextReg(cg.GetNextReg(cg.GetNextReg(destloc.register64.reghi))),1);
+                            end;
+{$endif defined(cpu8bitalu)}
+{$if defined(cpu16bitalu) or defined(cpu8bitalu)}
+                        { 4 paralocs? }
+                        4:
+                          if (target_info.endian=ENDIAN_BIG) then
+                            begin
+                              { paraloc^ -> high
+                                paraloc^.next^.next -> low }
+                              unget_para(paraloc^);
+                              gen_alloc_regloc(list,destloc,vardef);
+                              { reg->reg, alignment is irrelevant }
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^,cg.GetNextReg(destloc.register64.reghi),2);
+                              unget_para(paraloc^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^,destloc.register64.reghi,2);
+                              unget_para(paraloc^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^,cg.GetNextReg(destloc.register64.reglo),2);
+                              unget_para(paraloc^.next^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^.next^,destloc.register64.reglo,2);
+                            end
+                          else
+                            begin
+                              { paraloc^ -> low
+                                paraloc^.next^.next -> high }
+                              unget_para(paraloc^);
+                              gen_alloc_regloc(list,destloc,vardef);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^,destloc.register64.reglo,2);
+                              unget_para(paraloc^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^,cg.GetNextReg(destloc.register64.reglo),2);
+                              unget_para(paraloc^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^,destloc.register64.reghi,2);
+                              unget_para(paraloc^.next^.next^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^.next^,cg.GetNextReg(destloc.register64.reghi),2);
+                            end;
+{$endif defined(cpu16bitalu) or defined(cpu8bitalu)}
+                        2:
+                          if (target_info.endian=ENDIAN_BIG) then
+                            begin
+                              { paraloc^ -> high
+                                paraloc^.next -> low }
+                              unget_para(paraloc^);
+                              gen_alloc_regloc(list,destloc,vardef);
+                              { reg->reg, alignment is irrelevant }
+                              cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^,destloc.register64.reghi,4);
+                              unget_para(paraloc^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^.next^,destloc.register64.reglo,4);
+                            end
+                          else
+                            begin
+                              { paraloc^ -> low
+                                paraloc^.next -> high }
+                              unget_para(paraloc^);
+                              gen_alloc_regloc(list,destloc,vardef);
+                              cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^,destloc.register64.reglo,4);
+                              unget_para(paraloc^.next^);
+                              cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^.next^,destloc.register64.reghi,4);
+                            end;
+                        else
+                          { unexpected number of paralocs }
+                          internalerror(200410104);
+                      end;
+                    end;
+                  LOC_REFERENCE:
+                    begin
+                      gen_alloc_regloc(list,destloc,vardef);
+                      reference_reset_base(href,cpointerdef.getreusable(vardef),paraloc^.reference.index,paraloc^.reference.offset,ctempposinvalid,para.alignment,[]);
+                      cg64.a_load64_ref_reg(list,href,destloc.register64);
+                      unget_para(paraloc^);
+                    end;
+                  else
+                    internalerror(2005101501);
+                end
+              end
+            else
+{$endif cpu64bitalu}
+              begin
+                if assigned(paraloc^.next) then
+                  begin
+                    if (destloc.size in [OS_PAIR,OS_SPAIR]) and
+                      (para.Size in [OS_PAIR,OS_SPAIR]) then
+                      begin
+                        unget_para(paraloc^);
+                        gen_alloc_regloc(list,destloc,vardef);
+                        cg.a_load_cgparaloc_anyreg(list,OS_INT,paraloc^,destloc.register,sizeof(aint));
+                        unget_para(paraloc^.Next^);
+                        {$if defined(cpu16bitalu) or defined(cpu8bitalu)}
+                          cg.a_load_cgparaloc_anyreg(list,OS_INT,paraloc^.Next^,cg.GetNextReg(destloc.register),sizeof(aint));
+                        {$else}
+                          cg.a_load_cgparaloc_anyreg(list,OS_INT,paraloc^.Next^,destloc.registerhi,sizeof(aint));
+                        {$endif}
+                      end
+{$if defined(cpu8bitalu)}
+                    else if (destloc.size in [OS_32,OS_S32]) and
+                      (para.Size in [OS_32,OS_S32]) then
+                      begin
+                        unget_para(paraloc^);
+                        gen_alloc_regloc(list,destloc,vardef);
+                        cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^,destloc.register,sizeof(aint));
+                        unget_para(paraloc^.Next^);
+                        cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^.Next^,cg.GetNextReg(destloc.register),sizeof(aint));
+                        unget_para(paraloc^.Next^.Next^);
+                        cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^.Next^.Next^,cg.GetNextReg(cg.GetNextReg(destloc.register)),sizeof(aint));
+                        unget_para(paraloc^.Next^.Next^.Next^);
+                        cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^.Next^.Next^.Next^,cg.GetNextReg(cg.GetNextReg(cg.GetNextReg(destloc.register))),sizeof(aint));
+                      end
+{$endif defined(cpu8bitalu)}
+                    else
+                      begin
+                        { this can happen if a parameter is spread over
+                          multiple paralocs, e.g. if a record with two single
+                          fields must be passed in two single precision
+                          registers }
+                        { does it fit in the register of destloc? }
+                        sizeleft:=para.intsize;
+                        if sizeleft<>vardef.size then
+                          internalerror(2014122806);
+                        if sizeleft<>tcgsize2size[destloc.size] then
+                          internalerror(200410105);
+                        { store everything first to memory, then load it in
+                          destloc }
+                        tg.gettemp(list,sizeleft,sizeleft,tt_persistent,tempref);
+                        gen_alloc_regloc(list,destloc,vardef);
+                        while sizeleft>0 do
+                          begin
+                            if not assigned(paraloc) then
+                              internalerror(2014122807);
+                            unget_para(paraloc^);
+                            cg.a_load_cgparaloc_ref(list,paraloc^,tempref,sizeleft,newalignment(para.alignment,para.intsize-sizeleft));
+                            if (paraloc^.size=OS_NO) and
+                               assigned(paraloc^.next) then
+                              internalerror(2014122805);
+                            inc(tempref.offset,tcgsize2size[paraloc^.size]);
+                            dec(sizeleft,tcgsize2size[paraloc^.size]);
+                            paraloc:=paraloc^.next;
+                          end;
+                        dec(tempref.offset,para.intsize);
+                        cg.a_load_ref_reg(list,para.size,para.size,tempref,destloc.register);
+                        tg.ungettemp(list,tempref);
+                      end;
+                  end
+                else
+                  begin
+                    unget_para(paraloc^);
+                    gen_alloc_regloc(list,destloc,vardef);
+                    { we can't directly move regular registers into fpu
+                      registers }
+                    if getregtype(paraloc^.register)=R_FPUREGISTER then
+                      begin
+                        { store everything first to memory, then load it in
+                          destloc }
+                        tg.gettemp(list,tcgsize2size[paraloc^.size],para.intsize,tt_persistent,tempref);
+                        cg.a_load_cgparaloc_ref(list,paraloc^,tempref,tcgsize2size[paraloc^.size],tempref.alignment);
+                        cg.a_load_ref_reg(list,int_cgsize(tcgsize2size[paraloc^.size]),destloc.size,tempref,destloc.register);
+                        tg.ungettemp(list,tempref);
+                      end
+                    else
+                      cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,sizeof(aint));
+                  end;
+              end;
+          end;
+        LOC_FPUREGISTER,
+        LOC_CFPUREGISTER :
+          begin
+{$ifdef mips}
+            if (destloc.size = paraloc^.Size) and
+               (paraloc^.Loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER,LOC_REFERENCE,LOC_CREFERENCE]) then
+              begin
+                unget_para(paraloc^);
+                gen_alloc_regloc(list,destloc,vardef);
+                cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,para.alignment);
+              end
+            else if (destloc.size = OS_F32) and
+               (paraloc^.Loc in [LOC_REGISTER,LOC_CREGISTER]) then
+              begin
+                gen_alloc_regloc(list,destloc,vardef);
+                unget_para(paraloc^);
+                list.Concat(taicpu.op_reg_reg(A_MTC1,paraloc^.register,destloc.register));
+              end
+{ TODO: Produces invalid code, needs fixing together with regalloc setup. }
+{
+            else if (destloc.size = OS_F64) and
+                    (paraloc^.Loc in [LOC_REGISTER,LOC_CREGISTER]) and
+                    (paraloc^.next^.Loc in [LOC_REGISTER,LOC_CREGISTER]) then
+              begin
+                gen_alloc_regloc(list,destloc,vardef);
+
+                tmpreg:=destloc.register;
+                unget_para(paraloc^);
+                list.Concat(taicpu.op_reg_reg(A_MTC1,paraloc^.register,tmpreg));
+                setsupreg(tmpreg,getsupreg(tmpreg)+1);
+                unget_para(paraloc^.next^);
+                list.Concat(taicpu.op_reg_reg(A_MTC1,paraloc^.Next^.register,tmpreg));
+              end
+}
+            else
+              begin
+                sizeleft := TCGSize2Size[destloc.size];
+                tg.GetTemp(list,sizeleft,sizeleft,tt_normal,tempref);
+                href:=tempref;
+                while assigned(paraloc) do
+                  begin
+                    unget_para(paraloc^);
+                    cg.a_load_cgparaloc_ref(list,paraloc^,href,sizeleft,destloc.reference.alignment);
+                    inc(href.offset,TCGSize2Size[paraloc^.size]);
+                    dec(sizeleft,TCGSize2Size[paraloc^.size]);
+                    paraloc:=paraloc^.next;
+                  end;
+                gen_alloc_regloc(list,destloc,vardef);
+                cg.a_loadfpu_ref_reg(list,destloc.size,destloc.size,tempref,destloc.register);
+                tg.UnGetTemp(list,tempref);
+              end;
+{$else mips}
+{$if defined(sparc) or defined(arm)}
+            { Arm and Sparc passes floats in int registers, when loading to fpu register
+              we need a temp }
+            sizeleft := TCGSize2Size[destloc.size];
+            tg.GetTemp(list,sizeleft,sizeleft,tt_normal,tempref);
+            href:=tempref;
+            while assigned(paraloc) do
+              begin
+                unget_para(paraloc^);
+                cg.a_load_cgparaloc_ref(list,paraloc^,href,sizeleft,destloc.reference.alignment);
+                inc(href.offset,TCGSize2Size[paraloc^.size]);
+                dec(sizeleft,TCGSize2Size[paraloc^.size]);
+                paraloc:=paraloc^.next;
+              end;
+            gen_alloc_regloc(list,destloc,vardef);
+            cg.a_loadfpu_ref_reg(list,destloc.size,destloc.size,tempref,destloc.register);
+            tg.UnGetTemp(list,tempref);
+{$else defined(sparc) or defined(arm)}
+            unget_para(paraloc^);
+            gen_alloc_regloc(list,destloc,vardef);
+            { from register to register -> alignment is irrelevant }
+            cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,0);
+            if assigned(paraloc^.next) then
+              internalerror(200410109);
+{$endif defined(sparc) or defined(arm)}
+{$endif mips}
+          end;
+        LOC_MMREGISTER,
+        LOC_CMMREGISTER :
+          begin
+{$ifndef cpu64bitalu}
+            { ARM vfp floats are passed in integer registers }
+            if (para.size=OS_F64) and
+               (paraloc^.size in [OS_32,OS_S32]) and
+               use_vectorfpu(vardef) then
+              begin
+                { we need 2x32bit reg }
+                if not assigned(paraloc^.next) or
+                   assigned(paraloc^.next^.next) then
+                  internalerror(2009112421);
+                unget_para(paraloc^.next^);
+                case paraloc^.next^.loc of
+                  LOC_REGISTER:
+                    tempreg:=paraloc^.next^.register;
+                  LOC_REFERENCE:
+                    begin
+                      tempreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^.next^,tempreg,4);
+                    end;
+                  else
+                    internalerror(2012051301);
+                end;
+                { don't free before the above, because then the getintregister
+                  could reallocate this register and overwrite it }
+                unget_para(paraloc^);
+                gen_alloc_regloc(list,destloc,vardef);
+                if (target_info.endian=endian_big) then
+                  { paraloc^ -> high
+                    paraloc^.next -> low }
+                  reg64:=joinreg64(tempreg,paraloc^.register)
+                else
+                  reg64:=joinreg64(paraloc^.register,tempreg);
+                cg64.a_loadmm_intreg64_reg(list,OS_F64,reg64,destloc.register);
+              end
+            else
+{$endif not cpu64bitalu}
+              begin
+                if not assigned(paraloc^.next) then
+                  begin
+                    unget_para(paraloc^);
+                    gen_alloc_regloc(list,destloc,vardef);
+                    { from register to register -> alignment is irrelevant }
+                    cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,0);
+                  end
+                else
+                  begin
+                    internalerror(200410108);
+                  end;
+                { data could come in two memory locations, for now
+                  we simply ignore the sanity check (FK)
+                if assigned(paraloc^.next) then
+                  internalerror(200410108);
+                }
+              end;
+          end;
+        else
+          internalerror(2010052903);
+      end;
     end;
 
   function thlcg2ll.getintmmcgsize(reg: tregister; size: tcgsize): tcgsize;

compiler/hlcgobj.pas

@@ -991,7 +991,7 @@ implementation
                      { load the value piecewise to get it into the register }
                      orgsizeleft:=sizeleft;
                      reghasvalue:=false;
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu) or defined(cpuhighleveltarget)}
                      if sizeleft>=4 then
                        begin
                          a_load_ref_reg(list,u32inttype,location^.def,tmpref,location^.register);
@@ -1001,7 +1001,7 @@ implementation
                          inc(tmpref.offset,4);
                          reghasvalue:=true;
                        end;
-{$endif cpu64bitalu}
+{$endif defind(cpu64bitalu) or defined(cpuhighleveltarget)}
                      if sizeleft>=2 then
                        begin
                          tmpreg:=getintregister(list,location^.def);

compiler/i386/aoptcpu.pas

@@ -40,7 +40,6 @@ unit aoptcpu;
         procedure PeepHoleOptPass1; override;
         procedure PeepHoleOptPass2; override;
         procedure PostPeepHoleOpts; override;
-        function DoFpuLoadStoreOpt(var p : tai) : boolean;
       end;
 
     Var
@@ -58,74 +57,6 @@ unit aoptcpu;
       { units we should get rid off: }
       symsym,symconst;
 
-    function TCPUAsmoptimizer.DoFpuLoadStoreOpt(var p: tai): boolean;
-    { returns true if a "continue" should be done after this optimization }
-    var hp1, hp2: tai;
-    begin
-      DoFpuLoadStoreOpt := false;
-      if (taicpu(p).oper[0]^.typ = top_ref) and
-         getNextInstruction(p, hp1) and
-         (hp1.typ = ait_instruction) and
-         (((taicpu(hp1).opcode = A_FLD) and
-           (taicpu(p).opcode = A_FSTP)) or
-          ((taicpu(p).opcode = A_FISTP) and
-           (taicpu(hp1).opcode = A_FILD))) and
-         (taicpu(hp1).oper[0]^.typ = top_ref) and
-         (taicpu(hp1).opsize = taicpu(p).opsize) and
-         RefsEqual(taicpu(p).oper[0]^.ref^, taicpu(hp1).oper[0]^.ref^) then
-        begin
-          { replacing fstp f;fld f by fst f is only valid for extended because of rounding }
-          if (taicpu(p).opsize=S_FX) and
-             getNextInstruction(hp1, hp2) and
-             (hp2.typ = ait_instruction) and
-             IsExitCode(hp2) and
-             (taicpu(p).oper[0]^.ref^.base = current_procinfo.FramePointer) and
-             not(assigned(current_procinfo.procdef.funcretsym) and
-                 (taicpu(p).oper[0]^.ref^.offset < tabstractnormalvarsym(current_procinfo.procdef.funcretsym).localloc.reference.offset)) and
-             (taicpu(p).oper[0]^.ref^.index = NR_NO) then
-            begin
-              asml.remove(p);
-              asml.remove(hp1);
-              p.free;
-              hp1.free;
-              p := hp2;
-              removeLastDeallocForFuncRes(p);
-              doFPULoadStoreOpt := true;
-            end
-          (* can't be done because the store operation rounds
-          else
-            { fst can't store an extended value! }
-            if (taicpu(p).opsize <> S_FX) and
-               (taicpu(p).opsize <> S_IQ) then
-              begin
-                if (taicpu(p).opcode = A_FSTP) then
-                  taicpu(p).opcode := A_FST
-                else taicpu(p).opcode := A_FIST;
-                asml.remove(hp1);
-                hp1.free;
-              end
-          *)
-        end;
-    end;
-
-
-  { converts a TChange variable to a TRegister }
-  function tch2reg(ch: tinschange): tsuperregister;
-    const
-      ch2reg: array[CH_REAX..CH_REDI] of tsuperregister = (RS_EAX,RS_ECX,RS_EDX,RS_EBX,RS_ESP,RS_EBP,RS_ESI,RS_EDI);
-    begin
-      if (ch <= CH_REDI) then
-        tch2reg := ch2reg[ch]
-      else if (ch <= CH_WEDI) then
-        tch2reg := ch2reg[tinschange(ord(ch) - ord(CH_REDI))]
-      else if (ch <= CH_RWEDI) then
-        tch2reg := ch2reg[tinschange(ord(ch) - ord(CH_WEDI))]
-      else if (ch <= CH_MEDI) then
-        tch2reg := ch2reg[tinschange(ord(ch) - ord(CH_RWEDI))]
-      else
-        InternalError(2016041901)
-    end;
-
 
   { Checks if the register is a 32 bit general purpose register }
   function isgp32reg(reg: TRegister): boolean;
@@ -475,109 +406,10 @@ begin
                         end
                     end;
                   A_FLD:
-                    begin
-                      if (taicpu(p).oper[0]^.typ = top_reg) and
-                         GetNextInstruction(p, hp1) and
-                         (hp1.typ = Ait_Instruction) and
-                          (taicpu(hp1).oper[0]^.typ = top_reg) and
-                         (taicpu(hp1).oper[1]^.typ = top_reg) and
-                         (taicpu(hp1).oper[0]^.reg = NR_ST) and
-                         (taicpu(hp1).oper[1]^.reg = NR_ST1) then
-                         { change                        to
-                             fld      reg               fxxx reg,st
-                             fxxxp    st, st1 (hp1)
-                           Remark: non commutative operations must be reversed!
-                         }
-                        begin
-                            case taicpu(hp1).opcode Of
-                              A_FMULP,A_FADDP,
-                              A_FSUBP,A_FDIVP,A_FSUBRP,A_FDIVRP:
-                                begin
-                                  case taicpu(hp1).opcode Of
-                                    A_FADDP: taicpu(hp1).opcode := A_FADD;
-                                    A_FMULP: taicpu(hp1).opcode := A_FMUL;
-                                    A_FSUBP: taicpu(hp1).opcode := A_FSUBR;
-                                    A_FSUBRP: taicpu(hp1).opcode := A_FSUB;
-                                    A_FDIVP: taicpu(hp1).opcode := A_FDIVR;
-                                    A_FDIVRP: taicpu(hp1).opcode := A_FDIV;
-                                  end;
-                                  taicpu(hp1).oper[0]^.reg := taicpu(p).oper[0]^.reg;
-                                  taicpu(hp1).oper[1]^.reg := NR_ST;
-                                  asml.remove(p);
-                                  p.free;
-                                  p := hp1;
-                                  continue;
-                                end;
-                            end;
-                        end
-                      else
-                        if (taicpu(p).oper[0]^.typ = top_ref) and
-                           GetNextInstruction(p, hp2) and
-                           (hp2.typ = Ait_Instruction) and
-                           (taicpu(hp2).ops = 2) and
-                           (taicpu(hp2).oper[0]^.typ = top_reg) and
-                           (taicpu(hp2).oper[1]^.typ = top_reg) and
-                           (taicpu(p).opsize in [S_FS, S_FL]) and
-                           (taicpu(hp2).oper[0]^.reg = NR_ST) and
-                           (taicpu(hp2).oper[1]^.reg = NR_ST1) then
-                          if GetLastInstruction(p, hp1) and
-                             (hp1.typ = Ait_Instruction) and
-                             ((taicpu(hp1).opcode = A_FLD) or
-                              (taicpu(hp1).opcode = A_FST)) and
-                             (taicpu(hp1).opsize = taicpu(p).opsize) and
-                             (taicpu(hp1).oper[0]^.typ = top_ref) and
-                             RefsEqual(taicpu(p).oper[0]^.ref^, taicpu(hp1).oper[0]^.ref^) then
-                            if ((taicpu(hp2).opcode = A_FMULP) or
-                                (taicpu(hp2).opcode = A_FADDP)) then
-                            { change                      to
-                                fld/fst   mem1  (hp1)       fld/fst   mem1
-                                fld       mem1  (p)         fadd/
-                                faddp/                       fmul     st, st
-                                fmulp  st, st1 (hp2) }
-                              begin
-                                asml.remove(p);
-                                p.free;
-                                p := hp1;
-                                if (taicpu(hp2).opcode = A_FADDP) then
-                                  taicpu(hp2).opcode := A_FADD
-                                else
-                                  taicpu(hp2).opcode := A_FMUL;
-                                taicpu(hp2).oper[1]^.reg := NR_ST;
-                              end
-                            else
-                            { change              to
-                                fld/fst mem1 (hp1)   fld/fst mem1
-                                fld     mem1 (p)     fld      st}
-                              begin
-                                taicpu(p).changeopsize(S_FL);
-                                taicpu(p).loadreg(0,NR_ST);
-                              end
-                          else
-                            begin
-                              case taicpu(hp2).opcode Of
-                                A_FMULP,A_FADDP,A_FSUBP,A_FDIVP,A_FSUBRP,A_FDIVRP:
-                          { change                        to
-                              fld/fst  mem1    (hp1)      fld/fst    mem1
-                              fld      mem2    (p)        fxxx       mem2
-                              fxxxp    st, st1 (hp2)                      }
-
-                                  begin
-                                    case taicpu(hp2).opcode Of
-                                      A_FADDP: taicpu(p).opcode := A_FADD;
-                                      A_FMULP: taicpu(p).opcode := A_FMUL;
-                                      A_FSUBP: taicpu(p).opcode := A_FSUBR;
-                                      A_FSUBRP: taicpu(p).opcode := A_FSUB;
-                                      A_FDIVP: taicpu(p).opcode := A_FDIVR;
-                                      A_FDIVRP: taicpu(p).opcode := A_FDIV;
-                                    end;
-                                    asml.remove(hp2);
-                                    hp2.free;
-                                  end
-                              end
-                            end
-                    end;
+                    if OptPass1FLD(p) then
+                      continue;
                   A_FSTP,A_FISTP:
-                    if doFpuLoadStoreOpt(p) then
+                    if OptPass1FSTP(p) then
                       continue;
                   A_LEA:
                     begin
@@ -776,7 +608,7 @@ begin
                 if OptPass2Jcc(p) then
                   continue;
               A_FSTP,A_FISTP:
-                if DoFpuLoadStoreOpt(p) then
+                if OptPass1FSTP(p) then
                   continue;
               A_IMUL:
                 if OptPass2Imul(p) then

compiler/i386/cpupara.pas

@@ -466,25 +466,23 @@ unit cpupara;
             else
               begin
                 paralen:=push_size(hp.varspez,paradef,p.proccalloption);
-                { darwin/x86 requires that parameters < sizeof(aint) are sign/ }
-                { zero extended to sizeof(aint)                                }
-                if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and
-                   (side = callerside) and
-                   (paralen > 0) and
-                   (paralen < sizeof(aint)) then
-                  begin
-                    paralen:=sizeof(aint);
-                    paracgsize:=OS_SINT;
-                    paradef:=sinttype;
-                  end
-                else
-                  paracgsize:=def_cgsize(paradef);
+                paracgsize:=def_cgsize(paradef);
               end;
             hp.paraloc[side].reset;
             hp.paraloc[side].size:=paracgsize;
             hp.paraloc[side].intsize:=paralen;
             hp.paraloc[side].def:=paradef;
             hp.paraloc[side].Alignment:=paraalign;
+            { darwin/x86 requires that parameters < sizeof(aint) are sign/ }
+            { zero extended to sizeof(aint)                                }
+            if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and
+               (side = callerside) and
+               (paralen > 0) and
+               (paralen < sizeof(aint)) then
+              begin
+                paracgsize:=OS_SINT;
+                paradef:=sinttype;
+              end;
             { Copy to stack? }
             if (paracgsize=OS_NO) or
                (use_fixed_stack) then

compiler/i386/i386att.inc

@@ -684,6 +684,8 @@
 'aesimc',
 'aeskeygenassist',
 'rdtscp',
+'movbe',
+'pclmulqdq',
 'vaddpd',
 'vaddps',
 'vaddsd',
@@ -1009,6 +1011,9 @@
 'vzeroupper',
 'andn',
 'bextr',
+'blsi',
+'blsmsk',
+'blsr',
 'tzcnt',
 'bzhi',
 'mulx',
@@ -1018,6 +1023,8 @@
 'sarx',
 'shlx',
 'shrx',
+'adcx',
+'adox',
 'vbroadcasti128',
 'vextracti128',
 'vinserti128',

compiler/i386/i386atts.inc

@@ -684,6 +684,8 @@ attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
+attsufINT,
+attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
@@ -1021,6 +1023,11 @@ attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
+attsufINT,
+attsufINT,
+attsufNONE,
+attsufNONE,
+attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,

compiler/i386/i386int.inc

@@ -684,6 +684,8 @@
 'aesimc',
 'aeskeygenassist',
 'rdtscp',
+'movbe',
+'pclmulqdq',
 'vaddpd',
 'vaddps',
 'vaddsd',
@@ -1009,6 +1011,9 @@
 'vzeroupper',
 'andn',
 'bextr',
+'blsi',
+'blsmsk',
+'blsr',
 'tzcnt',
 'bzhi',
 'mulx',
@@ -1018,6 +1023,8 @@
 'sarx',
 'shlx',
 'shrx',
+'adcx',
+'adox',
 'vbroadcasti128',
 'vextracti128',
 'vinserti128',

compiler/i386/i386nop.inc

@@ -1,2 +1,2 @@
 { don't edit, this file is generated from x86ins.dat }
-2121;
+2129;

compiler/i386/i386op.inc

@@ -684,6 +684,8 @@ A_AESDECLAST,
 A_AESIMC,
 A_AESKEYGENASSIST,
 A_RDTSCP,
+A_MOVBE,
+A_PCLMULQDQ,
 A_VADDPD,
 A_VADDPS,
 A_VADDSD,
@@ -1009,6 +1011,9 @@ A_VZEROALL,
 A_VZEROUPPER,
 A_ANDN,
 A_BEXTR,
+A_BLSI,
+A_BLSMSK,
+A_BLSR,
 A_TZCNT,
 A_BZHI,
 A_MULX,
@@ -1018,6 +1023,8 @@ A_RORX,
 A_SARX,
 A_SHLX,
 A_SHRX,
+A_ADCX,
+A_ADOX,
 A_VBROADCASTI128,
 A_VEXTRACTI128,
 A_VINSERTI128,

compiler/i386/i386prop.inc

@@ -684,6 +684,8 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_WEAX, Ch_WEDX]),
+(Ch: [Ch_Rop1, Ch_Wop2]),
+(Ch: [Ch_All]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
@@ -1009,6 +1011,9 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_W0ZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
 (Ch: [Ch_Wop2, Ch_WFlags, Ch_Rop1]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_REDX, Ch_Rop1, Ch_Wop2, Ch_Wop3]),
@@ -1018,6 +1023,8 @@
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
+(Ch: [Ch_Rop1, Ch_Mop2, Ch_RWCarryFlag]),
+(Ch: [Ch_Rop1, Ch_Mop2, Ch_RWOverflowFlag]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),

compiler/i386/i386tab.inc

@@ -8708,6 +8708,27 @@
     code    : #3#15#1#249;
     flags   : [if_sse4,if_sm]
   ),
+  (
+    opcode  : A_MOVBE;
+    ops     : 2;
+    optypes : (ot_reg16 or ot_bits32 or ot_bits64,ot_memory or ot_bits16 or ot_bits32 or ot_bits64,ot_none,ot_none);
+    code    : #208#3#15#56#240#72;
+    flags   : [if_movbe,if_sm]
+  ),
+  (
+    opcode  : A_MOVBE;
+    ops     : 2;
+    optypes : (ot_memory or ot_bits16 or ot_bits32 or ot_bits64,ot_reg16 or ot_bits32 or ot_bits64,ot_none,ot_none);
+    code    : #209#3#15#56#241#65;
+    flags   : [if_movbe,if_sm]
+  ),
+  (
+    opcode  : A_PCLMULQDQ;
+    ops     : 3;
+    optypes : (ot_xmmreg,ot_xmmrm,ot_immediate or ot_bits8,ot_none);
+    code    : #241#3#15#58#68#72#22;
+    flags   : [if_clmul,if_sandybridge]
+  ),
   (
     opcode  : A_VADDPD;
     ops     : 3;
@@ -13608,6 +13629,27 @@
     code    : #242#249#1#247#62#72;
     flags   : [if_bmi1,if_prot]
   ),
+  (
+    opcode  : A_BLSI;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#139;
+    flags   : [if_bmi1,if_prot]
+  ),
+  (
+    opcode  : A_BLSMSK;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#138;
+    flags   : [if_bmi1,if_prot]
+  ),
+  (
+    opcode  : A_BLSR;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#137;
+    flags   : [if_bmi1,if_prot]
+  ),
   (
     opcode  : A_TZCNT;
     ops     : 2;
@@ -13671,6 +13713,20 @@
     code    : #220#242#249#1#247#62#72;
     flags   : [if_bmi2,if_prot]
   ),
+  (
+    opcode  : A_ADCX;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #241#3#15#56#246#72;
+    flags   : [if_adx]
+  ),
+  (
+    opcode  : A_ADOX;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #219#3#15#56#246#72;
+    flags   : [if_adx]
+  ),
   (
     opcode  : A_VBROADCASTI128;
     ops     : 2;

compiler/i8086/i8086att.inc

@@ -684,6 +684,8 @@
 'aesimc',
 'aeskeygenassist',
 'rdtscp',
+'movbe',
+'pclmulqdq',
 'vaddpd',
 'vaddps',
 'vaddsd',
@@ -1009,6 +1011,9 @@
 'vzeroupper',
 'andn',
 'bextr',
+'blsi',
+'blsmsk',
+'blsr',
 'tzcnt',
 'bzhi',
 'mulx',
@@ -1018,6 +1023,8 @@
 'sarx',
 'shlx',
 'shrx',
+'adcx',
+'adox',
 'vbroadcasti128',
 'vextracti128',
 'vinserti128',

compiler/i8086/i8086atts.inc

@@ -684,6 +684,8 @@ attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
+attsufINT,
+attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
@@ -1021,6 +1023,11 @@ attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
+attsufINT,
+attsufINT,
+attsufNONE,
+attsufNONE,
+attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,

compiler/i8086/i8086int.inc

@@ -684,6 +684,8 @@
 'aesimc',
 'aeskeygenassist',
 'rdtscp',
+'movbe',
+'pclmulqdq',
 'vaddpd',
 'vaddps',
 'vaddsd',
@@ -1009,6 +1011,9 @@
 'vzeroupper',
 'andn',
 'bextr',
+'blsi',
+'blsmsk',
+'blsr',
 'tzcnt',
 'bzhi',
 'mulx',
@@ -1018,6 +1023,8 @@
 'sarx',
 'shlx',
 'shrx',
+'adcx',
+'adox',
 'vbroadcasti128',
 'vextracti128',
 'vinserti128',

compiler/i8086/i8086nop.inc

@@ -1,2 +1,2 @@
 { don't edit, this file is generated from x86ins.dat }
-2153;
+2161;

compiler/i8086/i8086op.inc

@@ -684,6 +684,8 @@ A_AESDECLAST,
 A_AESIMC,
 A_AESKEYGENASSIST,
 A_RDTSCP,
+A_MOVBE,
+A_PCLMULQDQ,
 A_VADDPD,
 A_VADDPS,
 A_VADDSD,
@@ -1009,6 +1011,9 @@ A_VZEROALL,
 A_VZEROUPPER,
 A_ANDN,
 A_BEXTR,
+A_BLSI,
+A_BLSMSK,
+A_BLSR,
 A_TZCNT,
 A_BZHI,
 A_MULX,
@@ -1018,6 +1023,8 @@ A_RORX,
 A_SARX,
 A_SHLX,
 A_SHRX,
+A_ADCX,
+A_ADOX,
 A_VBROADCASTI128,
 A_VEXTRACTI128,
 A_VINSERTI128,

compiler/i8086/i8086prop.inc

@@ -684,6 +684,8 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_WEAX, Ch_WEDX]),
+(Ch: [Ch_Rop1, Ch_Wop2]),
+(Ch: [Ch_All]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
@@ -1009,6 +1011,9 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_W0ZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
 (Ch: [Ch_Wop2, Ch_WFlags, Ch_Rop1]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_REDX, Ch_Rop1, Ch_Wop2, Ch_Wop3]),
@@ -1018,6 +1023,8 @@
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
+(Ch: [Ch_Rop1, Ch_Mop2, Ch_RWCarryFlag]),
+(Ch: [Ch_Rop1, Ch_Mop2, Ch_RWOverflowFlag]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),

compiler/i8086/i8086tab.inc

@@ -8736,6 +8736,27 @@
     code    : #3#15#1#249;
     flags   : [if_sse4,if_sm]
   ),
+  (
+    opcode  : A_MOVBE;
+    ops     : 2;
+    optypes : (ot_reg16 or ot_bits32 or ot_bits64,ot_memory or ot_bits16 or ot_bits32 or ot_bits64,ot_none,ot_none);
+    code    : #208#3#15#56#240#72;
+    flags   : [if_movbe,if_sm]
+  ),
+  (
+    opcode  : A_MOVBE;
+    ops     : 2;
+    optypes : (ot_memory or ot_bits16 or ot_bits32 or ot_bits64,ot_reg16 or ot_bits32 or ot_bits64,ot_none,ot_none);
+    code    : #209#3#15#56#241#65;
+    flags   : [if_movbe,if_sm]
+  ),
+  (
+    opcode  : A_PCLMULQDQ;
+    ops     : 3;
+    optypes : (ot_xmmreg,ot_xmmrm,ot_immediate or ot_bits8,ot_none);
+    code    : #241#3#15#58#68#72#22;
+    flags   : [if_clmul,if_sandybridge]
+  ),
   (
     opcode  : A_VADDPD;
     ops     : 3;
@@ -13636,6 +13657,27 @@
     code    : #242#249#1#247#62#72;
     flags   : [if_bmi1,if_prot]
   ),
+  (
+    opcode  : A_BLSI;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#139;
+    flags   : [if_bmi1,if_prot]
+  ),
+  (
+    opcode  : A_BLSMSK;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#138;
+    flags   : [if_bmi1,if_prot]
+  ),
+  (
+    opcode  : A_BLSR;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#137;
+    flags   : [if_bmi1,if_prot]
+  ),
   (
     opcode  : A_TZCNT;
     ops     : 2;
@@ -13699,6 +13741,20 @@
     code    : #220#242#249#1#247#62#72;
     flags   : [if_bmi2,if_prot]
   ),
+  (
+    opcode  : A_ADCX;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #241#3#15#56#246#72;
+    flags   : [if_adx]
+  ),
+  (
+    opcode  : A_ADOX;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #219#3#15#56#246#72;
+    flags   : [if_adx]
+  ),
   (
     opcode  : A_VBROADCASTI128;
     ops     : 2;

compiler/llvm/hlcgllvm.pas

@@ -591,8 +591,14 @@ implementation
 
 
   procedure thlcgllvm.a_load_const_reg(list: TAsmList; tosize: tdef; a: tcgint; register: tregister);
+    var
+      fromsize: tdef;
     begin
-      list.concat(taillvm.op_reg_size_const_size(llvmconvop(ptrsinttype,tosize,false),register,ptrsinttype,a,tosize))
+      if tosize.size<=ptrsinttype.size then
+        fromsize:=ptrsinttype
+      else
+        fromsize:=tosize;
+      list.concat(taillvm.op_reg_size_const_size(llvmconvop(fromsize,tosize,false),register,fromsize,a,tosize))
     end;
 
 

compiler/nadd.pas

@@ -3694,7 +3694,7 @@ implementation
                    we're done here }
                  expectloc:=LOC_REGISTER;
                end
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
               { is there a 64 bit type ? }
              else if (torddef(ld).ordtype in [s64bit,u64bit,scurrency]) then
                begin
@@ -3706,7 +3706,7 @@ implementation
                   else
                     expectloc:=LOC_JUMP;
                end
-{$endif cpu64bitalu}
+{$endif not(cpu64bitalu) and not(cpuhighleveltarget)}
              { generic 32bit conversion }
              else
                begin
@@ -3740,8 +3740,10 @@ implementation
 {$endif cpuneedsmulhelper}
                   if nodetype in [addn,subn,muln,andn,orn,xorn] then
                     expectloc:=LOC_REGISTER
+{$if not defined(cpuhighleveltarget)}
                   else if torddef(ld).size>sizeof(aint) then
                     expectloc:=LOC_JUMP
+{$endif}
                   else
                     expectloc:=LOC_FLAGS;
               end;

compiler/ncgadd.pas

@@ -146,7 +146,7 @@ interface
     procedure tcgaddnode.set_result_location_reg;
       begin
         location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
         if location.size in [OS_64,OS_S64] then
           begin
             location.register64.reglo := cg.getintregister(current_asmdata.CurrAsmList,OS_32);
@@ -435,7 +435,7 @@ interface
               else
                  internalerror(200203247);
             end;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
             if right.location.size in [OS_64,OS_S64] then
               begin
                 if right.location.loc <> LOC_CONSTANT then
@@ -522,7 +522,7 @@ interface
           (right.resultdef.typ<>pointerdef) and
           (cs_check_overflow in current_settings.localswitches) and not(nf_internal in flags);
 
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu) or defined(cpuhighleveltarget)}
         case nodetype of
           xorn,orn,andn,addn:
             begin
@@ -563,7 +563,7 @@ interface
           else
             internalerror(2002072803);
         end;
-{$else cpu64bitalu}
+{$else cpu64bitalu or cpuhighleveltarget}
         case nodetype of
           xorn,orn,andn,addn:
             begin
@@ -609,7 +609,7 @@ interface
           else
             internalerror(2002072803);
         end;
-{$endif cpu64bitalu}
+{$endif cpu64bitalu or cpuhighleveltarget}
 
         { emit overflow check if enabled }
         if checkoverflow then

compiler/ncgbas.pas

@@ -625,14 +625,14 @@ interface
                 begin
                   { make sure the register allocator doesn't reuse the }
                   { register e.g. in the middle of a loop              }
-{$if defined(cpu32bitalu)}
+{$if defined(cpu32bitalu) and not defined(cpuhighleveltarget)}
                   if tempinfo^.location.size in [OS_64,OS_S64] then
                     begin
                       cg.a_reg_sync(current_asmdata.CurrAsmList,tempinfo^.location.register64.reghi);
                       cg.a_reg_sync(current_asmdata.CurrAsmList,tempinfo^.location.register64.reglo);
                     end
                   else
-{$elseif defined(cpu16bitalu)}
+{$elseif defined(cpu16bitalu) and not defined(cpuhighleveltarget)}
                   if tempinfo^.location.size in [OS_64,OS_S64] then
                     begin
                       cg.a_reg_sync(current_asmdata.CurrAsmList,tempinfo^.location.register64.reghi);
@@ -647,7 +647,7 @@ interface
                       cg.a_reg_sync(current_asmdata.CurrAsmList,cg.GetNextReg(tempinfo^.location.register));
                     end
                   else
-{$elseif defined(cpu8bitalu)}
+{$elseif defined(cpu8bitalu) and not defined(cpuhighleveltarget)}
                   if tempinfo^.location.size in [OS_64,OS_S64] then
                     begin
                       cg.a_reg_sync(current_asmdata.CurrAsmList,tempinfo^.location.register64.reghi);

compiler/ncgcal.pas

@@ -611,7 +611,7 @@ implementation
             case location.loc of
               LOC_REGISTER :
                 begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                   if location.size in [OS_64,OS_S64] then
                     cg64.a_load64_reg_loc(current_asmdata.CurrAsmList,location.register64,funcretnode.location)
                   else

compiler/ncgcnv.pas

@@ -248,7 +248,7 @@ interface
             end;
           LOC_REGISTER,LOC_CREGISTER :
             begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
               if left.location.size in [OS_64,OS_S64] then
                begin
                  hregister:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
@@ -256,7 +256,7 @@ interface
                  cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_OR,OS_32,left.location.register64.reghi,hregister);
                end
               else
-{$endif cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                begin
                  cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_OR,left.location.size,left.location.register,left.location.register);
                end;

compiler/ncgcon.pas

@@ -188,11 +188,11 @@ implementation
     procedure tcgordconstnode.pass_generate_code;
       begin
          location_reset(location,LOC_CONSTANT,def_cgsize(resultdef));
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu) or defined(cpuhighleveltarget)}
          location.value:=value.svalue;
-{$else cpu64bitalu}
+{$else cpu64bitalu or cpuhighleveltarget}
          location.value64:=value.svalue;
-{$endif cpu64bitalu}
+{$endif cpu64bitalu or cpuhighleveltarget}
       end;
 
 

compiler/ncginl.pas

@@ -82,9 +82,9 @@ implementation
       ncon,ncal,
       tgobj,ncgutil,
       cgutils,cgobj,hlcgobj
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
       ,cg64f32
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
       ;
 
 
@@ -322,7 +322,7 @@ implementation
         if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
           hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,false);
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
         if def_cgsize(resultdef) in [OS_64,OS_S64] then
           begin
             location.register64.reglo:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
@@ -330,7 +330,7 @@ implementation
             cg64.a_op64_const_reg_reg(current_asmdata.CurrAsmList,cgop,def_cgsize(resultdef),1,left.location.register64,location.register64);
           end
         else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
           begin
             location.register:=hlcg.getregisterfordef(current_asmdata.CurrAsmList,resultdef);
             hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,cgop,resultdef,1,left.location.register,location.register);
@@ -352,17 +352,17 @@ implementation
         var
          addvalue : TConstExprInt;
          addconstant : boolean;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          hregisterhi,
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
          hregister : tregister;
         begin
           { set defaults }
           addconstant:=true;
           hregister:=NR_NO;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
           hregisterhi:=NR_NO;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
           { first secondpass second argument, because if the first arg }
           { is used in that expression then SSL may move it to another }
@@ -398,9 +398,9 @@ implementation
                 begin
                   hlcg.location_force_reg(current_asmdata.CurrAsmList,tcallparanode(tcallparanode(left).right).left.location,tcallparanode(tcallparanode(left).right).left.resultdef,second_incdec_tempregdef,addvalue<=1);
                   hregister:=tcallparanode(tcallparanode(left).right).left.location.register;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                   hregisterhi:=tcallparanode(tcallparanode(left).right).left.location.register64.reghi;
-{$endif not cpu64bitalu}
+{$endif not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                   { insert multiply with addvalue if its >1 }
                   if addvalue>1 then
                     hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_IMUL,left.resultdef,addvalue.svalue,hregister);
@@ -410,11 +410,11 @@ implementation
           { write the add instruction }
           if addconstant then
             begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
               if def_cgsize(left.resultdef) in [OS_64,OS_S64] then
                 cg64.a_op64_const_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],def_cgsize(left.resultdef),addvalue,tcallparanode(left).left.location)
               else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                 hlcg.a_op_const_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],left.resultdef,
 {$ifdef cpu64bitalu}
                   aint(addvalue.svalue),
@@ -425,12 +425,12 @@ implementation
             end
            else
              begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                if def_cgsize(left.resultdef) in [OS_64,OS_S64] then
                  cg64.a_op64_reg_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],def_cgsize(left.resultdef),
                    joinreg64(hregister,hregisterhi),tcallparanode(left).left.location)
                else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                  hlcg.a_op_reg_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],left.resultdef,
                    hregister,tcallparanode(left).left.location);
              end;
@@ -464,18 +464,18 @@ implementation
         var
           maskvalue : TConstExprInt;
           maskconstant : boolean;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
           hregisterhi,
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
           hregister : tregister;
         begin
           { set defaults }
           maskconstant:=true;
           hregister:=NR_NO;
           maskvalue:=0;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
           hregisterhi:=NR_NO;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
           { first secondpass first argument, because if the second arg }
           { is used in that expression then SSL may move it to another }
@@ -495,9 +495,9 @@ implementation
               else
                 hlcg.location_force_reg(current_asmdata.CurrAsmList,tcallparanode(left).left.location,tcallparanode(left).left.resultdef,tcallparanode(left).right.resultdef,true);
               hregister:=tcallparanode(left).left.location.register;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
               hregisterhi:=tcallparanode(left).left.location.register64.reghi;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
               maskconstant:=false;
             end;
           { write the and/or/xor/sar/shl/shr/rol/ror instruction }
@@ -508,11 +508,11 @@ implementation
                   maskvalue:=maskvalue and 63
                 else
                   maskvalue:=maskvalue and 31;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
               if def_cgsize(tcallparanode(left).right.resultdef) in [OS_64,OS_S64] then
                 cg64.a_op64_const_loc(current_asmdata.CurrAsmList,andorxorop[inlinenumber],def_cgsize(tcallparanode(left).right.resultdef),maskvalue.svalue,tcallparanode(tcallparanode(left).right).left.location)
               else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                 hlcg.a_op_const_loc(current_asmdata.CurrAsmList,andorxorop[inlinenumber],tcallparanode(left).right.resultdef,
 {$ifdef cpu64bitalu}
                   aint(maskvalue.svalue),
@@ -523,12 +523,12 @@ implementation
             end
            else
              begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                if def_cgsize(tcallparanode(left).right.resultdef) in [OS_64,OS_S64] then
                  cg64.a_op64_reg_loc(current_asmdata.CurrAsmList,andorxorop[inlinenumber],def_cgsize(tcallparanode(left).right.resultdef),
                    joinreg64(hregister,hregisterhi),tcallparanode(tcallparanode(left).right).left.location)
                else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                  hlcg.a_op_reg_loc(current_asmdata.CurrAsmList,andorxorop[inlinenumber],tcallparanode(left).right.resultdef,
                    hregister,tcallparanode(tcallparanode(left).right).left.location);
              end;
@@ -828,33 +828,33 @@ implementation
         hlcg.location_force_reg(current_asmdata.CurrAsmList,op1.location,op1.resultdef,resultdef,true);
 
         location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
         if def_cgsize(resultdef) in [OS_64,OS_S64] then
           begin
             location.register64.reglo:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
             location.register64.reghi:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
           end
         else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
           location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
 
         if assigned(op2) then
           begin
              { rotating by a constant directly coded: }
              if op2.nodetype=ordconstn then
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                if def_cgsize(resultdef) in [OS_64,OS_S64] then
                  cg64.a_op64_const_reg_reg(current_asmdata.CurrAsmList,op,def_cgsize(resultdef),
                    tordconstnode(op2).value.uvalue and (resultdef.size*8-1),
                    op1.location.register64, location.register64)
                else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                  hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,op,resultdef,
                    tordconstnode(op2).value.uvalue and (resultdef.size*8-1),
                    op1.location.register, location.register)
              else
                begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                  if def_cgsize(resultdef) in [OS_64,OS_S64] then
                    begin
                      hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,
@@ -864,7 +864,7 @@ implementation
                                              location.register64);
                    end
                  else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                    begin
                      hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,
                                              op2.resultdef,resultdef,true);
@@ -875,12 +875,12 @@ implementation
                end;
           end
         else
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
           if def_cgsize(resultdef) in [OS_64,OS_S64] then
             cg64.a_op64_const_reg_reg(current_asmdata.CurrAsmList,op,def_cgsize(resultdef),1,
                                       op1.location.register64,location.register64)
           else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
             hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,op,resultdef,1,
                                     op1.location.register,location.register);
       end;

compiler/ncgld.pas

@@ -330,8 +330,9 @@ implementation
                begin
                  { Load a pointer to the thread var record into a register. }
                  { This register will be used in both multithreaded and non-multithreaded cases. }
-                 hreg_tv_rec:=hlcg.getaddressregister(current_asmdata.CurrAsmList,fieldptrdef);
-                 hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,resultdef,fieldptrdef,tvref,hreg_tv_rec);
+                 hreg_tv_rec:=hlcg.getaddressregister(current_asmdata.CurrAsmList,cpointerdef.getreusable(tv_rec));
+                 hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,tv_rec,cpointerdef.getreusable(tv_rec),tvref,hreg_tv_rec);
+                 reference_reset_base(tvref,hreg_tv_rec,0,ctempposinvalid,tvref.alignment,tvref.volatility)
                end;
              paraloc1.init;
              paramanager.getintparaloc(current_asmdata.CurrAsmList,tprocvardef(pvd),1,paraloc1);
@@ -346,8 +347,6 @@ implementation
              hlcg.g_set_addr_nonbitpacked_field_ref(current_asmdata.CurrAsmList,
                tv_rec,
                tfieldvarsym(tv_index_field),href);
-             if size_opt then
-               hlcg.reference_reset_base(href,tfieldvarsym(tv_index_field).vardef,hreg_tv_rec,href.offset,href.temppos,href.alignment,[]);
              hlcg.a_load_ref_cgpara(current_asmdata.CurrAsmList,tfieldvarsym(tv_index_field).vardef,href,paraloc1);
              { Dealloc the threadvar record register before calling the helper function to allow  }
              { the register allocator to assign non-mandatory real registers for hreg_tv_rec. }
@@ -377,10 +376,6 @@ implementation
              hlcg.g_set_addr_nonbitpacked_field_ref(current_asmdata.CurrAsmList,
                tv_rec,
                tfieldvarsym(tv_non_mt_data_field),href);
-             { load in the same "hregister" as above, so after this sequence
-               the address of the threadvar is always in hregister }
-             if size_opt then
-               hlcg.reference_reset_base(href,fieldptrdef,hreg_tv_rec,href.offset,href.temppos,href.alignment,[]);
              hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,resultdef,fieldptrdef,href,hregister);
              hlcg.a_label(current_asmdata.CurrAsmList,endrelocatelab);
 
@@ -695,7 +690,7 @@ implementation
          alignmentrequirement,
          len : aint;
          r : tregister;
-         {$if not defined(cpu64bitalu)}
+         {$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          r64 : tregister64;
          {$endif}
          oldflowcontrol : tflowcontrol;
@@ -840,11 +835,11 @@ implementation
             case right.location.loc of
               LOC_CONSTANT :
                 begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                   if (left.location.size in [OS_64,OS_S64]) or (right.location.size in [OS_64,OS_S64]) then
                     cg64.a_load64_const_loc(current_asmdata.CurrAsmList,right.location.value64,left.location)
                   else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                     hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,right.location.value,left.location);
                 end;
               LOC_REFERENCE,
@@ -952,11 +947,11 @@ implementation
                       hlcg.a_load_ref_subsetreg(current_asmdata.CurrAsmList,right.resultdef,left.resultdef,right.location.reference,left.location.sreg);
                     LOC_SUBSETREF,
                     LOC_CSUBSETREF:
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                       if right.location.size in [OS_64,OS_S64] then
                        cg64.a_load64_ref_subsetref(current_asmdata.CurrAsmList,right.location.reference,left.location.sref)
                       else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                        hlcg.a_load_ref_subsetref(current_asmdata.CurrAsmList,right.resultdef,left.resultdef,right.location.reference,left.location.sref);
                     else
                       internalerror(200203284);
@@ -1055,11 +1050,11 @@ implementation
               LOC_SUBSETREF,
               LOC_CSUBSETREF:
                 begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                   if right.location.size in [OS_64,OS_S64] then
                    cg64.a_load64_subsetref_loc(current_asmdata.CurrAsmList,right.location.sref,left.location)
                   else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                   hlcg.a_load_subsetref_loc(current_asmdata.CurrAsmList,
                       right.resultdef,left.resultdef,right.location.sref,left.location);
                 end;
@@ -1069,30 +1064,30 @@ implementation
                   hlcg.a_label(current_asmdata.CurrAsmList,right.location.truelabel);
                   if is_pasbool(left.resultdef) then
                     begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                       if left.location.size in [OS_64,OS_S64] then
                         cg64.a_load64_const_loc(current_asmdata.CurrAsmList,1,left.location)
                       else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                         hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,1,left.location)
                     end
                   else
                     begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                       if left.location.size in [OS_64,OS_S64] then
                         cg64.a_load64_const_loc(current_asmdata.CurrAsmList,-1,left.location)
                       else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                         hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,-1,left.location);
                     end;
 
                   hlcg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
                   hlcg.a_label(current_asmdata.CurrAsmList,right.location.falselabel);
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                   if left.location.size in [OS_64,OS_S64] then
                     cg64.a_load64_const_loc(current_asmdata.CurrAsmList,0,left.location)
                   else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                     hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,0,left.location);
                   hlcg.a_label(current_asmdata.CurrAsmList,hlabel);
                 end;
@@ -1103,7 +1098,7 @@ implementation
                     begin
                       case left.location.loc of
                         LOC_REGISTER,LOC_CREGISTER:
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                           if left.location.size in [OS_S64,OS_64] then
                             begin
                               cg.g_flags2reg(current_asmdata.CurrAsmList,OS_32,right.location.resflags,left.location.register64.reglo);
@@ -1111,7 +1106,7 @@ implementation
                               cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_32,0,left.location.register64.reghi);
                             end
                           else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                             begin
                               cg.g_flags2reg(current_asmdata.CurrAsmList,left.location.size,right.location.resflags,left.location.register);
                               cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
@@ -1119,7 +1114,7 @@ implementation
                         LOC_REFERENCE:
                         { i8086 and i386 have hacks in their code generators so that they can
                           deal with 64 bit locations in this parcticular case }
-{$if not defined(cpu64bitalu) and not defined(x86)}
+{$if not defined(cpu64bitalu) and not defined(x86) and not defined(cpuhighleveltarget)}
                           if left.location.size in [OS_S64,OS_64] then
                             begin
                               r64.reglo:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
@@ -1130,7 +1125,7 @@ implementation
                               cg64.a_load64_reg_ref(current_asmdata.CurrAsmList,r64,left.location.reference);
                             end
                           else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not x86 and not cpuhighleveltarget}
                             begin
                               cg.g_flags2ref(current_asmdata.CurrAsmList,left.location.size,right.location.resflags,left.location.reference);
                               cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
@@ -1148,7 +1143,7 @@ implementation
                     end
                   else
                     begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
                       if left.location.size in [OS_S64,OS_64] then
                         begin
                           r64.reglo:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
@@ -1161,7 +1156,7 @@ implementation
                           cg64.a_load64_reg_loc(current_asmdata.CurrAsmList,r64,left.location);
                         end
                       else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
                         begin
                           r:=cg.getintregister(current_asmdata.CurrAsmList,left.location.size);
                           cg.g_flags2reg(current_asmdata.CurrAsmList,left.location.size,right.location.resflags,r);

compiler/ncgmat.pas

@@ -46,9 +46,9 @@ interface
 {$ifdef SUPPORT_MMX}
          procedure second_mmx;virtual;abstract;
 {$endif SUPPORT_MMX}
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          procedure second_64bit;virtual;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
          procedure second_integer;virtual;
          procedure second_float;virtual;
          procedure second_float_emulated;virtual;
@@ -83,7 +83,7 @@ interface
            been done and emitted, so this should really a do a modulo.
          }
          procedure emit_mod_reg_reg(signed: boolean;denum,num : tregister);virtual;abstract;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          { This routine must do an actual 64-bit division, be it
            signed or unsigned. The result must set into the the
            @var(num) register.
@@ -98,16 +98,16 @@ interface
            64-bit systems, otherwise a helper is called in 1st pass.
          }
          procedure emit64_div_reg_reg(signed: boolean;denum,num : tregister64);virtual;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
       end;
 
       tcgshlshrnode = class(tshlshrnode)
 {$ifdef SUPPORT_MMX}
          procedure second_mmx;virtual;abstract;
 {$endif SUPPORT_MMX}
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          procedure second_64bit;virtual;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
          procedure second_integer;virtual;
          procedure pass_generate_code;override;
       end;
@@ -119,9 +119,9 @@ interface
 {$ifdef SUPPORT_MMX}
          procedure second_mmx;virtual;abstract;
 {$endif SUPPORT_MMX}
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          procedure second_64bit;virtual;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
          procedure second_integer;virtual;
       public
          procedure pass_generate_code;override;
@@ -197,7 +197,7 @@ implementation
       end;
 
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
     procedure tcgunaryminusnode.second_64bit;
       var
         tr: tregister;
@@ -223,7 +223,7 @@ implementation
             cg.a_label(current_asmdata.CurrAsmList,hl);
           end;
       end;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
 
     procedure tcgunaryminusnode.second_float_emulated;
@@ -319,11 +319,11 @@ implementation
 
     procedure tcgunaryminusnode.pass_generate_code;
       begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          if is_64bit(left.resultdef) then
            second_64bit
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 {$ifdef SUPPORT_MMX}
            if (cs_mmx in current_settings.localswitches) and is_mmx_able_array(left.resultdef) then
              second_mmx
@@ -345,7 +345,7 @@ implementation
                              TCGMODDIVNODE
 *****************************************************************************}
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
     procedure tcgmoddivnode.emit64_div_reg_reg(signed: boolean; denum,num:tregister64);
       begin
         { handled in pass_1 already, unless pass_1 is
@@ -354,7 +354,7 @@ implementation
         { should be handled in pass_1 (JM) }
         internalerror(200109052);
       end;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
 
     procedure tcgmoddivnode.pass_generate_code;
@@ -376,7 +376,7 @@ implementation
           exit;
          location_copy(location,left.location);
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          if is_64bit(resultdef) then
            begin
              if is_signed(left.resultdef) then
@@ -395,7 +395,7 @@ implementation
                joinreg64(location.register64.reglo,location.register64.reghi));
            end
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
            begin
               if is_signed(left.resultdef) then
                 begin
@@ -475,13 +475,13 @@ implementation
 *****************************************************************************}
 
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
     procedure tcgshlshrnode.second_64bit;
       begin
          { already hanled in 1st pass }
          internalerror(2002081501);
       end;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
 
     procedure tcgshlshrnode.second_integer;
@@ -610,11 +610,11 @@ implementation
              second_mmx
          else
 {$endif SUPPORT_MMX}
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          if is_64bit(left.resultdef) then
            second_64bit
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
            second_integer;
       end;
 
@@ -623,7 +623,7 @@ implementation
                                TCGNOTNODE
 *****************************************************************************}
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
     procedure tcgnotnode.second_64bit;
       begin
         secondpass(left);
@@ -635,7 +635,7 @@ implementation
         { perform the NOT operation }
         cg64.a_op64_reg_reg(current_asmdata.CurrAsmList,OP_NOT,location.size,left.location.register64,location.register64);
       end;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
 
     procedure tcgnotnode.second_integer;
@@ -676,10 +676,10 @@ implementation
         else if (cs_mmx in current_settings.localswitches) and is_mmx_able_array(left.resultdef) then
           second_mmx
 {$endif SUPPORT_MMX}
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
         else if is_64bit(left.resultdef) then
           second_64bit
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
         else
           second_integer;
       end;

compiler/ncgset.pas

@@ -755,16 +755,17 @@ implementation
 
       procedure genitem(t : pcaselabel);
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
         var
            l1 : tasmlabel;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
         begin
            if assigned(t^.less) then
              genitem(t^.less);
            if t^._low=t^._high then
              begin
+{$ifndef cpuhighleveltarget}
 {$if defined(cpu32bitalu)}
                 if def_cgsize(opsize) in [OS_S64,OS_64] then
                   begin
@@ -824,6 +825,7 @@ implementation
                   end
                 else
 {$endif}
+{$endif cpuhighleveltarget}
                   begin
                      hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ, aint(t^._low.svalue),hregister, blocklabel(t^.blockid));
                   end;
@@ -838,6 +840,7 @@ implementation
                 { ELSE-label                                }
                 if not lastwasrange or (t^._low-last>1) then
                   begin
+{$ifndef cpuhighleveltarget}
 {$if defined(cpu32bitalu)}
                      if def_cgsize(opsize) in [OS_64,OS_S64] then
                        begin
@@ -929,11 +932,13 @@ implementation
                        end
                      else
 {$endif}
+{$endif cpuhighleveltarget}
                        begin
                         hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_lt, aint(t^._low.svalue), hregister,
                            elselabel);
                        end;
                   end;
+{$ifndef cpuhighleveltarget}
 {$if defined(cpu32bitalu)}
                 if def_cgsize(opsize) in [OS_S64,OS_64] then
                   begin
@@ -1019,6 +1024,7 @@ implementation
                   end
                 else
 {$endif}
+{$endif cpuhighleveltarget}
                   begin
                      hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_le, aint(t^._high.svalue), hregister, blocklabel(t^.blockid));
                   end;
@@ -1200,14 +1206,14 @@ implementation
          opsize:=left.resultdef;
          { copy the case expression to a register }
          hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,opsize,false);
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu)}
          if def_cgsize(opsize) in [OS_S64,OS_64] then
            begin
              hregister:=left.location.register64.reglo;
              hregister2:=left.location.register64.reghi;
            end
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
            hregister:=left.location.register;
 
          { we need the min_label always to choose between }
@@ -1218,11 +1224,11 @@ implementation
 {$ifdef OLDREGVARS}
          load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu)}
          if def_cgsize(opsize) in [OS_64,OS_S64] then
            genlinearcmplist(labels)
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
            begin
               labelcnt := 0;
               TrueCount := 0;

compiler/ncgutil.pas

@@ -31,9 +31,9 @@ interface
       cpubase,cgbase,parabase,cgutils,
       aasmbase,aasmtai,aasmdata,aasmcpu,
       symconst,symbase,symdef,symsym,symtype
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
       ,cg64f32
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
       ;
 
     type
@@ -63,10 +63,6 @@ interface
     procedure location_force_mmreg(list:TAsmList;var l: tlocation;maybeconst:boolean);
     procedure location_allocate_register(list:TAsmList;out l: tlocation;def: tdef;constant: boolean);
 
-    { loads a cgpara into a tlocation; assumes that loc.loc is already
-      initialised }
-    procedure gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean);
-
     { allocate registers for a tlocation; assumes that loc.loc is already
       set to LOC_CREGISTER/LOC_CFPUREGISTER/... }
     procedure gen_alloc_regloc(list:TAsmList;var loc: tlocation;def: tdef);
@@ -80,7 +76,6 @@ interface
     procedure gen_proc_exit_code(list:TAsmList);
     procedure gen_save_used_regs(list:TAsmList);
     procedure gen_restore_used_regs(list:TAsmList);
-    procedure gen_load_para_value(list:TAsmList);
 
     procedure get_used_regvars(n: tnode; var rv: tusedregvars);
     { adds the regvars used in n and its children to rv.allregvars,
@@ -101,6 +96,9 @@ interface
 
     procedure gen_load_frame_for_exceptfilter(list : TAsmList);
 
+   procedure gen_alloc_regvar(list:TAsmList;sym: tabstractnormalvarsym; allocreg: boolean);
+
+
 implementation
 
   uses
@@ -138,7 +136,7 @@ implementation
           LOC_REGISTER,
           LOC_CREGISTER:
             begin
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu)}
                 { x86-64 system v abi:
                   structs with up to 16 bytes are returned in registers }
                 if location.size in [OS_128,OS_S128] then
@@ -148,7 +146,8 @@ implementation
                     if getsupreg(location.registerhi)<first_int_imreg then
                       cg.ungetcpuregister(list,location.registerhi);
                   end
-{$else cpu64bitalu}
+                else
+{$elseif not defined(cpuhighleveltarget)}
                 if location.size in [OS_64,OS_S64] then
                   begin
                     if getsupreg(location.register64.reglo)<first_int_imreg then
@@ -156,8 +155,8 @@ implementation
                     if getsupreg(location.register64.reghi)<first_int_imreg then
                       cg.ungetcpuregister(list,location.register64.reghi);
                   end
-{$endif cpu64bitalu}
                 else
+{$endif cpu64bitalu and not cpuhighleveltarget}
                   if getsupreg(location.register)<first_int_imreg then
                     cg.ungetcpuregister(list,location.register);
             end;
@@ -292,7 +291,7 @@ implementation
                        end;
                      LOC_CREGISTER,LOC_REGISTER,LOC_CREFERENCE,LOC_REFERENCE :
                        begin
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu)}
                          if opsize in [OS_128,OS_S128] then
                            begin
                              hlcg.location_force_reg(list,p.location,p.resultdef,cgsize_orddef(opsize),true);
@@ -302,7 +301,7 @@ implementation
                              p.location.register:=tmpreg;
                              opsize:=OS_64;
                            end;
-{$else cpu64bitalu}
+{$elseif not defined(cpuhighleveltarget)}
                          if opsize in [OS_64,OS_S64] then
                            begin
                              hlcg.location_force_reg(list,p.location,p.resultdef,cgsize_orddef(opsize),true);
@@ -312,7 +311,7 @@ implementation
                              p.location.register:=tmpreg;
                              opsize:=OS_32;
                            end;
-{$endif cpu64bitalu}
+{$endif cpu64bitalu and not cpuhighleveltarget}
                          cg.a_cmp_const_loc_label(list,opsize,OC_NE,0,p.location,truelabel);
                          cg.a_jmp_always(list,falselabel);
                        end;
@@ -456,21 +455,21 @@ implementation
               location_reset(l,LOC_CREGISTER,l.size)
             else
               location_reset(l,LOC_REGISTER,l.size);
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu)}
             if l.size in [OS_128,OS_S128,OS_F128] then
               begin
                 l.register128.reglo:=cg.getintregister(list,OS_64);
                 l.register128.reghi:=cg.getintregister(list,OS_64);
               end
             else
-{$else cpu64bitalu}
+{$elseif not defined(cpuhighleveltarget)}
             if l.size in [OS_64,OS_S64,OS_F64] then
               begin
                 l.register64.reglo:=cg.getintregister(list,OS_32);
                 l.register64.reghi:=cg.getintregister(list,OS_32);
               end
             else
-{$endif cpu64bitalu}
+{$endif cpu64bitalu and not cpuhighleveltarget}
             { Note: for widths of records (and maybe objects, classes, etc.) an
                     address register could be set here, but that is later
                     changed to an intregister neverthless when in the
@@ -556,21 +555,21 @@ implementation
         case loc.loc of
           LOC_CREGISTER:
             begin
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu)}
               if loc.size in [OS_128,OS_S128] then
                 begin
                   loc.register128.reglo:=cg.getintregister(list,OS_64);
                   loc.register128.reghi:=cg.getintregister(list,OS_64);
                 end
               else
-{$else cpu64bitalu}
+{$elseif not defined(cpuhighleveltarget)}
               if loc.size in [OS_64,OS_S64] then
                 begin
                   loc.register64.reglo:=cg.getintregister(list,OS_32);
                   loc.register64.reghi:=cg.getintregister(list,OS_32);
                 end
               else
-{$endif cpu64bitalu}
+{$endif cpu64bitalu and not cpuhighleveltarget}
                 if hlcg.def2regtyp(def)=R_ADDRESSREGISTER then
                   loc.register:=hlcg.getaddressregister(list,def)
                 else
@@ -612,14 +611,14 @@ implementation
                 cg.a_reg_sync(list,sym.initialloc.register128.reghi);
               end
             else
-{$elseif defined(cpu32bitalu)}
+{$elseif defined(cpu32bitalu) and not defined(cpuhighleveltarget)}
             if sym.initialloc.size in [OS_64,OS_S64] then
               begin
                 cg.a_reg_sync(list,sym.initialloc.register64.reglo);
                 cg.a_reg_sync(list,sym.initialloc.register64.reghi);
               end
             else
-{$elseif defined(cpu16bitalu)}
+{$elseif defined(cpu16bitalu) and not defined(cpuhighleveltarget)}
             if sym.initialloc.size in [OS_64,OS_S64] then
               begin
                 cg.a_reg_sync(list,sym.initialloc.register64.reglo);
@@ -634,7 +633,7 @@ implementation
                 cg.a_reg_sync(list,cg.GetNextReg(sym.initialloc.register));
               end
             else
-{$elseif defined(cpu8bitalu)}
+{$elseif defined(cpu8bitalu) and not defined(cpuhighleveltarget)}
             if sym.initialloc.size in [OS_64,OS_S64] then
               begin
                 cg.a_reg_sync(list,sym.initialloc.register64.reglo);
@@ -664,640 +663,20 @@ implementation
 {$endif}
              cg.a_reg_sync(list,sym.initialloc.register);
           end;
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu)}
         if (sym.initialloc.size in [OS_128,OS_S128]) then
           varloc:=tai_varloc.create128(sym,sym.initialloc.register,sym.initialloc.registerhi)
-{$else cpu64bitalu}
+        else
+{$elseif not defined(cpuhighleveltarget)}
         if (sym.initialloc.size in [OS_64,OS_S64]) then
           varloc:=tai_varloc.create64(sym,sym.initialloc.register,sym.initialloc.registerhi)
-{$endif cpu64bitalu}
         else
+{$endif cpu64bitalu and not cpuhighleveltarget}
           varloc:=tai_varloc.create(sym,sym.initialloc.register);
         list.concat(varloc);
       end;
 
 
-    procedure gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean);
-
-      procedure unget_para(const paraloc:TCGParaLocation);
-        begin
-           case paraloc.loc of
-             LOC_REGISTER :
-               begin
-                 if getsupreg(paraloc.register)<first_int_imreg then
-                   cg.ungetcpuregister(list,paraloc.register);
-               end;
-             LOC_MMREGISTER :
-               begin
-                 if getsupreg(paraloc.register)<first_mm_imreg then
-                   cg.ungetcpuregister(list,paraloc.register);
-               end;
-             LOC_FPUREGISTER :
-               begin
-                 if getsupreg(paraloc.register)<first_fpu_imreg then
-                   cg.ungetcpuregister(list,paraloc.register);
-               end;
-           end;
-        end;
-
-      var
-        paraloc   : pcgparalocation;
-        href      : treference;
-        sizeleft  : aint;
-        tempref   : treference;
-        loadsize  : tcgint;
-        tempreg  : tregister;
-{$ifdef mips}
-        //tmpreg   : tregister;
-{$endif mips}
-{$ifndef cpu64bitalu}
-        reg64    : tregister64;
-{$if defined(cpu8bitalu)}
-        curparaloc : PCGParaLocation;
-{$endif defined(cpu8bitalu)}
-{$endif not cpu64bitalu}
-      begin
-        paraloc:=para.location;
-        if not assigned(paraloc) then
-          internalerror(200408203);
-        { skip e.g. empty records }
-        if (paraloc^.loc = LOC_VOID) then
-          exit;
-        case destloc.loc of
-          LOC_REFERENCE :
-            begin
-              { If the parameter location is reused we don't need to copy
-                anything }
-              if not reusepara then
-                begin
-                  href:=destloc.reference;
-                  sizeleft:=para.intsize;
-                  while assigned(paraloc) do
-                    begin
-                      if (paraloc^.size=OS_NO) then
-                        begin
-                          { Can only be a reference that contains the rest
-                            of the parameter }
-                          if (paraloc^.loc<>LOC_REFERENCE) or
-                             assigned(paraloc^.next) then
-                            internalerror(2005013010);
-                          cg.a_load_cgparaloc_ref(list,paraloc^,href,sizeleft,destloc.reference.alignment);
-                          inc(href.offset,sizeleft);
-                          sizeleft:=0;
-                        end
-                      else
-                        begin
-                          { the min(...) call ensures that we do not store more than place is left as
-                             paraloc^.size could be bigger than destloc.size of a parameter occupies a full register
-                             and as on big endian system the parameters might be left aligned, we have to work
-                             with the full register size for paraloc^.size }
-                          if tcgsize2size[destloc.size]<>0 then
-                            loadsize:=min(min(tcgsize2size[paraloc^.size],tcgsize2size[destloc.size]),sizeleft)
-                          else
-                            loadsize:=min(tcgsize2size[paraloc^.size],sizeleft);
-
-                          cg.a_load_cgparaloc_ref(list,paraloc^,href,loadsize,destloc.reference.alignment);
-                          inc(href.offset,loadsize);
-                          dec(sizeleft,loadsize);
-                        end;
-                      unget_para(paraloc^);
-                      paraloc:=paraloc^.next;
-                    end;
-                end;
-            end;
-          LOC_REGISTER,
-          LOC_CREGISTER :
-            begin
-{$ifdef cpu64bitalu}
-              if (para.size in [OS_128,OS_S128,OS_F128]) and
-                 ({ in case of fpu emulation, or abi's that pass fpu values
-                    via integer registers }
-                  (vardef.typ=floatdef) or
-                   is_methodpointer(vardef) or
-                   is_record(vardef)) then
-                begin
-                  case paraloc^.loc of
-                    LOC_REGISTER,
-                    LOC_MMREGISTER:
-                      begin
-                        if not assigned(paraloc^.next) then
-                          internalerror(200410104);
-                        case tcgsize2size[paraloc^.size] of
-                          8:
-                            begin
-                              if (target_info.endian=ENDIAN_BIG) then
-                                begin
-                                  { paraloc^ -> high
-                                    paraloc^.next -> low }
-                                  unget_para(paraloc^);
-                                  gen_alloc_regloc(list,destloc,vardef);
-                                  { reg->reg, alignment is irrelevant }
-                                  cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reghi,8);
-                                  unget_para(paraloc^.next^);
-                                  cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^.next^,destloc.register128.reglo,8);
-                                end
-                              else
-                                begin
-                                  { paraloc^ -> low
-                                    paraloc^.next -> high }
-                                  unget_para(paraloc^);
-                                  gen_alloc_regloc(list,destloc,vardef);
-                                  cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reglo,8);
-                                  unget_para(paraloc^.next^);
-                                  cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^.next^,destloc.register128.reghi,8);
-                                end;
-                            end;
-                          4:
-                            begin
-                              { The 128-bit parameter is located in 4 32-bit MM registers.
-                                It is needed to copy them to 2 64-bit int registers.
-                                A code generator or a target cpu must support loading of a 32-bit MM register to
-                                a 64-bit int register, zero extending it. }
-                              if target_info.endian=ENDIAN_BIG then
-                                internalerror(2018101702);  // Big endian support not implemented yet
-                              gen_alloc_regloc(list,destloc,vardef);
-                              tempreg:=cg.getintregister(list,OS_64);
-                              // Low part of the 128-bit param
-                              unget_para(paraloc^);
-                              cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,tempreg,4);
-                              paraloc:=paraloc^.next;
-                              if paraloc=nil then
-                                internalerror(2018101703);
-                              unget_para(paraloc^);
-                              cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reglo,4);
-                              cg.a_op_const_reg(list,OP_SHL,OS_64,32,destloc.register128.reglo);
-                              cg.a_op_reg_reg(list,OP_OR,OS_64,tempreg,destloc.register128.reglo);
-                              // High part of the 128-bit param
-                              paraloc:=paraloc^.next;
-                              if paraloc=nil then
-                                internalerror(2018101704);
-                              unget_para(paraloc^);
-                              cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,tempreg,4);
-                              paraloc:=paraloc^.next;
-                              if paraloc=nil then
-                                internalerror(2018101705);
-                              unget_para(paraloc^);
-                              cg.a_load_cgparaloc_anyreg(list,OS_64,paraloc^,destloc.register128.reghi,4);
-                              cg.a_op_const_reg(list,OP_SHL,OS_64,32,destloc.register128.reghi);
-                              cg.a_op_reg_reg(list,OP_OR,OS_64,tempreg,destloc.register128.reghi);
-                            end
-                          else
-                            internalerror(2018101701);
-                        end;
-                      end;
-                    LOC_REFERENCE:
-                      begin
-                        gen_alloc_regloc(list,destloc,vardef);
-                        reference_reset_base(href,paraloc^.reference.index,paraloc^.reference.offset,ctempposinvalid,para.alignment,[]);
-                        cg128.a_load128_ref_reg(list,href,destloc.register128);
-                        unget_para(paraloc^);
-                      end;
-                    else
-                      internalerror(2012090607);
-                  end
-                end
-              else
-{$else cpu64bitalu}
-              if (para.size in [OS_64,OS_S64,OS_F64]) and
-                 (is_64bit(vardef) or
-                  { in case of fpu emulation, or abi's that pass fpu values
-                    via integer registers }
-                  (vardef.typ=floatdef) or
-                   is_methodpointer(vardef) or
-                   is_record(vardef)) then
-                begin
-                  case paraloc^.loc of
-                    LOC_REGISTER:
-                      begin
-                        case para.locations_count of
-{$if defined(cpu8bitalu)}
-                          { 8 paralocs? }
-                          8:
-                            if (target_info.endian=ENDIAN_BIG) then
-                              begin
-                                { is there any big endian 8 bit ALU/16 bit Addr CPU? }
-                                internalerror(2015041003);
-                                { paraloc^ -> high
-                                  paraloc^.next^.next^.next^.next -> low }
-                                unget_para(paraloc^);
-                                gen_alloc_regloc(list,destloc,vardef);
-                                { reg->reg, alignment is irrelevant }
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^,cg.GetNextReg(destloc.register64.reghi),1);
-                                unget_para(paraloc^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^,destloc.register64.reghi,1);
-                                unget_para(paraloc^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^,cg.GetNextReg(destloc.register64.reglo),1);
-                                unget_para(paraloc^.next^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^.next^,destloc.register64.reglo,1);
-                              end
-                            else
-                              begin
-                                { paraloc^ -> low
-                                  paraloc^.next^.next^.next^.next -> high }
-                                curparaloc:=paraloc;
-                                unget_para(curparaloc^);
-                                gen_alloc_regloc(list,destloc,vardef);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^,destloc.register64.reglo,2);
-                                unget_para(curparaloc^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^,cg.GetNextReg(destloc.register64.reglo),1);
-                                unget_para(curparaloc^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^,cg.GetNextReg(cg.GetNextReg(destloc.register64.reglo)),1);
-                                unget_para(curparaloc^.next^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^.next^,cg.GetNextReg(cg.GetNextReg(cg.GetNextReg(destloc.register64.reglo))),1);
-
-                                curparaloc:=paraloc^.next^.next^.next^.next;
-                                unget_para(curparaloc^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^,destloc.register64.reghi,2);
-                                unget_para(curparaloc^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^,cg.GetNextReg(destloc.register64.reghi),1);
-                                unget_para(curparaloc^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^,cg.GetNextReg(cg.GetNextReg(destloc.register64.reghi)),1);
-                                unget_para(curparaloc^.next^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_8,curparaloc^.next^.next^.next^,cg.GetNextReg(cg.GetNextReg(cg.GetNextReg(destloc.register64.reghi))),1);
-                              end;
-{$endif defined(cpu8bitalu)}
-{$if defined(cpu16bitalu) or defined(cpu8bitalu)}
-                          { 4 paralocs? }
-                          4:
-                            if (target_info.endian=ENDIAN_BIG) then
-                              begin
-                                { paraloc^ -> high
-                                  paraloc^.next^.next -> low }
-                                unget_para(paraloc^);
-                                gen_alloc_regloc(list,destloc,vardef);
-                                { reg->reg, alignment is irrelevant }
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^,cg.GetNextReg(destloc.register64.reghi),2);
-                                unget_para(paraloc^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^,destloc.register64.reghi,2);
-                                unget_para(paraloc^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^,cg.GetNextReg(destloc.register64.reglo),2);
-                                unget_para(paraloc^.next^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^.next^,destloc.register64.reglo,2);
-                              end
-                            else
-                              begin
-                                { paraloc^ -> low
-                                  paraloc^.next^.next -> high }
-                                unget_para(paraloc^);
-                                gen_alloc_regloc(list,destloc,vardef);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^,destloc.register64.reglo,2);
-                                unget_para(paraloc^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^,cg.GetNextReg(destloc.register64.reglo),2);
-                                unget_para(paraloc^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^,destloc.register64.reghi,2);
-                                unget_para(paraloc^.next^.next^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_16,paraloc^.next^.next^.next^,cg.GetNextReg(destloc.register64.reghi),2);
-                              end;
-{$endif defined(cpu16bitalu) or defined(cpu8bitalu)}
-                          2:
-                            if (target_info.endian=ENDIAN_BIG) then
-                              begin
-                                { paraloc^ -> high
-                                  paraloc^.next -> low }
-                                unget_para(paraloc^);
-                                gen_alloc_regloc(list,destloc,vardef);
-                                { reg->reg, alignment is irrelevant }
-                                cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^,destloc.register64.reghi,4);
-                                unget_para(paraloc^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^.next^,destloc.register64.reglo,4);
-                              end
-                            else
-                              begin
-                                { paraloc^ -> low
-                                  paraloc^.next -> high }
-                                unget_para(paraloc^);
-                                gen_alloc_regloc(list,destloc,vardef);
-                                cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^,destloc.register64.reglo,4);
-                                unget_para(paraloc^.next^);
-                                cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^.next^,destloc.register64.reghi,4);
-                              end;
-                          else
-                            { unexpected number of paralocs }
-                            internalerror(200410104);
-                        end;
-                      end;
-                    LOC_REFERENCE:
-                      begin
-                        gen_alloc_regloc(list,destloc,vardef);
-                        reference_reset_base(href,paraloc^.reference.index,paraloc^.reference.offset,ctempposinvalid,para.alignment,[]);
-                        cg64.a_load64_ref_reg(list,href,destloc.register64);
-                        unget_para(paraloc^);
-                      end;
-                    else
-                      internalerror(2005101501);
-                  end
-                end
-              else
-{$endif cpu64bitalu}
-                begin
-                  if assigned(paraloc^.next) then
-                    begin
-                      if (destloc.size in [OS_PAIR,OS_SPAIR]) and
-                        (para.Size in [OS_PAIR,OS_SPAIR]) then
-                        begin
-                          unget_para(paraloc^);
-                          gen_alloc_regloc(list,destloc,vardef);
-                          cg.a_load_cgparaloc_anyreg(list,OS_INT,paraloc^,destloc.register,sizeof(aint));
-                          unget_para(paraloc^.Next^);
-                          {$if defined(cpu16bitalu) or defined(cpu8bitalu)}
-                            cg.a_load_cgparaloc_anyreg(list,OS_INT,paraloc^.Next^,cg.GetNextReg(destloc.register),sizeof(aint));
-                          {$else}
-                            cg.a_load_cgparaloc_anyreg(list,OS_INT,paraloc^.Next^,destloc.registerhi,sizeof(aint));
-                          {$endif}
-                        end
-{$if defined(cpu8bitalu)}
-                      else if (destloc.size in [OS_32,OS_S32]) and
-                        (para.Size in [OS_32,OS_S32]) then
-                        begin
-                          unget_para(paraloc^);
-                          gen_alloc_regloc(list,destloc,vardef);
-                          cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^,destloc.register,sizeof(aint));
-                          unget_para(paraloc^.Next^);
-                          cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^.Next^,cg.GetNextReg(destloc.register),sizeof(aint));
-                          unget_para(paraloc^.Next^.Next^);
-                          cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^.Next^.Next^,cg.GetNextReg(cg.GetNextReg(destloc.register)),sizeof(aint));
-                          unget_para(paraloc^.Next^.Next^.Next^);
-                          cg.a_load_cgparaloc_anyreg(list,OS_8,paraloc^.Next^.Next^.Next^,cg.GetNextReg(cg.GetNextReg(cg.GetNextReg(destloc.register))),sizeof(aint));
-                        end
-{$endif defined(cpu8bitalu)}
-                      else
-                        begin
-                          { this can happen if a parameter is spread over
-                            multiple paralocs, e.g. if a record with two single
-                            fields must be passed in two single precision
-                            registers }
-                          { does it fit in the register of destloc? }
-                          sizeleft:=para.intsize;
-                          if sizeleft<>vardef.size then
-                            internalerror(2014122806);
-                          if sizeleft<>tcgsize2size[destloc.size] then
-                            internalerror(200410105);
-                          { store everything first to memory, then load it in
-                            destloc }
-                          tg.gettemp(list,sizeleft,sizeleft,tt_persistent,tempref);
-                          gen_alloc_regloc(list,destloc,vardef);
-                          while sizeleft>0 do
-                            begin
-                              if not assigned(paraloc) then
-                                internalerror(2014122807);
-                              unget_para(paraloc^);
-                              cg.a_load_cgparaloc_ref(list,paraloc^,tempref,sizeleft,newalignment(para.alignment,para.intsize-sizeleft));
-                              if (paraloc^.size=OS_NO) and
-                                 assigned(paraloc^.next) then
-                                internalerror(2014122805);
-                              inc(tempref.offset,tcgsize2size[paraloc^.size]);
-                              dec(sizeleft,tcgsize2size[paraloc^.size]);
-                              paraloc:=paraloc^.next;
-                            end;
-                          dec(tempref.offset,para.intsize);
-                          cg.a_load_ref_reg(list,para.size,para.size,tempref,destloc.register);
-                          tg.ungettemp(list,tempref);
-                        end;
-                    end
-                  else
-                    begin
-                      unget_para(paraloc^);
-                      gen_alloc_regloc(list,destloc,vardef);
-                      { we can't directly move regular registers into fpu
-                        registers }
-                      if getregtype(paraloc^.register)=R_FPUREGISTER then
-                        begin
-                          { store everything first to memory, then load it in
-                            destloc }
-                          tg.gettemp(list,tcgsize2size[paraloc^.size],para.intsize,tt_persistent,tempref);
-                          cg.a_load_cgparaloc_ref(list,paraloc^,tempref,tcgsize2size[paraloc^.size],tempref.alignment);
-                          cg.a_load_ref_reg(list,int_cgsize(tcgsize2size[paraloc^.size]),destloc.size,tempref,destloc.register);
-                          tg.ungettemp(list,tempref);
-                        end
-                      else
-                        cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,sizeof(aint));
-                    end;
-                end;
-            end;
-          LOC_FPUREGISTER,
-          LOC_CFPUREGISTER :
-            begin
-{$ifdef mips}
-              if (destloc.size = paraloc^.Size) and
-                 (paraloc^.Loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER,LOC_REFERENCE,LOC_CREFERENCE]) then
-                begin
-                  unget_para(paraloc^);
-                  gen_alloc_regloc(list,destloc,vardef);
-                  cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,para.alignment);
-                end
-              else if (destloc.size = OS_F32) and
-                 (paraloc^.Loc in [LOC_REGISTER,LOC_CREGISTER]) then
-                begin
-                  gen_alloc_regloc(list,destloc,vardef);
-                  unget_para(paraloc^);
-                  list.Concat(taicpu.op_reg_reg(A_MTC1,paraloc^.register,destloc.register));
-                end
-{ TODO: Produces invalid code, needs fixing together with regalloc setup. }
-{
-              else if (destloc.size = OS_F64) and
-                      (paraloc^.Loc in [LOC_REGISTER,LOC_CREGISTER]) and
-                      (paraloc^.next^.Loc in [LOC_REGISTER,LOC_CREGISTER]) then
-                begin
-                  gen_alloc_regloc(list,destloc,vardef);
-
-                  tmpreg:=destloc.register;
-                  unget_para(paraloc^);
-                  list.Concat(taicpu.op_reg_reg(A_MTC1,paraloc^.register,tmpreg));
-                  setsupreg(tmpreg,getsupreg(tmpreg)+1);
-                  unget_para(paraloc^.next^);
-                  list.Concat(taicpu.op_reg_reg(A_MTC1,paraloc^.Next^.register,tmpreg));
-                end
-}
-              else
-                begin
-                  sizeleft := TCGSize2Size[destloc.size];
-                  tg.GetTemp(list,sizeleft,sizeleft,tt_normal,tempref);
-                  href:=tempref;
-                  while assigned(paraloc) do
-                    begin
-                      unget_para(paraloc^);
-                      cg.a_load_cgparaloc_ref(list,paraloc^,href,sizeleft,destloc.reference.alignment);
-                      inc(href.offset,TCGSize2Size[paraloc^.size]);
-                      dec(sizeleft,TCGSize2Size[paraloc^.size]);
-                      paraloc:=paraloc^.next;
-                    end;
-                  gen_alloc_regloc(list,destloc,vardef);
-                  cg.a_loadfpu_ref_reg(list,destloc.size,destloc.size,tempref,destloc.register);
-                  tg.UnGetTemp(list,tempref);
-                end;
-{$else mips}
-{$if defined(sparc) or defined(arm)}
-              { Arm and Sparc passes floats in int registers, when loading to fpu register
-                we need a temp }
-              sizeleft := TCGSize2Size[destloc.size];
-              tg.GetTemp(list,sizeleft,sizeleft,tt_normal,tempref);
-              href:=tempref;
-              while assigned(paraloc) do
-                begin
-                  unget_para(paraloc^);
-                  cg.a_load_cgparaloc_ref(list,paraloc^,href,sizeleft,destloc.reference.alignment);
-                  inc(href.offset,TCGSize2Size[paraloc^.size]);
-                  dec(sizeleft,TCGSize2Size[paraloc^.size]);
-                  paraloc:=paraloc^.next;
-                end;
-              gen_alloc_regloc(list,destloc,vardef);
-              cg.a_loadfpu_ref_reg(list,destloc.size,destloc.size,tempref,destloc.register);
-              tg.UnGetTemp(list,tempref);
-{$else defined(sparc) or defined(arm)}
-              unget_para(paraloc^);
-              gen_alloc_regloc(list,destloc,vardef);
-              { from register to register -> alignment is irrelevant }
-              cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,0);
-              if assigned(paraloc^.next) then
-                internalerror(200410109);
-{$endif defined(sparc) or defined(arm)}
-{$endif mips}
-            end;
-          LOC_MMREGISTER,
-          LOC_CMMREGISTER :
-            begin
-{$ifndef cpu64bitalu}
-              { ARM vfp floats are passed in integer registers }
-              if (para.size=OS_F64) and
-                 (paraloc^.size in [OS_32,OS_S32]) and
-                 use_vectorfpu(vardef) then
-                begin
-                  { we need 2x32bit reg }
-                  if not assigned(paraloc^.next) or
-                     assigned(paraloc^.next^.next) then
-                    internalerror(2009112421);
-                  unget_para(paraloc^.next^);
-                  case paraloc^.next^.loc of
-                    LOC_REGISTER:
-                      tempreg:=paraloc^.next^.register;
-                    LOC_REFERENCE:
-                      begin
-                        tempreg:=cg.getintregister(list,OS_32);
-                        cg.a_load_cgparaloc_anyreg(list,OS_32,paraloc^.next^,tempreg,4);
-                      end;
-                    else
-                      internalerror(2012051301);
-                  end;
-                  { don't free before the above, because then the getintregister
-                    could reallocate this register and overwrite it }
-                  unget_para(paraloc^);
-                  gen_alloc_regloc(list,destloc,vardef);
-                  if (target_info.endian=endian_big) then
-                    { paraloc^ -> high
-                      paraloc^.next -> low }
-                    reg64:=joinreg64(tempreg,paraloc^.register)
-                  else
-                    reg64:=joinreg64(paraloc^.register,tempreg);
-                  cg64.a_loadmm_intreg64_reg(list,OS_F64,reg64,destloc.register);
-                end
-              else
-{$endif not cpu64bitalu}
-                begin
-                  if not assigned(paraloc^.next) then
-                    begin
-                      unget_para(paraloc^);
-                      gen_alloc_regloc(list,destloc,vardef);
-                      { from register to register -> alignment is irrelevant }
-                      cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,0);
-                    end
-                  else
-                    begin
-                      internalerror(200410108);
-                    end;
-                  { data could come in two memory locations, for now
-                    we simply ignore the sanity check (FK)
-                  if assigned(paraloc^.next) then
-                    internalerror(200410108);
-                  }
-                end;
-            end;
-          else
-            internalerror(2010052903);
-        end;
-      end;
-
-
-    procedure gen_load_para_value(list:TAsmList);
-
-       procedure get_para(const paraloc:TCGParaLocation);
-         begin
-            case paraloc.loc of
-              LOC_REGISTER :
-                begin
-                  if getsupreg(paraloc.register)<first_int_imreg then
-                    cg.getcpuregister(list,paraloc.register);
-                end;
-              LOC_MMREGISTER :
-                begin
-                  if getsupreg(paraloc.register)<first_mm_imreg then
-                    cg.getcpuregister(list,paraloc.register);
-                end;
-              LOC_FPUREGISTER :
-                begin
-                  if getsupreg(paraloc.register)<first_fpu_imreg then
-                    cg.getcpuregister(list,paraloc.register);
-                end;
-            end;
-         end;
-
-
-      var
-        i : longint;
-        currpara : tparavarsym;
-        paraloc  : pcgparalocation;
-      begin
-        if (po_assembler in current_procinfo.procdef.procoptions) or
-        { exceptfilters have a single hidden 'parentfp' parameter, which
-          is handled by tcg.g_proc_entry. }
-           (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
-          exit;
-
-        { Allocate registers used by parameters }
-        for i:=0 to current_procinfo.procdef.paras.count-1 do
-          begin
-            currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
-            paraloc:=currpara.paraloc[calleeside].location;
-            while assigned(paraloc) do
-              begin
-                if paraloc^.loc in [LOC_REGISTER,LOC_FPUREGISTER,LOC_MMREGISTER] then
-                  get_para(paraloc^);
-                paraloc:=paraloc^.next;
-              end;
-          end;
-
-        { Copy parameters to local references/registers }
-        for i:=0 to current_procinfo.procdef.paras.count-1 do
-          begin
-            currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
-            { don't use currpara.vardef, as this will be wrong in case of
-              call-by-reference parameters (it won't contain the pointerdef) }
-            gen_load_cgpara_loc(list,currpara.paraloc[calleeside].def,currpara.paraloc[calleeside],currpara.initialloc,paramanager.param_use_paraloc(currpara.paraloc[calleeside]));
-            { gen_load_cgpara_loc() already allocated the initialloc
-              -> don't allocate again }
-            if currpara.initialloc.loc in [LOC_CREGISTER,LOC_CFPUREGISTER,LOC_CMMREGISTER] then
-              begin
-                gen_alloc_regvar(list,currpara,false);
-                hlcg.varsym_set_localloc(list,currpara);
-              end;
-          end;
-
-        { generate copies of call by value parameters, must be done before
-          the initialization and body is parsed because the refcounts are
-          incremented using the local copies }
-        current_procinfo.procdef.parast.SymList.ForEachCall(@hlcg.g_copyvalueparas,list);
-        if not(po_assembler in current_procinfo.procdef.procoptions) then
-          begin
-            { initialize refcounted paras, and trash others. Needed here
-              instead of in gen_initialize_code, because when a reference is
-              intialised or trashed while the pointer to that reference is kept
-              in a regvar, we add a register move and that one again has to
-              come after the parameter loading code as far as the register
-              allocator is concerned }
-            current_procinfo.procdef.parast.SymList.ForEachCall(@init_paras,list);
-          end;
-      end;
-
-
 {****************************************************************************
                                 Entry/Exit
 ****************************************************************************}

compiler/ninl.pas

@@ -90,9 +90,9 @@ interface
           function first_seg: tnode; virtual;
           function first_sar: tnode; virtual;
           function first_fma : tnode; virtual;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
           function first_ShiftRot_assign_64bitint: tnode; virtual;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
           function first_AndOrXorShiftRot_assign: tnode; virtual;
           function first_NegNot_assign: tnode; virtual;
           function first_cpu : tnode; virtual;
@@ -5235,7 +5235,7 @@ implementation
        end;
 
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
      function tinlinenode.first_ShiftRot_assign_64bitint: tnode;
        var
          procname: string[31];
@@ -5273,18 +5273,18 @@ implementation
          tcallparanode(left).left := nil;
          firstpass(result);
        end;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and nto cpuhighleveltarget}
 
 
      function tinlinenode.first_AndOrXorShiftRot_assign: tnode;
        begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          { 64 bit ints have their own shift handling }
          if is_64bit(tcallparanode(left).right.resultdef) and
             (inlinenumber in [in_sar_assign_x_y,in_shl_assign_x_y,in_shr_assign_x_y,in_rol_assign_x_y,in_ror_assign_x_y]) then
            result := first_ShiftRot_assign_64bitint
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
            begin
              result:=nil;
              expectloc:=tcallparanode(tcallparanode(left).right).left.expectloc;

compiler/nmat.pas

@@ -47,14 +47,14 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           function simplify(forinline : boolean) : tnode;override;
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
           { override the following if you want to implement }
           { parts explicitely in the code generator (CEC)
             Should return nil, if everything will be handled
             in the code generator
           }
           function first_shlshr64bitint: tnode; virtual;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
        end;
        tshlshrnodeclass = class of tshlshrnode;
 
@@ -183,15 +183,15 @@ implementation
         { not with an ifdef around the call to this routine, because e.g. the
           Java VM has a signed 64 bit division opcode, but not an unsigned
           one }
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu) or defined(cpuhighleveltarget)}
         result:=false;
-{$else cpu64bitalu}
+{$else cpu64bitalu or cpuhighleveltarget}
         result:=
           (left.resultdef.typ=orddef) and
           (right.resultdef.typ=orddef) and
           { include currency as well }
           (is_64bit(left.resultdef) or is_64bit(right.resultdef));
-{$endif cpu64bitaly}
+{$endif cpu64bitalu or cpuhighleveltarget}
       end;
 
 
@@ -503,14 +503,14 @@ implementation
         { divide/mod a number by a constant which is a power of 2? }
         if (right.nodetype = ordconstn) and
           isabspowerof2(tordconstnode(right).value,power) and
-{$ifdef cpu64bitalu}
+{$if defined(cpu64bitalu) or defined(cpuhighleveltarget)}
           { for 64 bit, we leave the optimization to the cg }
             (not is_signed(resultdef)) then
-{$else cpu64bitalu}
+{$else cpu64bitalu or cpuhighleveltarget}
            (((nodetype=divn) and is_oversizedord(resultdef)) or
             (nodetype=modn) or
             not is_signed(resultdef)) then
-{$endif cpu64bitalu}
+{$endif cpu64bitalu or cpuhighleveltarget}
           begin
             if nodetype=divn then
               begin
@@ -848,7 +848,7 @@ implementation
       end;
 
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
     function tshlshrnode.first_shlshr64bitint: tnode;
       var
         procname: string[31];
@@ -874,7 +874,7 @@ implementation
         right := nil;
         firstpass(result);
       end;
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
 
 
     function tshlshrnode.pass_1 : tnode;
@@ -887,7 +887,7 @@ implementation
          if codegenerror then
            exit;
 
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
          { 64 bit ints have their own shift handling }
          if is_64bit(left.resultdef) then
            begin
@@ -897,7 +897,7 @@ implementation
              regs:=2;
            end
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
            begin
              regs:=1
            end;
@@ -1354,14 +1354,14 @@ implementation
              expectloc:=LOC_MMXREGISTER
          else
 {$endif SUPPORT_MMX}
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
            if is_64bit(left.resultdef) then
              begin
                 if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
                   expectloc:=LOC_REGISTER;
              end
          else
-{$endif not cpu64bitalu}
+{$endif not cpu64bitalu and not cpuhighleveltarget}
            if is_integer(left.resultdef) then
              expectloc:=LOC_REGISTER;
       end;

compiler/options.pas

@@ -138,7 +138,7 @@ const
                         + [system_i386_wdosx]
                         + [system_riscv32_linux,system_riscv64_linux];
 
-  suppported_targets_x_smallr = systems_linux + systems_solaris
+  suppported_targets_x_smallr = systems_linux + systems_solaris + systems_android
                              + [system_i386_haiku,system_x86_64_haiku]
                              + [system_i386_beos]
                              + [system_m68k_amiga];
@@ -4023,8 +4023,10 @@ begin
       Message(option_w_unsupported_debug_format);
 
   { switch assembler if it's binary and we got -a on the cmdline }
-  if (cs_asm_leave in init_settings.globalswitches) and
-     (af_outputbinary in target_asm.flags) then
+  if ((cs_asm_leave in init_settings.globalswitches) and
+     (af_outputbinary in target_asm.flags)) or
+     { if -s is passed, we shouldn't call the internal assembler }
+     (cs_asm_extern in init_settings.globalswitches) then
    begin
      Message(option_switch_bin_to_src_assembler);
      set_target_asm(target_info.assemextern);

compiler/parabase.pas

@@ -269,7 +269,7 @@ implementation
         case location^.loc of
           LOC_REGISTER :
             begin
-{$ifndef cpu64bitalu}
+{$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
               if size in [OS_64,OS_S64] then
                 begin
                   if not assigned(location^.next) then

compiler/symdef.pas

@@ -5345,8 +5345,8 @@ implementation
             begin
               p:=tparavarsym(parast.SymList[i]);
               { check if no parameter is located on the stack }
-              if is_open_array(p.vardef) or
-                 is_array_of_const(p.vardef) then
+              if (is_open_array(p.vardef) or
+                 is_array_of_const(p.vardef)) and (p.varspez=vs_value) then
                 begin
                   result:=true;
                   exit;

compiler/systems/i_linux.pas

@@ -380,6 +380,9 @@ unit i_linux;
             name         : 'Linux for x86-64';
             shortname    : 'Linux';
             flags        : [tf_smartlink_sections,tf_needs_symbol_size,tf_needs_dwarf_cfi,
+{$ifdef tls_threadvars}
+                            tf_section_threadvars,
+{$endif tls_threadvars}
                             tf_library_needs_pic,tf_needs_symbol_type,tf_files_case_sensitive,
                             tf_has_winlike_resources,tf_safecall_exceptions,tf_safecall_clearstack
                             {$ifdef llvm},tf_use_psabieh{$endif}];

compiler/systems/t_morph.pas

@@ -69,7 +69,7 @@ begin
    begin
     if not UseVLink then
      begin
-      ExeCmd[1]:='ld $OPT -o $EXE $RES';
+      ExeCmd[1]:='ld $OPT $GCSECTIONS -o $EXE $RES';
       ExeCmd[2]:='strip --strip-unneeded --remove-section .comment $EXE';
      end
     else
@@ -223,6 +223,11 @@ begin
      StripStr:='-s -P __abox__';
     if create_smartlink_sections then
      GCSectionsStr:='-gc-all -sc -sd';
+   end
+  else
+   begin
+    if create_smartlink_sections then
+     GCSectionsStr:='--gc-sections -e _start';
    end;
 
 { Write used files and libraries }
@@ -242,6 +247,7 @@ begin
    begin
     Replace(cmdstr,'$EXE',maybequoted(ScriptFixFileName(current_module.exefilename)));
     Replace(cmdstr,'$RES',maybequoted(ScriptFixFileName(outputexedir+Info.ResName)));
+    Replace(cmdstr,'$GCSECTIONS',GCSectionsStr);
    end;
   success:=DoExec(FindUtil(utilsprefix+BinStr),cmdstr,true,false);
 

compiler/utils/fpc.pp

@@ -35,7 +35,11 @@ program fpc;
     {$ifdef NETWARE}
       exeext='.nlm';
     {$else}
-      exeext='.exe';
+      {$ifdef ATARI}
+        exeext='.ttp';
+      {$else}
+        exeext='.exe';
+      {$endif ATARI}
     {$endif NETWARE}
   {$endif HASAMIGA}
 {$endif UNIX}

compiler/x86/aasmcpu.pas

@@ -331,10 +331,14 @@ interface
         IF_SSSE3,
         IF_SSE41,
         IF_SSE42,
+        IF_MOVBE,
+        IF_CLMUL,
         IF_AVX,
         IF_AVX2,
         IF_BMI1,
         IF_BMI2,
+        { Intel ADX (Multi-Precision Add-Carry Instruction Extensions) }
+        IF_ADX,
         IF_16BITONLY,
         IF_FMA,
         IF_FMA4,

compiler/x86/agx86att.pas

@@ -185,6 +185,12 @@ interface
              addr_tlsgd:
                owner.writer.AsmWrite('@tlsgd');
 {$endif i386}
+{$ifdef x86_64}
+             addr_tpoff:
+               owner.writer.AsmWrite('@tpoff');
+             addr_tlsgd:
+               owner.writer.AsmWrite('@tlsgd');
+{$endif x86_64}
            end;
 
            if offset<0 then
@@ -231,7 +237,10 @@ interface
             else
               owner.writer.AsmWrite(gas_regname(o.reg));
           top_ref :
-            if o.ref^.refaddr in [addr_no,addr_pic,addr_pic_no_got{$ifdef i386},addr_ntpoff,addr_tlsgd{$endif i386}] then
+            if o.ref^.refaddr in [addr_no,addr_pic,addr_pic_no_got
+              {$ifdef i386},addr_ntpoff,addr_tlsgd{$endif i386}
+              {$ifdef x86_64},addr_tpoff,addr_tlsgd{$endif x86_64}
+              ] then
               WriteReference(o.ref^)
             else
               begin

compiler/x86/aoptx86.pas

@@ -71,6 +71,8 @@ unit aoptx86;
         function OptPass1Sub(var p : tai) : boolean;
         function OptPass1SHLSAL(var p : tai) : boolean;
         function OptPass1SETcc(var p: tai): boolean;
+        function OptPass1FSTP(var p: tai): boolean;
+        function OptPass1FLD(var p: tai): boolean;
 
         function OptPass2MOV(var p : tai) : boolean;
         function OptPass2Imul(var p : tai) : boolean;
@@ -948,6 +950,14 @@ unit aoptx86;
           GetNextInstruction(p,hp2) and
           MatchInstruction(hp2,A_RET,[S_NO])
          ) or
+         (((taicpu(p).opcode=A_LEA) and
+           MatchOpType(taicpu(p),top_ref,top_reg) and
+           (taicpu(p).oper[0]^.ref^.base=NR_STACK_POINTER_REG) and
+           (taicpu(p).oper[1]^.reg=NR_STACK_POINTER_REG)
+           ) and
+          GetNextInstruction(p,hp2) and
+          MatchInstruction(hp2,A_RET,[S_NO])
+         ) or
          ((((taicpu(p).opcode=A_MOV) and
            MatchOpType(taicpu(p),top_reg,top_reg) and
            (taicpu(p).oper[0]^.reg=current_procinfo.framepointer) and
@@ -1842,7 +1852,7 @@ unit aoptx86;
               end
             else if MatchOpType(taicpu(hp2),top_reg,top_reg) and
               not(SuperRegistersEqual(taicpu(hp1).oper[0]^.reg,taicpu(hp2).oper[1]^.reg)) and
-              (not((taicpu(hp1).opsize=S_Q) and (taicpu(hp2).opsize=S_L)) or
+              ((topsize2memsize[taicpu(hp1).opsize]<= topsize2memsize[taicpu(hp2).opsize]) or
                { opsize matters for these opcodes, we could probably work around this, but it is not worth the effort }
                ((taicpu(hp1).opcode<>A_SHL) and (taicpu(hp1).opcode<>A_SHR) and (taicpu(hp1).opcode<>A_SAR))
               )
@@ -1879,6 +1889,10 @@ unit aoptx86;
                           debug_op2str(taicpu(p).opcode)+debug_opsize2str(taicpu(p).opsize)+' '+
                           debug_op2str(taicpu(hp1).opcode)+debug_opsize2str(taicpu(hp1).opsize)+' '+
                           debug_op2str(taicpu(hp2).opcode)+debug_opsize2str(taicpu(hp2).opsize),p);
+                    { limit size of constants as well to avoid assembler errors, but
+                      check opsize to avoid overflow when left shifting the 1 }
+                    if (taicpu(p).oper[0]^.typ=top_const) and (topsize2memsize[taicpu(hp2).opsize]<=4) then
+                      taicpu(p).oper[0]^.val:=taicpu(p).oper[0]^.val and ((qword(1) shl (topsize2memsize[taicpu(hp2).opsize]*8))-1);
                     taicpu(hp1).changeopsize(taicpu(hp2).opsize);
                     taicpu(p).changeopsize(taicpu(hp2).opsize);
                     if taicpu(p).oper[0]^.typ=top_reg then
@@ -2444,7 +2458,161 @@ unit aoptx86;
       end;
 
 
-    function TX86AsmOptimizer.OptPass2MOV(var p : tai) : boolean;
+    function TX86AsmOptimizer.OptPass1FSTP(var p: tai): boolean;
+      { returns true if a "continue" should be done after this optimization }
+      var
+        hp1, hp2: tai;
+      begin
+        Result := false;
+        if MatchOpType(taicpu(p),top_ref) and
+           GetNextInstruction(p, hp1) and
+           (hp1.typ = ait_instruction) and
+           (((taicpu(hp1).opcode = A_FLD) and
+             (taicpu(p).opcode = A_FSTP)) or
+            ((taicpu(p).opcode = A_FISTP) and
+             (taicpu(hp1).opcode = A_FILD))) and
+           MatchOpType(taicpu(hp1),top_ref) and
+           (taicpu(hp1).opsize = taicpu(p).opsize) and
+           RefsEqual(taicpu(p).oper[0]^.ref^, taicpu(hp1).oper[0]^.ref^) then
+          begin
+            { replacing fstp f;fld f by fst f is only valid for extended because of rounding }
+            if (taicpu(p).opsize=S_FX) and
+               GetNextInstruction(hp1, hp2) and
+               (hp2.typ = ait_instruction) and
+               IsExitCode(hp2) and
+               (taicpu(p).oper[0]^.ref^.base = current_procinfo.FramePointer) and
+               not(assigned(current_procinfo.procdef.funcretsym) and
+                   (taicpu(p).oper[0]^.ref^.offset < tabstractnormalvarsym(current_procinfo.procdef.funcretsym).localloc.reference.offset)) and
+               (taicpu(p).oper[0]^.ref^.index = NR_NO) then
+              begin
+                asml.remove(p);
+                asml.remove(hp1);
+                p.free;
+                hp1.free;
+                p := hp2;
+                RemoveLastDeallocForFuncRes(p);
+                Result := true;
+              end
+            (* can't be done because the store operation rounds
+            else
+              { fst can't store an extended value! }
+              if (taicpu(p).opsize <> S_FX) and
+                 (taicpu(p).opsize <> S_IQ) then
+                begin
+                  if (taicpu(p).opcode = A_FSTP) then
+                    taicpu(p).opcode := A_FST
+                  else taicpu(p).opcode := A_FIST;
+                  asml.remove(hp1);
+                  hp1.free;
+                end
+            *)
+          end;
+      end;
+
+
+     function TX86AsmOptimizer.OptPass1FLD(var p : tai) : boolean;
+      var
+       hp1, hp2: tai;
+      begin
+        result:=false;
+        if MatchOpType(taicpu(p),top_reg) and
+           GetNextInstruction(p, hp1) and
+           (hp1.typ = Ait_Instruction) and
+           MatchOpType(taicpu(hp1),top_reg,top_reg) and
+           (taicpu(hp1).oper[0]^.reg = NR_ST) and
+           (taicpu(hp1).oper[1]^.reg = NR_ST1) then
+           { change                        to
+               fld      reg               fxxx reg,st
+               fxxxp    st, st1 (hp1)
+             Remark: non commutative operations must be reversed!
+           }
+          begin
+              case taicpu(hp1).opcode Of
+                A_FMULP,A_FADDP,
+                A_FSUBP,A_FDIVP,A_FSUBRP,A_FDIVRP:
+                  begin
+                    case taicpu(hp1).opcode Of
+                      A_FADDP: taicpu(hp1).opcode := A_FADD;
+                      A_FMULP: taicpu(hp1).opcode := A_FMUL;
+                      A_FSUBP: taicpu(hp1).opcode := A_FSUBR;
+                      A_FSUBRP: taicpu(hp1).opcode := A_FSUB;
+                      A_FDIVP: taicpu(hp1).opcode := A_FDIVR;
+                      A_FDIVRP: taicpu(hp1).opcode := A_FDIV;
+                    end;
+                    taicpu(hp1).oper[0]^.reg := taicpu(p).oper[0]^.reg;
+                    taicpu(hp1).oper[1]^.reg := NR_ST;
+                    asml.remove(p);
+                    p.free;
+                    p := hp1;
+                    Result:=true;
+                    exit;
+                  end;
+              end;
+          end
+        else
+          if MatchOpType(taicpu(p),top_ref) and
+             GetNextInstruction(p, hp2) and
+             (hp2.typ = Ait_Instruction) and
+             MatchOpType(taicpu(hp2),top_reg,top_reg) and
+             (taicpu(p).opsize in [S_FS, S_FL]) and
+             (taicpu(hp2).oper[0]^.reg = NR_ST) and
+             (taicpu(hp2).oper[1]^.reg = NR_ST1) then
+            if GetLastInstruction(p, hp1) and
+              MatchInstruction(hp1,A_FLD,A_FST,[taicpu(p).opsize]) and
+              MatchOpType(taicpu(hp1),top_ref) and
+              RefsEqual(taicpu(p).oper[0]^.ref^, taicpu(hp1).oper[0]^.ref^) then
+              if ((taicpu(hp2).opcode = A_FMULP) or
+                  (taicpu(hp2).opcode = A_FADDP)) then
+              { change                      to
+                  fld/fst   mem1  (hp1)       fld/fst   mem1
+                  fld       mem1  (p)         fadd/
+                  faddp/                       fmul     st, st
+                  fmulp  st, st1 (hp2) }
+                begin
+                  asml.remove(p);
+                  p.free;
+                  p := hp1;
+                  if (taicpu(hp2).opcode = A_FADDP) then
+                    taicpu(hp2).opcode := A_FADD
+                  else
+                    taicpu(hp2).opcode := A_FMUL;
+                  taicpu(hp2).oper[1]^.reg := NR_ST;
+                end
+              else
+              { change              to
+                  fld/fst mem1 (hp1)   fld/fst mem1
+                  fld     mem1 (p)     fld      st}
+                begin
+                  taicpu(p).changeopsize(S_FL);
+                  taicpu(p).loadreg(0,NR_ST);
+                end
+            else
+              begin
+                case taicpu(hp2).opcode Of
+                  A_FMULP,A_FADDP,A_FSUBP,A_FDIVP,A_FSUBRP,A_FDIVRP:
+            { change                        to
+                fld/fst  mem1    (hp1)      fld/fst    mem1
+                fld      mem2    (p)        fxxx       mem2
+                fxxxp    st, st1 (hp2)                      }
+
+                    begin
+                      case taicpu(hp2).opcode Of
+                        A_FADDP: taicpu(p).opcode := A_FADD;
+                        A_FMULP: taicpu(p).opcode := A_FMUL;
+                        A_FSUBP: taicpu(p).opcode := A_FSUBR;
+                        A_FSUBRP: taicpu(p).opcode := A_FSUB;
+                        A_FDIVP: taicpu(p).opcode := A_FDIVR;
+                        A_FDIVRP: taicpu(p).opcode := A_FDIV;
+                      end;
+                      asml.remove(hp2);
+                      hp2.free;
+                    end
+                end
+              end
+      end;
+
+
+   function TX86AsmOptimizer.OptPass2MOV(var p : tai) : boolean;
       var
        hp1,hp2: tai;
 {$ifdef x86_64}

compiler/x86/cgx86.pas

@@ -1140,6 +1140,38 @@ unit cgx86;
                 end;
               end;
 {$endif i386}
+{$ifdef x86_64}
+            if refaddr=addr_tpoff then
+              begin
+                { Convert thread local address to a process global addres
+                  as we cannot handle far pointers.}
+                case target_info.system of
+                  system_x86_64_linux:
+                    if segment=NR_FS then
+                      begin
+                        reference_reset(tmpref,1,[]);
+                        tmpref.segment:=NR_FS;
+                        tmpreg:=getaddressregister(list);
+                        a_load_ref_reg(list,OS_ADDR,OS_ADDR,tmpref,tmpreg);
+                        reference_reset(tmpref,1,[]);
+                        tmpref.symbol:=symbol;
+                        tmpref.refaddr:=refaddr;
+                        tmpref.base:=tmpreg;
+                        if base<>NR_NO then
+                          tmpref.index:=base;
+                        list.concat(Taicpu.op_ref_reg(A_LEA,tcgsize2opsize[OS_ADDR],tmpref,tmpreg));
+                        segment:=NR_NO;
+                        base:=tmpreg;
+                        symbol:=nil;
+                        refaddr:=addr_no;
+                      end
+                    else
+                      Internalerror(2019012003);
+                  else
+                    Internalerror(2019012004);
+                end;
+              end;
+{$endif x86_64}
             if (base=NR_NO) and (index=NR_NO) then
               begin
                 if assigned(dirref.symbol) then
@@ -2814,6 +2846,24 @@ unit cgx86;
            dstref.base:=r;
          end;
 {$endif i386}
+{$ifdef x86_64}
+      { we could handle "far" pointers here, but reloading es/ds is probably much slower
+        than just resolving the tls segment }
+      if (srcref.refaddr=addr_tpoff) and (srcref.segment=NR_FS) then
+        begin
+          r:=getaddressregister(list);
+          a_loadaddr_ref_reg(list,srcref,r);
+          reference_reset(srcref,srcref.alignment,srcref.volatility);
+          srcref.base:=r;
+        end;
+       if (dstref.refaddr=addr_tpoff) and (dstref.segment=NR_FS) then
+         begin
+           r:=getaddressregister(list);
+           a_loadaddr_ref_reg(list,dstref,r);
+           reference_reset(dstref,dstref.alignment,dstref.volatility);
+           dstref.base:=r;
+         end;
+{$endif x86_64}
       cm:=copy_move;
       helpsize:=3*sizeof(aword);
       if cs_opt_size in current_settings.optimizerswitches then

compiler/x86/nx86ld.pas

@@ -121,6 +121,45 @@ implementation
                 end;
             end;
 {$endif i386}
+{$ifdef x86_64}
+            case target_info.system of
+              system_x86_64_linux:
+                begin
+                  case current_settings.tlsmodel of
+                    tlsm_local:
+                      begin
+                        location.reference.segment:=NR_FS;
+                        location.reference.refaddr:=addr_tpoff;
+                      end;
+                    tlsm_general:
+                      begin
+                        if not(cs_create_pic in current_settings.moduleswitches) then
+                          Internalerror(2019012001);
+
+                        current_asmdata.CurrAsmList.concat(tai_const.Create_8bit($66));
+                        reference_reset(href,0,[]);
+                        location.reference.base:=NR_RIP;
+                        location.reference.scalefactor:=1;
+                        location.reference.refaddr:=addr_tlsgd;
+                        cg.getcpuregister(current_asmdata.CurrAsmList,NR_RDI);
+                        current_asmdata.CurrAsmList.concat(taicpu.op_ref_reg(A_LEA,S_Q,location.reference,NR_RDI));
+                        current_asmdata.CurrAsmList.concat(tai_const.Create_8bit($66));
+                        current_asmdata.CurrAsmList.concat(tai_const.Create_8bit($66));
+                        current_asmdata.CurrAsmList.concat(tai_const.Create_8bit($48));
+                        cg.g_call(current_asmdata.CurrAsmList,'__tls_get_addr');
+                        cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_RDI);
+                        cg.ungetcpuregister(current_asmdata.CurrAsmList,NR_EAX);
+                        hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
+                        cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,NR_RAX,hregister);
+                        reference_reset(location.reference,location.reference.alignment,location.reference.volatility);
+                        location.reference.base:=hregister;
+                      end;
+                    else
+                      Internalerror(2019012002);
+                  end;
+                end;
+            end;
+{$endif x86_64}
           end;
       end;
 

compiler/x86/x86ins.dat

@@ -3582,6 +3582,21 @@ void                   \326\1\xAD                                    X86_64
 (Ch_RWRSI, Ch_RMemEDI, Ch_RWRDI, Ch_RDirFlag, Ch_WOverflowFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WAuxiliaryFlag, Ch_WCarryFlag, Ch_WParityFlag)
 void                   \326\1\xA7                                    X86_64
 
+[MOVBE,movbeX]
+(Ch_Rop1, Ch_Wop2)
+reg16|32|64,mem16|32|64              \320\3\xf\x38\xf0\110           MOVBE,SM
+mem16|32|64,reg16|32|64              \321\3\xf\x38\xf1\101           MOVBE,SM
+
+
+;*******************************************************************************
+;********* CLMUL ***************************************************************
+;*******************************************************************************
+
+[PCLMULQDQ]
+(Ch_All)
+xmmreg,xmmrm,imm8                    \361\3\xf\x3A\x44\110\26        CLMUL,SANDYBRIDGE
+
+
 ;*******************************************************************************
 ;****** AVX I ******************************************************************
 ;*******************************************************************************
@@ -5285,6 +5300,21 @@ reg64,reg64,rm64                      \362\363\371\1\xf2\75\120           BMI1,P
 reg32,rm32,reg32                      \362\371\1\xf7\76\110               BMI1,PROT
 reg64,rm64,reg64                      \362\363\371\1\xf7\76\110           BMI1,PROT,X86_64
 
+[BLSI]
+(Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag)
+reg32,rm32                            \362\371\1\xf3\74\213               BMI1,PROT
+reg64,rm64                            \362\363\371\1\xf3\74\213           BMI1,PROT,X86_64
+
+[BLSMSK]
+(Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_W0ZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag)
+reg32,rm32                            \362\371\1\xf3\74\212               BMI1,PROT
+reg64,rm64                            \362\363\371\1\xf3\74\212           BMI1,PROT,X86_64
+
+[BLSR]
+(Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag)
+reg32,rm32                            \362\371\1\xf3\74\211               BMI1,PROT
+reg64,rm64                            \362\363\371\1\xf3\74\211           BMI1,PROT,X86_64
+
 [TZCNT]
 (Ch_Wop2, Ch_WFlags, Ch_Rop1)
 reg16|32|64,regmem                    \320\333\2\x0F\xBC\110              BMI1,SM
@@ -5333,6 +5363,19 @@ reg64,rm64,reg64                      \361\362\363\371\1\xf7\76\110       BMI2,P
 reg32,rm32,reg32                      \334\362\371\1\xf7\76\110           BMI2,PROT
 reg64,rm64,reg64                      \334\362\363\371\1\xf7\76\110       BMI2,PROT,X86_64
 
+;*******************************************************************************
+;********** ADX ****************************************************************
+;*******************************************************************************
+
+[ADCX,adcxX]
+(Ch_Rop1, Ch_Mop2, Ch_RWCarryFlag)
+reg32,rm32                            \361\3\xf\x38\xf6\110               ADX
+reg64,rm64                            \361\326\3\xf\x38\xf6\110           ADX,X86_64
+
+[ADOX,adoxX]
+(Ch_Rop1, Ch_Mop2, Ch_RWOverflowFlag)
+reg32,rm32                            \333\3\xf\x38\xf6\110               ADX
+reg64,rm64                            \333\326\3\xf\x38\xf6\110           ADX,X86_64
 
 ;*******************************************************************************
 ;********** AVX2 ***************************************************************

compiler/x86_64/aoptcpu.pas

@@ -118,6 +118,10 @@ uses
                 result:=OptPass1SHLSAL(p);
               A_SETcc:
                 result:=OptPass1SETcc(p);
+              A_FSTP,A_FISTP:
+                result:=OptPass1FSTP(p);
+              A_FLD:
+                result:=OptPass1FLD(p);
             end;
           end;
         end;

compiler/x86_64/cpunode.pas

@@ -53,6 +53,7 @@ unit cpunode;
        nx86con,
        nx86mem,
        nx64add,
+       nx86ld,
        nx64cal,
        nx64cnv,
        nx64mat,

compiler/x86_64/x8664ats.inc

@@ -680,6 +680,8 @@ attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
+attsufINT,
+attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
@@ -1017,6 +1019,11 @@ attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
+attsufINT,
+attsufINT,
+attsufNONE,
+attsufNONE,
+attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,

compiler/x86_64/x8664att.inc

@@ -680,6 +680,8 @@
 'stosq',
 'lodsq',
 'cmpsq',
+'movbe',
+'pclmulqdq',
 'vaddpd',
 'vaddps',
 'vaddsd',
@@ -1005,6 +1007,9 @@
 'vzeroupper',
 'andn',
 'bextr',
+'blsi',
+'blsmsk',
+'blsr',
 'tzcnt',
 'bzhi',
 'mulx',
@@ -1014,6 +1019,8 @@
 'sarx',
 'shlx',
 'shrx',
+'adcx',
+'adox',
 'vbroadcasti128',
 'vextracti128',
 'vinserti128',

compiler/x86_64/x8664int.inc

@@ -680,6 +680,8 @@
 'stosq',
 'lodsq',
 'cmpsq',
+'movbe',
+'pclmulqdq',
 'vaddpd',
 'vaddps',
 'vaddsd',
@@ -1005,6 +1007,9 @@
 'vzeroupper',
 'andn',
 'bextr',
+'blsi',
+'blsmsk',
+'blsr',
 'tzcnt',
 'bzhi',
 'mulx',
@@ -1014,6 +1019,8 @@
 'sarx',
 'shlx',
 'shrx',
+'adcx',
+'adox',
 'vbroadcasti128',
 'vextracti128',
 'vinserti128',

compiler/x86_64/x8664nop.inc

@@ -1,2 +1,2 @@
 { don't edit, this file is generated from x86ins.dat }
-2178;
+2191;

compiler/x86_64/x8664op.inc

@@ -680,6 +680,8 @@ A_RDTSCP,
 A_STOSQ,
 A_LODSQ,
 A_CMPSQ,
+A_MOVBE,
+A_PCLMULQDQ,
 A_VADDPD,
 A_VADDPS,
 A_VADDSD,
@@ -1005,6 +1007,9 @@ A_VZEROALL,
 A_VZEROUPPER,
 A_ANDN,
 A_BEXTR,
+A_BLSI,
+A_BLSMSK,
+A_BLSR,
 A_TZCNT,
 A_BZHI,
 A_MULX,
@@ -1014,6 +1019,8 @@ A_RORX,
 A_SARX,
 A_SHLX,
 A_SHRX,
+A_ADCX,
+A_ADOX,
 A_VBROADCASTI128,
 A_VEXTRACTI128,
 A_VINSERTI128,

compiler/x86_64/x8664pro.inc

@@ -680,6 +680,8 @@
 (Ch: [Ch_RRAX, Ch_WMemEDI, Ch_RWRDI, Ch_RDirFlag]),
 (Ch: [Ch_WRAX, Ch_RWRSI, Ch_RDirFlag]),
 (Ch: [Ch_RWRSI, Ch_RMemEDI, Ch_RWRDI, Ch_RDirFlag, Ch_WOverflowFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WAuxiliaryFlag, Ch_WCarryFlag, Ch_WParityFlag]),
+(Ch: [Ch_Rop1, Ch_Wop2]),
+(Ch: [Ch_All]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
 (Ch: [Ch_Wop3, Ch_Rop2, Ch_Rop1]),
@@ -1005,6 +1007,9 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_W0ZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
+(Ch: [Ch_Rop1, Ch_Wop2, Ch_W0OverflowFlag, Ch_WCarryFlag, Ch_WSignFlag, Ch_WZeroFlag, Ch_WUParityFlag, Ch_WUAuxiliaryFlag]),
 (Ch: [Ch_Wop2, Ch_WFlags, Ch_Rop1]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_REDX, Ch_Rop1, Ch_Wop2, Ch_Wop3]),
@@ -1014,6 +1019,8 @@
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
 (Ch: [Ch_Rop1, Ch_Rop2, Ch_Wop3]),
+(Ch: [Ch_Rop1, Ch_Mop2, Ch_RWCarryFlag]),
+(Ch: [Ch_Rop1, Ch_Mop2, Ch_RWOverflowFlag]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),

compiler/x86_64/x8664tab.inc

@@ -9009,6 +9009,27 @@
     code    : #214#1#167;
     flags   : [if_x86_64]
   ),
+  (
+    opcode  : A_MOVBE;
+    ops     : 2;
+    optypes : (ot_reg16 or ot_bits32 or ot_bits64,ot_memory or ot_bits16 or ot_bits32 or ot_bits64,ot_none,ot_none);
+    code    : #208#3#15#56#240#72;
+    flags   : [if_movbe,if_sm]
+  ),
+  (
+    opcode  : A_MOVBE;
+    ops     : 2;
+    optypes : (ot_memory or ot_bits16 or ot_bits32 or ot_bits64,ot_reg16 or ot_bits32 or ot_bits64,ot_none,ot_none);
+    code    : #209#3#15#56#241#65;
+    flags   : [if_movbe,if_sm]
+  ),
+  (
+    opcode  : A_PCLMULQDQ;
+    ops     : 3;
+    optypes : (ot_xmmreg,ot_xmmrm,ot_immediate or ot_bits8,ot_none);
+    code    : #241#3#15#58#68#72#22;
+    flags   : [if_clmul,if_sandybridge]
+  ),
   (
     opcode  : A_VADDPD;
     ops     : 3;
@@ -13951,6 +13972,48 @@
     code    : #242#243#249#1#247#62#72;
     flags   : [if_bmi1,if_prot,if_x86_64]
   ),
+  (
+    opcode  : A_BLSI;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#139;
+    flags   : [if_bmi1,if_prot]
+  ),
+  (
+    opcode  : A_BLSI;
+    ops     : 2;
+    optypes : (ot_reg64,ot_rm_gpr or ot_bits64,ot_none,ot_none);
+    code    : #242#243#249#1#243#60#139;
+    flags   : [if_bmi1,if_prot,if_x86_64]
+  ),
+  (
+    opcode  : A_BLSMSK;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#138;
+    flags   : [if_bmi1,if_prot]
+  ),
+  (
+    opcode  : A_BLSMSK;
+    ops     : 2;
+    optypes : (ot_reg64,ot_rm_gpr or ot_bits64,ot_none,ot_none);
+    code    : #242#243#249#1#243#60#138;
+    flags   : [if_bmi1,if_prot,if_x86_64]
+  ),
+  (
+    opcode  : A_BLSR;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #242#249#1#243#60#137;
+    flags   : [if_bmi1,if_prot]
+  ),
+  (
+    opcode  : A_BLSR;
+    ops     : 2;
+    optypes : (ot_reg64,ot_rm_gpr or ot_bits64,ot_none,ot_none);
+    code    : #242#243#249#1#243#60#137;
+    flags   : [if_bmi1,if_prot,if_x86_64]
+  ),
   (
     opcode  : A_TZCNT;
     ops     : 2;
@@ -14070,6 +14133,34 @@
     code    : #220#242#243#249#1#247#62#72;
     flags   : [if_bmi2,if_prot,if_x86_64]
   ),
+  (
+    opcode  : A_ADCX;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #241#3#15#56#246#72;
+    flags   : [if_adx]
+  ),
+  (
+    opcode  : A_ADCX;
+    ops     : 2;
+    optypes : (ot_reg64,ot_rm_gpr or ot_bits64,ot_none,ot_none);
+    code    : #241#214#3#15#56#246#72;
+    flags   : [if_adx,if_x86_64]
+  ),
+  (
+    opcode  : A_ADOX;
+    ops     : 2;
+    optypes : (ot_reg32,ot_rm_gpr or ot_bits32,ot_none,ot_none);
+    code    : #219#3#15#56#246#72;
+    flags   : [if_adx]
+  ),
+  (
+    opcode  : A_ADOX;
+    ops     : 2;
+    optypes : (ot_reg64,ot_rm_gpr or ot_bits64,ot_none,ot_none);
+    code    : #219#214#3#15#56#246#72;
+    flags   : [if_adx,if_x86_64]
+  ),
   (
     opcode  : A_VBROADCASTI128;
     ops     : 2;

packages/fcl-base/src/uriparser.pp

@@ -40,11 +40,11 @@ function EncodeURI(const URI: TURI): String;
 function ParseURI(const URI: String; Decode : Boolean = True):  TURI; overload;
 function ParseURI(const URI, DefaultProtocol: String; DefaultPort: Word; Decode : Boolean = True):  TURI; overload;
 
-function ResolveRelativeURI(const BaseUri, RelUri: WideString;
-  out ResultUri: WideString): Boolean; overload;
-
-function ResolveRelativeURI(const BaseUri, RelUri: AnsiString;
-  out ResultUri: AnsiString): Boolean; overload;
+function ResolveRelativeURI(const BaseUri, RelUri: UnicodeString;out ResultUri: UnicodeString): Boolean; overload;
+{$ifdef WINDOWS}  
+function ResolveRelativeURI(const BaseUri, RelUri: WideString; out ResultUri: WideString): Boolean; overload;
+{$ENDIF}
+function ResolveRelativeURI(const BaseUri, RelUri: AnsiString;  out ResultUri: AnsiString): Boolean; overload;
 
 function URIToFilename(const URI: string; out Filename: string): Boolean;
 function FilenameToURI(const Filename: string; Encode : Boolean = True): string;
@@ -335,8 +335,7 @@ begin
   end;
 end;
 
-function ResolveRelativeURI(const BaseUri, RelUri: AnsiString;
-  out ResultUri: AnsiString): Boolean;
+function ResolveRelativeURI(const BaseUri, RelUri: AnsiString; out ResultUri: AnsiString): Boolean;
 var
   Base, Rel: TUri;
 begin
@@ -384,8 +383,21 @@ begin
   ResultUri := EncodeUri(Rel);
 end;
 
-function ResolveRelativeURI(const BaseUri, RelUri: WideString;
-  out ResultUri: WideString): Boolean;
+{$IFDEF WINDOWS}
+function ResolveRelativeURI(const BaseUri, RelUri: WideString; out ResultUri: WideString): Boolean;
+
+Var
+  Res : AnsiString;
+
+begin
+  Result := ResolveRelativeURI(UTF8Encode(BaseUri), UTF8Encode(RelUri), Res);
+  if Result then
+    ResultURI := UTF8Decode(res);
+end;
+{$ENDIF}
+
+function ResolveRelativeURI(const BaseUri, RelUri: UnicodeString;
+  out ResultUri: UnicodeString): Boolean;
 var
   rslt: AnsiString;
 begin

packages/fcl-image/src/fpreadgif.pas

@@ -211,7 +211,10 @@ begin
     // skip extensions
     Repeat
       Introducer:=SkipBlock(Stream);
-    until (Introducer = $2C) or (Introducer = $3B);
+    until (Introducer = $2C) or (Introducer = $3B) or (Stream.Position>=Stream.Size);
+    
+    if Stream.Position>=Stream.Size then 
+      Exit;
 
     // descriptor
     Stream.Read(FDescriptor, SizeOf(FDescriptor));
@@ -298,7 +301,10 @@ begin
         Stream.Seek(B, soFromCurrent);
         CodeMask := (1 shl CodeSize) - 1;
       end;
-    until B = 0;
+    until (B = 0)  or (Stream.Position>=Stream.Size);
+    
+    if Stream.Position>=Stream.Size then 
+      Exit(False);
 
     Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
              False, Rect(0,0,0,0), '', ContProgress);
@@ -315,7 +321,11 @@ begin
          Stream.ReadBuffer(SourcePtr^, B);
          Inc(SourcePtr,B);
       end;
-    until B = 0;
+    until (B = 0) or (Stream.Position>=Stream.Size);
+    
+    if Stream.Position>=Stream.Size then
+       Exit(False);
+              
 
     Progress(psRunning, trunc(100.0 * (Stream.position / Stream.size)),
              False, Rect(0,0,0,0), '', ContProgress);

packages/fcl-js/src/jswriter.pp

@@ -247,6 +247,7 @@ Type
 {$ifdef FPC_HAS_CPSTRING}
 Function UTF16ToUTF8(const S: UnicodeString): string;
 {$endif}
+Function QuoteJSString(const S: TJSString; Quote: TJSChar = #0): TJSString;
 
 implementation
 
@@ -273,6 +274,35 @@ begin
 end;
 {$endif}
 
+function QuoteJSString(const S: TJSString; Quote: TJSChar): TJSString;
+var
+  i, j, Count: Integer;
+begin
+  if Quote=#0 then
+    begin
+    if Pos('"',S)>0 then
+      Quote:=''''
+    else
+      Quote:='"';
+    end;
+  Result := '' + Quote;
+  Count := length(S);
+  i := 0;
+  j := 0;
+  while i < Count do
+    begin
+    inc(i);
+    if S[i] = Quote then
+      begin
+      Result := Result + copy(S, 1 + j, i - j) + Quote;
+      j := i;
+      end;
+    end;
+  if i <> j then
+    Result := Result + copy(S, 1 + j, i - j);
+  Result := Result + Quote;
+end;
+
 { TBufferWriter }
 
 function TBufferWriter.GetBufferLength: Integer;
@@ -651,7 +681,7 @@ Var
   p, StartP: Integer;
   MinIndent, CurLineIndent, j, Exp, Code: Integer;
   i: SizeInt;
-  D: TJSNumber;
+  D, AsNumber: TJSNumber;
 begin
   if V.CustomValue<>'' then
     begin
@@ -706,15 +736,17 @@ begin
       exit;
       end;
     jstNumber :
-      if (Frac(V.AsNumber)=0)
-          and (V.AsNumber>=double(MinSafeIntDouble))
-          and (V.AsNumber<=double(MaxSafeIntDouble)) then
+      begin
+      AsNumber:=V.AsNumber;
+      if (Frac(AsNumber)=0)
+          and (AsNumber>=double(MinSafeIntDouble))
+          and (AsNumber<=double(MaxSafeIntDouble)) then
         begin
-        Str(Round(V.AsNumber),S);
+        Str(Round(AsNumber),S);
         end
       else
         begin
-        Str(V.AsNumber,S);
+        Str(AsNumber,S);
         if S[1]=' ' then Delete(S,1,1);
         i:=Pos('E',S);
         if (i>2) then
@@ -728,7 +760,7 @@ begin
             if s[j]='.' then inc(j);
             S2:=LeftStr(S,j)+copy(S,i,length(S));
             val(S2,D,Code);
-            if (Code=0) and (D=V.AsNumber) then
+            if (Code=0) and (D=AsNumber) then
               S:=S2;
             end;
           '9':
@@ -766,7 +798,7 @@ begin
                 end;
             until false;
             val(S2,D,Code);
-            if (Code=0) and (D=V.AsNumber) then
+            if (Code=0) and (D=AsNumber) then
               S:=S2;
             end;
           end;
@@ -783,6 +815,7 @@ begin
               Delete(S,i,length(S))
             else if (Exp>=-6) and (Exp<=6) then
               begin
+              // small exponent -> use notation without E
               Delete(S,i,length(S));
               j:=Pos('.',S);
               if j>0 then
@@ -826,12 +859,16 @@ begin
               end
             else
               begin
-              // e.g. 1.0E+001  -> 1.0E1
+              // e.g. 1.1E+0010  -> 1.1E10
               S:=LeftStr(S,i)+IntToStr(Exp);
+              if (i >= 4) and (s[i-1] = '0') and (s[i-2] = '.') then
+                // e.g. 1.0E22 -> 1E22
+                Delete(S, i-2, 2);
               end
             end;
           end;
         end;
+      end;
     jstObject : ;
     jstReference : ;
     jstCompletion : ;
@@ -1023,14 +1060,11 @@ end;
 
 
 procedure TJSWriter.WriteObjectLiteral(El: TJSObjectLiteral);
-
-
 Var
   i,C : Integer;
   QE,WC : Boolean;
   S : TJSString;
   Prop: TJSObjectLiteralElement;
-
 begin
   C:=El.Elements.Count-1;
   QE:=(woQuoteElementNames in Options);
@@ -1053,7 +1087,14 @@ begin
    Writer.CurElement:=Prop.Expr;
    S:=Prop.Name;
    if QE or not IsValidJSIdentifier(S) then
-     S:='"'+S+'"';
+     begin
+     if (length(S)>1)
+         and (((S[1]='"') and (S[length(S)]='"'))
+           or ((S[1]='''') and (S[length(S)]=''''))) then
+       // already quoted
+     else
+       S:=QuoteJSString(s);
+     end;
    Write(S+': ');
    Indent;
    FSkipRoundBrackets:=true;

packages/fcl-passrc/src/pasresolveeval.pas

@@ -25,7 +25,7 @@ Works:
 - int/uint
   - unary +, -
   - binary: +, -, *, div, mod, ^^, =, <>, <, >, <=, >=, and, or, xor, not, shl, shr
-  - low(), high(), pred(), succ(), ord()
+  - Low(), High(), Pred(), Succ(), Ord(), Lo(), Hi()
   - typecast longint(-1), word(-2), intsingle(-1), uintsingle(1)
 - float:
   - typecast single(double), double(single), float(integer)
@@ -119,7 +119,7 @@ const
   nWrongNumberOfParametersForArray = 3042;
   nCantAssignValuesToAnAddress = 3043;
   nIllegalExpression = 3044;
-  nCantAccessPrivateMember = 3045;
+  nCantAccessXMember = 3045;
   nMustBeInsideALoop = 3046;
   nExpectXArrayElementsButFoundY = 3047;
   nCannotCreateADescendantOfTheSealedXY = 3048;
@@ -178,6 +178,9 @@ const
   nFunctionHidesIdentifier_NonProc = 3112;
   nTypeXCannotBeExtendedByATypeHelper = 3113;
   nDerivedXMustExtendASubClassY = 3114;
+  nDefaultPropertyNotAllowedInHelperForX = 3115;
+  nHelpersCannotBeUsedAsTypes = 3116;
+  nBitWiseOperationsAre32Bit = 3117;
 
   // using same IDs as FPC
   nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@@ -236,7 +239,7 @@ resourcestring
   sWrongNumberOfParametersForArray = 'Wrong number of parameters for array';
   sCantAssignValuesToAnAddress = 'Can''t assign values to an address';
   sIllegalExpression = 'Illegal expression';
-  sCantAccessPrivateMember = 'Can''t access %s member %s';
+  sCantAccessXMember = 'Can''t access %s member %s';
   sMustBeInsideALoop = '%s must be inside a loop';
   sExpectXArrayElementsButFoundY = 'Expect %s array elements, but found %s';
   sCannotCreateADescendantOfTheSealedXY = 'Cannot create a descendant of the sealed %s "%s"';
@@ -303,6 +306,9 @@ resourcestring
   sIllegalAssignmentToForLoopVar = 'Illegal assignment to for-loop variable "%s"';
   sTypeXCannotBeExtendedByATypeHelper = 'Type "%s" cannot be extended by a type helper';
   sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself';
+  sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s';
+  sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types';
+  sBitWiseOperationsAre32Bit = 'Bitwise operations are 32-bit';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }
@@ -708,6 +714,8 @@ type
     function EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
     function EvalStringAddExpr(Expr, LeftExpr, RightExpr: TPasExpr;
       LeftValue, RightValue: TResEvalValue): TResEvalValue; virtual;
+    function LoHiValue(Value: TResEvalValue; ShiftSize: Integer; Mask: LongWord;
+      ErrorEl: TPasElement): TResEvalValue; virtual;
     function EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
       Flags: TResEvalFlags): TResEvalEnum; virtual;
     {$ifdef FPC_HAS_CPSTRING}
@@ -729,6 +737,7 @@ type
   TResExprEvaluatorClass = class of TResExprEvaluator;
 
 procedure ReleaseEvalValue(var Value: TResEvalValue);
+function NumberIsFloat(const Value: string): boolean;
 
 {$ifdef FPC_HAS_CPSTRING}
 function RawStrToCaption(const r: RawByteString; MaxLength: integer): string;
@@ -751,6 +760,17 @@ begin
   Value:=nil;
 end;
 
+function NumberIsFloat(const Value: string): boolean;
+var
+  i: Integer;
+begin
+  if Value='' then exit(false);
+  if Value[1] in ['$','%','&'] then exit(false);
+  for i:=2 to length(Value) do
+    if Value[i] in ['.','E','e'] then exit(true);
+  Result:=false;
+end;
+
 {$ifdef FPC_HAS_CPSTRING}
 function RawStrToCaption(const r: RawByteString; MaxLength: integer): string;
 var
@@ -1861,7 +1881,7 @@ begin
       // float - currency
       try
         {$Q+}
-        aCurrency:=aCurrency - TResEvalCurrency(RightValue).Value;
+        aCurrency:=Flo - TResEvalCurrency(RightValue).Value;
         {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
         Result:=TResEvalCurrency.CreateValue(aCurrency);
       except
@@ -3886,6 +3906,8 @@ end;
 
 function TResExprEvaluator.ExprStringToOrd(Value: TResEvalValue;
   PosEl: TPasElement): longword;
+const
+  Invalid = $12345678; // bigger than $ffff and smaller than $8000000
 var
   {$ifdef FPC_HAS_CPSTRING}
   S: RawByteString;
@@ -3897,11 +3919,29 @@ begin
     begin
     // ord(ansichar)
     S:=TResEvalString(Value).S;
-    if length(S)<>1 then
-      RaiseMsg(20170522221143,nXExpectedButYFound,sXExpectedButYFound,
-        ['char','string'],PosEl)
+    if length(S)=1 then
+      Result:=ord(S[1])
+    else if (length(S)=0) or (length(S)>4) then
+      begin
+      if PosEl<>nil then
+        RaiseMsg(20170522221143,nXExpectedButYFound,sXExpectedButYFound,
+          ['char','string'],PosEl)
+      else
+        exit(Invalid);
+      end
     else
-      Result:=ord(S[1]);
+      begin
+      U:=GetUnicodeStr(S,nil);
+      if length(U)<>1 then
+        begin
+        if PosEl<>nil then
+          RaiseMsg(20190124180407,nXExpectedButYFound,sXExpectedButYFound,
+            ['char','string'],PosEl)
+        else
+          exit(Invalid);
+        end;
+      Result:=ord(U[1]);
+      end;
     end
   else
   {$endif}
@@ -3910,8 +3950,13 @@ begin
     // ord(widechar)
     U:=TResEvalUTF16(Value).S;
     if length(U)<>1 then
-      RaiseMsg(20170522221358,nXExpectedButYFound,sXExpectedButYFound,
-        ['char','string'],PosEl)
+      begin
+      if PosEl<>nil then
+        RaiseMsg(20170522221358,nXExpectedButYFound,sXExpectedButYFound,
+          ['char','string'],PosEl)
+      else
+        exit(Invalid);
+      end
     else
       Result:=ord(U[1]);
     end
@@ -3949,12 +3994,12 @@ function TResExprEvaluator.EvalPrimitiveExprString(Expr: TPrimitiveExpr
     {$endif}
   end;
 
-  procedure AddHash(u: longword);
+  procedure AddHash(u: longword; ForceUTF16: boolean);
   {$ifdef FPC_HAS_CPSTRING}
   var
     h: RawByteString;
   begin
-    if (u>255) and (Result.Kind=revkString) then
+    if ((u>255) or (ForceUTF16)) and (Result.Kind=revkString) then
       begin
       // switch to unicodestring
       h:=TResEvalString(Result).S;
@@ -4056,11 +4101,11 @@ begin
           begin
           // split into two
           dec(u,$10000);
-          AddHash($D800+(u shr 10));
-          AddHash($DC00+(u and $3ff));
+          AddHash($D800+(u shr 10),true);
+          AddHash($DC00+(u and $3ff),true);
           end
         else
-          AddHash(u);
+          AddHash(u,p-StartP>2);
         end
       else
         begin
@@ -4080,7 +4125,7 @@ begin
           end;
         if p=StartP then
           RaiseInternalError(20170523123806);
-        AddHash(u);
+        AddHash(u,false);
         end;
       end;
     '^':
@@ -4091,8 +4136,8 @@ begin
         RaiseInternalError(20181016121520);
       c:=S[p];
       case c of
-      'a'..'z': AddHash(ord(c)-ord('a')+1);
-      'A'..'Z': AddHash(ord(c)-ord('A')+1);
+      'a'..'z': AddHash(ord(c)-ord('a')+1,false);
+      'A'..'Z': AddHash(ord(c)-ord('A')+1,false);
       else RaiseInternalError(20170523123809);
       end;
       inc(p);
@@ -4551,35 +4596,35 @@ end;
 
 function TResExprEvaluator.OrdValue(Value: TResEvalValue; ErrorEl: TPasElement
   ): TResEvalValue;
+var
+  v: longword;
 begin
+  Result:=nil;
+  v:=0;
   case Value.Kind of
     revkBool:
       if TResEvalBool(Value).B then
-        Result:=TResEvalInt.CreateValue(1)
+        v:=1
       else
-        Result:=TResEvalInt.CreateValue(0);
+        v:=0;
     revkInt,revkUInt:
-      Result:=Value;
+      exit(Value);
     {$ifdef FPC_HAS_CPSTRING}
     revkString:
-      if length(TResEvalString(Value).S)<>1 then
-        RaiseRangeCheck(20170624160128,ErrorEl)
-      else
-        Result:=TResEvalInt.CreateValue(ord(TResEvalString(Value).S[1]));
+      v:=ExprStringToOrd(Value,ErrorEl);
     {$endif}
     revkUnicodeString:
-      if length(TResEvalUTF16(Value).S)<>1 then
-        RaiseRangeCheck(20170624160129,ErrorEl)
-      else
-        Result:=TResEvalInt.CreateValue(ord(TResEvalUTF16(Value).S[1]));
+      v:=ExprStringToOrd(Value,ErrorEl);
     revkEnum:
-      Result:=TResEvalInt.CreateValue(TResEvalEnum(Value).Index);
+      v:=TResEvalEnum(Value).Index;
   else
     {$IFDEF VerbosePasResEval}
     writeln('TResExprEvaluator.OrdValue ',Value.AsDebugString);
     {$ENDIF}
     RaiseNotYetImplemented(20170624155932,ErrorEl);
   end;
+  if v>$ffff then exit;
+  Result:=TResEvalInt.CreateValue(v);
 end;
 
 procedure TResExprEvaluator.PredValue(Value: TResEvalValue; ErrorEl: TPasElement
@@ -4818,6 +4863,35 @@ begin
   end;
 end;
 
+function TResExprEvaluator.LoHiValue(Value: TResEvalValue; ShiftSize: Integer;
+  Mask: LongWord; ErrorEl: TPasElement): TResEvalValue;
+var
+  uint: LongWord;
+begin
+  case Value.Kind of
+    revkInt:
+      {$IFDEF Pas2js}
+      if ShiftSize=32 then
+        uint := longword(TResEvalInt(Value).Int div $100000000)
+      else
+      {$ENDIF}
+        uint := (TResEvalInt(Value).Int shr ShiftSize) and Mask;
+    revkUInt:
+      {$IFDEF Pas2js}
+      if ShiftSize=32 then
+        uint := longword(TResEvalUInt(Value).UInt div $100000000)
+      else
+      {$ENDIF}
+        uint := (TResEvalUInt(Value).UInt shr ShiftSize) and Mask;
+  else
+    {$IFDEF VerbosePasResEval}
+    writeln('TResExprEvaluator.LoHiValue ',Value.AsDebugString);
+    {$ENDIF}
+    RaiseNotYetImplemented(20190129012100,ErrorEl);
+  end;
+  Result := TResEvalInt.CreateValue(uint);
+end;
+
 function TResExprEvaluator.EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
   Flags: TResEvalFlags): TResEvalEnum;
 var

packages/fcl-passrc/src/pastree.pp

@@ -57,10 +57,10 @@ resourcestring
   SPasTreeObjectType = 'object';
   SPasTreeClassType = 'class';
   SPasTreeInterfaceType = 'interface';
-  SPasTreeGenericType = 'generic class';
   SPasTreeSpecializedType = 'specialized class type';
-  SPasClassHelperType = 'Class helper type';
-  SPasRecordHelperType = 'Record helper type';
+  SPasClassHelperType = 'class helper type';
+  SPasRecordHelperType = 'record helper type';
+  SPasTypeHelperType = 'type helper type';
   SPasTreeArgument = 'argument';
   SPasTreeProcedureType = 'procedure type';
   SPasTreeResultElement = 'function result';
@@ -737,10 +737,16 @@ type
 
   TPasObjKind = (
     okObject, okClass, okInterface,
-    okGeneric, // MG: what is okGeneric?
+    // okGeneric  removed in FPC 3.3.1  check instead GenericTemplateTypes.Count>0
     // okSpecialize removed in FPC 3.1.1
     okClassHelper,okRecordHelper,okTypeHelper,
     okDispInterface);
+const
+  okWithFields = [okObject, okClass];
+  okAllHelpers = [okClassHelper,okRecordHelper,okTypeHelper];
+  okWithClassFields = okWithFields+okAllHelpers;
+
+type
 
   TPasClassInterfaceType = (
     citCom, // default
@@ -772,7 +778,6 @@ type
     ExternalNameSpace : String;
     ExternalName : String;
     InterfaceType: TPasClassInterfaceType;
-    Procedure SetGenericTemplates(AList : TFPList); override;
     Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
     Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
     Function InterfaceGUID : string;
@@ -1074,11 +1079,25 @@ type
   end;
 
   { TPasOperator }
-  TOperatorType = (otUnknown,otImplicit,otExplicit,otMul,otPlus, otMinus, otDivision,otLessThan, otEqual,
-                   otGreaterThan, otAssign,otNotEqual,otLessEqualThan,otGreaterEqualThan,otPower,
-                   otSymmetricalDifference, otInc, otDec, otMod, otNegative, otPositive, otBitWiseOr, otDiv,
-                   otLeftShift, otLogicalOr, otBitwiseAnd, otbitwiseXor,otLogicalAnd,otLogicalNot,otLogicalXor,
-                   otRightShift,otEnumerator, otIn);
+  TOperatorType = (
+    otUnknown,
+    otImplicit, otExplicit,
+    otMul, otPlus, otMinus, otDivision,
+    otLessThan, otEqual, otGreaterThan,
+    otAssign, otNotEqual, otLessEqualThan, otGreaterEqualThan,
+    otPower, otSymmetricalDifference,
+    otInc, otDec,
+    otMod,
+    otNegative, otPositive,
+    otBitWiseOr,
+    otDiv,
+    otLeftShift,
+    otLogicalOr,
+    otBitwiseAnd, otbitwiseXor,
+    otLogicalAnd, otLogicalNot, otLogicalXor,
+    otRightShift,
+    otEnumerator, otIn
+    );
   TOperatorTypes = set of TOperatorType;
 
   TPasOperator = class(TPasFunction)
@@ -1610,8 +1629,9 @@ const
     'strict private', 'strict protected');
 
   ObjKindNames: array[TPasObjKind] of string = (
-    'object', 'class', 'interface', 'class',
-    'class helper','record helper','type helper','dispinterface');
+    'object', 'class', 'interface',
+    'class helper','record helper','type helper',
+    'dispinterface');
 
   InterfaceTypeNames: array[TPasClassInterfaceType] of string = (
     'COM',
@@ -3017,9 +3037,9 @@ begin
     okObject: Result := SPasTreeObjectType;
     okClass: Result := SPasTreeClassType;
     okInterface: Result := SPasTreeInterfaceType;
-    okGeneric : Result := SPasTreeGenericType;
     okClassHelper : Result:=SPasClassHelperType;
     okRecordHelper : Result:=SPasRecordHelperType;
+    okTypeHelper : Result:=SPasTypeHelperType;
   else
     Result:='ObjKind('+IntToStr(ord(ObjKind))+')';
   end;
@@ -3039,12 +3059,6 @@ begin
   ForEachChildCall(aMethodCall,Arg,GUIDExpr,false);
 end;
 
-procedure TPasClassType.SetGenericTemplates(AList: TFPList);
-begin
-  ObjKind:=okGeneric;
-  inherited SetGenericTemplates(AList);
-end;
-
 function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement;
 
 Var

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -1452,7 +1452,7 @@ begin
       begin
       if Ref.WithExprScope<>nil then
         begin
-        if Ref.WithExprScope.Scope is TPasRecordScope then
+        if Ref.WithExprScope.ClassRecScope is TPasRecordScope then
           begin
           // a record member was accessed -> access the record too
           UseExprRef(El,Ref.WithExprScope.Expr,Access,false);

packages/fcl-passrc/src/pparser.pp

@@ -135,7 +135,7 @@ resourcestring
   // free for 2029
   SLogStartImplementation = 'Start parsing implementation section.';
   SLogStartInterface = 'Start parsing interface section';
-  SParserNoConstructorAllowed = 'Constructors or Destructors are not allowed in Interfaces or Record helpers';
+  SParserNoConstructorAllowed = 'Constructors or Destructors are not allowed in Interfaces or Records';
   SParserNoFieldsAllowedInX = 'Fields are not allowed in %s';
   SParserInvalidRecordVisibility = 'Records can only have public and (strict) private as visibility specifiers';
   SErrRecordConstantsNotAllowed = 'Record constants not allowed at this location.';
@@ -730,6 +730,8 @@ begin
         Scanner.AddDefine('CPU32');
       end;
     Parser := TPasParser.Create(Scanner, FileResolver, AEngine);
+    if (poSkipDefaultDefs in Options) then
+      Parser.ImplicitUses.Clear;
     Filename := '';
     Parser.LogEvents:=AEngine.ParserLogEvents;
     Parser.OnLog:=AEngine.Onlog;
@@ -2166,29 +2168,6 @@ function TPasParser.ParseExprOperand(AParent: TPasElement): TPasExpr;
       end;
   end;
 
-  Procedure HandleSelf(Var Last: TPasExpr);
-
-  Var
-    b       : TBinaryExpr;
-    optk    : TToken;
-
-  begin
-    NextToken;
-    if CurToken = tkDot then
-      begin // self.Write(EscapeText(AText));
-      optk:=CurToken;
-      NextToken;
-      b:=CreateBinaryExpr(AParent,Last, ParseExprOperand(AParent), TokenToExprOp(optk));
-      if not Assigned(b.right) then
-        begin
-        b.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
-        ParseExcExpectedIdentifier;
-        end;
-      Last:=b;
-      end;
-    UngetToken;
-  end;
-
   function IsSpecialize: boolean;
   var
     LookAhead, i: Integer;
@@ -2264,11 +2243,8 @@ begin
       begin
       CanSpecialize:=true;
       aName:=CurTokenText;
-      if CompareText(aName,'self')=0 then
-        begin
-        Last:=CreateSelfExpr(AParent);
-        HandleSelf(Last);
-        end
+      if (CompareText(aName,'self')=0) and not (tkself in Scanner.NonTokens) then
+        Last:=CreateSelfExpr(AParent)
       else
         Last:=CreatePrimitiveExpr(AParent,pekIdent,aName);
       end;
@@ -2299,7 +2275,6 @@ begin
       CanSpecialize:=true;
       aName:=CurTokenText;
       Last:=CreateSelfExpr(AParent);
-      HandleSelf(Last);
       end;
     tkprocedure,tkfunction:
       begin
@@ -2690,7 +2665,6 @@ begin
   end;
 end;
 
-
 function GetExprIdent(p: TPasExpr): String;
 begin
   Result:='';
@@ -3347,13 +3321,27 @@ end;
 
 procedure TPasParser.ParseDeclarations(Declarations: TPasDeclarations);
 var
+  HadTypeSection: boolean;
   CurBlock: TDeclType;
 
   procedure SetBlock(NewBlock: TDeclType);
   begin
     if CurBlock=NewBlock then exit;
     if CurBlock=declType then
-      Engine.FinishScope(stTypeSection,Declarations);
+      begin
+      if msDelphi in CurrentModeswitches then
+        // Delphi allows forward types only inside a type section
+        Engine.FinishScope(stTypeSection,Declarations);
+      end;
+    if NewBlock=declType then
+      HadTypeSection:=true
+    else if (NewBlock=declNone) and HadTypeSection then
+      begin
+      HadTypeSection:=false;
+      if not (msDelphi in CurrentModeswitches) then
+        // ObjFPC allows forward types inside a whole section
+        Engine.FinishScope(stTypeSection,Declarations);
+      end;
     CurBlock:=NewBlock;
     Scanner.SetForceCaret(NewBlock=declType);
   end;
@@ -3377,6 +3365,7 @@ var
   RecordEl: TPasRecordType;
 begin
   CurBlock := declNone;
+  HadTypeSection:=false;
   while True do
   begin
     if CurBlock in [DeclNone,declConst,declType] then
@@ -3649,7 +3638,7 @@ begin
         break;
         end
       else if (Declarations is TInterfaceSection)
-      or (Declarations is TImplementationSection) then
+          or (Declarations is TImplementationSection) then
         begin
         SetBlock(declNone);
         ParseInitialization;
@@ -3675,9 +3664,9 @@ begin
       end;
     tklabel:
       begin
-        SetBlock(declNone);
-        if not (Declarations is TInterfaceSection) then
-          ParseLabels(Declarations);
+      SetBlock(declNone);
+      if not (Declarations is TInterfaceSection) then
+        ParseLabels(Declarations);
       end;
     tkSquaredBraceOpen:
       if [msPrefixedAttributes,msIgnoreAttributes]*CurrentModeSwitches<>[] then
@@ -3866,8 +3855,6 @@ begin
       finally
         Scanner.SetForceCaret(OldForceCaret);
       end;
-{      if Result.VarType is TPasRangeType then
-        Ungettoken; // Range type stops on token after last range token}
       end
     else
       begin
@@ -4008,7 +3995,7 @@ begin
       end;
     if not (CurToken in [tkComma,tkSemicolon,tkGreaterThan]) then
       ParseExc(nParserExpectToken2Error,SParserExpectToken2Error,
-        [TokenInfos[tkComma], TokenInfos[tkColon], TokenInfos[tkGreaterThan]]);
+        [TokenInfos[tkComma], TokenInfos[tkGreaterThan]]);
   until CurToken = tkGreaterThan;
 end;
 
@@ -4417,7 +4404,7 @@ begin
     TPasVariable(VarList[OldListCount]).Expr:=Value;
     Value:=nil;
 
-    // Note: external members are allowed for non external classes too
+    // Note: external members are allowed for non external classes/records too
     ExternalStruct:=(msExternalClass in CurrentModeSwitches)
                     and (Parent is TPasMembersType);
 
@@ -5608,14 +5595,13 @@ var
 
 var
   SubBlock: TPasImplElement;
-  Left, Right: TPasExpr;
+  Left, Right, Expr: TPasExpr;
   El : TPasImplElement;
   lt : TLoopType;
   SrcPos: TPasSourcePos;
   Name: String;
   TypeEl: TPasType;
   ImplRaise: TPasImplRaise;
-  Expr: TPasExpr;
 
 begin
   NewImplElement:=nil;
@@ -5812,12 +5798,11 @@ begin
           SrcPos:=CurTokenPos;
           NextToken;
           El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
-          Left:=DoParseExpression(CurBlock);
+          Expr:=DoParseExpression(CurBlock);
           //writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText);
-          TPasImplWithDo(El).AddExpression(Left);
-          Left.Parent:=El;
-          Engine.BeginScope(stWithExpr,Left);
-          Left:=nil;
+          TPasImplWithDo(El).AddExpression(Expr);
+          Expr.Parent:=El;
+          Engine.BeginScope(stWithExpr,Expr);
           CreateBlock(TPasImplWithDo(El));
           El:=nil;
           repeat
@@ -5825,11 +5810,10 @@ begin
             if CurToken<>tkComma then
               ParseExcTokenError(TokenInfos[tkdo]);
             NextToken;
-            Left:=DoParseExpression(CurBlock);
+            Expr:=DoParseExpression(CurBlock);
             //writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
-            TPasImplWithDo(CurBlock).AddExpression(Left);
-            Engine.BeginScope(stWithExpr,Left);
-            Left:=nil;
+            TPasImplWithDo(CurBlock).AddExpression(Expr);
+            Engine.BeginScope(stWithExpr,Expr);
           until false;
         end;
       tkcase:
@@ -6088,7 +6072,7 @@ begin
             tkAssignMinus,
             tkAssignMul,
             tkAssignDivision:
-            begin
+              begin
               // assign statement
               El:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock,SrcPos));
               TPasImplAssign(El).left:=Left;
@@ -6102,10 +6086,12 @@ begin
               Right:=nil;
               AddStatement(El);
               El:=nil;
-            end;
+              end;
             tkColon:
-            begin
-              if not (Left is TPrimitiveExpr) then
+              begin
+              if not (bsGoto in Scanner.CurrentBoolSwitches) then
+                ParseExcTokenError(TokenInfos[tkSemicolon])
+              else if not (Left is TPrimitiveExpr) then
                 ParseExcTokenError(TokenInfos[tkSemicolon]);
               // label mark. todo: check mark identifier in the list of labels
               El:=TPasImplLabelMark(CreateElement(TPasImplLabelMark,'', CurBlock,SrcPos));
@@ -6114,7 +6100,7 @@ begin
               CurBlock.AddElement(El);
               CmdElem:=TPasImplLabelMark(El);
               El:=nil;
-            end;
+              end;
           else
             // simple statement (function call)
             El:=TPasImplSimple(CreateElement(TPasImplSimple,'',CurBlock,SrcPos));
@@ -6221,7 +6207,7 @@ begin
   ptOperator,ptClassOperator:
     begin
     NextToken;
-    IsTokenBased:=Curtoken<>tkIdentifier;
+    IsTokenBased:=CurToken<>tkIdentifier;
     if IsTokenBased then
       OT:=TPasOperator.TokenToOperatorType(CurTokenText)
     else
@@ -6684,8 +6670,8 @@ Type
 Var
   CurVisibility : TPasMemberVisibility;
   CurSection : TSectionType;
-  haveClass ,
-    IsMethodResolution: Boolean; // true means last token was class keyword
+  haveClass: boolean; // true means last token was class keyword
+  IsMethodResolution: Boolean;
   LastToken: TToken;
   PropEl: TPasProperty;
   MethodRes: TPasMethodResolution;
@@ -6705,7 +6691,7 @@ begin
       tkType:
         begin
         case AType.ObjKind of
-        okClass,okObject,okGeneric,
+        okClass,okObject,
         okClassHelper,okRecordHelper,okTypeHelper: ;
         else
           ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['TYPE',ObjKindNames[AType.ObjKind]]);
@@ -6718,7 +6704,7 @@ begin
           ParseExc(nParserExpectToken2Error,SParserExpectToken2Error,
             ['Procedure','Var']);
         case AType.ObjKind of
-        okClass,okObject,okGeneric,
+        okClass,okObject,
         okClassHelper,okRecordHelper,okTypeHelper: ;
         else
           ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['CONST',ObjKindNames[AType.ObjKind]]);
@@ -6728,8 +6714,8 @@ begin
       tkVar:
         if not (CurSection in [stVar,stClassVar]) then
           begin
-          if (AType.ObjKind in [okClass,okObject,okGeneric])
-          or (haveClass and (AType.ObjKind in [okClassHelper,okRecordHelper,okTypeHelper])) then
+          if (AType.ObjKind in okWithFields)
+          or (haveClass and (AType.ObjKind in okAllHelpers)) then
             // ok
           else
             ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['VAR',ObjKindNames[AType.ObjKind]]);
@@ -6753,14 +6739,14 @@ begin
           stNone,
           stVar:
             begin
-            if not (AType.ObjKind in [okObject,okClass,okGeneric]) then
+            if not (AType.ObjKind in okWithFields) then
               ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]);
             ParseClassFields(AType,CurVisibility,CurSection=stClassVar);
             HaveClass:=False;
             end;
           stClassVar:
             begin
-            if not (AType.ObjKind in [okObject,okClass,okGeneric,okClassHelper,okRecordHelper,okTypeHelper]) then
+            if not (AType.ObjKind in okWithClassFields) then
               ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]);
             ParseClassFields(AType,CurVisibility,CurSection=stClassVar);
             HaveClass:=False;
@@ -6774,12 +6760,19 @@ begin
         curSection:=stNone;
         if not haveClass then
           SaveComments;
-        if (AType.ObjKind in [okObject,okClass,okGeneric])
-            or ((CurToken=tkconstructor)
-              and (AType.ObjKind in [okClassHelper,okTypeHelper,okRecordHelper])) then
-          // ok
+        case AType.ObjKind of
+        okObject,okClass: ;
+        okClassHelper,okTypeHelper,okRecordHelper:
+          begin
+          if (CurToken=tkdestructor) and not haveClass then
+            ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['destructor',ObjKindNames[AType.ObjKind]]);
+          end;
         else
-          ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
+          if CurToken=tkconstructor then
+            ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['constructor',ObjKindNames[AType.ObjKind]])
+          else
+            ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['destructor',ObjKindNames[AType.ObjKind]]);
+        end;
         ProcessMethod(AType,HaveClass,CurVisibility);
         haveClass:=False;
         end;
@@ -6815,7 +6808,7 @@ begin
       tkclass:
         begin
         case AType.ObjKind of
-        okClass,okObject,okGeneric,
+        okClass,okObject,
         okClassHelper,okRecordHelper,okTypeHelper: ;
         else
           ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['CLASS',ObjKindNames[AType.ObjKind]]);
@@ -6855,7 +6848,7 @@ var
   Expr: TPasExpr;
 
 begin
-  if (CurToken=tkIdentifier) and (AType.ObjKind in [okClass,okGeneric]) then
+  if (CurToken=tkIdentifier) and (AType.ObjKind=okClass) then
     begin
     s := LowerCase(CurTokenString);
     if (s = 'sealed') or (s = 'abstract') then
@@ -6875,7 +6868,7 @@ begin
       CheckToken(tkend);
     NextToken;
     AType.AncestorType := ParseTypeReference(AType,false,Expr);
-    if AType.ObjKind in [okClass,okGeneric] then
+    if AType.ObjKind=okClass then
       while CurToken=tkComma do
         begin
         NextToken;
@@ -6885,7 +6878,7 @@ begin
     NextToken;
     AType.IsShortDefinition:=(CurToken=tkSemicolon);
     end;
-  if (AType.ObjKind in [okClassHelper,okRecordHelper,okTypeHelper]) then
+  if (AType.ObjKind in okAllHelpers) then
     begin
     CheckToken(tkfor);
     NextToken;
@@ -6957,7 +6950,7 @@ begin
     AExternalNameSpace:='';
     AExternalName:='';
     end;
-  if AObjKind in [okClassHelper,okRecordHelper,okTypeHelper] then
+  if AObjKind in okAllHelpers then
     begin
     if not CurTokenIsIdentifier('Helper') then
       ParseExcSyntaxError;

packages/fcl-passrc/src/pscanner.pp

@@ -294,8 +294,9 @@ type
     msExternalClass,       { Allow external class definitions }
     msPrefixedAttributes,  { Allow attributes, disable proc modifier [] }
     msIgnoreAttributes,    { workaround til resolver/converter supports attributes }
-    msOmitRTTI             { treat class section 'published' as 'public' and typeinfo does not work on symbols declared with this switch }
-  );
+    msOmitRTTI,            { treat class section 'published' as 'public' and typeinfo does not work on symbols declared with this switch }
+    msMultipleScopeHelpers { off=only one helper per type, on=all }
+    );
   TModeSwitches = Set of TModeSwitch;
 
   // switches, that can be 'on' or 'off'
@@ -333,7 +334,8 @@ type
     bsMacro,
     bsScopedEnums,
     bsObjectChecks,   // check methods 'Self' and object type casts
-    bsPointerMath     // pointer arithmetic
+    bsPointerMath,    // pointer arithmetic
+    bsGoto       // support label and goto, set by {$goto on|off}
     );
   TBoolSwitches = set of TBoolSwitch;
 const
@@ -369,8 +371,8 @@ const
   bsAll = [low(TBoolSwitch)..high(TBoolSwitch)];
   bsFPCMode: TBoolSwitches = [bsPointerMath,bsWriteableConst];
   bsObjFPCMode: TBoolSwitches = [bsPointerMath,bsWriteableConst];
-  bsDelphiMode: TBoolSwitches = [bsWriteableConst];
-  bsDelphiUnicodeMode: TBoolSwitches = [bsWriteableConst];
+  bsDelphiMode: TBoolSwitches = [bsWriteableConst,bsGoto];
+  bsDelphiUnicodeMode: TBoolSwitches = [bsWriteableConst,bsGoto];
   bsMacPasMode: TBoolSwitches = [bsPointerMath,bsWriteableConst];
 
 type
@@ -987,7 +989,7 @@ const
     'Tab'
   );
 
-  SModeSwitchNames : array[TModeSwitch] of string{$ifdef fpc}[18]{$endif} =
+  SModeSwitchNames : array[TModeSwitch] of string{$ifdef fpc}[20]{$endif} =
   ( '', // msNone
     '', // Fpc,
     '', // Objfpc,
@@ -1037,7 +1039,8 @@ const
     'EXTERNALCLASS',
     'PREFIXEDATTRIBUTES',
     'IGNOREATTRIBUTES',
-    'OMITRTTI'
+    'OMITRTTI',
+    'MULTIPLESCOPEHELPERS'
     );
 
   LetterSwitchNames: array['A'..'Z'] of string=(
@@ -1100,7 +1103,8 @@ const
     'Macro',
     'ScopedEnums',
     'ObjectChecks',
-    'PointerMath'
+    'PointerMath',
+    'Goto'
     );
 
   ValueSwitchNames: array[TValueSwitch] of string = (
@@ -1117,7 +1121,7 @@ const
 
 const
   // all mode switches supported by FPC
-  msAllFPCModeSwitches = [low(TModeSwitch)..High(TModeSwitch)];
+  msAllModeSwitches = [low(TModeSwitch)..High(TModeSwitch)];
 
   DelphiModeSwitches = [msDelphi,msClass,msObjpas,msResult,msStringPchar,
      msPointer2Procedure,msAutoDeref,msTPProcVar,msInitFinal,msDefaultAnsistring,
@@ -1128,7 +1132,7 @@ const
 
   DelphiUnicodeModeSwitches = delphimodeswitches + [msSystemCodePage,msDefaultUnicodestring];
 
-  // mode switches of $mode FPC, don't confuse with msAllFPCModeSwitches
+  // mode switches of $mode FPC, don't confuse with msAllModeSwitches
   FPCModeSwitches = [msFpc,msStringPchar,msNestedComment,msRepeatForward,
     msCVarSupport,msInitFinal,msHintDirective,msProperty,msDefaultInline];
   //FPCBoolSwitches bsObjectChecks
@@ -2663,7 +2667,7 @@ begin
   FMaxIncludeStackDepth:=DefaultMaxIncludeStackDepth;
 
   FCurrentModeSwitches:=FPCModeSwitches;
-  FAllowedModeSwitches:=msAllFPCModeSwitches;
+  FAllowedModeSwitches:=msAllModeSwitches;
   FCurrentBoolSwitches:=bsFPCMode;
   FAllowedBoolSwitches:=bsAll;
   FAllowedValueSwitches:=vsAllValueSwitches;
@@ -3672,6 +3676,8 @@ begin
           DoBoolDirective(bsAssertions);
         'DEFINE':
           HandleDefine(Param);
+        'GOTO':
+          DoBoolDirective(bsGoto);
         'ERROR':
           HandleError(Param);
         'HINT':
@@ -3786,9 +3792,9 @@ begin
     DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,
       [BoolSwitchNames[bs]])
   else if NewValue then
-    Include(FCurrentBoolSwitches,bs)
+    CurrentBoolSwitches:=CurrentBoolSwitches+[bs]
   else
-    Exclude(FCurrentBoolSwitches,bs);
+    CurrentBoolSwitches:=CurrentBoolSwitches-[bs];
 end;
 
 function TPascalScanner.DoFetchToken: TToken;
@@ -4508,9 +4514,24 @@ begin
 end;
 
 procedure TPascalScanner.SetCurrentBoolSwitches(const AValue: TBoolSwitches);
+var
+  OldBS, Removed, Added: TBoolSwitches;
 begin
   if FCurrentBoolSwitches=AValue then Exit;
+  OldBS:=FCurrentBoolSwitches;
   FCurrentBoolSwitches:=AValue;
+  Removed:=OldBS-FCurrentBoolSwitches;
+  Added:=FCurrentBoolSwitches-OldBS;
+  if bsGoto in Added then
+    begin
+    UnsetNonToken(tklabel);
+    UnsetNonToken(tkgoto);
+    end;
+  if bsGoto in Removed then
+    begin
+    SetNonToken(tklabel);
+    SetNonToken(tkgoto);
+    end;
 end;
 
 procedure TPascalScanner.SetCurrentModeSwitches(AValue: TModeSwitches);

packages/fcl-passrc/tests/tcexprparser.pas

@@ -109,6 +109,8 @@ type
     Procedure TestAPlusBBracketArrayParams;
     Procedure TestAPlusBBracketDotC;
     Procedure TestADotBDotC;
+    Procedure TestADotBBracketC;
+    Procedure TestSelfDotBBracketC;
     Procedure TestRange;
     Procedure TestBracketsTotal;
     Procedure TestBracketsLeft;
@@ -1249,6 +1251,44 @@ begin
   AssertExpression('right b',SubB.right,pekIdent,'b');
 end;
 
+procedure TTestExpressions.TestADotBBracketC;
+var
+  P: TParamsExpr;
+  B: TBinaryExpr;
+begin
+  ParseExpression('a.b[c]');
+  P:=TParamsExpr(AssertExpression('ArrayParams',TheExpr,pekArrayParams,TParamsExpr));
+
+  B:=TBinaryExpr(AssertExpression('Binary identifier',P.Value,pekBinary,TBinaryExpr));
+  AssertEquals('dot expr',eopSubIdent,B.OpCode);
+  TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
+  TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
+  AssertExpression('left a',B.left,pekIdent,'a');
+  AssertExpression('right b',B.right,pekIdent,'b');
+
+  AssertEquals('length(p.Params)',length(p.Params),1);
+  AssertExpression('first param c',p.Params[0],pekIdent,'c');
+end;
+
+procedure TTestExpressions.TestSelfDotBBracketC;
+var
+  P: TParamsExpr;
+  B: TBinaryExpr;
+begin
+  ParseExpression('self.b[c]');
+  P:=TParamsExpr(AssertExpression('ArrayParams',TheExpr,pekArrayParams,TParamsExpr));
+
+  B:=TBinaryExpr(AssertExpression('Binary identifier',P.Value,pekBinary,TBinaryExpr));
+  AssertEquals('dot expr',eopSubIdent,B.OpCode);
+  TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
+  TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
+  AssertEquals('left self',TSelfExpr,B.left.classtype);
+  AssertExpression('right b',B.right,pekIdent,'b');
+
+  AssertEquals('length(p.Params)',length(p.Params),1);
+  AssertExpression('first param c',p.Params[0],pekIdent,'c');
+end;
+
 initialization
 
   RegisterTest(TTestExpressions);

packages/fcl-passrc/tests/tcgenerics.pp

@@ -12,20 +12,21 @@ Type
   { TTestGenerics }
 
   TTestGenerics = Class(TBaseTestTypeParser)
-  private
   Published
     Procedure TestObjectGenerics;
     Procedure TestRecordGenerics;
     Procedure TestArrayGenerics;
+    Procedure TestGenericConstraint;
+    Procedure TestDeclarationConstraint;
     Procedure TestSpecializationDelphi;
-    procedure TestDeclarationConstraint;
     Procedure TestDeclarationDelphi;
     Procedure TestDeclarationDelphiSpecialize;
-    procedure TestDeclarationFPC;
+    Procedure TestDeclarationFPC;
     Procedure TestMethodImplementation;
     Procedure TestInlineSpecializationInArgument;
     Procedure TestSpecializeNested;
     Procedure TestInlineSpecializeInStatement;
+    Procedure TestGenericFunction; // ToDo
   end;
 
 implementation
@@ -61,20 +62,25 @@ begin
   ParseDeclarations;
 end;
 
-procedure TTestGenerics.TestSpecializationDelphi;
+procedure TTestGenerics.TestGenericConstraint;
 begin
-  ParseType('TFPGList<integer>',TPasSpecializeType,'');
+  Add([
+    'Type',
+    'Generic TSomeClass<T: TObject> = class',
+    '  b : T;',
+    'end;',
+    '']);
+  ParseDeclarations;
 end;
 
-procedure TTestGenerics.TestDeclarationDelphi;
+procedure TTestGenerics.TestDeclarationConstraint;
 Var
   T : TPasClassType;
 begin
   Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ;
   Source.Add('Type');
-  Source.Add('  TSomeClass<T,T2> = Class(TObject)');
+  Source.Add('  TSomeClass<T: T2> = Class(TObject)');
   Source.Add('  b : T;');
-  Source.Add('  b2 : T2;');
   Source.Add('end;');
   ParseDeclarations;
   AssertNotNull('have generic definition',Declarations.Classes);
@@ -82,18 +88,23 @@ begin
   AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
   T:=TPasClassType(Declarations.Classes[0]);
   AssertNotNull('have generic templates',T.GenericTemplateTypes);
-  AssertEquals('2 template types',2,T.GenericTemplateTypes.Count);
+  AssertEquals('1 template types',1,T.GenericTemplateTypes.Count);
   AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent);
-  AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
+  AssertEquals('Type constraint is recorded','T2',TPasGenericTemplateType(T.GenericTemplateTypes[0]).TypeConstraint);
 end;
 
-procedure TTestGenerics.TestDeclarationFPC;
+procedure TTestGenerics.TestSpecializationDelphi;
+begin
+  ParseType('TFPGList<integer>',TPasSpecializeType,'');
+end;
+
+procedure TTestGenerics.TestDeclarationDelphi;
 Var
   T : TPasClassType;
 begin
   Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ;
   Source.Add('Type');
-  Source.Add('  TSomeClass<T;T2> = Class(TObject)');
+  Source.Add('  TSomeClass<T,T2> = Class(TObject)');
   Source.Add('  b : T;');
   Source.Add('  b2 : T2;');
   Source.Add('end;');
@@ -108,34 +119,35 @@ begin
   AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
 end;
 
-
-procedure TTestGenerics.TestDeclarationConstraint;
+procedure TTestGenerics.TestDeclarationDelphiSpecialize;
 Var
   T : TPasClassType;
 begin
   Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ;
   Source.Add('Type');
-  Source.Add('  TSomeClass<T: T2> = Class(TObject)');
+  Source.Add('  TSomeClass<T,T2> = Class(TSomeGeneric<Integer,Integer>)');
   Source.Add('  b : T;');
+  Source.Add('  b2 : T2;');
   Source.Add('end;');
   ParseDeclarations;
   AssertNotNull('have generic definition',Declarations.Classes);
   AssertEquals('have generic definition',1,Declarations.Classes.Count);
   AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
   T:=TPasClassType(Declarations.Classes[0]);
+  AssertEquals('Name is correct','TSomeClass',T.Name);
   AssertNotNull('have generic templates',T.GenericTemplateTypes);
-  AssertEquals('1 template types',1,T.GenericTemplateTypes.Count);
+  AssertEquals('2 template types',2,T.GenericTemplateTypes.Count);
   AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent);
-  AssertEquals('Type constraint is recorded','T2',TPasGenericTemplateType(T.GenericTemplateTypes[0]).TypeConstraint);
+  AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
 end;
 
-procedure TTestGenerics.TestDeclarationDelphiSpecialize;
+procedure TTestGenerics.TestDeclarationFPC;
 Var
   T : TPasClassType;
 begin
-  Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ;
+  Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches;
   Source.Add('Type');
-  Source.Add('  TSomeClass<T,T2> = Class(TSomeGeneric<Integer,Integer>)');
+  Source.Add('  TSomeClass<T;T2> = Class(TObject)');
   Source.Add('  b : T;');
   Source.Add('  b2 : T2;');
   Source.Add('end;');
@@ -144,7 +156,6 @@ begin
   AssertEquals('have generic definition',1,Declarations.Classes.Count);
   AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
   T:=TPasClassType(Declarations.Classes[0]);
-  AssertEquals('Name is correct','TSomeClass',T.Name);
   AssertNotNull('have generic templates',T.GenericTemplateTypes);
   AssertEquals('2 template types',2,T.GenericTemplateTypes.Count);
   AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent);
@@ -206,6 +217,19 @@ begin
   ParseModule;
 end;
 
+procedure TTestGenerics.TestGenericFunction;
+begin
+  exit; // ToDo
+  Add([
+  'generic function IfThen<T>(val:boolean;const iftrue:T; const iffalse:T) :T; inline; overload;',
+  'begin',
+  'end;',
+  'begin',
+  '  IfThen<word>(true,2,3);',
+  '']);
+  ParseModule;
+end;
+
 initialization
   RegisterTest(TTestGenerics);
 end.

packages/fcl-passrc/tests/tcprocfunc.pas

@@ -1273,18 +1273,20 @@ procedure TTestProcedureFunction.TestOperatorNames;
 
 Var
   t : TOperatorType;
+  S: String;
 
 begin
   For t:=Succ(otUnknown) to High(TOperatorType) do
       begin
+      S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
       ResetParser;
       if t in UnaryOperators then
         AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]]))
       else
         AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]]));
       ParseOperator;
-      AssertEquals('Token based',False,FOperator.TokenBased);
-      AssertEquals('Correct operator type',T,FOperator.OperatorType);
+      AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased);
+      AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
       if t in UnaryOperators then
         AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
       else

packages/fcl-passrc/tests/tcresolver.pas

@@ -256,6 +256,7 @@ type
     // enums and sets
     Procedure TestEnums;
     Procedure TestEnumRangeFail;
+    Procedure TestEnumDotValueFail;
     Procedure TestSets;
     Procedure TestSetOperators;
     Procedure TestEnumParams;
@@ -347,6 +348,8 @@ type
     Procedure TestForLoopStartIncompFail;
     Procedure TestForLoopEndIncompFail;
     Procedure TestSimpleStatement_VarFail;
+    Procedure TestLabelStatementFail;
+    Procedure TestLabelStatementDelphiFail;
 
     // units
     Procedure TestUnitForwardOverloads;
@@ -490,6 +493,7 @@ type
     Procedure TestAdvRecord;
     Procedure TestAdvRecord_Private;
     Procedure TestAdvRecord_StrictPrivate;
+    Procedure TestAdvRecord_StrictPrivateFail;
     Procedure TestAdvRecord_MethodImplMissingFail;
     Procedure TestAdvRecord_VarConst;
     Procedure TestAdvRecord_RecVal_ConstFail;
@@ -520,6 +524,9 @@ type
     Procedure TestClassForwardAsAncestorFail;
     Procedure TestClassForwardNotResolved;
     Procedure TestClassForwardDuplicateFail;
+    Procedure TestClassForwardDelphiFail;
+    Procedure TestClassForwardObjFPCProgram;
+    Procedure TestClassForwardObjFPCUnit;
     Procedure TestClass_Method;
     Procedure TestClass_ConstructorMissingDotFail;
     Procedure TestClass_MethodImplDuplicateFail;
@@ -658,6 +665,8 @@ type
     Procedure TestPropertyReadAccessorFuncWrongResult;
     Procedure TestPropertyReadAccessorFuncWrongArgCount;
     Procedure TestPropertyReadAccessorFunc;
+    Procedure TestPropertyReadAccessorStrictPrivate;
+    Procedure TestPropertyReadAccessorNonClassFail;
     Procedure TestPropertyWriteAccessorVarWrongType;
     Procedure TestPropertyWriteAccessorFuncNotProc;
     Procedure TestPropertyWriteAccessorProcWrongArgCount;
@@ -861,14 +870,45 @@ type
     Procedure TestHint_Garbage;
 
     // helpers
-    Procedure ClassHelper;
-    Procedure ClassHelper_AncestorIsNotHelperForDescendantFail;
-    Procedure ClassHelper_ForInterfaceFail;
-    Procedure ClassHelper_FieldFail;
-    Procedure ClassHelper_AbstractFail;
-    Procedure ClassHelper_VirtualObjFPCFail;
-    Procedure RecordHelper;
-    Procedure TypeHelper;
+    Procedure TestClassHelper;
+    Procedure TestClassHelper_AncestorIsNotHelperForDescendantFail;
+    Procedure TestClassHelper_HelperForParentFail;
+    Procedure TestClassHelper_ForInterfaceFail;
+    Procedure TestClassHelper_FieldFail;
+    Procedure TestClassHelper_AbstractFail;
+    Procedure TestClassHelper_VirtualObjFPCFail;
+    Procedure TestClassHelper_VirtualDelphiFail;
+    Procedure TestClassHelper_DestructorFail;
+    Procedure TestClassHelper_ClassRefersToTypeHelperOfAncestor;
+    Procedure TestClassHelper_InheritedObjFPC;
+    Procedure TestClassHelper_InheritedObjFPC2;
+    Procedure TestClassHelper_InheritedObjFPCStrictPrivateFail;
+    Procedure TestClassHelper_InheritedClassObjFPC;
+    Procedure TestClassHelper_InheritedDelphi;
+    Procedure TestClassHelper_NestedInheritedParentFail;
+    Procedure TestClassHelper_AccessFields;
+    Procedure TestClassHelper_CallClassMethodFail;
+    Procedure TestClassHelper_WithHelperFail;
+    Procedure TestClassHelper_AsTypeFail;
+    Procedure TestClassHelper_Enumerator;
+    Procedure TestClassHelper_FromUnitInterface;
+    Procedure TestClassHelper_Constructor_NewInstance;
+    Procedure TestClassHelper_ReintroduceHides_CallFail;
+    Procedure TestClassHelper_DefaultProperty;
+    Procedure TestClassHelper_DefaultClassProperty;
+    Procedure TestClassHelper_MultipleScopeHelpers;
+    Procedure TestRecordHelper;
+    Procedure TestRecordHelper_InheritedObjFPC;
+    Procedure TestRecordHelper_Constructor_NewInstance;
+    Procedure TestTypeHelper;
+    Procedure TestTypeHelper_HelperForProcTypeFail;
+    Procedure TestTypeHelper_DefaultPropertyFail;
+    Procedure TestTypeHelper_Enum;
+    Procedure TestTypeHelper_EnumDotValueFail;
+    Procedure TestTypeHelper_EnumHelperDotProcFail;
+    Procedure TestTypeHelper_Enumerator;
+    Procedure TestTypeHelper_Constructor_NewInstance;
+    Procedure TestTypeHelper_InterfaceFail;
 
     // attributes
     Procedure TestAttributes_Ignore;
@@ -2757,6 +2797,20 @@ begin
   '  r=low(word)+high(int64);',
   '  s=low(longint)+high(integer);',
   '  t=succ(2)+pred(2);',
+  '  lo1:byte=lo(word($1234));',
+  '  hi1:byte=hi(word($1234));',
+  '  lo2:word=lo(longword($1234CDEF));',
+  '  hi2:word=hi(longword($1234CDEF));',
+  '  lo3:word=lo(LongInt(-$1234CDEF));',
+  '  hi3:word=hi(LongInt(-$1234CDEF));',
+  '  lo4:byte=lo(byte($34));',
+  '  hi4:byte=hi(byte($34));',
+  '  lo5:byte=lo(shortint(-$34));',
+  '  hi5:byte=hi(shortint(-$34));',
+  '  lo6:longword=lo($123456789ABCDEF0);',
+  '  hi6:longword=hi($123456789ABCDEF0);',
+  '  lo7:longword=lo(-$123456789ABCDEF0);',
+  '  hi7:longword=hi(-$123456789ABCDEF0);',
   'begin']);
   ParseProgram;
   CheckResolverUnexpectedHints;
@@ -3517,6 +3571,17 @@ begin
   CheckParserException('Const ranges are not allowed',nParserNoConstRangeAllowed);
 end;
 
+procedure TTestResolver.TestEnumDotValueFail;
+begin
+  StartProgram(false);
+  Add([
+  'type TFlag = (a,b,c);',
+  'var f: TFlag;',
+  'begin',
+  '  f:=f.a;']);
+  CheckResolverException('illegal qualifier "." after "f:TFlag"',nIllegalQualifierAfter);
+end;
+
 procedure TTestResolver.TestSets;
 begin
   StartProgram(false);
@@ -4308,6 +4373,10 @@ begin
   Add('  if i>=j then;');
   Add('  if i<j then;');
   Add('  if i<=j then;');
+  Add('  i:=lo($1234);');
+  Add('  i:=lo($1234CDEF);');
+  Add('  i:=hi($1234);');
+  Add('  i:=hi($1234CDEF);');
   ParseProgram;
 end;
 
@@ -5250,6 +5319,26 @@ begin
   CheckResolverException('Illegal expression',nIllegalExpression);
 end;
 
+procedure TTestResolver.TestLabelStatementFail;
+begin
+  StartProgram(false);
+  Add('var i: longint;');
+  Add('begin');
+  Add('  i: i;');
+  CheckParserException('Expected ";"',nParserExpectTokenError);
+end;
+
+procedure TTestResolver.TestLabelStatementDelphiFail;
+begin
+  StartProgram(false);
+  Add('{$mode delphi}');
+  Add('{$goto off}');
+  Add('var i: longint;');
+  Add('begin');
+  Add('  i: i;');
+  CheckParserException('Expected ";"',nParserExpectTokenError);
+end;
+
 procedure TTestResolver.TestUnitForwardOverloads;
 begin
   StartUnit(false);
@@ -7872,6 +7961,30 @@ begin
 end;
 
 procedure TTestResolver.TestAdvRecord_StrictPrivate;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  strict private',
+  '    FSize: longword;',
+  '    function GetSize: longword;',
+  '  public',
+  '    property Size: longword read GetSize write FSize;',
+  '  end;',
+  'function TRec.GetSize: longword;',
+  'begin',
+  '  FSize:=GetSize;',
+  'end;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  '  r.Size:=r.Size;']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_StrictPrivateFail;
 begin
   StartProgram(false);
   Add([
@@ -7885,7 +7998,7 @@ begin
   '  r: TRec;',
   'begin',
   '  r.a:=r.a;']);
-  CheckResolverException('Can''t access strict private member A',nCantAccessPrivateMember);
+  CheckResolverException('Can''t access strict private member A',nCantAccessXMember);
 end;
 
 procedure TTestResolver.TestAdvRecord_MethodImplMissingFail;
@@ -8027,8 +8140,16 @@ begin
   'begin',
   '  TRec.{#p}Create(4); // new object',
   '  r:=TRec.{#q}Create(5); // new object',
-  '  r.{#r}Create(6); // normal call',
-  '  r:=r.{#s}Create(7); // normal call',
+  '  with TRec do begin',
+  '    {#r}Create(6); // new object',
+  '    r:={#s}Create(7); // new object',
+  '  end;',
+  '  r.{#t}Create(8); // normal call',
+  '  r:=r.{#u}Create(9); // normal call',
+  '  with r do begin',
+  '    {#v}Create(10); // normal call',
+  '    r:={#w}Create(11); // normal call',
+  '  end;',
   '']);
   ParseProgram;
   aMarker:=FirstSrcMarker;
@@ -8053,7 +8174,7 @@ begin
         break;
         end;
       case aMarker^.Identifier of
-      'a','r','s':// should be normal call
+      'a','t','u','v','w':// should be normal call
         if ActualNewInstance then
           RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
       else // should be newinstance
@@ -8616,6 +8737,62 @@ begin
   CheckResolverException('Duplicate identifier "TObject" at afile.pp(3,10)',nDuplicateIdentifier);
 end;
 
+procedure TTestResolver.TestClassForwardDelphiFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  TBird = class;',
+  'const k = 1;',
+  'type',
+  '  TBird = class',
+  '  end;',
+  'begin']);
+  CheckResolverException('Forward type not resolved "TBird"',nForwardTypeNotResolved);
+end;
+
+procedure TTestResolver.TestClassForwardObjFPCProgram;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  TBird = class;',
+  'const k = 1;',
+  'type',
+  '  TBird = class',
+  '  end;',
+  'begin']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassForwardObjFPCUnit;
+begin
+  StartUnit(false);
+  Add([
+  '{$mode objfpc}',
+  'interface',
+  'type',
+  '  TObject = class end;',
+  '  TBird = class;',
+  'const k = 1;',
+  'type',
+  '  TBird = class',
+  '  end;',
+  'implementation',
+  'type',
+  '  TEagle = class;',
+  'const c = 1;',
+  'type',
+  '  TEagle = class',
+  '  end;',
+  '']);
+  ParseUnit;
+end;
+
 procedure TTestResolver.TestClass_Method;
 begin
   StartProgram(false);
@@ -9912,7 +10089,7 @@ begin
   Add('begin');
   Add('  if o.v=3 then ;');
   CheckResolverException('Can''t access private member v',
-    nCantAccessPrivateMember);
+    nCantAccessXMember);
 end;
 
 procedure TTestResolver.TestClass_PrivateInDescendantFail;
@@ -9940,7 +10117,7 @@ begin
   Add('end;');
   Add('begin');
   CheckResolverException('Can''t access private member v',
-    nCantAccessPrivateMember);
+    nCantAccessXMember);
 end;
 
 procedure TTestResolver.TestClass_ProtectedInDescendant;
@@ -10002,7 +10179,7 @@ begin
   Add('begin');
   Add('  if o.v=3 then ;');
   CheckResolverException('Can''t access strict private member v',
-    nCantAccessPrivateMember);
+    nCantAccessXMember);
 end;
 
 procedure TTestResolver.TestClass_StrictProtectedInMainBeginFail;
@@ -10017,7 +10194,7 @@ begin
   Add('begin');
   Add('  if o.v=3 then ;');
   CheckResolverException('Can''t access strict protected member v',
-    nCantAccessPrivateMember);
+    nCantAccessXMember);
 end;
 
 procedure TTestResolver.TestClass_Constructor_NewInstance;
@@ -10809,7 +10986,7 @@ begin
   '  Arm: TObject.TArm;',
   'begin',
   '']);
-  CheckResolverException('Can''t access strict private member TArm',nCantAccessPrivateMember);
+  CheckResolverException('Can''t access strict private member TArm',nCantAccessXMember);
 end;
 
 procedure TTestResolver.TestNestedClass_AccessStrictPrivate;
@@ -11580,6 +11757,42 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestPropertyReadAccessorStrictPrivate;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  strict private',
+  '    FSize: word;',
+  '    property Size: word read FSize;',
+  '  strict protected',
+  '    FName: string;',
+  '    property Name: string read FName;',
+  '  end;',
+  '  TBird = class',
+  '  strict protected',
+  '    property Caption: string read FName;',
+  '  end;',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestPropertyReadAccessorNonClassFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    FSize: word;',
+  '    class property Size: word read FSize;',
+  '  end;',
+  'begin',
+  '']);
+  CheckResolverException('class var expected, but var found',nXExpectedButYFound);
+end;
+
 procedure TTestResolver.TestPropertyWriteAccessorVarWrongType;
 begin
   StartProgram(false);
@@ -11665,19 +11878,27 @@ end;
 procedure TTestResolver.TestPropertyTypeless;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  {#TOBJ}TObject = class');
-  Add('    {#FB}FB: longint;');
-  Add('    property {#TOBJ_B}B: longint write {@FB}FB;');
-  Add('  end;');
-  Add('  {#TA}TClassA = class');
-  Add('    {#FC}FC: longint;');
-  Add('    property {#TA_B}{@TOBJ_B}B write {@FC}FC;');
-  Add('  end;');
-  Add('var');
-  Add('  {#v}{=TA}v: TClassA;');
-  Add('begin');
-  Add('  {@v}v.{@TA_B}B:=3;');
+  Add([
+  'type',
+  '  {#TOBJ}TObject = class',
+  '    {#FB}FB: longint;',
+  '    property {#TOBJ_B}B: longint write {@FB}FB;',
+  '    property {#TOBJ_D}D: longint write {@FB}FB;',
+  '  end;',
+  '  {#TA}TClassA = class',
+  '    {#FC}FC: longint;',
+  '    property {#TA_B}{@TOBJ_B}B write {@FC}FC;',
+  '  end;',
+  '  {#TB}TClassB = class(TClassA)',
+  '  published',
+  '    property {#TB_D}{@TOBJ_D}D;',
+  '  end;',
+  'var',
+  '  {#v}{=TA}v: TClassA;',
+  'begin',
+  '  {@v}v.{@TA_B}B:=3;',
+  '  {@v}v.{@TObj_D}D:=4;',
+  '']);
   ParseProgram;
 end;
 
@@ -12024,25 +12245,26 @@ end;
 procedure TTestResolver.TestDefaultProperty;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  TObject = class');
-  Add('    function GetB(Index: longint): longint;');
-  Add('    procedure SetB(Index: longint; Value: longint);');
-  Add('    property B[Index: longint]: longint read GetB write SetB; default;');
-  Add('  end;');
-  Add('function TObject.GetB(Index: longint): longint;');
-  Add('begin');
-  Add('end;');
-  Add('procedure TObject.SetB(Index: longint; Value: longint);');
-  Add('begin');
-  Add('  if Value=Self[Index] then ;');
-  Add('  Self[Index]:=Value;');
-  Add('end;');
-  Add('var o: TObject;');
-  Add('begin');
-  Add('  o[3]:=4;');
-  Add('  if o[5]=6 then;');
-  Add('  if 7=o[8] then;');
+  Add([
+  'type',
+  '  TObject = class',
+  '    function GetB(Index: longint): longint;',
+  '    procedure SetB(Index: longint; Value: longint);',
+  '    property B[Index: longint]: longint read GetB write SetB; default;',
+  '  end;',
+  'function TObject.GetB(Index: longint): longint;',
+  'begin',
+  'end;',
+  'procedure TObject.SetB(Index: longint; Value: longint);',
+  'begin',
+  '  if Value=Self[Index] then ;',
+  '  Self[Index]:=Value;',
+  'end;',
+  'var o: TObject;',
+  'begin',
+  '  o[3]:=4;',
+  '  if o[5]=6 then;',
+  '  if 7=o[8] then;']);
   ParseProgram;
 end;
 
@@ -12219,7 +12441,7 @@ begin
   '    constructor Create;',
   '  end;',
   'begin']);
-  CheckParserException(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
+  CheckParserException('constructor is not allowed in interface',nParserXNotAllowedInY);
 end;
 
 procedure TTestResolver.TestClassInterface_DelphiClassAncestorIntfFail;
@@ -15203,7 +15425,6 @@ begin
   '  PInteger = ^integer;',
   'var',
   '  i: integer;',
-  '  p1: PInteger;',
   'begin',
   '']);
   CheckResolverException('identifier not found "integer"',nIdentifierNotFound);
@@ -15496,7 +15717,7 @@ begin
   CheckResolverUnexpectedHints(true);
 end;
 
-procedure TTestResolver.ClassHelper;
+procedure TTestResolver.TestClassHelper;
 begin
   StartProgram(false);
   Add([
@@ -15523,7 +15744,7 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolver.ClassHelper_AncestorIsNotHelperForDescendantFail;
+procedure TTestResolver.TestClassHelper_AncestorIsNotHelperForDescendantFail;
 begin
   StartProgram(false);
   Add([
@@ -15544,7 +15765,25 @@ begin
     nDerivedXMustExtendASubClassY);
 end;
 
-procedure TTestResolver.ClassHelper_ForInterfaceFail;
+procedure TTestResolver.TestClassHelper_HelperForParentFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TBird = class(TObject)',
+  '  type',
+  '    TBirdHelper = class helper for TBird',
+  '    end;',
+  '  end;',
+  'begin',
+  '']);
+  CheckResolverException(sTypeXIsNotYetCompletelyDefined,
+    nTypeXIsNotYetCompletelyDefined);
+end;
+
+procedure TTestResolver.TestClassHelper_ForInterfaceFail;
 begin
   StartProgram(false);
   Add([
@@ -15560,7 +15799,7 @@ begin
     nXExpectedButYFound);
 end;
 
-procedure TTestResolver.ClassHelper_FieldFail;
+procedure TTestResolver.TestClassHelper_FieldFail;
 begin
   StartProgram(false);
   Add([
@@ -15576,7 +15815,7 @@ begin
     nParserNoFieldsAllowed);
 end;
 
-procedure TTestResolver.ClassHelper_AbstractFail;
+procedure TTestResolver.TestClassHelper_AbstractFail;
 begin
   StartProgram(false);
   Add([
@@ -15593,7 +15832,7 @@ begin
     nInvalidXModifierY);
 end;
 
-procedure TTestResolver.ClassHelper_VirtualObjFPCFail;
+procedure TTestResolver.TestClassHelper_VirtualObjFPCFail;
 begin
   StartProgram(false);
   Add([
@@ -15611,47 +15850,1126 @@ begin
     nInvalidXModifierY);
 end;
 
-procedure TTestResolver.RecordHelper;
+procedure TTestResolver.TestClassHelper_VirtualDelphiFail;
 begin
   StartProgram(false);
   Add([
   '{$mode delphi}',
   'type',
-  '  TRec = record',
+  '  TObject = class',
   '  end;',
-  '  TRecHelper = record helper for TRec',
-  '  type T = word;',
-  '  const',
-  '    c: T = 3;',
-  '    k: T = 4;',
-  '  class var',
-  '    v: T;',
-  '    w: T;',
+  '  TObjHelper = class helper for TObject',
+  '    procedure DoIt; virtual;',
   '  end;',
-  '  TAnt = word;',
-  '  TAntHelper = record helper for TAnt',
+  'procedure TObjHelper.DoIt;',
+  'begin end;',
+  'begin',
+  '']);
+  CheckResolverException('Invalid class helper procedure modifier virtual',
+    nInvalidXModifierY);
+end;
+
+procedure TTestResolver.TestClassHelper_DestructorFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TObjHelper = class helper for TObject',
+  '    destructor Destroyer;',
+  '  end;',
+  'destructor TObjHelper.Destroyer;',
+  'begin end;',
+  'begin',
+  '']);
+  CheckParserException('destructor is not allowed in class helper',
+    nParserXNotAllowedInY);
+end;
+
+procedure TTestResolver.TestClassHelper_ClassRefersToTypeHelperOfAncestor;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TObjHelper = class helper for TObject',
+  '  type',
+  '    TInt = word;',
+  '    function GetSize: TInt;',
   '  end;',
+  '  TAnt = class',
+  '    procedure SetSize(Value: TInt);',
+  '    property Size: TInt read GetSize write SetSize;',
+  '  end;',
+  'function Tobjhelper.getSize: TInt;',
+  'begin',
+  'end;',
+  'procedure TAnt.SetSize(Value: TInt);',
+  'begin',
+  'end;',
   'begin',
   '']);
   ParseProgram;
 end;
 
-procedure TTestResolver.TypeHelper;
+procedure TTestResolver.TestClassHelper_InheritedObjFPC;
 begin
   StartProgram(false);
   Add([
-  '{$modeswitch typehelpers}',
   'type',
-  '  TStringHelper = type helper for string',
+  '  TObject = class',
+  '    procedure {#TObject_Fly}Fly;',
   '  end;',
-  '  TCaption = string;',
-  '  TCapHelper = type helper(TStringHelper) for TCaption',
+  '  TObjHelper = class helper for TObject',
+  '    procedure {#TObjHelper_Fly}Fly;',
+  '  end;',
+  '  TBird = class',
+  '    procedure {#TBird_Fly}Fly;',
+  '  end;',
+  '  TBirdHelper = class helper for TBird',
+  '    procedure {#TBirdHelper_Fly}Fly;',
+  '    procedure {#TBirdHelper_Walk}Walk;',
+  '  end;',
+  '  TEagleHelper = class helper(TBirdHelper) for TBird',
+  '    procedure {#TEagleHelper_Fly}Fly;',
+  '    procedure {#TEagleHelper_Walk}Walk;',
   '  end;',
+  'procedure Tobject.fly;',
+  'begin',
+  '  inherited;', // ignore
+  'end;',
+  'procedure Tobjhelper.fly;',
   'begin',
+  '  {@TObject_Fly}inherited;',
+  '  inherited {@TObject_Fly}Fly;',
+  'end;',
+  'procedure Tbird.fly;',
+  'begin',
+  '  {@TObjHelper_Fly}inherited;',
+  '  inherited {@TObjHelper_Fly}Fly;',
+  'end;',
+  'procedure Tbirdhelper.fly;',
+  'begin',
+  '  {@TBird_Fly}inherited;',
+  '  inherited {@TBird_Fly}Fly;',
+  'end;',
+  'procedure Tbirdhelper.walk;',
+  'begin',
+  'end;',
+  'procedure teagleHelper.fly;',
+  'begin',
+  '  {@TBird_Fly}inherited;',
+  '  inherited {@TBird_Fly}Fly;',
+  'end;',
+  'procedure teagleHelper.walk;',
+  'begin',
+  '  {@TBirdHelper_Walk}inherited;',
+  '  inherited {@TBirdHelper_Walk}Walk;',
+  'end;',
+  'var',
+  '  o: TObject;',
+  '  b: TBird;',
+  'begin',
+  '  o.{@TObjHelper_Fly}Fly;',
+  '  b.{@TEagleHelper_Fly}Fly;',
   '']);
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClassHelper_InheritedObjFPC2;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure {#TObject_Fly}Fly;',
+  '  end;',
+  '  TObjHelper = class helper for TObject',
+  '    procedure {#TObjHelper_Walk}Walk;',
+  '  end;',
+  '  TBird = class',
+  '    procedure {#TBird_Fly}Fly;',
+  '  end;',
+  '  TBirdHelper = class helper for TBird',
+  '    procedure {#TBirdHelper_Walk}Walk;',
+  '  end;',
+  '  TEagleHelper = class helper(TBirdHelper) for TBird',
+  '    procedure {#TEagleHelper_Walk}Walk;',
+  '  end;',
+  'procedure Tobject.fly;',
+  'begin',
+  '  inherited;', // ignore
+  'end;',
+  'procedure Tobjhelper.walk;',
+  'begin',
+  '  inherited;', // ignore
+  'end;',
+  'procedure Tbird.fly;',
+  'begin',
+  '  {@TObject_Fly}inherited;', // no helper, search further in ancestor
+  '  inherited {@TObject_Fly}Fly;', // no helper, search further in ancestor
+  'end;',
+  'procedure Tbirdhelper.walk;',
+  'begin',
+  '  {@TObjHelper_Walk}inherited;',
+  '  inherited {@TObjHelper_Walk}Walk;',
+  'end;',
+  'procedure teagleHelper.walk;',
+  'begin',
+  '  {@TObjHelper_Walk}inherited;',
+  '  inherited {@TObjHelper_Walk}Walk;',
+  'end;',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_InheritedObjFPCStrictPrivateFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  strict private i: word;',
+  '  end;',
+  '  THelper = class helper for TObject',
+  '    property a: word read i;',
+  '  end;',
+  'begin',
+  '']);
+  CheckResolverException('Can''t access strict private member i',nCantAccessXMember);
+end;
+
+procedure TTestResolver.TestClassHelper_InheritedClassObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    class procedure {#TObject_Fly}Fly;',
+  '  end;',
+  '  TObjHelper = class helper for TObject',
+  '    class procedure {#TObjHelper_Fly}Fly;',
+  '  end;',
+  '  TBird = class',
+  '    class procedure {#TBird_Fly}Fly;',
+  '  end;',
+  '  TBirdHelper = class helper for TBird',
+  '    class procedure {#TBirdHelper_Fly}Fly;',
+  '    class procedure {#TBirdHelper_Walk}Walk;',
+  '  end;',
+  '  TEagleHelper = class helper(TBirdHelper) for TBird',
+  '    class procedure {#TEagleHelper_Fly}Fly;',
+  '    class procedure {#TEagleHelper_Walk}Walk;',
+  '  end;',
+  'class procedure Tobject.fly;',
+  'begin',
+  '  inherited;', // ignore
+  'end;',
+  'class procedure Tobjhelper.fly;',
+  'begin',
+  '  {@TObject_Fly}inherited;',
+  '  inherited {@TObject_Fly}Fly;',
+  'end;',
+  'class procedure Tbird.fly;',
+  'begin',
+  '  {@TObjHelper_Fly}inherited;',
+  '  inherited {@TObjHelper_Fly}Fly;',
+  'end;',
+  'class procedure Tbirdhelper.fly;',
+  'begin',
+  '  {@TBird_Fly}inherited;',
+  '  inherited {@TBird_Fly}Fly;',
+  'end;',
+  'class procedure Tbirdhelper.walk;',
+  'begin',
+  'end;',
+  'class procedure teagleHelper.fly;',
+  'begin',
+  '  {@TBird_Fly}inherited;',
+  '  inherited {@TBird_Fly}Fly;',
+  'end;',
+  'class procedure teagleHelper.walk;',
+  'begin',
+  '  {@TBirdHelper_Walk}inherited;',
+  '  inherited {@TBirdHelper_Walk}Walk;',
+  'end;',
+  'var',
+  '  o: TObject;',
+  '  b: TBird;',
+  'begin',
+  '  o.{@TObjHelper_Fly}Fly;',
+  '  TObject.{@TObjHelper_Fly}Fly;',
+  '  b.{@TEagleHelper_Fly}Fly;',
+  '  TBird.{@TEagleHelper_Fly}Fly;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_InheritedDelphi;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class',
+  '    procedure {#TObject_Fly}Fly;',
+  '  end;',
+  '  TObjHelper = class helper for TObject',
+  '    procedure {#TObjHelper_Fly}Fly;',
+  '  end;',
+  '  TBird = class',
+  '    procedure {#TBird_Fly}Fly;',
+  '  end;',
+  '  TBirdHelper = class helper for TBird',
+  '    procedure {#TBirdHelper_Fly}Fly;',
+  '    procedure {#TBirdHelper_Walk}Walk;',
+  '  end;',
+  '  TEagleHelper = class helper(TBirdHelper) for TBird',
+  '    procedure {#TEagleHelper_Fly}Fly;',
+  '    procedure {#TEagleHelper_Walk}Walk;',
+  '  end;',
+  'procedure Tobject.fly;',
+  'begin',
+  '  inherited;', // ignore
+  'end;',
+  'procedure Tobjhelper.fly;',
+  'begin',
+  '  inherited;', // ignore
+  '  inherited {@TObject_Fly}Fly;',
+  'end;',
+  'procedure Tbird.fly;',
+  'begin',
+  '  {@TObjHelper_Fly}inherited;',
+  '  inherited {@TObjHelper_Fly}Fly;',
+  'end;',
+  'procedure Tbirdhelper.fly;',
+  'begin',
+  '  {@TObjHelper_Fly}inherited;',// skip helperfortype too
+  '  inherited {@TBird_Fly}Fly;',
+  'end;',
+  'procedure Tbirdhelper.walk;',
+  'begin',
+  'end;',
+  'procedure teagleHelper.fly;',
+  'begin',
+  '  {@TObjHelper_Fly}inherited;',// skip helperfortype too
+  '  inherited {@TBird_Fly}Fly;',
+  'end;',
+  'procedure teagleHelper.walk;',
+  'begin',
+  '  inherited;', // ignore
+  '  inherited {@TBirdHelper_Walk}Walk;',
+  'end;',
+  'var',
+  '  o: TObject;',
+  '  b: TBird;',
+  'begin',
+  '  o.{@TObjHelper_Fly}Fly;',
+  '  b.{@TEagleHelper_Fly}Fly;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_NestedInheritedParentFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TBird = class',
+  '    procedure Fly;',
+  '  type',
+  '    TBirdHelper = class helper for TObject',
+  '      procedure Fly;',
+  '    end;',
+  '  end;',
+  'procedure TBird.fly;',
+  'begin',
+  'end;',
+  'procedure TBird.Tbirdhelper.fly;',
+  'begin',
+  '  inherited Fly;',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('identifier not found "Fly"',nIdentifierNotFound);
+end;
+
+procedure TTestResolver.TestClassHelper_AccessFields;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  TBird = class',
+  '    Size: word;',
+  '    FItems: array of word;',
+  '  end;',
+  '  TBirdHelper = class helper for TBird',
+  '    procedure Fly;',
+  '  end;',
+  'procedure TBirdHelper.Fly;',
+  'begin',
+  '  Size:=FItems[0];',
+  '  Self.Size:=Self.FItems[0];',
+  'end;',
+  'var',
+  '  b: TBird;',
+  'begin',
+  '  b.Fly;',
+  '  b.Fly()',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_CallClassMethodFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  THelper = class helper for TObject',
+  '    class procedure Fly;',
+  '  end;',
+  'class procedure THelper.Fly;',
+  'begin',
+  'end;',
+  'begin',
+  '  THelper.Fly;',
+  '']);
+  CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
+end;
+
+procedure TTestResolver.TestClassHelper_WithHelperFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  THelper = class helper for TObject',
+  '  end;',
+  'begin',
+  '  with THelper do ;',
+  '']);
+  CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
+end;
+
+procedure TTestResolver.TestClassHelper_AsTypeFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  THelper = class helper for TObject',
+  '  end;',
+  'var h: THelper;',
+  'begin',
+  '']);
+  CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
+end;
+
+procedure TTestResolver.TestClassHelper_Enumerator;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  TItem = TObject;',
+  '  TEnumerator = class',
+  '    FCurrent: TItem;',
+  '    property Current: TItem read FCurrent;',
+  '    function MoveNext: boolean;',
+  '  end;',
+  '  TBird = class',
+  '    FItems: array of TItem;',
+  '  end;',
+  '  TBirdHelper = class helper for TBird',
+  '    function GetEnumerator: TEnumerator;',
+  '  end;',
+  'function TEnumerator.MoveNext: boolean;',
+  'begin',
+  'end;',
+  'function TBirdHelper.GetEnumerator: TEnumerator;',
+  'begin',
+  '  Result.FCurrent:=FItems[0];',
+  '  Result.FCurrent:=Self.FItems[0];',
+  'end;',
+  'var',
+  '  b: TBird;',
+  '  i: TItem;',
+  '  {#i2}i2: TItem;',
+  'begin',
+  '  for i in b do {@i2}i2:=i;']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_FromUnitInterface;
+begin
+  AddModuleWithIntfImplSrc('unit2.pas',
+    LinesToStr([
+    'type',
+    '  TObject = class',
+    '  public',
+    '    Id: word;',
+    '  end;',
+    '  TObjHelper = class helper for TObject',
+    '    property Size: word read ID write ID;',
+    '  end;',
+    '']),
+    '');
+  AddModuleWithIntfImplSrc('unit3.pas',
+    LinesToStr([
+    'uses unit2;',
+    'type',
+    '  TObjHelper = class helper for TObject',
+    '    property Size: word read ID write ID;',
+    '  end;',
+    '']),
+    '');
+  StartProgram(true);
+  Add([
+  'uses unit2, unit3;',
+  'var o: TObject;',
+  'begin',
+  '  o.Size:=o.Size;']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_Constructor_NewInstance;
+var
+  aMarker: PSrcMarker;
+  Elements: TFPList;
+  i: Integer;
+  El: TPasElement;
+  Ref: TResolvedReference;
+  ActualNewInstance, ActualImplicitCallWithoutParams: Boolean;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  THelper = class helper for TObject',
+  '    constructor Create;',
+  '    class function DoSome: TObject;',
+  '  end;',
+  'constructor THelper.Create;',
+  'begin',
+  '  {#a}Create; // normal call',
+  '  TObject.{#b}Create; // new instance',
+  'end;',
+  'class function THelper.DoSome: TObject;',
+  'begin',
+  '  Result:={#c}Create; // new instance',
+  'end;',
+  'var',
+  '  o: TObject;',
+  'begin',
+  '  TObject.{#p}Create; // new object',
+  '  o:=TObject.{#q}Create; // new object',
+  '  with TObject do begin',
+  '    {#r}Create; // new object',
+  '    o:={#s}Create; // new object',
+  '  end;',
+  '  o.{#t}Create; // normal call',
+  '  o:=o.{#u}Create; // normal call',
+  '  with o do begin',
+  '    {#v}Create; // normal call',
+  '    o:={#w}Create; // normal call',
+  '  end;',
+  '']);
+  ParseProgram;
+  aMarker:=FirstSrcMarker;
+  while aMarker<>nil do
+    begin
+    //writeln('TTestResolver.TestClassHelper_Constructor_NewInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
+    Elements:=FindElementsAt(aMarker);
+    try
+      ActualNewInstance:=false;
+      ActualImplicitCallWithoutParams:=false;
+      for i:=0 to Elements.Count-1 do
+        begin
+        El:=TPasElement(Elements[i]);
+        //writeln('TTestResolver.TestClassHelper_Constructor_NewInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
+        if not (El.CustomData is TResolvedReference) then continue;
+        Ref:=TResolvedReference(El.CustomData);
+        if not (Ref.Declaration is TPasProcedure) then continue;
+        //writeln('TTestResolver.TestClassHelper_Constructor_NewInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags);
+        if (Ref.Declaration is TPasConstructor) then
+          ActualNewInstance:=rrfNewInstance in Ref.Flags;
+        ActualImplicitCallWithoutParams:=rrfImplicitCallWithoutParams in Ref.Flags;
+        break;
+        end;
+      if not ActualImplicitCallWithoutParams then
+        RaiseErrorAtSrcMarker('expected implicit call at "#'+aMarker^.Identifier+', but got function ref"',aMarker);
+      case aMarker^.Identifier of
+      'a','t','u','v','w':// should be normal call
+        if ActualNewInstance then
+          RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
+      else // should be newinstance
+        if not ActualNewInstance then
+          RaiseErrorAtSrcMarker('expected newinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker);
+      end;
+    finally
+      Elements.Free;
+    end;
+    aMarker:=aMarker^.Next;
+    end;
+end;
+
+procedure TTestResolver.TestClassHelper_ReintroduceHides_CallFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    constructor Create(o: tobject);',
+  '  end;',
+  '  TBird = class helper for TObject',
+  '    constructor Create(i: longint); reintroduce;',
+  '  end;',
+  'constructor tobject.Create(o: tobject); begin end;',
+  'constructor tbird.Create(i: longint); begin end;',
+  'var o: TObject;',
+  'begin',
+  '  o:=TObject.Create(nil);',
+  '']);
+  CheckResolverException('Incompatible type arg no. 1: Got "Nil", expected "Longint"',
+    nIncompatibleTypeArgNo);
+end;
+
+procedure TTestResolver.TestClassHelper_DefaultProperty;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    function GetB(Index: longint): longint;',
+  '    procedure SetB(Index: longint; Value: longint);',
+  '  end;',
+  '  THelper = class helper for TObject',
+  '    property B[Index: longint]: longint read GetB write SetB; default;',
+  '  end;',
+  'function TObject.GetB(Index: longint): longint;',
+  'begin',
+  'end;',
+  'procedure TObject.SetB(Index: longint; Value: longint);',
+  'begin',
+  '  if Value=Self[Index] then ;',
+  '  Self[Index]:=Value;',
+  'end;',
+  'var o: TObject;',
+  'begin',
+  '  o[3]:=4;',
+  '  if o[5]=6 then;',
+  '  if 7=o[8] then;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_DefaultClassProperty;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TClass = class of TObject;',
+  '  TObject = class',
+  '    class function GetB(Index: longint): longint; static;',
+  '    class procedure SetB(Index: longint; Value: longint); static;',
+  '  end;',
+  '  THelper = class helper for TObject',
+  '    class property B[Index: longint]: longint read GetB write SetB; default;',
+  '  end;',
+  'class function TObject.GetB(Index: longint): longint;',
+  'begin',
+  'end;',
+  'class procedure TObject.SetB(Index: longint; Value: longint);',
+  'begin',
+  '  if Value=TObject[Index] then ;',
+  '  TObject[Index]:=Value;',
+  'end;',
+  'var c: TClass;',
+  'begin',
+  '  c[3]:=4;',
+  '  if c[5]=6 then;',
+  '  if 7=c[8] then;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestClassHelper_MultipleScopeHelpers;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch multiplescopehelpers}',
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TFlyHelper = class helper for TObject',
+  '    procedure {#Fly}Fly;',
+  '    procedure {#FlyMove}Move;',
+  '  end;',
+  '  TRunHelper = class helper for TObject',
+  '    procedure {#Run}Run;',
+  '    procedure {#RunMove}Move;',
+  '    procedure {#RunBack}Back;',
+  '  end;',
+  '  TSwimHelper = class helper for TObject',
+  '    procedure {#Swim}Swim;',
+  '    procedure {#SwimBack}Back;',
+  '  end;',
+  'procedure TFlyHelper.Fly; begin end;',
+  'procedure TFlyHelper.Move; begin end;',
+  'procedure TRunHelper.Run; begin end;',
+  'procedure TRunHelper.Move; begin end;',
+  'procedure TRunHelper.Back; begin end;',
+  'procedure TSwimHelper.Swim; begin end;',
+  'procedure TSwimHelper.Back; begin end;',
+  'var o: TObject;',
+  'begin',
+  '  o.{@Fly}Fly;',
+  '  o.{@Run}Run;',
+  '  o.{@Swim}Swim;',
+  '  o.{@RunMove}Move;',
+  '  o.{@SwimBack}Back;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestRecordHelper;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TProc = procedure of object;',
+  '  TRec = record',
+  '    x: word;',
+  '  end;',
+  '  TRecHelper = record helper for TRec',
+  '  type T = word;',
+  '  const',
+  '    c: T = 3;',
+  '    k: T = 4;',
+  '  class var',
+  '    v: T;',
+  '    w: T;',
+  '    procedure Fly;',
+  '  end;',
+  '  TAnt = word;',
+  '  TAntHelper = record helper for TAnt',
+  '  end;',
+  'procedure TRecHelper.Fly;',
+  'var',
+  '  r: TRec;',
+  '  p: TProc;',
+  'begin',
+  '  Self:=r;',
+  '  r:=Self;',
+  '  c:=v+x;',
+  '  x:=k+w;',
+  '  p:=Fly;',
+  'end;',
+  'var',
+  '  r: TRec;',
+  '  p: TProc;',
+  'begin',
+  '  p:=r.Fly;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestRecordHelper_InheritedObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '    procedure {#TRec_Fly}Fly;',
+  '  end;',
+  '  TRecHelper = record helper for TRec',
+  '    procedure {#TRecHelper_Fly}Fly;',
+  '    procedure {#TRecHelper_Walk}Walk;',
+  '    procedure {#TRecHelper_Run}Run;',
+  '  end;',
+  '  TEagleHelper = record helper(TRecHelper) for TRec',
+  '    procedure {#TEagleHelper_Fly}Fly;',
+  '    procedure {#TEagleHelper_Run}Run;',
+  '  end;',
+  'procedure TRec.fly;',
+  'begin',
+  'end;',
+  'procedure TRechelper.fly;',
+  'begin',
+  '  {@TRec_Fly}inherited;',
+  '  inherited {@TRec_Fly}Fly;',
+  'end;',
+  'procedure TRechelper.walk;',
+  'begin',
+  '  inherited;', // ignore
+  'end;',
+  'procedure TRechelper.run;',
+  'begin',
+  '  inherited;', // ignore
+  'end;',
+  'procedure teagleHelper.fly;',
+  'begin',
+  '  {@TRec_Fly}inherited;',
+  '  inherited {@TRec_Fly}Fly;',
+  'end;',
+  'procedure teagleHelper.run;',
+  'begin',
+  '  {@TRecHelper_Run}inherited;',
+  '  inherited {@TRecHelper_Run}Run;',
+  'end;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  '  r.{@TEagleHelper_Fly}Fly;',
+  '  r.{@TRecHelper_Walk}Walk;',
+  '  r.{@TEagleHelper_Run}Run;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestRecordHelper_Constructor_NewInstance;
+var
+  aMarker: PSrcMarker;
+  Elements: TFPList;
+  ActualNewInstance: Boolean;
+  i: Integer;
+  El: TPasElement;
+  Ref: TResolvedReference;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TRec = record',
+  '    constructor Create(w: word);',
+  '    class function DoSome: TRec; static;',
+  '  end;',
+  'constructor TRec.Create(w: word);',
+  'begin',
+  '  {#a}Create(1); // normal call',
+  '  TRec.{#b}Create(2); // new instance',
+  'end;',
+  'class function TRec.DoSome: TRec;',
+  'begin',
+  '  Result:={#c}Create(3); // new instance',
+  'end;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  '  TRec.{#p}Create(4); // new object',
+  '  r:=TRec.{#q}Create(5); // new object',
+  '  with TRec do begin',
+  '    {#r}Create(6); // new object',
+  '    r:={#s}Create(7); // new object',
+  '  end;',
+  '  r.{#t}Create(8); // normal call',
+  '  r:=r.{#u}Create(9); // normal call',
+  '  with r do begin',
+  '    {#v}Create(10); // normal call',
+  '    r:={#w}Create(11); // normal call',
+  '  end;',
+  '']);
+  ParseProgram;
+  aMarker:=FirstSrcMarker;
+  while aMarker<>nil do
+    begin
+    //writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
+    Elements:=FindElementsAt(aMarker);
+    try
+      ActualNewInstance:=false;
+      for i:=0 to Elements.Count-1 do
+        begin
+        El:=TPasElement(Elements[i]);
+        //writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
+        if not (El.CustomData is TResolvedReference) then continue;
+        Ref:=TResolvedReference(El.CustomData);
+        if not (Ref.Declaration is TPasProcedure) then continue;
+        //writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags);
+        if (Ref.Declaration is TPasConstructor) then
+          ActualNewInstance:=rrfNewInstance in Ref.Flags;
+        if rrfImplicitCallWithoutParams in Ref.Flags then
+          RaiseErrorAtSrcMarker('unexpected implicit call at "#'+aMarker^.Identifier+' ref"',aMarker);
+        break;
+        end;
+      case aMarker^.Identifier of
+      'a','t','u','v','w':// should be normal call
+        if ActualNewInstance then
+          RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
+      else // should be newinstance
+        if not ActualNewInstance then
+          RaiseErrorAtSrcMarker('expected newinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker);
+      end;
+    finally
+      Elements.Free;
+    end;
+    aMarker:=aMarker^.Next;
+    end;
+end;
+
+procedure TTestResolver.TestTypeHelper;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TStringHelper = type helper for string',
+  '  end;',
+  '  TCaption = string;',
+  '  TCapHelper = type helper(TStringHelper) for TCaption',
+  '    procedure Fly;',
+  '  end;',
+  '  TProc = procedure of object;',
+  'procedure TCapHelper.Fly; begin end;',
+  'var',
+  '  c: TCaption;',
+  '  p: TProc;',
+  'begin',
+  '  c.Fly;',
+  '  p:[email protected];',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTypeHelper_HelperForProcTypeFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TProc = procedure;',
+  '  THelper = type helper for TProc',
+  '  end;',
+  'begin',
+  '']);
+  CheckResolverException('Type "TProc" cannot be extended by a type helper',
+    nTypeXCannotBeExtendedByATypeHelper);
+end;
+
+procedure TTestResolver.TestTypeHelper_DefaultPropertyFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TStringHelper = type helper for string',
+  '  end;',
+  '  TCaption = string;',
+  '  TCapHelper = type helper(TStringHelper) for TCaption',
+  '    function GetItems(Index: boolean): boolean;',
+  '    property Items[Index: boolean]: boolean read GetItems; default;',
+  '  end;',
+  'function TCapHelper.GetItems(Index: boolean): boolean; begin end;',
+  'begin',
+  '']);
+  CheckResolverException('Default property not allowed in helper for TCaption',
+    nDefaultPropertyNotAllowedInHelperForX);
+end;
+
+procedure TTestResolver.TestTypeHelper_Enum;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TFlag = (Red, Green, Blue);',
+  '  THelper = type helper for TFlag',
+  '    function toString: string;',
+  '    class procedure Fly;',
+  '  end;',
+  'function THelper.toString: string;',
+  'begin',
+  '  Self:=Red;',
+  '  if Self=TFlag.Blue then ;',
+  '  Result:=str(Self);',
+  'end;',
+  'class procedure THelper.Fly;',
+  'begin',
+  'end;',
+  'var',
+  '  f: TFlag;',
+  'begin',
+  '  f.toString;',
+  '  TFlag.Fly;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTypeHelper_EnumDotValueFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TFlag = (Red, Green, Blue);',
+  '  THelper = type helper for TFlag',
+  '  end;',
+  'var',
+  '  f: TFlag;',
+  'begin',
+  '  f:=f.red;',
+  '']);
+  CheckResolverException('identifier not found "red"',nIdentifierNotFound);
+end;
+
+procedure TTestResolver.TestTypeHelper_EnumHelperDotProcFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TFlag = (Red, Green, Blue);',
+  '  THelper = type helper for TFlag',
+  '    procedure Fly;',
+  '  end;',
+  'procedure THelper.Fly;',
+  'begin',
+  'end;',
+  'begin',
+  '  TFlag.Fly;',
+  '']);
+  CheckResolverException('Cannot access this member from a type helper',nCannotAccessThisMemberFromAX);
+end;
+
+procedure TTestResolver.TestTypeHelper_Enumerator;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TObject = class end;',
+  '  TItem = byte;',
+  '  TEnumerator = class',
+  '    FCurrent: TItem;',
+  '    property Current: TItem read FCurrent;',
+  '    function MoveNext: boolean;',
+  '  end;',
+  '  TWordHelper = type helper for Word',
+  '    function GetEnumerator: TEnumerator;',
+  '  end;',
+  'function TEnumerator.MoveNext: boolean;',
+  'begin',
+  'end;',
+  'function TWordHelper.GetEnumerator: TEnumerator;',
+  'begin',
+  '  if Self=2 then ;',
+  '  Self:=Self+3;',
+  'end;',
+  'var',
+  '  w: word;',
+  '  i: TItem;',
+  '  {#i2}i2: TItem;',
+  'begin',
+  '  w.GetEnumerator;',
+  '  for i in w do {@i2}i2:=i;']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTypeHelper_Constructor_NewInstance;
+var
+  aMarker: PSrcMarker;
+  Elements: TFPList;
+  ActualNewInstance: Boolean;
+  i: Integer;
+  El: TPasElement;
+  Ref: TResolvedReference;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  TInt = type word;',
+  '  THelper = type helper for TInt',
+  '    constructor Create(w: TInt);',
+  '    class function DoSome: TInt; static;',
+  '  end;',
+  'constructor THelper.Create(w: TInt);',
+  'begin',
+  '  {#a}Create(1); // normal call',
+  '  TInt.{#b}Create(2); // new instance',
+  'end;',
+  'class function THelper.DoSome: TInt;',
+  'begin',
+  '  Result:={#c}Create(3); // new instance',
+  'end;',
+  'var',
+  '  r: TInt;',
+  'begin',
+  '  TInt.{#p}Create(4); // new object',
+  '  r:=TInt.{#q}Create(5); // new object',
+  '  with TInt do begin',
+  '    {#r}Create(6); // new object',
+  '    r:={#s}Create(7); // new object',
+  '  end;',
+  '  r.{#t}Create(8); // normal call',
+  '  r:=r.{#u}Create(9); // normal call',
+  '  with r do begin',
+  '    {#v}Create(10); // normal call',
+  '    r:={#w}Create(11); // normal call',
+  '  end;',
+  '']);
+  ParseProgram;
+  aMarker:=FirstSrcMarker;
+  while aMarker<>nil do
+    begin
+    //writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
+    Elements:=FindElementsAt(aMarker);
+    try
+      ActualNewInstance:=false;
+      for i:=0 to Elements.Count-1 do
+        begin
+        El:=TPasElement(Elements[i]);
+        //writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
+        if not (El.CustomData is TResolvedReference) then continue;
+        Ref:=TResolvedReference(El.CustomData);
+        if not (Ref.Declaration is TPasProcedure) then continue;
+        //writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags);
+        if (Ref.Declaration is TPasConstructor) then
+          ActualNewInstance:=rrfNewInstance in Ref.Flags;
+        if rrfImplicitCallWithoutParams in Ref.Flags then
+          RaiseErrorAtSrcMarker('unexpected implicit call at "#'+aMarker^.Identifier+' ref"',aMarker);
+        break;
+        end;
+      case aMarker^.Identifier of
+      'a','t','u','v','w':// should be normal call
+        if ActualNewInstance then
+          RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
+      else // should be newinstance
+        if not ActualNewInstance then
+          RaiseErrorAtSrcMarker('expected newinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker);
+      end;
+    finally
+      Elements.Free;
+    end;
+    aMarker:=aMarker^.Next;
+    end;
+end;
+
+procedure TTestResolver.TestTypeHelper_InterfaceFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  IUnknown = interface end;',
+  '  THelper = type helper for IUnknown',
+  '  end;',
+  'begin',
+  '']);
+  CheckResolverException('Type "IUnknown" cannot be extended by a type helper',nTypeXCannotBeExtendedByATypeHelper);
+end;
+
 procedure TTestResolver.TestAttributes_Ignore;
 begin
   StartProgram(false);

packages/fcl-passrc/tests/tcstatements.pas

@@ -1794,7 +1794,9 @@ end;
 procedure TTestStatementParser.TestGotoInIfThen;
 
 begin
-  AddStatements(['if expr then',
+  AddStatements([
+  '{$goto on}',
+  'if expr then',
   '  dosomething',
   '   else if expr2 then',
   '    goto try_qword',

packages/graph/src/go32v2/graph.pp

@@ -155,9 +155,13 @@ const
      ScrWidth : word absolute $40:$4a;
      inWindows: boolean;
 
-{$ifndef tp}
   Procedure seg_bytemove(sseg : word;source : longint;dseg : word;dest : longint;count : longint); assembler;
     asm
+      {# Var sseg located in register ax
+       # Var source located in register edx
+       # Var dseg located in register cx
+       # Var dest located at ebp+12, size=OS_S32
+       # Var count located at ebp+8, size=OS_S32 }
       push edi
       push esi
       push es
@@ -173,14 +177,11 @@ const
       pop es
       pop esi
       pop edi
-    end ['ECX'];
-{$endif tp}
+    end;
 
  Procedure CallInt10(val_ax : word); assembler;
    asm
-{$IFNDEF REGCALL}
-     mov ax,val_ax
-{$ENDIF REGCALL}
+      {# Var val_ax located in register ax }
       push ebp
       push esi
       push edi
@@ -190,114 +191,125 @@ const
       pop edi
       pop esi
       pop ebp
-   end ['EAX'];
+   end;
 
-  procedure seg_xorword(segment : word;ofs : longint;count : longint;w : word);
-    begin
-      asm
-         push edi
-         mov edi, [ofs]
-         mov ecx, [count]
-         movzx edx, word ptr [w]
-         { load segment }
-         push es
-         mov ax, [segment]
-         mov es, ax
-         { fill eax }
-         mov eax, edx
-         shl eax, 16
-         or eax, edx
-         test edi, 3
-         jz @@aligned
-         xor word ptr es:[edi], ax
-         add edi, 2
-         dec ecx
-         jz @@done
+ Procedure InitInt10hMode(mode : byte);
+   begin
+     if DontClearGraphMemory then
+       CallInt10(mode or $80)
+     else
+       CallInt10(mode);
+   end;
+
+  procedure seg_xorword(segment : word;ofs : longint;count : longint;w : word); assembler;
+    asm
+      {# Var segment located in register ax
+       # Var ofs located in register edx
+       # Var count located in register ecx
+       # Var w located at ebp+8, size=OS_16 }
+      push edi
+      mov edi, edx
+      { load segment }
+      push es
+      mov es, ax
+      { fill eax }
+      movzx edx, word ptr [w]
+      mov eax, edx
+      shl eax, 16
+      or eax, edx
+      test edi, 3
+      jz @@aligned
+      xor word ptr es:[edi], ax
+      add edi, 2
+      dec ecx
+      jz @@done
 @@aligned:
-         mov edx, ecx
-         shr ecx, 1
-@@lp:    xor dword ptr es:[edi], eax
-         add edi, 4
-         dec ecx
-         jnz @@lp
-         test edx, 1
-         jz @@done
-         xor word ptr es:[edi], ax
-@@done:  pop es
-         pop edi
-      end;
+      mov edx, ecx
+      shr ecx, 1
+@@lp: xor dword ptr es:[edi], eax
+      add edi, 4
+      dec ecx
+      jnz @@lp
+      test edx, 1
+      jz @@done
+      xor word ptr es:[edi], ax
+@@done:
+      pop es
+      pop edi
     end;
 
-  procedure seg_orword(segment : word;ofs : longint;count : longint;w : word);
-    begin
-      asm
-         push edi
-         mov edi, [ofs]
-         mov ecx, [count]
-         movzx edx, word ptr [w]
-         { load segment }
-         push es
-         mov ax, [segment]
-         mov es, ax
-         { fill eax }
-         mov eax, edx
-         shl eax, 16
-         or eax, edx
-         test edi, 3
-         jz @@aligned
-         or word ptr es:[edi], ax
-         add edi, 2
-         dec ecx
-         jz @@done
+  procedure seg_orword(segment : word;ofs : longint;count : longint;w : word); assembler;
+    asm
+      {# Var segment located in register ax
+       # Var ofs located in register edx
+       # Var count located in register ecx
+       # Var w located at ebp+8, size=OS_16 }
+      push edi
+      mov edi, edx
+      { load segment }
+      push es
+      mov es, ax
+      { fill eax }
+      movzx edx, word ptr [w]
+      mov eax, edx
+      shl eax, 16
+      or eax, edx
+      test edi, 3
+      jz @@aligned
+      or word ptr es:[edi], ax
+      add edi, 2
+      dec ecx
+      jz @@done
 @@aligned:
-         mov edx, ecx
-         shr ecx, 1
-@@lp:    or dword ptr es:[edi], eax
-         add edi, 4
-         dec ecx
-         jnz @@lp
-         test edx, 1
-         jz @@done
-         or word ptr es:[edi], ax
-@@done:  pop es
-         pop edi
-      end;
+      mov edx, ecx
+      shr ecx, 1
+@@lp: or dword ptr es:[edi], eax
+      add edi, 4
+      dec ecx
+      jnz @@lp
+      test edx, 1
+      jz @@done
+      or word ptr es:[edi], ax
+@@done:
+      pop es
+      pop edi
     end;
 
-  procedure seg_andword(segment : word;ofs : longint;count : longint;w : word);
-    begin
-      asm
-         push edi
-         mov edi, [ofs]
-         mov ecx, [count]
-         movzx edx, word ptr [w]
-         { load segment }
-         push es
-         mov ax, [segment]
-         mov es, ax
-         { fill eax }
-         mov eax, edx
-         shl eax, 16
-         or eax, edx
-         test edi, 3
-         jz @@aligned
-         and word ptr es:[edi], ax
-         add edi, 2
-         dec ecx
-         jz @@done
+  procedure seg_andword(segment : word;ofs : longint;count : longint;w : word); assembler;
+    asm
+      {# Var segment located in register ax
+       # Var ofs located in register edx
+       # Var count located in register ecx
+       # Var w located at ebp+8, size=OS_16 }
+      push edi
+      mov edi, edx
+      { load segment }
+      push es
+      mov es, ax
+      { fill eax }
+      movzx edx, word ptr [w]
+      mov eax, edx
+      shl eax, 16
+      or eax, edx
+      test edi, 3
+      jz @@aligned
+      and word ptr es:[edi], ax
+      add edi, 2
+      dec ecx
+      jz @@done
 @@aligned:
-         mov edx, ecx
-         shr ecx, 1
-@@lp:    and dword ptr es:[edi], eax
-         add edi, 4
-         dec ecx
-         jnz @@lp
-         test edx, 1
-         jz @@done
-         and word ptr es:[edi], ax
-@@done:  pop es
-         pop edi
-      end;
+      mov edx, ecx
+      shr ecx, 1
+@@lp: and dword ptr es:[edi], eax
+      add edi, 4
+      dec ecx
+      jnz @@lp
+      test edx, 1
+      jz @@done
+      and word ptr es:[edi], ax
+@@done:
+      pop es
+      pop edi
     end;
 
 {************************************************************************}
@@ -671,9 +683,7 @@ var
 
 procedure SetCGAPalette(CGAPaletteID: Byte); assembler;
 asm
-{$IFNDEF REGCALL}
-  mov ax,val_ax
-{$ENDIF REGCALL}
+  {# Var CGAPaletteID located in register al }
   push ebp
   push esi
   push edi
@@ -690,9 +700,7 @@ end;
 
 procedure SetCGABorder(CGABorder: Byte); assembler;
 asm
-{$IFNDEF REGCALL}
-  mov ax,val_ax
-{$ENDIF REGCALL}
+  {# Var CGABorder located in register al }
   push ebp
   push esi
   push edi
@@ -722,10 +730,7 @@ end;
 
 procedure InitCGA320C0;
 begin
-  if DontClearGraphMemory then
-    CallInt10($84)
-  else
-    CallInt10($04);
+  InitInt10hMode($04);
   VideoOfs := 0;
   SetCGAPalette(0);
   SetCGABorder(16);
@@ -734,10 +739,7 @@ end;
 
 procedure InitCGA320C1;
 begin
-  if DontClearGraphMemory then
-    CallInt10($84)
-  else
-    CallInt10($04);
+  InitInt10hMode($04);
   VideoOfs := 0;
   SetCGAPalette(1);
   SetCGABorder(16);
@@ -746,10 +748,7 @@ end;
 
 procedure InitCGA320C2;
 begin
-  if DontClearGraphMemory then
-    CallInt10($84)
-  else
-    CallInt10($04);
+  InitInt10hMode($04);
   VideoOfs := 0;
   SetCGAPalette(2);
   SetCGABorder(0);
@@ -758,10 +757,7 @@ end;
 
 procedure InitCGA320C3;
 begin
-  if DontClearGraphMemory then
-    CallInt10($84)
-  else
-    CallInt10($04);
+  InitInt10hMode($04);
   VideoOfs := 0;
   SetCGAPalette(3);
   SetCGABorder(0);
@@ -1054,10 +1050,7 @@ end;
 
 procedure InitCGA640;
 begin
-  if DontClearGraphMemory then
-    CallInt10($86)
-  else
-    CallInt10($06);
+  InitInt10hMode($06);
   VideoOfs := 0;
   CurrentCGABorder := 0; {yes, TP7 CGA.BGI behaves *exactly* like that}
 end;
@@ -1365,10 +1358,7 @@ end;
 
 procedure InitMCGA640;
 begin
-  if DontClearGraphMemory then
-    CallInt10($91)
-  else
-    CallInt10($11);
+  InitInt10hMode($11);
   VideoOfs := 0;
   CurrentCGABorder := 0; {yes, TP7 CGA.BGI behaves *exactly* like that}
 end;
@@ -1664,20 +1654,14 @@ end;
 
   Procedure Init640x200x16;
     begin
-      if DontClearGraphMemory then
-        CallInt10($8e)
-      else
-        CallInt10($e);
+      InitInt10hMode($e);
       VideoOfs := 0;
     end;
 
 
    Procedure Init640x350x16;
     begin
-      if DontClearGraphMemory then
-        CallInt10($90)
-      else
-        CallInt10($10);
+      InitInt10hMode($10);
       VideoOfs := 0;
     end;
 
@@ -1685,21 +1669,17 @@ end;
 
   Procedure Init640x480x16;
     begin
-      if DontClearGraphMemory then
-        CallInt10($92)
-      else
-        CallInt10($12);
+      InitInt10hMode($12);
       VideoOfs := 0;
     end;
 
 
 
 
- Procedure PutPixel16(X,Y : smallint; Pixel: Word);
 {$ifndef asmgraph}
+ Procedure PutPixel16(X,Y : smallint; Pixel: Word);
  var offset: word;
      dummy: byte;
-{$endif asmgraph}
   Begin
     X:= X + StartXViewPort;
     Y:= Y + StartYViewPort;
@@ -1711,7 +1691,6 @@ end;
        if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
          exit;
      end;
-{$ifndef asmgraph}
      offset := y * 80 + (x shr 3) + VideoOfs;
      PortW[$3ce] := $0f01;       { Index 01 : Enable ops on all 4 planes }
      PortW[$3ce] := (Pixel and $ff) shl 8; { Index 00 : Enable correct plane and write color }
@@ -1721,7 +1700,20 @@ end;
      Mem[Sega000: offset] := dummy;  { Write the data into video memory }
      PortW[$3ce] := $ff08;         { Enable all bit planes.           }
      PortW[$3ce] := $0001;         { Index 01 : Disable ops on all four planes.         }
+   end;
 {$else asmgraph}
+ Procedure PutPixel16(X,Y : smallint; Pixel: Word);
+  Begin
+    X:= X + StartXViewPort;
+    Y:= Y + StartYViewPort;
+    { convert to absolute coordinates and then verify clipping...}
+    if ClipPixels then
+     Begin
+       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+         exit;
+       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+         exit;
+     end;
       asm
         push eax
         push ebx
@@ -1776,19 +1768,17 @@ end;
         pop ebx
         pop eax
       end;
-{$endif asmgraph}
    end;
+{$endif asmgraph}
 
 
- Function GetPixel16(X,Y: smallint):word;
 {$ifndef asmgraph}
+ Function GetPixel16(X,Y: smallint):word;
  Var dummy, offset: Word;
      shift: byte;
-{$endif asmgraph}
   Begin
     X:= X + StartXViewPort;
     Y:= Y + StartYViewPort;
-{$ifndef asmgraph}
     offset := Y * 80 + (x shr 3) + VideoOfs;
     PortW[$3ce] := $0004;
     shift := 7 - (X and 7);
@@ -1800,7 +1790,12 @@ end;
     Port[$3cf] := 3;
     dummy := dummy or (((Mem[Sega000:offset] shr shift) and 1) shl 3);
     GetPixel16 := dummy;
+  end;
 {$else asmgraph}
+ Function GetPixel16(X,Y: smallint):word;
+  Begin
+    X:= X + StartXViewPort;
+    Y:= Y + StartYViewPort;
     asm
       push eax
       push ebx
@@ -1876,8 +1871,8 @@ end;
       pop ebx
       pop eax
     end;
-{$endif asmgraph}
   end;
+{$endif asmgraph}
 
 Procedure GetScanLine16(x1, x2, y: smallint; var data);
 
@@ -2006,14 +2001,13 @@ Begin
 {$Endif logging}
 End;
 
+{$ifndef asmgraph}
  Procedure DirectPutPixel16(X,Y : smallint);
  { x,y -> must be in global coordinates. No clipping. }
   var
    color: word;
-{$ifndef asmgraph}
   offset: word;
   dummy: byte;
-{$endif asmgraph}
  begin
     If CurrentWriteMode <> NotPut Then
       Color := CurrentColor
@@ -2032,7 +2026,6 @@ End;
        else
          PortW[$3ce]:=$0003}
     end;
-{$ifndef asmgraph}
     offset := Y * 80 + (X shr 3) + VideoOfs;
     PortW[$3ce] := $f01;
     PortW[$3ce] := Color shl 8;
@@ -2045,7 +2038,30 @@ End;
        (CurrentWriteMode = ANDPut) or
        (CurrentWriteMode = ORPut) then
       PortW[$3ce] := $0003;
+ end;
 {$else asmgraph}
+ Procedure DirectPutPixel16(X,Y : smallint);
+ { x,y -> must be in global coordinates. No clipping. }
+  var
+   color: word;
+ begin
+    If CurrentWriteMode <> NotPut Then
+      Color := CurrentColor
+    else Color := not CurrentColor;
+
+    case CurrentWriteMode of
+       XORPut:
+         PortW[$3ce]:=((3 shl 3) shl 8) or 3;
+       ANDPut:
+         PortW[$3ce]:=((1 shl 3) shl 8) or 3;
+       ORPut:
+         PortW[$3ce]:=((2 shl 3) shl 8) or 3;
+       {not needed, this is the default state (e.g. PutPixel16 requires it)}
+       {NormalPut, NotPut:
+         PortW[$3ce]:=$0003
+       else
+         PortW[$3ce]:=$0003}
+    end;
 { note: still needs xor/or/and/notput support !!!!! (JM) }
     asm
       push eax
@@ -2101,8 +2117,8 @@ End;
       pop ebx
       pop eax
     end;
-{$endif asmgraph}
  end;
+{$endif asmgraph}
 
 
   procedure HLine16(x,x2,y: smallint);
@@ -2172,11 +2188,7 @@ End;
          if HLength>0 then
            begin
               Port[$3cf]:=$ff;
-{$ifndef tp}
               seg_bytemove(dosmemselector,$a0000+ScrOfs,dosmemselector,$a0000+ScrOfs,HLength);
-{$else}
-              move(Ptr(SegA000,ScrOfs)^, Ptr(SegA000,ScrOfs)^, HLength);
-{$endif}
               ScrOfs:=ScrOfs+HLength;
            end;
          Port[$3cf]:=RMask;
@@ -2254,78 +2266,32 @@ End;
   End;
 
 
- procedure SetVisual200(page: word);
-  { four page support... }
+ procedure SetVisual200_350(page: word);
   begin
     if page > HardwarePages then exit;
     asm
-      mov ax,[page]    { only lower byte is supPorted. }
+      mov ax,[page]    { only lower byte is supported. }
       mov ah,05h
-      push ebp
-      push esi
-      push edi
-      push ebx
       int 10h
-      pop ebx
-      pop edi
-      pop esi
-      pop ebp
-
-      { read start address }
-      mov dx,3d4h
-      mov al,0ch
-      out dx,al
-      inc dx
-      in  al,dx
-      mov ah,al
-      dec dx
-      mov al,0dh
-      out dx,al
-      in  al,dx
-    end ['EDX','EAX'];
+    end ['EAX','EBX','ECX','EDX','ESI','EDI','EBP'];
   end;
 
  procedure SetActive200(page: word);
   { four page support... }
   begin
-    case page of
-     0 : VideoOfs := 0;
-     1 : VideoOfs := 16384;
-     2 : VideoOfs := 32768;
-     3 : VideoOfs := 49152;
+    if (page >= 0) and (page <= 3) then
+      VideoOfs := page shl 14
     else
       VideoOfs := 0;
-    end;
-  end;
-
- procedure SetVisual350(page: word);
-  { one page supPort... }
-  begin
-    if page > HardwarePages then exit;
-    asm
-      mov ax,[page]    { only lower byte is supPorted. }
-      mov ah,05h
-      push ebp
-      push esi
-      push edi
-      push ebx
-      int 10h
-      pop ebx
-      pop edi
-      pop esi
-      pop ebp
-    end ['EAX'];
   end;
 
  procedure SetActive350(page: word);
   { one page supPort... }
   begin
-    case page of
-     0 : VideoOfs := 0;
-     1 : VideoOfs := 32768;
+    if page = 1 then
+      VideoOfs := 32768
     else
       VideoOfs := 0;
-    end;
   end;
 
 
@@ -2338,31 +2304,21 @@ End;
 
  Procedure Init320;
     begin
-      if DontClearGraphMemory then
-        CallInt10($93)
-      else
-        CallInt10($13);
-      VideoOfs := 0;
+      InitInt10hMode($13);
     end;
 
 
 
- Procedure PutPixel320(X,Y : smallint; Pixel: Word);
+ Procedure PutPixel320(X,Y : smallint; Pixel: Word); assembler;
  { x,y -> must be in local coordinates. Clipping if required. }
-  assembler;
   asm
-      push eax
+      {# Var X located in register ax
+       # Var Y located in register dx
+       # Var Pixel located in register cx }
       push ebx
-      push ecx
       push edi
-{$IFDEF REGCALL}
       movsx  edi, ax
       movsx  ebx, dx
-      mov    al, cl
-{$ELSE REGCALL}
-      movsx  edi, x
-      movsx  ebx, y
-{$ENDIF REGCALL}
       cmp    clippixels, 0
       je     @putpix320noclip
       test   edi, edi
@@ -2374,62 +2330,45 @@ End;
       cmp    bx, ViewHeight
       jg     @putpix320done
 @putpix320noclip:
-      movsx  ecx, StartYViewPort
+      movsx  eax, StartYViewPort
       movsx  edx, StartXViewPort
-      add    ebx, ecx
+      add    ebx, eax
       add    edi, edx
-{    add    edi, [VideoOfs]      no multiple pages in 320*200*256 }
-{$IFNDEF REGCALL}
-      mov    ax, [pixel]
-{$ENDIF REGCALL}
       shl    ebx, 6
       add    edi, ebx
-      mov    fs:[edi+ebx*4+$a0000], al
+      mov    fs:[edi+ebx*4+$a0000], cl
 @putpix320done:
       pop edi
-      pop ecx
       pop ebx
-      pop eax
  end;
 
 
- Function GetPixel320(X,Y: smallint):word;
-  assembler;
+ Function GetPixel320(X,Y: smallint):word; assembler;
   asm
+    {# Var X located in register ax
+     # Var Y located in register dx }
     push ebx
-    push ecx
-    push edx
-    push edi
-{$IFDEF REGCALL}
-    movsx  edi, ax
+    movsx  eax, ax
     movsx  ebx, dx
-{$ELSE REGCALL}
-    movsx  edi, x
-    movsx  ebx, y
-{$ENDIF REGCALL}
     movsx  ecx, StartYViewPort
     movsx  edx, StartXViewPort
     add    ebx, ecx
-    add    edi, edx
- {   add    edi, [VideoOfs]       no multiple pages in 320*200*256 }
+    add    eax, edx
     shl    ebx, 6
-    add    edi, ebx
-    movzx  eax, byte ptr fs:[edi+ebx*4+$a0000]
-    pop edi
-    pop edx
-    pop ecx
+    add    eax, ebx
+    movzx  eax, byte ptr fs:[eax+ebx*4+$a0000]
     pop ebx
   end;
 
 
+{$ifndef asmgraph}
  Procedure DirectPutPixel320(X,Y : smallint);
  { x,y -> must be in global coordinates. No clipping. }
-{$ifndef asmgraph}
  var offset: word;
      dummy: Byte;
  begin
    dummy := CurrentColor;
-   offset := y * 320 + x + VideoOfs;
+   offset := y * 320 + x;
    case CurrentWriteMode of
      XorPut: dummy := dummy xor Mem[Sega000:offset];
      OrPut: dummy := dummy or Mem[Sega000:offset];
@@ -2439,8 +2378,9 @@ End;
    Mem[SegA000:offset] := dummy;
  end;
 {$else asmgraph}
+ Procedure DirectPutPixel320(X,Y : smallint); assembler;
+ { x,y -> must be in global coordinates. No clipping. }
 { note: still needs or/and/notput support !!!!! (JM) }
-  assembler;
     asm
       push eax
       push ebx
@@ -2452,7 +2392,6 @@ End;
       movzx  edi, x
       movzx  ebx, y
 {$ENDIF REGCALL}
-   {   add    edi, [VideoOfs]       no multiple pages in 320*200*256 }
       shl    ebx, 6
       add    edi, ebx
       mov    ax, [CurrentColor]
@@ -2471,19 +2410,19 @@ End;
  procedure SetVisual320(page: word);
   { no page supPort... }
   begin
-    VideoOfs := 0;
   end;
 
  procedure SetActive320(page: word);
   { no page supPort... }
   begin
-    VideoOfs := 0;
   end;
 
  {************************************************************************}
  {*                       Mode-X related routines                        *}
  {************************************************************************}
-const CrtAddress: word = 0;
+const
+  CrtAddress: word = 0;
+  ModeXVideoPageStart: array [0..3] of longint = (0,16000,32000,48000);
 
  procedure InitModeX;
   begin
@@ -2560,18 +2499,21 @@ const CrtAddress: word = 0;
  end;
 
 
- Function GetPixelX(X,Y: smallint): word;
 {$ifndef asmgraph}
+ Function GetPixelX(X,Y: smallint): word;
  var offset: word;
-{$endif asmgraph}
   begin
      X:= X + StartXViewPort;
      Y:= Y + StartYViewPort;
-{$ifndef asmgraph}
      offset := y * 80 + x shr 2 + VideoOfs;
      PortW[$3ce] := ((x and 3) shl 8) + 4;
      GetPixelX := Mem[SegA000:offset];
+ end;
 {$else asmgraph}
+ Function GetPixelX(X,Y: smallint): word;
+  begin
+     X:= X + StartXViewPort;
+     Y:= Y + StartYViewPort;
     asm
      push eax
      push ebx
@@ -2606,11 +2548,11 @@ const CrtAddress: word = 0;
     pop ebx
     pop eax
    end;
-{$endif asmgraph}
  end;
+{$endif asmgraph}
 
  procedure SetVisualX(page: word);
-  { 4 page supPort... }
+  { 4 page support... }
 
    Procedure SetVisibleStart(AOffset: word); Assembler;
    (* Select where the left corner of the screen will be *)
@@ -2663,33 +2605,24 @@ const CrtAddress: word = 0;
 {$undef asmgraph}
 
   begin
-    Case page of
-      0: SetVisibleStart(0);
-      1: SetVisibleStart(16000);
-      2: SetVisibleStart(32000);
-      3: SetVisibleStart(48000);
+    if (page >= 0) and (page <= 3) then
+      SetVisibleStart(ModeXVideoPageStart[page])
     else
       SetVisibleStart(0);
-    end;
   end;
 
  procedure SetActiveX(page: word);
-  { 4 page supPort... }
+  { 4 page support... }
   begin
-   case page of
-     0: VideoOfs := 0;
-     1: VideoOfs := 16000;
-     2: VideoOfs := 32000;
-     3: VideoOfs := 48000;
-   else
-     VideoOfs:=0;
-   end;
+    if (page >= 0) and (page <= 3) then
+      VideoOfs := ModeXVideoPageStart[page]
+    else
+      VideoOfs := 0;
   end;
 
- Procedure PutPixelX(X,Y: smallint; color:word);
 {$ifndef asmgraph}
+ Procedure PutPixelX(X,Y: smallint; color:word);
  var offset: word;
-{$endif asmgraph}
   begin
     X:= X + StartXViewPort;
     Y:= Y + StartYViewPort;
@@ -2701,11 +2634,23 @@ const CrtAddress: word = 0;
        if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
          exit;
      end;
-{$ifndef asmgraph}
     offset := y * 80 + x shr 2 + VideoOfs;
     PortW[$3c4] := (hi(word(FirstPlane)) shl 8) shl (x and 3)+ lo(word(FirstPlane));
     Mem[SegA000:offset] := color;
+  end;
 {$else asmgraph}
+ Procedure PutPixelX(X,Y: smallint; color:word);
+  begin
+    X:= X + StartXViewPort;
+    Y:= Y + StartYViewPort;
+    { convert to absolute coordinates and then verify clipping...}
+    if ClipPixels then
+     Begin
+       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+         exit;
+       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+         exit;
+     end;
      asm
       push ax
       push bx
@@ -2748,13 +2693,13 @@ const CrtAddress: word = 0;
       pop bx
       pop ax
     end;
-{$endif asmgraph}
   end;
+{$endif asmgraph}
 
 
+{$ifndef asmgraph}
  Procedure DirectPutPixelX(X,Y: smallint);
  { x,y -> must be in global coordinates. No clipping. }
-{$ifndef asmgraph}
  Var offset: Word;
      dummy: Byte;
  begin
@@ -2782,8 +2727,9 @@ const CrtAddress: word = 0;
    Mem[Sega000: offset] := Dummy;
  end;
 {$else asmgraph}
+ Procedure DirectPutPixelX(X,Y: smallint); Assembler;
+ { x,y -> must be in global coordinates. No clipping. }
 { note: still needs or/and/notput support !!!!! (JM) }
- Assembler;
  asm
    push ax
    push bx
@@ -3607,7 +3553,7 @@ const CrtAddress: word = 0;
          mode.MaxX := 639;
          mode.MaxY := 199;
          mode.HardwarePages := 3;
-         mode.SetVisualPage := @SetVisual200;
+         mode.SetVisualPage := @SetVisual200_350;
          mode.SetActivePage := @SetActive200;
          mode.InitMode := @Init640x200x16;
          mode.XAspect := 4500;
@@ -3622,7 +3568,7 @@ const CrtAddress: word = 0;
          mode.MaxX := 639;
          mode.MaxY := 349;
          mode.HardwarePages := 1;
-         mode.SetVisualPage := @SetVisual350;
+         mode.SetVisualPage := @SetVisual200_350;
          mode.SetActivePage := @SetActive350;
          mode.InitMode := @Init640x350x16;
          mode.XAspect := 7750;
@@ -3780,7 +3726,7 @@ const CrtAddress: word = 0;
          mode.MaxX := 639;
          mode.MaxY := 199;
          mode.HardwarePages := 3;
-         mode.SetVisualPage := @SetVisual200;
+         mode.SetVisualPage := @SetVisual200_350;
          mode.SetActivePage := @SetActive200;
          mode.InitMode := @Init640x200x16;
          mode.XAspect := 4500;
@@ -3795,7 +3741,7 @@ const CrtAddress: word = 0;
          mode.MaxX := 639;
          mode.MaxY := 349;
          mode.HardwarePages := 1;
-         mode.SetVisualPage := @SetVisual350;
+         mode.SetVisualPage := @SetVisual200_350;
          mode.SetActivePage := @SetActive350;
          mode.InitMode := @Init640x350x16;
          mode.XAspect := 7750;

packages/graph/src/inc/fills.inc

@@ -433,36 +433,45 @@ var
    Cont : Boolean;
    BackupColor : ColorType;
    x1, x2, prevy: smallint;
+   SBufferSize, DrawnListSize: SizeUInt;
   Begin
-    GetMem(DrawnList,sizeof(PFloodLine)*((ViewHeight div YResDiv) + 1));
-    FillChar(DrawnList^,sizeof(PFloodLine)*((ViewHeight div YResDiv) + 1),0);
-    { init prevy }
-    prevy := 32767;
-    { Save current drawing color }
-    BackupColor := CurrentColor;
-    CurrentColor := FillSettings.Color;
+    If (x<0) Or (y<0) Or
+       (x>ViewWidth) Or (y>ViewHeight) then Exit;
+    DrawnListSize:=sizeof(PFloodLine)*((ViewHeight div YResDiv) + 1);
     { MaxX is based on zero index }
 {$ifdef FPC_GRAPH_SUPPORTS_TRUECOLOR}
     if MaxColor > 65536 then
-    begin
-      GetMem (s1,(ViewWidth+1)*4);  { A pixel color represents a word }
-      GetMem (s2,(ViewWidth+1)*4);  { A pixel color represents a word }
-      GetMem (s3,(ViewWidth+1)*4);  { A pixel color represents a word }
-    end
+      SBufferSize := (ViewWidth+1)*4   { A pixel color is represented by a longword }
     else
 {$endif FPC_GRAPH_SUPPORTS_TRUECOLOR}
-    begin
-      GetMem (s1,(ViewWidth+1)*2);  { A pixel color represents a word }
-      GetMem (s2,(ViewWidth+1)*2);  { A pixel color represents a word }
-      GetMem (s3,(ViewWidth+1)*2);  { A pixel color represents a word }
-    end;
-    if (not assigned(s1)) or (not assigned(s2)) or (not assigned(s3)) then
+      SBufferSize := (ViewWidth+1)*2;  { A pixel color is represented by a word }
+    DrawnList:=nil;
+    s1:=nil;
+    s2:=nil;
+    s3:=nil;
+    GetMem(DrawnList,DrawnListSize);
+    GetMem (s1,SBufferSize);
+    GetMem (s2,SBufferSize);
+    GetMem (s3,SBufferSize);
+    if (not assigned(DrawnList)) or (not assigned(s1)) or (not assigned(s2)) or (not assigned(s3)) then
       begin
         _GraphResult := grNoFloodMem;
+        if assigned(s1) then
+          System.FreeMem (s1,SBufferSize);
+        if assigned(s2) then
+          System.FreeMem (s2,SBufferSize);
+        if assigned(s3) then
+          System.FreeMem (s3,SBufferSize);
+        if assigned(DrawnList) then
+          System.FreeMem(DrawnList,DrawnListSize);
         exit;
       end;
-    If (x<0) Or (y<0) Or
-       (x>ViewWidth) Or (y>ViewHeight) then Exit;
+    FillChar(DrawnList^,DrawnListSize,0);
+    { init prevy }
+    prevy := 32767;
+    { Save current drawing color }
+    BackupColor := CurrentColor;
+    CurrentColor := FillSettings.Color;
     { Index of points to check  }
     Buffer.WordIndex:=0;
     PushPoint (x,y);
@@ -591,22 +600,11 @@ var
        PatternLine (x1,x2,y);
      End; { end while }
 
-{$ifdef FPC_GRAPH_SUPPORTS_TRUECOLOR}
-    if MaxColor > 65536 then
-    begin
-      System.FreeMem (s1,(ViewWidth+1)*4);
-      System.FreeMem (s2,(ViewWidth+1)*4);
-      System.FreeMem (s3,(ViewWidth+1)*4);
-    end
-    else
-{$endif FPC_GRAPH_SUPPORTS_TRUECOLOR}
-    begin
-      System.FreeMem (s1,(ViewWidth+1)*2);
-      System.FreeMem (s2,(ViewWidth+1)*2);
-      System.FreeMem (s3,(ViewWidth+1)*2);
-    end;
+    System.FreeMem (s1,SBufferSize);
+    System.FreeMem (s2,SBufferSize);
+    System.FreeMem (s3,SBufferSize);
     CleanUpDrawnList;
-    System.FreeMem(DrawnList,sizeof(PFloodLine)*((ViewHeight div YResDiv) + 1));
+    System.FreeMem(DrawnList,DrawnListSize);
     CurrentColor := BackUpColor;
   End;
 

packages/graph/src/inc/graph.inc

@@ -1312,28 +1312,28 @@ end;
      Halt(1);
    end;
 
-  procedure DirectPutPixelDefault(X,Y: smallint);
+  procedure DirectPutPixelDefault(X,Y: smallint); noreturn;
    begin
      NotInGraphicsMode;
    end;
 
-  function GetPixelDefault(X,Y: smallint): ColorType;
+  function GetPixelDefault(X,Y: smallint): ColorType; noreturn;
    begin
      NotInGraphicsMode;
    end;
 
-  procedure PutPixelDefault(X,Y: smallint; Color: ColorType);
+  procedure PutPixelDefault(X,Y: smallint; Color: ColorType); noreturn;
    begin
      NotInGraphicsMode;
    end;
 
-  procedure SetRGBPaletteDefault(ColorNum, RedValue, GreenValue, BlueValue: smallint);
+  procedure SetRGBPaletteDefault(ColorNum, RedValue, GreenValue, BlueValue: smallint); noreturn;
    begin
      NotInGraphicsMode;
    end;
 
   procedure GetRGBPaletteDefault(ColorNum: smallint; var
-            RedValue, GreenValue, BlueValue: smallint);
+            RedValue, GreenValue, BlueValue: smallint); noreturn;
    begin
      NotInGraphicsMode;
    end;

packages/graph/src/ptcgraph/ptcgraph.pp

@@ -17,7 +17,7 @@
 unit ptcgraph;
 
 {//$define logging}
-{//$define FPC_GRAPH_SUPPORTS_TRUECOLOR}
+{$define FPC_GRAPH_SUPPORTS_TRUECOLOR}
 
 {******************************************************************************}
                                     interface

packages/ide/fpviews.pas

@@ -4256,7 +4256,7 @@ begin
   C^.Insert(NewStr(S));
 end;
 begin
-  R.Assign(0,0,58,14{$ifdef NODEBUG}-1{$endif});
+  R.Assign(0,0,58,14{$ifdef USE_GRAPH_SWITCH}+1{$endif});
   inherited Init(R, dialog_about);
   HelpCtx:=hcAbout;
   GetExtent(R); R.Grow(-3,-2);

packages/ide/weditor.pas

@@ -5991,12 +5991,11 @@ begin
 end;
 
 procedure TCustomCodeEditor.GotoLine;
-var
-  GotoRec: TGotoLineDialogRec;
+const
+  GotoRec: TGotoLineDialogRec = (LineNo:'1';Lines:0);  {keep previous goto line number}
 begin
   with GotoRec do
   begin
-    LineNo:='1';
     Lines:=GetLineCount;
     {Linecount can be 0, but in that case there still is a cursor blinking in top
      of the window, which will become line 1 as soon as sometype hits a key.}

packages/pastojs/src/pas2jscompiler.pp

@@ -136,6 +136,7 @@ type
     // source map
     coSourceMapCreate,
     coSourceMapInclude,
+    coSourceMapFilenamesAbsolute,
     coSourceMapXSSIHeader
     );
   TP2jsCompilerOptions = set of TP2jsCompilerOption;
@@ -184,6 +185,7 @@ const
     'Keep not used declarations (WPO)',
     'Create source map',
     'Include Pascal sources in source map',
+    'Do not shorten filenames in source map',
     'Prepend XSSI protection )]} to source map'
     );
 
@@ -505,6 +507,7 @@ type
     function GetSkipDefaultConfig: Boolean; inline;
     function GetSrcMapEnable: boolean;
     function GetSrcMapInclude: boolean;
+    function GetSrcMapFilenamesAbsolute: boolean;
     function GetSrcMapXSSIHeader: boolean;
     function GetTargetPlatform: TPasToJsPlatform;
     function GetTargetProcessor: TPasToJsProcessor;
@@ -532,6 +535,7 @@ type
     procedure SetSrcMapBaseDir(const AValue: string);
     procedure SetSrcMapEnable(const AValue: boolean);
     procedure SetSrcMapInclude(const AValue: boolean);
+    procedure SetSrcMapFilenamesAbsolute(const AValue: boolean);
     procedure SetSrcMapXSSIHeader(const AValue: boolean);
     procedure SetTargetPlatform(const AValue: TPasToJsPlatform);
     procedure SetTargetProcessor(const AValue: TPasToJsProcessor);
@@ -573,7 +577,7 @@ type
     // Command-line option handling
     procedure HandleOptionPCUFormat(aValue: String); virtual;
     function HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): Boolean; virtual;
-    function HandleOptionJS(C: Char; aValue: String; Quick,FromCmdLine: Boolean): Boolean; virtual;
+    function HandleOptionJ(C: Char; aValue: String; Quick,FromCmdLine: Boolean): Boolean; virtual;
     procedure HandleOptionConfigFile(aPos: Integer; const aFileName: string); virtual;
     procedure HandleOptionInfo(aValue: string);
     // DoWriteJSFile: return false to use the default write function.
@@ -629,7 +633,7 @@ type
     function IsDefined(const aName: String): boolean;
     procedure SetOption(Flag: TP2jsCompilerOption; Enable: boolean);
 
-    function GetUnitInfo(const UseUnitName, InFileName: String;
+    function GetUnitInfo(const UseUnitName, InFileName, ModuleDir: String;
       PCUSupport: TPCUSupport): TFindUnitInfo;
     function FindFileWithUnitFilename(UnitFilename: string): TPas2jsCompilerFile;
     procedure LoadModuleFile(UnitFilename, UseUnitName: string;
@@ -659,6 +663,7 @@ type
     property SrcMapSourceRoot: string read FSrcMapSourceRoot write FSrcMapSourceRoot;
     property SrcMapInclude: boolean read GetSrcMapInclude write SetSrcMapInclude;
     property SrcMapXSSIHeader: boolean read GetSrcMapXSSIHeader write SetSrcMapXSSIHeader;
+    property SrcMapFilenamesAbsolute: boolean read GetSrcMapFilenamesAbsolute write SetSrcMapFilenamesAbsolute;
     property ShowDebug: boolean read GetShowDebug write SetShowDebug;
     property ShowFullPaths: boolean read GetShowFullPaths write SetShowFullPaths;
     property ShowLogo: Boolean read GetShowLogo write SetShowLogo;
@@ -683,9 +688,6 @@ type
     property PostProcessorSupport: TPas2JSPostProcessorSupport Read FPostProcessorSupport Write FPostProcessorSupport;
   end;
 
-
-
-
 function GetCompiledDate: string;
 function GetCompiledVersion: string;
 function GetCompiledTargetOS: string;
@@ -1622,6 +1624,7 @@ var
   aFile: TPas2jsCompilerFile;
   UnitInfo: TFindUnitInfo;
   LoadInfo: TLoadUnitInfo;
+  ModuleDir: String;
 begin
   Result:=nil;
   aFile:=Nil;
@@ -1629,7 +1632,8 @@ begin
   if CompareText(ExtractFilenameOnly(UnitFilename),UseUnitname)=0 then
     Parser.RaiseParserError(nUnitCycle,[UseUnitname]);
 
-  UnitInfo:=Compiler.GetUnitInfo(UseUnitName,InFileName,PCUSupport);
+  ModuleDir:=ExtractFilePath(PasFileName);
+  UnitInfo:=Compiler.GetUnitInfo(UseUnitName,InFileName,ModuleDir,PCUSupport);
   if UnitInfo.FileName<>'' then
     begin
     LoadInfo.UseFilename:=UnitInfo.FileName;
@@ -1655,8 +1659,6 @@ begin
   // if Result=nil resolver will give a nice error position, so don't do it here
 end;
 
-
-
 { TPas2jsCompiler }
 
 procedure TPas2jsCompiler.SetFS(AValue: TPas2jsFS);
@@ -2009,7 +2011,8 @@ begin
       SrcMap.SourceContents[i]:=aFile.Source;
     end;
     // translate local file name
-    if BaseDir<>'' then
+    MapFilename:=LocalFilename;
+    if (BaseDir<>'') and not SrcMapFilenamesAbsolute then
     begin
       if not FS.TryCreateRelativePath(LocalFilename,BaseDir,true,MapFilename) then
       begin
@@ -2024,12 +2027,14 @@ begin
         // the source is included, do not translate the filename
         MapFilename:=LocalFilename;
       end;
-      {$IFNDEF Unix}
-      // use / as PathDelim
+    end;
+    {$IFNDEF Unix}
+    // use / as PathDelim
+    if PathDelim<>'/' then
       MapFilename:=StringReplace(MapFilename,PathDelim,'/',[rfReplaceAll]);
-      {$ENDIF}
+    {$ENDIF}
+    if LocalFilename<>MapFilename then
       SrcMap.SourceTranslatedFiles[i]:=MapFilename;
-    end;
   end;
 end;
 
@@ -2483,6 +2488,11 @@ begin
   Result:=coSourceMapInclude in FOptions;
 end;
 
+function TPas2jsCompiler.GetSrcMapFilenamesAbsolute: boolean;
+begin
+  Result:=coSourceMapFilenamesAbsolute in FOptions;
+end;
+
 function TPas2jsCompiler.GetSrcMapXSSIHeader: boolean;
 begin
   Result:=coSourceMapXSSIHeader in FOptions;
@@ -2588,6 +2598,11 @@ begin
   SetOption(coSourceMapInclude,AValue);
 end;
 
+procedure TPas2jsCompiler.SetSrcMapFilenamesAbsolute(const AValue: boolean);
+begin
+  SetOption(coSourceMapFilenamesAbsolute,AValue);
+end;
+
 procedure TPas2jsCompiler.SetSrcMapXSSIHeader(const AValue: boolean);
 begin
   SetOption(coSourceMapXSSIHeader,AValue);
@@ -3010,7 +3025,7 @@ begin
 
 end;
 
-function TPas2jsCompiler.HandleOptionJS(C: Char; aValue: String;
+function TPas2jsCompiler.HandleOptionJ(C: Char; aValue: String;
   Quick, FromCmdLine: Boolean): Boolean;
 
 Var
@@ -3084,6 +3099,10 @@ begin
         SrcMapInclude:=true;
       'include-':
         SrcMapInclude:=false;
+      'absolute':
+        SrcMapFilenamesAbsolute:=true;
+      'absolute-':
+        SrcMapFilenamesAbsolute:=false;
       'xssiheader':
         SrcMapXSSIHeader:=true;
       'xssiheader-':
@@ -3092,7 +3111,7 @@ begin
         begin
         i:=Pos('=',aValue);
         if i<1 then
-          result:=false
+          ParamFatal('unknown -Jm parameter "'+aValue+'"')
         else
           begin
           S:=LeftStr(aValue,i-1);
@@ -3101,7 +3120,7 @@ begin
             'sourceroot': SrcMapSourceRoot:=aValue;
             'basedir': SrcMapBaseDir:=aValue;
           else
-            Result:=False;
+            ParamFatal('unknown -Jm parameter "'+s+'"')
           end;
           end;
         end;
@@ -3403,7 +3422,7 @@ begin
             UnknownParam;
           c:=aValue[1];
           Delete(aValue,1,1);
-          if not HandleOptionJS(c,aValue,Quick,FromCmdLine) then
+          if not HandleOptionJ(c,aValue,Quick,FromCmdLine) then
             UnknownParam;
         end;
       'M': // syntax mode
@@ -4214,8 +4233,9 @@ begin
   w('   -Jl   : lower case identifiers');
   w('   -Jm   : generate source maps');
   w('     -Jmsourceroot=<x>: use x as "sourceRoot", prefix URL for source file names.');
-  w('     -Jmbasedir=<x>: write source file names relative to directory x.');
+  w('     -Jmbasedir=<x>: write source file names relative to directory x, default is map file folder.');
   w('     -Jminclude: include Pascal sources in source map.');
+  w('     -Jmabsolute: store absolute filenames, not relative.');
   w('     -Jmxssiheader: start source map with XSSI protection )]}'', default.');
   w('     -Jm-: disable generating source maps');
   w('   -Jo<x>: Enable or disable extra option. The x is case insensitive:');
@@ -4637,8 +4657,8 @@ begin
   Result:=FMainJSFileResolved;
 end;
 
-function TPas2jsCompiler.GetUnitInfo(const UseUnitName, InFileName: String;
-  PCUSupport: TPCUSupport): TFindUnitInfo;
+function TPas2jsCompiler.GetUnitInfo(const UseUnitName, InFileName,
+  ModuleDir: String; PCUSupport: TPCUSupport): TFindUnitInfo;
 
 var
   FoundPasFilename, FoundPasUnitName: string;
@@ -4667,7 +4687,7 @@ var
         end;
       end else begin
         // search pas in unit path
-        FoundPasFilename:=FS.FindUnitFileName(TestUnitName,'',FoundPasIsForeign);
+        FoundPasFilename:=FS.FindUnitFileName(TestUnitName,'',ModuleDir,FoundPasIsForeign);
         if FoundPasFilename<>'' then
           FoundPasUnitName:=TestUnitName;
       end;
@@ -4725,7 +4745,7 @@ begin
     end;
   end else begin
     // search Pascal file with InFilename
-    FoundPasFilename:=FS.FindUnitFileName(UseUnitname,InFilename,FoundPasIsForeign);
+    FoundPasFilename:=FS.FindUnitFileName(UseUnitname,InFilename,ModuleDir,FoundPasIsForeign);
     if FoundPasFilename='' then
       exit; // an in-filename unit source is missing -> stop
     FoundPasUnitName:=ExtractFilenameOnly(InFilename);

packages/pastojs/src/pas2jsfilecache.pp

@@ -256,7 +256,7 @@ type
     function SearchLowUpCase(var Filename: string): boolean;
     function FindCustomJSFileName(const aFilename: string): String; override;
     function FindUnitJSFileName(const aUnitFilename: string): String; override;
-    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; override;
+    function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; override;
     function FindIncludeFileName(const aFilename: string): String; override;
     function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
     function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
@@ -1805,10 +1805,11 @@ begin
   AddSrcUnitPaths(aValue,FromCmdLine,Result);
 end;
 
-function TPas2jsFilesCache.TryCreateRelativePath(const Filename, BaseDirectory: String; UsePointDirectory: boolean; out
-  RelPath: String): Boolean;
+function TPas2jsFilesCache.TryCreateRelativePath(const Filename, BaseDirectory: String;
+  UsePointDirectory: boolean; out RelPath: String): Boolean;
 begin
-  Result:=Pas2jsFileUtils.TryCreateRelativePath(Filename, BaseDirectory, UsePointDirectory, RelPath);
+  Result:=Pas2jsFileUtils.TryCreateRelativePath(Filename, BaseDirectory,
+    UsePointDirectory, true, RelPath);
 end;
 
 function TPas2jsFilesCache.FindIncludeFileName(const aFilename: string): String;
@@ -1888,7 +1889,8 @@ begin
 end;
 
 
-function TPas2jsFilesCache.FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String;
+function TPas2jsFilesCache.FindUnitFileName(const aUnitname, InFilename,
+  ModuleDir: string; out IsForeign: boolean): String;
 var
   SearchedDirs: TStringList;
 
@@ -1924,7 +1926,7 @@ begin
         if SearchLowUpCase(Result) then exit;
       end else
       begin
-        Result:=ResolveDots(BaseDirectory+Result);
+        Result:=ResolveDots(ModuleDir+Result);
         if SearchLowUpCase(Result) then exit;
       end;
       exit('');
@@ -1939,6 +1941,10 @@ begin
         exit;
       end;
 
+    // then in ModuleDir
+    IsForeign:=false;
+    if SearchInDir(ModuleDir,Result) then exit;
+
     // then in BaseDirectory
     IsForeign:=false;
     if SearchInDir(BaseDirectory,Result) then exit;

packages/pastojs/src/pas2jsfiler.pp

@@ -169,7 +169,8 @@ const
     'ExternalClass',
     'PrefixedAttributes',
     'IgnoreAttributes',
-    'OmitRTTI'
+    'OmitRTTI',
+    'MultipleScopeHelpers'
     );
 
   PCUDefaultBoolSwitches: TBoolSwitches = [
@@ -206,7 +207,8 @@ const
     'Macro',
     'ScopedEnums',
     'ObjectChecks',
-    'PointerMath'
+    'PointerMath',
+    'Goto'
     );
 
   PCUDefaultConverterOptions: TPasToJsConverterOptions = [coUseStrict];
@@ -348,7 +350,6 @@ const
     'Object',
     'Class',
     'Interface',
-    'Generic',
     'ClassHelper',
     'RecordHelper',
     'TypeHelper',
@@ -2636,6 +2637,9 @@ begin
   WriteIdentifierScope(Obj,Scope,aContext);
 
   // not needed: Scope ElevatedLocals
+  // not needed: Scope Helpers
+  if (length(Scope.Helpers)>0) and not (Scope.Element is TInterfaceSection) then
+    RaiseMsg(20190119122007,Section);
 
   WriteDeclarations(Obj,Section,aContext);
   if Section is TInterfaceSection then
@@ -3711,7 +3715,7 @@ begin
     RaiseMsg(20180219135933,Scope.Element);
   AddReferenceToObj(Obj,'ImplProc',Scope.ImplProc);
   AddReferenceToObj(Obj,'Overridden',Scope.OverriddenProc);
-  // ClassScope: TPasClassScope; auto derived
+  // ClassOrRecordScope: TPasClassScope; auto derived
   if Scope.SelfArg<>nil then
     RaiseMsg(20180211180457,Scope.Element); // SelfArg only valid for method implementation
   // Mode: TModeSwitch: auto derived
@@ -3733,8 +3737,7 @@ begin
   WritePasElement(Obj,El,aContext);
   Scope:=El.CustomData as TPas2JSProcedureScope;
   //writeln('TPCUWriter.WriteProcedure ',GetObjName(El),' ',GetObjName(Scope),' ',Resolver.GetElementSourcePosStr(El));
-  // BEWARE: Scope can be nil for ignored methods of an interface (msIgnoreInterfaces)
-  if (Scope=nil) or (Scope.DeclarationProc=nil) then
+  if Scope.DeclarationProc=nil then
     begin
     WriteElementProperty(Obj,El,'ProcType',El.ProcType,aContext);
     WriteExpr(Obj,El,'Public',El.PublicName,aContext);
@@ -3752,12 +3755,6 @@ begin
       if El.MessageType<>pmtInteger then
         Obj.Add('MessageType',PCUProcedureMessageTypeNames[El.MessageType]);
       end;
-
-    if Scope=nil then
-      begin
-      Obj.Add('Scope',false); // msIgnoreInterfaces
-      exit;
-      end;
     WriteProcedureScope(Obj,Scope,aContext);
     end
   else
@@ -5401,6 +5398,7 @@ procedure TPCUReader.ReadSectionScope(Obj: TJSONObject;
 begin
   ReadIdentifierScope(Obj,Scope,aContext);
   // not needed: Scope ElevatedLocals
+  // not needed: Scope Helpers, autogenerated in ReadClassType
   Scope.BoolSwitches:=ReadBoolSwitches(Obj,Scope.Element,'BoolSwitches',aContext.BoolSwitches);
   Scope.ModeSwitches:=ReadModeSwitches(Obj,Scope.Element,'ModeSwitches',aContext.ModeSwitches);
 end;
@@ -5696,7 +5694,6 @@ begin
     'Object': CreateClassType(okObject,Name);
     'Class': CreateClassType(okClass,Name);
     'Interface': CreateClassType(okInterface,Name);
-    'Generic': CreateClassType(okGeneric,Name);
     'ClassHelper': CreateClassType(okClassHelper,Name);
     'RecordHelper': CreateClassType(okRecordHelper,Name);
     'TypeHelper': CreateClassType(okTypeHelper,Name);
@@ -6925,6 +6922,8 @@ var
   Data: TJSONData;
   Scope: TPas2JSClassScope;
   Ref: TResolvedReference;
+  Parent: TPasElement;
+  SectionScope: TPasSectionScope;
 begin
   ReadBoolean(Obj,'Forward',El.IsForward,El);
 
@@ -6986,6 +6985,22 @@ begin
     begin
     ReadClassScopeAbstractProcs(Obj,Scope);
     ReadClassScopeInterfaces(Obj,Scope);
+
+    if El.ObjKind in okAllHelpers then
+      begin
+      // restore cached helpers in interface
+      Parent:=El.Parent;
+      while Parent<>nil do
+        begin
+        if Parent.ClassType=TInterfaceSection then
+          begin
+          SectionScope:=Parent.CustomData as TPasSectionScope;
+          Resolver.AddHelper(El,SectionScope.Helpers);
+          break;
+          end;
+        Parent:=Parent.Parent;
+        end;
+      end;
     end;
 end;
 
@@ -7328,8 +7343,9 @@ begin
   ReadElementReference(Obj,Scope,'ImplProc',@Set_ProcedureScope_ImplProc);
   ReadElementReference(Obj,Scope,'Overridden',@Set_ProcedureScope_Overridden);
   if Proc.Parent is TPasMembersType then
-    Scope.ClassOrRecordScope:=Proc.Parent.CustomData as TPasClassOrRecordScope; // no AddRef
-  // ClassScope: TPasClassScope; auto derived
+    Scope.ClassRecScope:=Proc.Parent.CustomData as TPasClassOrRecordScope // no AddRef
+  else
+    ; // set via Set_ProcedureScope_ImplProc
   // Scope.SelfArg only valid for method implementation
 
   Scope.Flags:=ReadProcScopeFlags(Obj,Proc,'SFlags',[]);
@@ -7346,8 +7362,8 @@ var
   DeclProc: TPasProcedure;
 begin
   // Note: the References are stored in the scope object of the declaration proc,
-  //       OTOH in the JSON they are stored in the scope of the implementation
-  //       proc, so that all references can be resolved immediately.
+  //       But TPCUWriter stores them in the implementation scope, so that all
+  //       references can be resolved immediately.
   if ImplScope.ImplProc<>nil then
     RaiseMsg(20180318212631,ImplScope.Element);
   DeclProc:=ImplScope.DeclarationProc;

packages/pastojs/src/pas2jsfileutils.pp

@@ -40,8 +40,15 @@ function FileIsInPath(const Filename, Path: string): boolean;
 function ChompPathDelim(const Path: string): string;
 function ExpandFileNamePJ(const FileName: string; {const} BaseDir: string = ''): string;
 function ExpandDirectory(const aDirectory: string): string;
-function TryCreateRelativePath(const Filename, BaseDirectory: String;
-  UsePointDirectory: boolean; out RelPath: String): Boolean;
+function IsUNCPath(const {%H-}Path: String): Boolean;
+function ExtractUNCVolume(const {%H-}Path: String): String;
+function ExtractFileRoot(FileName: String): String;
+function TryCreateRelativePath(
+  const Dest: String; // Filename
+  const Source: String; // Directory
+  UsePointDirectory: boolean; // True = return '.' for the current directory instead of ''
+  AlwaysRequireSharedBaseFolder: Boolean;// true = only shorten if at least one shared folder
+  out RelPath: String): Boolean;
 function ResolveDots(const AFilename: string): string;
 procedure ForcePathDelims(Var FileName: string);
 function GetForcedPathDelims(Const FileName: string): String;
@@ -201,8 +208,47 @@ begin
   Result:=IncludeTrailingPathDelimiter(Result);
 end;
 
-function TryCreateRelativePath(const Filename, BaseDirectory: String;
-  UsePointDirectory: boolean; out RelPath: String): Boolean;
+{
+  Returns
+  - DriveLetter + : + PathDelim on Windows (if present) or
+  - UNC Share on Windows if present or
+  - PathDelim if FileName starts with PathDelim on Unix or Wince or
+  - Empty string of non eof the above applies
+}
+function ExtractFileRoot(FileName: String): String;
+var
+  Len: Integer;
+begin
+  Result := '';
+  Len := Length(FileName);
+  if (Len > 0) then
+  begin
+    if IsUncPath(FileName) then
+    begin
+      Result := ExtractUNCVolume(FileName);
+      // is it like \\?\C:\Directory?  then also include the "C:\" part
+      if (Result = '\\?\') and (Length(FileName) > 6) and
+         (FileName[5] in ['a'..'z','A'..'Z']) and (FileName[6] = ':') and (FileName[7] in AllowDirectorySeparators)
+      then
+        Result := Copy(FileName, 1, 7);
+    end
+    else
+    begin
+      {$if defined(unix) or defined(wince)}
+      if (FileName[1] = PathDelim) then Result := PathDelim;
+      {$else}
+        {$ifdef HASAMIGA}
+        if Pos(':', FileName) > 1 then
+          Result := Copy(FileName, 1, Pos(':', FileName));
+        {$else}
+        if (Len > 2) and (FileName[1] in ['a'..'z','A'..'Z']) and (FileName[2] = ':') and (FileName[3] in AllowDirectorySeparators) then
+          Result := UpperCase(Copy(FileName,1,3));
+        {$endif}
+      {$endif}
+    end;
+  end;
+end;
+
 {
   Returns True if it is possible to create a relative path from Source to Dest
   Function must be thread safe, so no expanding of filenames is done, since this
@@ -221,104 +267,168 @@ function TryCreateRelativePath(const Filename, BaseDirectory: String;
     no PathDelimiter is appended to the end of RelPath
 
   Examples:
-  - Filename = /foo/bar BaseDirectory = /foo Result = True RelPath = bar
-  - Filename = /foo///bar BaseDirectory = /foo// Result = True RelPath = bar
-  - Filename = /foo BaseDirectory = /foo/bar Result = True RelPath = ../
-  - Filename = /foo/bar BaseDirectory = /bar Result = False (no shared base directory)
-  - Filename = foo/bar BaseDirectory = foo/foo Result = True RelPath = ../bar
-  - Filename = foo/bar BaseDirectory = bar/foo Result = False (no shared base directory)
-  - Filename = /foo BaseDirectory = bar Result = False (mixed absolute and relative)
+  - Dest = /foo/bar Source = /foo Result = True RelPath = bar
+  - Dest = /foo///bar Source = /foo// Result = True RelPath = bar
+  - Dest = /foo Source = /foo/bar Result = True RelPath = ../
+  - Dest = /foo/bar Source = /bar Result = True RelPath = ../foo/bar
+  - Dest = foo/bar Source = foo/foo Result = True RelPath = ../bar
+  - Dest = foo/bar Source = bar/foo Result = False (no shared base directory)
+  - Dest = /foo Source = bar Result = False (mixed absolute and relative)
+  - Dest = c:foo Source = c:bar Result = False (no expanding)
+  - Dest = c:\foo Source = d:\bar Result is False (different drives)
+  - Dest = \foo Source = foo (Windows) Result is False (too ambiguous to guess what this should mean)
+  - Dest = /foo Source = /bar AlwaysRequireSharedBaseFolder = True Result = False
+  - Dest = /foo Source = /bar AlwaysRequireSharedBaseFolder = False Result = True RelPath = ../foo
 }
-  function IsNameChar(c: char): boolean; inline;
+function TryCreateRelativePath(const Dest: String; const Source: String;
+  UsePointDirectory: boolean; AlwaysRequireSharedBaseFolder: Boolean; out
+  RelPath: String): Boolean;
+Type
+  TDirArr =  TStringArray;
+
+  function SplitDirs(Dir: String; out Dirs: TDirArr): integer;
+  var
+    Start, Stop, Len: Integer;
+    S: String;
   begin
-    Result:=(c<>#0) and not (c in AllowDirectorySeparators);
+    Result := 0;
+    Len := Length(Dir);
+    Dirs:=nil;
+    if (Len = 0) then Exit;
+    Start := 1;
+    Stop := 1;
+
+    While Start <= Len do
+    begin
+      if (Dir[Start] in AllowDirectorySeparators) then
+      begin
+        S := Copy(Dir,Stop,Start-Stop);
+        //ignore empty strings, they are caused by double PathDelims, which we just ignore
+        if (S <> '') then
+        begin
+          Inc(Result);
+          if Result>length(Dirs) then
+            SetLength(Dirs,length(Dirs)*2+10);
+          Dirs[Result-1] := S;
+        end;
+        Stop := Start + 1;
+      end;
+      Inc(Start);
+    end;
+
+    S := Copy(Dir,Stop,Start-Stop);
+    if (S <> '') then
+    begin
+      Inc(Result);
+      if Result>length(Dirs) then
+        SetLength(Dirs,length(Dirs)*2+10);
+      Dirs[Result-1] := S;
+    end;
   end;
 
 var
-  UpDirCount: Integer;
-  i: Integer;
-  s: string;
-  SharedDirs: Integer;
-  FileP, BaseP, FileEndP, BaseEndP, FileL, BaseL: integer;
+  SourceRoot, DestRoot, CmpDest, CmpSource: String;
+  CmpDestLen, CmpSourceLen, DestCount, SourceCount, i,
+  SharedFolders, LevelsBack, LevelsUp: Integer;
+  SourceDirs, DestDirs: TDirArr;
+  IsAbs: Boolean;
 begin
-  Result:=false;
-  RelPath:=Filename;
-  if (BaseDirectory='') or (Filename='') then exit;
-  {$IFDEF Windows}
-  // check for different windows file drives
-  if (CompareText(ExtractFileDrive(Filename),
-                     ExtractFileDrive(BaseDirectory))<>0)
-  then
-    exit;
-  {$ENDIF}
+  Result := False;
+  if (Dest = '') or (Source = '') then Exit;
+  if (Pos('..',Dest) > 0) or (Pos('..',Source) > 0) then Exit;
+  SourceRoot := ExtractFileRoot(Source);
+  DestRoot := ExtractFileRoot(Dest);
+  // Root must be same: either both absolute filenames or both relative (and on same drive in Windows)
+  if (CompareFileNames(SourceRoot, DestRoot) <> 0) then Exit;
+  IsAbs := (DestRoot <> '');
+  {$if defined(windows) and not defined(wince)}
+  if not IsAbs then  // relative paths
+  begin
+    //we cannot handle files like c:foo
+    if ((Length(Dest) > 1) and (UpCase(Dest[1]) in ['A'..'Z']) and (Dest[2] = ':')) or
+       ((Length(Source) > 1) and (UpCase(Source[1]) in ['A'..'Z']) and (Source[2] = ':')) then Exit;
+    //we cannot handle combinations like dest=foo source=\bar or the other way around
+    if ((Dest[1] in AllowDirectorySeparators) and not (Source[1] in AllowDirectorySeparators)) or
+       (not (Dest[1] in AllowDirectorySeparators) and (Source[1] in AllowDirectorySeparators)) then Exit;
+  end;
+  {$endif}
 
-  FileP:=1;
-  FileL:=length(Filename);
-  BaseP:=1;
-  BaseL:=length(BaseDirectory);
+  CmpSource := Source;
+  CmpDest := Dest;
 
-  // skip matching directories
-  SharedDirs:=0;
-  if Filename[FileP] in AllowDirectorySeparators then
+  CmpDest := ChompPathDelim(Dest);
+  CmpSource := ChompPathDelim(Source);
+  if IsAbs then
   begin
-    if not (BaseDirectory[BaseP] in AllowDirectorySeparators) then exit;
-    repeat
-      while (FileP<=FileL) and (Filename[FileP] in AllowDirectorySeparators) do
-        inc(FileP);
-      while (BaseP<=BaseL) and (BaseDirectory[BaseP] in AllowDirectorySeparators) do
-        inc(BaseP);
-      if (FileP>FileL) or (BaseP>BaseL) then break;
-      //writeln('TryCreateRelativePath check match .. File="',copy(Filename,FileP),'" Base="',copy(BaseDirectory,BaseP),'"');
-      FileEndP:=FileP;
-      BaseEndP:=BaseP;
-      while (FileEndP<=FileL) and IsNameChar(Filename[FileEndP]) do inc(FileEndP);
-      while (BaseEndP<=BaseL) and IsNameChar(BaseDirectory[BaseEndP]) do inc(BaseEndP);
-      if CompareFilenames(copy(Filename,FileP,FileEndP-FileP),
-        copy(BaseDirectory,BaseP,BaseEndP-BaseP))<>0
-      then
-        break;
-      FileP:=FileEndP;
-      BaseP:=BaseEndP;
-      inc(SharedDirs);
-    until false;
-  end else if (BaseDirectory[BaseP] in AllowDirectorySeparators) then
-    exit;
-
-  //writeln('TryCreateRelativePath skipped matches SharedDirs=',SharedDirs,' File="',copy(Filename,FileP),'" Base="',copy(BaseDirectory,BaseP),'"');
-  if SharedDirs=0 then exit;
-
-  // calculate needed '../'
-  UpDirCount:=0;
-  BaseEndP:=BaseP;
-  while (BaseEndP<=BaseL) and IsNameChar(BaseDirectory[BaseEndP]) do begin
-    inc(UpDirCount);
-    while (BaseEndP<=BaseL) and IsNameChar(BaseDirectory[BaseEndP]) do
-      inc(BaseEndP);
-    while (BaseEndP<=BaseL) and (BaseDirectory[BaseEndP] in AllowDirectorySeparators) do
-      inc(BaseEndP);
+    System.Delete(CmpSource,1,Length(SourceRoot));
+    System.Delete(CmpDest,1,Length(DestRoot));
   end;
 
-  //writeln('TryCreateRelativePath UpDirCount=',UpDirCount,' File="',copy(Filename,FileP),'" Base="',copy(BaseDirectory,BaseP),'"');
-  // create relative filename
-  if (FileP>FileL) and (UpDirCount=0) then
+  //Get rid of excessive trailing PathDelims now after (!) we stripped Root
+  while (Length(CmpDest) > 0) and (CmpDest[Length(CmpDest)] in AllowDirectorySeparators) do System.Delete(CmpDest,Length(CmpDest),1);
+  while (Length(CmpSource) > 0) and (CmpSource[Length(CmpSource)] in AllowDirectorySeparators) do System.Delete(CmpSource,Length(CmpSource),1);
+
+  CmpDestLen := Length(CmpDest);
+  CmpSourceLen := Length(CmpSource);
+
+  DestCount := SplitDirs(CmpDest, DestDirs);
+  SourceCount :=  SplitDirs(CmpSource, SourceDirs);
+
+  //writeln('TryCreaterelativePath: DestDirs:');
+  //for i := 1 to DestCount do writeln(i,' "',DestDirs[i-1],'"');
+  //writeln('TryCreaterelativePath: SrcDirs:');
+  //for i := 1 to SourceCount do writeln(i,' "',SourceDirs[i-1],'"');
+
+  i := 0;
+  SharedFolders := 0;
+  while (i < DestCount) and (i < SourceCount) do
   begin
-    // Filename is the BaseDirectory
-    if UsePointDirectory then
-      RelPath:='.'
+    if CompareFilenames(DestDirs[i], SourceDirs[i]) = 0 then
+    begin
+      Inc(SharedFolders);
+      Inc(i);
+    end
     else
-      RelPath:='';
-    exit(true);
+      Break;
   end;
 
-  s:='';
-  for i:=1 to UpDirCount do
-    s+='..'+PathDelim;
-  if (FileP>FileL) and (UpDirCount>0) then
-    s:=LeftStr(s,length(s)-1)
+  //writeln('TryCreaterelativePath: SharedFolders = ',SharedFolders);
+  if (SharedFolders = 0) and ((not IsAbs) or AlwaysRequireSharedBaseFolder) and not ((CmpDestLen = 0) or (CmpSourceLen = 0)) then
+  begin
+    //debguln('TryCreaterelativePath: FAIL: IsAbs = ',DbgS(IsAs),' AlwaysRequireSharedBaseFolder = ',DbgS(AlwaysRequireSharedBaseFolder),
+    //' SharedFolders = 0, CmpDestLen = ',DbgS(cmpdestlen),' CmpSourceLen = ',DbgS(CmpSourceLen));
+    Exit;
+  end;
+  LevelsBack := SourceCount - SharedFolders;
+  LevelsUp := DestCount - SharedFolders;
+  //writeln('TryCreaterelativePath: LevelsBack = ',Levelsback);
+  //writeln('TryCreaterelativePath: LevelsUp   = ',LevelsUp);
+  if (LevelsBack > 0) then
+  begin
+    RelPath := '';
+    for i := 1 to LevelsBack do RelPath := '..' + PathDelim + Relpath;
+
+    for i := LevelsUp downto 1 do
+    begin
+      if (RelPath <> '') and not (RelPath[Length(RelPath)] in AllowDirectorySeparators) then RelPath := RelPath + PathDelim;
+      RelPath := RelPath + DestDirs[DestCount - i];
+    end;
+    RelPath := ChompPathDelim(RelPath);
+  end
   else
-    s+=copy(Filename,FileP);
-  RelPath:=s;
-  Result:=true;
+  begin
+    RelPath := '';
+    for i := LevelsUp downto 1 do
+    begin
+      if (RelPath <> '') then RelPath := RelPath + PathDelim;
+      RelPath := RelPath + DestDirs[DestCount - i];
+    end;
+  end;
+  if UsePointDirectory and (RelPath = '') then
+    RelPath := '.'; // Dest = Source
+
+  //writeln('TryCreateRelativePath RelPath=',RelPath);
+  Result := True;
 end;
 
 function ResolveDots(const AFilename: string): string;
@@ -542,7 +652,7 @@ begin
 end;
 {$ENDIF}
 
-procedure ForcePathDelims(Var FileName: string);
+procedure ForcePathDelims(var FileName: string);
 begin
   Filename:=GetForcedPathDelims(Filename);
 end;

packages/pastojs/src/pas2jsfileutilsnodejs.inc

@@ -142,6 +142,16 @@ begin
     Result:='';
 end;
 
+function IsUNCPath(const Path: String): Boolean;
+begin
+  Result := false;
+end;
+
+function ExtractUNCVolume(const Path: String): String;
+begin
+  Result := '';
+end;
+
 function FileIsWritable(const AFilename: string): boolean;
 begin
   try

packages/pastojs/src/pas2jsfileutilsunix.inc

@@ -143,6 +143,16 @@ begin
     Result:='';
 end;
 
+function IsUNCPath(const Path: String): Boolean;
+begin
+  Result := false;
+end;
+
+function ExtractUNCVolume(const Path: String): String;
+begin
+  Result := '';
+end;
+
 function FileIsWritable(const AFilename: string): boolean;
 begin
   Result := BaseUnix.FpAccess(AFilename, BaseUnix.W_OK) = 0;

packages/pastojs/src/pas2jsfileutilswin.inc

@@ -411,6 +411,56 @@ begin
   Result:=Filename;
 end;
 
+function IsUNCPath(const Path: String): Boolean;
+begin
+  Result := (Length(Path) > 2)
+    and (Path[1] in AllowDirectorySeparators)
+    and (Path[2] in AllowDirectorySeparators);
+end;
+
+function ExtractUNCVolume(const Path: String): String;
+var
+  I, Len: Integer;
+
+  // the next function reuses Len variable
+  function NextPathDelim(const Start: Integer): Integer;// inline;
+  begin
+    Result := Start;
+    while (Result <= Len) and not (Path[Result] in AllowDirectorySeparators) do
+      inc(Result);
+  end;
+
+begin
+  if not IsUNCPath(Path) then
+    Exit('');
+  I := 3;
+  Len := Length(Path);
+  if Path[I] = '?' then
+  begin
+    // Long UNC path form like:
+    // \\?\UNC\ComputerName\SharedFolder\Resource or
+    // \\?\C:\Directory
+    inc(I);
+    if not (Path[I] in AllowDirectorySeparators) then
+      Exit('');
+    if UpperCase(Copy(Path, I + 1, 3)) = 'UNC' then
+    begin
+      inc(I, 4);
+      if I < Len then
+        I := NextPathDelim(I + 1);
+      if I < Len then
+        I := NextPathDelim(I + 1);
+    end;
+  end
+  else
+  begin
+    I := NextPathDelim(I);
+    if I < Len then
+      I := NextPathDelim(I + 1);
+  end;
+  Result := Copy(Path, 1, I);
+end;
+
 function FileGetAttrUTF8(const FileName: String): Longint;
 begin
   Result:=Integer(Windows.GetFileAttributesW(PWideChar(UTF8Decode(FileName))));

packages/pastojs/src/pas2jsfs.pp

@@ -101,7 +101,7 @@ Type
     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;
+    function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; virtual; abstract;
     procedure SaveToFile(ms: TFPJSStream; Filename: string); virtual; abstract;
     function PCUExists(var aFileName: string): Boolean; virtual;
     procedure GetPCUDirs(aList: TStrings; const aBaseDir: String); virtual;

packages/pastojs/tests/tcfiler.pas

@@ -668,6 +668,7 @@ procedure TCustomTestPrecompile.CheckRestoredSectionScope(const Path: string;
 var
   i: Integer;
   OrigUses, RestUses: TPas2JSSectionScope;
+  OrigHelperEntry, RestHelperEntry: TPRHelperEntry;
 begin
   if Orig.BoolSwitches<>Rest.BoolSwitches then
     Fail(Path+'.BoolSwitches Orig='+BoolSwitchesToStr(Orig.BoolSwitches)+' Rest='+BoolSwitchesToStr(Rest.BoolSwitches));
@@ -684,6 +685,18 @@ begin
       Fail(Path+'.UsesScopes['+IntToStr(i)+'] Orig='+GetObjName(OrigUses)+' Rest='+GetObjName(RestUses));
     CheckRestoredReference(Path+'.UsesScopes['+IntToStr(i)+']',OrigUses.Element,RestUses.Element);
     end;
+  AssertEquals(Path+' length(Helpers)',length(Orig.Helpers),length(Rest.Helpers));
+  for i:=0 to length(Orig.Helpers)-1 do
+    begin
+    OrigHelperEntry:=TPRHelperEntry(Orig.Helpers[i]);
+    RestHelperEntry:=TPRHelperEntry(Rest.Helpers[i]);
+    if OrigHelperEntry.ClassType<>RestHelperEntry.ClassType then
+      Fail(Path+'.Helpers['+IntToStr(i)+'] Orig='+GetObjName(OrigHelperEntry)+' Rest='+GetObjName(RestHelperEntry));
+    AssertEquals(Path+'.Helpers['+IntToStr(i)+'].Added',OrigHelperEntry.Added,RestHelperEntry.Added);
+    CheckRestoredReference(Path+'.Helpers['+IntToStr(i)+'].Helper',OrigHelperEntry.Helper,RestHelperEntry.Helper);
+    CheckRestoredReference(Path+'.Helpers['+IntToStr(i)+'].HelperForType',OrigHelperEntry.HelperForType,RestHelperEntry.HelperForType);
+    end;
+
   AssertEquals(Path+'.Finished',Orig.Finished,Rest.Finished);
   CheckRestoredIdentifierScope(Path,Orig,Rest);
 end;
@@ -810,7 +823,7 @@ begin
     AssertEquals(Path+'.ResultVarName',Orig.ResultVarName,Rest.ResultVarName);
     CheckRestoredReference(Path+'.OverriddenProc',Orig.OverriddenProc,Rest.OverriddenProc);
 
-    CheckRestoredScopeReference(Path+'.ClassScope',Orig.ClassOrRecordScope,Rest.ClassOrRecordScope);
+    CheckRestoredScopeReference(Path+'.ClassScope',Orig.ClassRecScope,Rest.ClassRecScope);
     CheckRestoredElement(Path+'.SelfArg',Orig.SelfArg,Rest.SelfArg);
     if Orig.Flags<>Rest.Flags then
       Fail(Path+'.Flags');

packages/pastojs/tests/tcmodules.pas

@@ -257,6 +257,7 @@ type
     Procedure TestInteger;
     Procedure TestIntegerRange;
     Procedure TestIntegerTypecasts;
+    Procedure TestBitwiseAndNativeIntWarn;
     Procedure TestCurrency;
     Procedure TestForBoolDo;
     Procedure TestForIntDo;
@@ -369,6 +370,8 @@ type
     // statements
     Procedure TestNestBegin;
     Procedure TestIncDec;
+    Procedure TestLoHiFpcMode;
+    Procedure TestLoHiDelphiMode;
     Procedure TestAssignments;
     Procedure TestArithmeticOperators1;
     Procedure TestLogicalOperators;
@@ -393,6 +396,7 @@ type
     Procedure TestCaseOfNoElse_UseSwitch;
     Procedure TestCaseOfRange;
     Procedure TestCaseOfString;
+    Procedure TestCaseOfChar;
     Procedure TestCaseOfExternalClassConst;
     Procedure TestDebugger;
 
@@ -448,6 +452,7 @@ type
     Procedure TestRecord_Const;
     Procedure TestRecord_TypecastFail;
     Procedure TestRecord_InFunction;
+    // ToDo: Procedure TestRecord_ExternalField;
     // ToDo: RTTI of local record
     // ToDo: pcu local record, name clash and rtti
 
@@ -457,6 +462,7 @@ type
     Procedure TestAdvRecord_PropertyDefault;
     Procedure TestAdvRecord_Property_ClassMethod;
     Procedure TestAdvRecord_Const;
+    Procedure TestAdvRecord_ExternalField;
     Procedure TestAdvRecord_SubRecord;
     Procedure TestAdvRecord_SubClass;
     Procedure TestAdvRecord_SubInterfaceFail;
@@ -621,6 +627,10 @@ type
     Procedure TestClassInterface_GUID;
     Procedure TestClassInterface_GUIDProperty;
 
+    // helpers
+    Procedure TestClassHelper_ClassVar; // ToDo
+    // todo: TestClassHelper_Overload
+
     // proc types
     Procedure TestProcType;
     Procedure TestProcType_Arg;
@@ -2359,9 +2369,9 @@ begin
   Add('  d2: double = 5.6;');
   Add('  i3: longint = $707;');
   Add('  i4: nativeint = 4503599627370495;');
-  Add('  i5: nativeint = -4503599627370496;');
+  Add('  i5: nativeint = -4503599627370495-1;');
   Add('  i6: nativeint =   $fffffffffffff;');
-  Add('  i7: nativeint = -$10000000000000;');
+  Add('  i7: nativeint = -$fffffffffffff-1;');
   Add('  i8: byte = 00;');
   Add('  u8: nativeuint =  $fffffffffffff;');
   Add('  u9: nativeuint =  $0000000000000;');
@@ -2382,9 +2392,9 @@ begin
     'this.d2 = 5.6;',
     'this.i3 = 0x707;',
     'this.i4 = 4503599627370495;',
-    'this.i5 = -4503599627370496;',
+    'this.i5 = -4503599627370495-1;',
     'this.i6 = 0xfffffffffffff;',
-    'this.i7 =-0x10000000000000;',
+    'this.i7 =-0xfffffffffffff-1;',
     'this.i8 = 0;',
     'this.u8 = 0xfffffffffffff;',
     'this.u9 = 0x0;',
@@ -2675,6 +2685,154 @@ begin
     ]));
 end;
 
+procedure TTestModule.TestLoHiFpcMode;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'const',
+  '  LoByte1 = Lo(Word($1234));',
+  '  HiByte1 = Hi(Word($1234));',
+  '  LoByte2 = Lo(SmallInt($1234));',
+  '  HiByte2 = Hi(SmallInt($1234));',
+  '  LoWord1 = Lo($1234CDEF);',
+  '  HiWord1 = Hi($1234CDEF);',
+  '  LoWord2 = Lo(-$1234CDEF);',
+  '  HiWord2 = Hi(-$1234CDEF);',
+  '  lo4:byte=lo(byte($34));',
+  '  hi4:byte=hi(byte($34));',
+  '  lo5:byte=lo(shortint(-$34));',
+  '  hi5:byte=hi(shortint(-$34));',
+  '  lo6:longword=lo($123456789ABCD);',
+  '  hi6:longword=hi($123456789ABCD);',
+  '  lo7:longword=lo(-$123456789ABCD);',
+  '  hi7:longword=hi(-$123456789ABCD);',
+  'var',
+  '  b: Byte;',
+  '  ss: shortint;',
+  '  w: Word;',
+  '  si: SmallInt;',
+  '  lw: LongWord;',
+  '  li: LongInt;',
+  '  b2: Byte;',
+  '  ni: nativeint;',
+  'begin',
+  '  w := $1234;',
+  '  ss := -$12;',
+  '  b := lo(ss);',
+  '  b := HI(ss);',
+  '  b := lo(w);',
+  '  b := HI(w);',
+  '  b2 := lo(b);',
+  '  b2 := hi(b);',
+  '  lw := $1234CDEF;',
+  '  w := lo(lw);',
+  '  w := hi(lw);',
+  '  ni := $123456789ABCD;',
+  '  lw := lo(ni);',
+  '  lw := hi(ni);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestLoHiFpcMode',
+    LinesToStr([ // statements
+    'this.LoByte1 = 0x1234 & 0xFF;',
+    'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
+    'this.LoByte2 = 0x1234 & 0xFF;',
+    'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
+    'this.LoWord1 = 0x1234CDEF & 0xFFFF;',
+    'this.HiWord1 = (0x1234CDEF >> 16) & 0xFFFF;',
+    'this.LoWord2 = -0x1234CDEF & 0xFFFF;',
+    'this.HiWord2 = (-0x1234CDEF >> 16) & 0xFFFF;',
+    'this.lo4 = 0x34 & 0xF;',
+    'this.hi4 = (0x34 >> 4) & 0xF;',
+    'this.lo5 = (((-0x34 & 255) << 24) >> 24) & 0xFF;',
+    'this.hi5 = ((((-0x34 & 255) << 24) >> 24) >> 8) & 0xFF;',
+    'this.lo6 = 0x123456789ABCD >>> 0;',
+    'this.hi6 = 74565 >>> 0;',
+    'this.lo7 = -0x123456789ABCD >>> 0;',
+    'this.hi7 = Math.floor(-0x123456789ABCD / 4294967296) >>> 0;',
+    'this.b = 0;',
+    'this.ss = 0;',
+    'this.w = 0;',
+    'this.si = 0;',
+    'this.lw = 0;',
+    'this.li = 0;',
+    'this.b2 = 0;',
+    'this.ni = 0;',
+    '']),
+    LinesToStr([ // this.$main
+    '$mod.w = 0x1234;',
+    '$mod.ss = -0x12;',
+    '$mod.b = $mod.ss & 0xFF;',
+    '$mod.b = ($mod.ss >> 8) & 0xFF;',
+    '$mod.b = $mod.w & 0xFF;',
+    '$mod.b = ($mod.w >> 8) & 0xFF;',
+    '$mod.b2 = $mod.b & 0xF;',
+    '$mod.b2 = ($mod.b >> 4) & 0xF;',
+    '$mod.lw = 0x1234CDEF;',
+    '$mod.w = $mod.lw & 0xFFFF;',
+    '$mod.w = ($mod.lw >> 16) & 0xFFFF;',
+    '$mod.ni = 0x123456789ABCD;',
+    '$mod.lw = $mod.ni >>> 0;',
+    '$mod.lw = Math.floor($mod.ni / 4294967296) >>> 0;',
+    '']));
+end;
+
+procedure TTestModule.TestLoHiDelphiMode;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'const',
+  '  LoByte1 = Lo(Word($1234));',
+  '  HiByte1 = Hi(Word($1234));',
+  '  LoByte2 = Lo(SmallInt($1234));',
+  '  HiByte2 = Hi(SmallInt($1234));',
+  '  LoByte3 = Lo($1234CDEF);',
+  '  HiByte3 = Hi($1234CDEF);',
+  '  LoByte4 = Lo(-$1234CDEF);',
+  '  HiByte4 = Hi(-$1234CDEF);',
+  'var',
+  '  b: Byte;',
+  '  w: Word;',
+  '  si: SmallInt;',
+  '  lw: LongWord;',
+  '  li: LongInt;',
+  'begin',
+  '  w := $1234;',
+  '  b := lo(w);',
+  '  b := HI(w);',
+  '  lw := $1234CDEF;',
+  '  b := lo(lw);',
+  '  b := hi(lw);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestLoHiDelphiMode',
+    LinesToStr([ // statements
+    'this.LoByte1 = 0x1234 & 0xFF;',
+    'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
+    'this.LoByte2 = 0x1234 & 0xFF;',
+    'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
+    'this.LoByte3 = 0x1234CDEF & 0xFF;',
+    'this.HiByte3 = (0x1234CDEF >> 8) & 0xFF;',
+    'this.LoByte4 = -0x1234CDEF & 0xFF;',
+    'this.HiByte4 = (-0x1234CDEF >> 8) & 0xFF;',
+    'this.b = 0;',
+    'this.w = 0;',
+    'this.si = 0;',
+    'this.lw = 0;',
+    'this.li = 0;'
+    ]),
+    LinesToStr([ // this.$main
+    '$mod.w = 0x1234;',
+    '$mod.b = $mod.w & 0xFF;',
+    '$mod.b = ($mod.w >> 8) & 0xFF;',
+    '$mod.lw = 0x1234CDEF;',
+    '$mod.b = $mod.lw & 0xFF;',
+    '$mod.b = ($mod.lw >> 8) & 0xFF;'
+    ]));
+end;
+
 procedure TTestModule.TestAssignments;
 begin
   StartProgram(false);
@@ -5853,7 +6011,17 @@ begin
   '  maxdouble = 1.7e+308;',
   '  mindouble = -1.7e+308;',
   '  MinSafeIntDouble = -$10000000000000;',
+  '  MinSafeIntDouble2 = -$fffffffffffff-1;',
   '  MaxSafeIntDouble =   $fffffffffffff;',
+  '  DZeroResolution = 1E-12;',
+  '  Minus1 = -1E-12;',
+  '  EPS = 1E-9;',
+  '  DELTA = 0.001;',
+  '  Big = 129.789E+100;',
+  '  Test0_15 = 0.15;',
+  '  Test999 = 2.9999999999999;',
+  '  Test111999 = 211199999999999000.0;',
+  '  TestMinus111999 = -211199999999999000.0;',
   'var',
   '  d: double = b;',
   'begin',
@@ -5864,8 +6032,9 @@ begin
   '  d:=1.7E308;',
   '  d:=001.00E00;',
   '  d:=002.00E001;',
-  '  d:=-003.00E-00;',
-  '  d:=-004.00E-001;',
+  '  d:=003.000E000;',
+  '  d:=-004.00E-00;',
+  '  d:=-005.00E-001;',
   '  d:=10**3;',
   '  d:=10 mod 3;',
   '  d:=10 div 3;',
@@ -5885,6 +6054,9 @@ begin
   '  d:=maxdouble;',
   '  d:=mindouble;',
   '  d:=MinSafeIntDouble;',
+  '  d:=double(MinSafeIntDouble);',
+  '  d:=MinSafeIntDouble2;',
+  '  d:=double(MinSafeIntDouble2);',
   '  d:=MaxSafeIntDouble;',
   '  d:=default(double);',
   '']);
@@ -5909,7 +6081,17 @@ begin
     'this.maxdouble = 1.7e+308;',
     'this.mindouble = -1.7e+308;',
     'this.MinSafeIntDouble = -0x10000000000000;',
+    'this.MinSafeIntDouble2 = -0xfffffffffffff - 1;',
     'this.MaxSafeIntDouble = 0xfffffffffffff;',
+    'this.DZeroResolution = 1E-12;',
+    'this.Minus1 = -1E-12;',
+    'this.EPS = 1E-9;',
+    'this.DELTA = 0.001;',
+    'this.Big = 129.789E+100;',
+    'this.Test0_15 = 0.15;',
+    'this.Test999 = 2.9999999999999;',
+    'this.Test111999 = 211199999999999000.0;',
+    'this.TestMinus111999 = -211199999999999000.0;',
     'this.d = 4.4;'
     ]),
     LinesToStr([
@@ -5920,8 +6102,9 @@ begin
     '$mod.d = 1.7E308;',
     '$mod.d = 1.00E0;',
     '$mod.d = 2.00E1;',
-    '$mod.d = -3.00E-0;',
-    '$mod.d = -4.00E-1;',
+    '$mod.d = 3.000E0;',
+    '$mod.d = -4.00E-0;',
+    '$mod.d = -5.00E-1;',
     '$mod.d = Math.pow(10, 3);',
     '$mod.d = 10 % 3;',
     '$mod.d = Math.floor(10 / 3);',
@@ -5941,6 +6124,9 @@ begin
     '$mod.d = 1.7E308;',
     '$mod.d = -1.7E308;',
     '$mod.d = -4503599627370496;',
+    '$mod.d = -4503599627370496;',
+    '$mod.d = -4503599627370496;',
+    '$mod.d = -4503599627370496;',
     '$mod.d = 4503599627370495;',
     '$mod.d = 0.0;',
     '']));
@@ -6069,6 +6255,27 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestBitwiseAndNativeIntWarn;
+begin
+  StartProgram(false);
+  Add([
+  'var',
+  '  i,j: nativeint;',
+  'begin',
+  '  i:=i and j;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestBitwiseAndNativeIntWarn',
+    LinesToStr([
+    'this.i = 0;',
+    'this.j = 0;',
+    '']),
+    LinesToStr([
+    '$mod.i = $mod.i & $mod.j;',
+    '']));
+  CheckHint(mtWarning,nBitWiseOperationsAre32Bit,sBitWiseOperationsAre32Bit);
+end;
+
 procedure TTestModule.TestCurrency;
 begin
   StartProgram(false);
@@ -6313,33 +6520,35 @@ begin
   StartProgram(false);
   Add([
   'const',
- '  c: char = ''1'';',
- 'begin',
- '  c:=#0;',
- '  c:=#1;',
- '  c:=#9;',
- '  c:=#10;',
- '  c:=#13;',
- '  c:=#31;',
- '  c:=#32;',
- '  c:=#$A;',
- '  c:=#$0A;',
- '  c:=#$b;',
- '  c:=#$0b;',
- '  c:=^A;',
- '  c:=''"'';',
- '  c:=default(char);',
- '  c:=#$00E4;', // ä
- '  c:=''ä'';',
- '  c:=#$E4;', // ä
- '  c:=#$D800;', // invalid UTF-16
- '  c:=#$DFFF;', // invalid UTF-16
- '  c:=#$FFFF;', // last UCS-2
- '  c:=high(c);', // last UCS-2
- '']);
+  '  a = #$00F3;',
+  '  c: char = ''1'';',
+  'begin',
+  '  c:=#0;',
+  '  c:=#1;',
+  '  c:=#9;',
+  '  c:=#10;',
+  '  c:=#13;',
+  '  c:=#31;',
+  '  c:=#32;',
+  '  c:=#$A;',
+  '  c:=#$0A;',
+  '  c:=#$b;',
+  '  c:=#$0b;',
+  '  c:=^A;',
+  '  c:=''"'';',
+  '  c:=default(char);',
+  '  c:=#$00E4;', // ä
+  '  c:=''ä'';',
+  '  c:=#$E4;', // ä
+  '  c:=#$D800;', // invalid UTF-16
+  '  c:=#$DFFF;', // invalid UTF-16
+  '  c:=#$FFFF;', // last UCS-2
+  '  c:=high(c);', // last UCS-2
+  '']);
   ConvertProgram;
   CheckSource('TestCharConst',
     LinesToStr([
+    'this.a="ó";',
     'this.c="1";'
     ]),
     LinesToStr([
@@ -6426,6 +6635,9 @@ begin
   '  c:=succ(c);',
   '  c:=low(c);',
   '  c:=high(c);',
+  '  i:=byte(c);',
+  '  i:=word(c);',
+  '  i:=longint(c);',
   '']);
   ConvertProgram;
   CheckSource('TestChar_BuiltInProcs',
@@ -6442,6 +6654,9 @@ begin
     '$mod.c = String.fromCharCode($mod.c.charCodeAt() + 1);',
     '$mod.c = "\x00";',
     '$mod.c = "\uFFFF";',
+    '$mod.i = $mod.c.charCodeAt() & 255;',
+    '$mod.i = $mod.c.charCodeAt();',
+    '$mod.i = $mod.c.charCodeAt() & 0xFFFFFFFF;',
     '']));
 end;
 
@@ -6450,6 +6665,8 @@ begin
   StartProgram(false);
   Add([
   '{$H+}',
+  'const',
+  '  a = #$00F3#$017C;', // first <256, then >=256
   'var',
   '  s: string = ''abc'';',
   'begin',
@@ -6469,6 +6686,7 @@ begin
   ConvertProgram;
   CheckSource('TestStringConst',
     LinesToStr([
+    'this.a = "óż";',
     'this.s="abc";'
     ]),
     LinesToStr([
@@ -6790,6 +7008,7 @@ begin
   'begin',
   '  for c:=''a'' to ''c'' do ;',
   '  for c:=c downto ''a'' do ;',
+  '  for c:=''Б'' to ''Я'' do ;',
   '']);
   ConvertProgram;
   CheckSource('TestForCharDo',
@@ -6798,6 +7017,7 @@ begin
     LinesToStr([ // this.$main
     'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
     'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $l2--) $mod.c = String.fromCharCode($l2);',
+    'for (var $l3 = 1041; $l3 <= 1071; $l3++) $mod.c = String.fromCharCode($l3);',
     '']));
 end;
 
@@ -7557,6 +7777,7 @@ begin
   '  case s of',
   '  ''foo'': s:=h;',
   '  ''a''..''z'': h:=s;',
+  '  ''Б''..''Я'': ;',
   '  end;',
   '']);
   ConvertProgram;
@@ -7569,7 +7790,34 @@ begin
     'var $tmp1 = $mod.s;',
     'if ($tmp1 === "foo") {',
     '  $mod.s = $mod.h}',
-    ' else if (($tmp1.length === 1) && ($tmp1 >= "a") && ($tmp1 <= "z")) $mod.h = $mod.s;',
+    ' else if (($tmp1.length === 1) && ($tmp1 >= "a") && ($tmp1 <= "z")) {',
+    '  $mod.h = $mod.s}',
+    ' else if (($tmp1.length === 1) && ($tmp1 >= "Б") && ($tmp1 <= "Я")) ;',
+    '']));
+end;
+
+procedure TTestModule.TestCaseOfChar;
+begin
+  StartProgram(false);
+  Add([
+  'var s,h: char;',
+  'begin',
+  '  case s of',
+  '  ''a''..''z'': h:=s;',
+  '  ''Б''..''Я'': ;',
+  '  end;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestCaseOfString',
+    LinesToStr([ // statements
+    'this.s = "";',
+    'this.h = "";',
+    '']),
+    LinesToStr([ // $mod.$main
+    'var $tmp1 = $mod.s;',
+    'if (($tmp1 >= "a") && ($tmp1 <= "z")) {',
+    '  $mod.h = $mod.s}',
+    ' else if (($tmp1 >= "Б") && ($tmp1 <= "Я")) ;',
     '']));
 end;
 
@@ -10169,7 +10417,7 @@ begin
     '  this.SetInt = function (Value) {',
     '  };',
     '  this.DoIt = function () {',
-    '    this.Fy = this.Fx + 1;',
+    '    $mod.TRec.Fy = this.Fx + 1;',
     '    this.SetInt(this.GetInt() + 1);',
     '  };',
     '}, true);',
@@ -10180,7 +10428,7 @@ begin
     'if ($mod.TRec.GetInt() === 2) ;',
     '$mod.TRec.SetInt($mod.TRec.GetInt() + 2);',
     '$mod.TRec.SetInt($mod.TRec.Fx);',
-    '$mod.r.$record.Fy = $mod.r.Fx + 1;',
+    '$mod.TRec.Fy = $mod.r.Fx + 1;',
     'if ($mod.r.$record.GetInt() === 2) ;',
     '$mod.r.$record.SetInt($mod.r.$record.GetInt() + 2);',
     '$mod.r.$record.SetInt($mod.r.Fx);',
@@ -10276,6 +10524,73 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestAdvRecord_ExternalField;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch AdvancedRecords}',
+  '{$modeswitch externalclass}',
+  'type',
+  '  TCar = record',
+  '  public',
+  '    Intern: longint external name ''$Intern'';',
+  '    Intern2: longint external name ''$Intern2'';',
+  '    Bracket: longint external name ''["A B"]'';',
+  '    procedure DoIt;',
+  '  end;',
+  'implementation',
+  'procedure tcar.doit;',
+  'begin',
+  '  Intern:=Intern+1;',
+  '  Intern2:=Intern2+2;',
+  '  Bracket:=Bracket+3;',
+  'end;',
+  'var Rec: TCar = (intern: 11; intern2: 12; bracket: 13);',
+  'begin',
+  '  Rec.intern:=Rec.intern+1;',
+  '  Rec.intern2:=Rec.intern2+2;',
+  '  Rec.Bracket:=Rec.Bracket+3;',
+  '  with Rec do begin',
+  '    intern:=intern+1;',
+  '    intern2:=intern2+2;',
+  '    Bracket:=Bracket+3;',
+  '  end;']);
+  ConvertProgram;
+  CheckSource('TestAdvRecord_ExternalField',
+    LinesToStr([ // statements
+    'rtl.recNewT($mod, "TCar", function () {',
+    '  this.$eq = function (b) {',
+    '    return (this.$Intern === b.$Intern) && (this.$Intern2 === b.$Intern2) && (this["A B"] === b["A B"]);',
+    '  };',
+    '  this.$assign = function (s) {',
+    '    this.$Intern = s.$Intern;',
+    '    this.$Intern2 = s.$Intern2;',
+    '    this["A B"] = s["A B"];',
+    '    return this;',
+    '  };',
+    '  this.DoIt = function () {',
+    '    this.$Intern = this.$Intern + 1;',
+    '    this.$Intern2 = this.$Intern2 + 2;',
+    '    this["A B"] = this["A B"] + 3;',
+    '  };',
+    '});',
+    'this.Rec = $mod.TCar.$clone({',
+    '  $Intern: 11,',
+    '  $Intern2: 12,',
+    '  "A B": 13',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.Rec.$Intern = $mod.Rec.$Intern + 1;',
+    '$mod.Rec.$Intern2 = $mod.Rec.$Intern2 + 2;',
+    '$mod.Rec["A B"] = $mod.Rec["A B"] + 3;',
+    'var $with1 = $mod.Rec;',
+    '$with1.$Intern = $with1.$Intern + 1;',
+    '$with1.$Intern2 = $with1.$Intern2 + 2;',
+    '$with1["A B"] = $with1["A B"] + 3;',
+    '']));
+end;
+
 procedure TTestModule.TestAdvRecord_SubRecord;
 begin
   StartProgram(false);
@@ -10331,10 +10646,10 @@ begin
     '      return this;',
     '    };',
     '    this.DoIt = function () {',
-    '      this.$record.Count = this.Count + 3;',
+    '      $mod.TRec.TPoint.Count = this.Count + 3;',
     '    };',
     '    this.DoThat = function () {',
-    '      this.Count = this.Count + 4;',
+    '      $mod.TRec.TPoint.Count = this.Count + 4;',
     '    };',
     '  }, true);',
     '  this.i = 0;',
@@ -10353,7 +10668,7 @@ begin
     '  };',
     '  this.DoSome = function () {',
     '    this.p.x = this.p.y + 1;',
-    '    this.p.$record.Count = this.p.Count + 2;',
+    '    this.TPoint.Count = this.p.Count + 2;',
     '  };',
     '}, true);',
     'this.r = $mod.TRec.$clone({',
@@ -11436,6 +11751,8 @@ begin
   '    class var Fy: longint;',
   '    class function GetInt: longint;',
   '    class procedure SetInt(Value: longint);',
+  '  end;',
+  '  TBird = class',
   '    class procedure DoIt;',
   '    class property IntA: longint read Fx write Fy;',
   '    class property IntB: longint read GetInt write SetInt;',
@@ -11447,23 +11764,41 @@ begin
   'class procedure tobject.setint(value: longint);',
   'begin',
   'end;',
-  'class procedure tobject.doit;',
+  'class procedure tbird.doit;',
   'begin',
+  '  FX:=3;',
   '  IntA:=IntA+1;',
   '  Self.IntA:=Self.IntA+1;',
   '  IntB:=IntB+1;',
   '  Self.IntB:=Self.IntB+1;',
+  '  with Self do begin',
+  '    FX:=11;',
+  '    IntA:=IntA+12;',
+  '    IntB:=IntB+13;',
+  '  end;',
   'end;',
-  'var Obj: tobject;',
+  'var Obj: tbird;',
   'begin',
-  '  tobject.inta:=tobject.inta+1;',
-  '  if tobject.intb=2 then;',
-  '  tobject.intb:=tobject.intb+2;',
-  '  tobject.setint(tobject.inta);',
+  '  tbird.fx:=tbird.fx+1;',
+  '  tbird.inta:=tbird.inta+1;',
+  '  if tbird.intb=2 then;',
+  '  tbird.intb:=tbird.intb+2;',
+  '  tbird.setint(tbird.inta);',
   '  obj.inta:=obj.inta+1;',
   '  if obj.intb=2 then;',
   '  obj.intb:=obj.intb+2;',
-  '  obj.setint(obj.inta);']);
+  '  obj.setint(obj.inta);',
+  '  with Tbird do begin',
+  '    FX:=FY+1;',
+  '    inta:=inta+2;',
+  '    intb:=intb+3;',
+  '  end;',
+  '  with Obj do begin',
+  '    FX:=FY+1;',
+  '    inta:=inta+2;',
+  '    intb:=intb+3;',
+  '  end;',
+  '']);
   ConvertProgram;
   CheckSource('TestClass_Property_ClassMethod',
     LinesToStr([ // statements
@@ -11481,25 +11816,40 @@ begin
     '  };',
     '  this.SetInt = function (Value) {',
     '  };',
+    '});',
+    'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
     '  this.DoIt = function () {',
-    '    this.Fy = this.Fx + 1;',
-    '    this.Fy = this.Fx + 1;',
+    '    $mod.TObject.Fx = 3;',
+    '    $mod.TObject.Fy = this.Fx + 1;',
+    '    $mod.TObject.Fy = this.Fx + 1;',
     '    this.SetInt(this.GetInt() + 1);',
     '    this.SetInt(this.GetInt() + 1);',
+    '    $mod.TObject.Fx = 11;',
+    '    $mod.TObject.Fy = this.Fx + 12;',
+    '    this.SetInt(this.GetInt() + 13);',
     '  };',
     '});',
     'this.Obj = null;'
     ]),
     LinesToStr([ // $mod.$main
-    '$mod.TObject.Fy = $mod.TObject.Fx + 1;',
-    'if ($mod.TObject.GetInt() === 2);',
-    '$mod.TObject.SetInt($mod.TObject.GetInt() + 2);',
-    '$mod.TObject.SetInt($mod.TObject.Fx);',
-    '$mod.Obj.$class.Fy = $mod.Obj.Fx + 1;',
+    '$mod.TObject.Fx = $mod.TBird.Fx + 1;',
+    '$mod.TObject.Fy = $mod.TBird.Fx + 1;',
+    'if ($mod.TBird.GetInt() === 2);',
+    '$mod.TBird.SetInt($mod.TBird.GetInt() + 2);',
+    '$mod.TBird.SetInt($mod.TBird.Fx);',
+    '$mod.TObject.Fy = $mod.Obj.Fx + 1;',
     'if ($mod.Obj.$class.GetInt() === 2);',
     '$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
-    '$mod.Obj.$class.SetInt($mod.Obj.Fx);'
-    ]));
+    '$mod.Obj.$class.SetInt($mod.Obj.Fx);',
+    'var $with1 = $mod.TBird;',
+    '$mod.TObject.Fx = $with1.Fy + 1;',
+    '$mod.TObject.Fy = $with1.Fx + 2;',
+    '$with1.SetInt($with1.GetInt() + 3);',
+    'var $with2 = $mod.Obj;',
+    '$mod.TObject.Fx = $with2.Fy + 1;',
+    '$mod.TObject.Fy = $with2.Fx + 2;',
+    '$with2.SetInt($with2.GetInt() + 3);',
+    '']));
 end;
 
 procedure TTestModule.TestClass_Property_Indexed;
@@ -11759,9 +12109,9 @@ begin
   'type',
   '  TObject = class end;',
   '  TAlphaList = class',
-  '    function GetAlphas(Index: longint): Pointer; virtual; abstract;',
-  '    procedure SetAlphas(Index: longint; Value: Pointer); virtual; abstract;',
-  '    property Alphas[Index: longint]: Pointer read getAlphas write setAlphas; default;',
+  '    function GetAlphas(Index: boolean): Pointer; virtual; abstract;',
+  '    procedure SetAlphas(Index: boolean; Value: Pointer); virtual; abstract;',
+  '    property Alphas[Index: boolean]: Pointer read getAlphas write setAlphas; default;',
   '  end;',
   '  TBetaList = class',
   '    function GetBetas(Index: longint): Pointer; virtual; abstract;',
@@ -11775,14 +12125,14 @@ begin
   'var',
   '  List: TAlphaList;',
   'begin',
-  '  if TBetaList(List[2])[3]=nil then ;',
-  '  TBetaList(List[4])[5]:=nil;',
+  '  if TBetaList(List[true])[3]=nil then ;',
+  '  TBetaList(List[false])[5]:=nil;',
   'end;',
   'var',
   '  List: TAlphaList;',
   'begin',
-  '  if TBetaList(List[2])[3]=nil then ;',
-  '  TBetaList(List[4])[5]:=nil;',
+  '  if TBetaList(List[true])[3]=nil then ;',
+  '  TBetaList(List[false])[5]:=nil;',
   '']);
   ConvertProgram;
   CheckSource('TestClass_PropertyDefault2',
@@ -11800,15 +12150,15 @@ begin
     'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
     '  this.DoIt = function () {',
     '    var List = null;',
-    '    if (List.GetAlphas(2).GetBetas(3) === null) ;',
-    '    List.GetAlphas(4).SetBetas(5, null);',
+    '    if (List.GetAlphas(true).GetBetas(3) === null) ;',
+    '    List.GetAlphas(false).SetBetas(5, null);',
     '  };',
     '});',
     'this.List = null;',
     '']),
     LinesToStr([ // $mod.$main
-    'if ($mod.List.GetAlphas(2).GetBetas(3) === null) ;',
-    '$mod.List.GetAlphas(4).SetBetas(5, null);',
+    'if ($mod.List.GetAlphas(true).GetBetas(3) === null) ;',
+    '$mod.List.GetAlphas(false).SetBetas(5, null);',
     '']));
 end;
 
@@ -13780,37 +14130,39 @@ end;
 procedure TTestModule.TestClassOf_ClassProperty;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  TObject = class');
-  Add('    class var FA: longint;');
-  Add('    class function GetA: longint;');
-  Add('    class procedure SetA(Value: longint);');
-  Add('    class property pA: longint read fa write fa;');
-  Add('    class property pB: longint read geta write seta;');
-  Add('  end;');
-  Add('  TObjectClass = class of tobject;');
-  Add('class function tobject.geta: longint; begin end;');
-  Add('class procedure tobject.seta(value: longint); begin end;');
-  Add('var');
-  Add('  b: boolean;');
-  Add('  Obj: tobject;');
-  Add('  Cla: tobjectclass;');
-  Add('begin');
-  Add('  obj.pa:=obj.pa;');
-  Add('  obj.pb:=obj.pb;');
-  Add('  b:=obj.pa=4;');
-  Add('  b:=obj.pb=obj.pb;');
-  Add('  b:=5=obj.pa;');
-  Add('  cla.pa:=6;');
-  Add('  cla.pa:=cla.pa;');
-  Add('  cla.pb:=cla.pb;');
-  Add('  b:=cla.pa=7;');
-  Add('  b:=cla.pb=cla.pb;');
-  Add('  b:=8=cla.pa;');
-  Add('  tobject.pa:=9;');
-  Add('  tobject.pb:=tobject.pb;');
-  Add('  b:=tobject.pa=10;');
-  Add('  b:=11=tobject.pa;');
+  Add([
+  'type',
+  '  TObject = class',
+  '    class var FA: longint;',
+  '    class function GetA: longint;',
+  '    class procedure SetA(Value: longint);',
+  '    class property pA: longint read fa write fa;',
+  '    class property pB: longint read geta write seta;',
+  '  end;',
+  '  TObjectClass = class of tobject;',
+  'class function tobject.geta: longint; begin end;',
+  'class procedure tobject.seta(value: longint); begin end;',
+  'var',
+  '  b: boolean;',
+  '  Obj: tobject;',
+  '  Cla: tobjectclass;',
+  'begin',
+  '  obj.pa:=obj.pa;',
+  '  obj.pb:=obj.pb;',
+  '  b:=obj.pa=4;',
+  '  b:=obj.pb=obj.pb;',
+  '  b:=5=obj.pa;',
+  '  cla.pa:=6;',
+  '  cla.pa:=cla.pa;',
+  '  cla.pb:=cla.pb;',
+  '  b:=cla.pa=7;',
+  '  b:=cla.pb=cla.pb;',
+  '  b:=8=cla.pa;',
+  '  tobject.pa:=9;',
+  '  tobject.pb:=tobject.pb;',
+  '  b:=tobject.pa=10;',
+  '  b:=11=tobject.pa;',
+  '']);
   ConvertProgram;
   CheckSource('TestClassOf_ClassProperty',
     LinesToStr([ // statements
@@ -13832,13 +14184,13 @@ begin
     'this.Cla = null;'
     ]),
     LinesToStr([ // $mod.$main
-    '$mod.Obj.$class.FA = $mod.Obj.FA;',
+    '$mod.TObject.FA = $mod.Obj.FA;',
     '$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
     '$mod.b = $mod.Obj.FA === 4;',
     '$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
     '$mod.b = 5 === $mod.Obj.FA;',
-    '$mod.Cla.FA = 6;',
-    '$mod.Cla.FA = $mod.Cla.FA;',
+    '$mod.TObject.FA = 6;',
+    '$mod.TObject.FA = $mod.Cla.FA;',
     '$mod.Cla.SetA($mod.Cla.GetA());',
     '$mod.b = $mod.Cla.FA === 7;',
     '$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
@@ -16144,7 +16496,7 @@ begin
   '  end;',
   'begin']);
   SetExpectedParserError(
-    'Fields are not allowed in Interfaces at token "Identifier external" in file test1.pp at line 6 column 21',
+    'Fields are not allowed in interface at token "Identifier external" in file test1.pp at line 6 column 21',
     nParserNoFieldsAllowed);
   ConvertProgram;
 end;
@@ -18192,6 +18544,102 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClassHelper_ClassVar;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  THelper = class helper for TObject',
+  '  const',
+  '    One = 1;',
+  '    Two: word = 2;',
+  '  class var Glob: word;',
+  '  function Foo(w: word): word;',
+  '  class function Bar(w: word): word;',
+  '  end;',
+  'function THelper.foo(w: word): word;',
+  'begin',
+  '  Result:=w;',
+  '  Two:=One+w;',
+  '  Glob:=Glob;',
+  '  Result:=Self.Glob;',
+  '  Self.Glob:=Self.Glob;',
+  '  with Self do Glob:=Glob;',
+  'end;',
+  'class function THelper.bar(w: word): word;',
+  'begin',
+  '  Result:=w;',
+  '  Two:=One;',
+  '  Glob:=Glob;',
+  '  Self.Glob:=Self.Glob;',
+  '  with Self do Glob:=Glob;',
+  'end;',
+  'var o: TObject;',
+  'begin',
+  '  tobject.two:=tobject.one;',
+  '  tobject.Glob:=tobject.Glob;',
+  '  with tobject do begin',
+  '    two:=one;',
+  '    Glob:=Glob;',
+  '  end;',
+  '  o.two:=o.one;',
+  '  o.Glob:=o.Glob;',
+  '  with o do begin',
+  '    two:=one;',
+  '    Glob:=Glob;',
+  '  end;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClassHelper',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createHelper($mod, "THelper", null, function () {',
+    '  this.One = 1;',
+    '  this.Two = 2;',
+    '  this.Glob = 0;',
+    '  this.Foo = function (w) {',
+    '    var Result = 0;',
+    '    Result = w;',
+    '    $mod.THelper.Two = 1 + w;',
+    '    $mod.THelper.Glob = $mod.THelper.Glob;',
+    '    Result = $mod.THelper.Glob;',
+    '    $mod.THelper.Glob = $mod.THelper.Glob;',
+    '    $mod.THelper.Glob = $mod.THelper.Glob;',
+    '    return Result;',
+    '  };',
+    '  this.Bar = function (w) {',
+    '    var Result = 0;',
+    '    Result = w;',
+    '    $mod.THelper.Two = 1;',
+    '    $mod.THelper.Glob = $mod.THelper.Glob;',
+    '    $mod.THelper.Glob = $mod.THelper.Glob;',
+    '    $mod.THelper.Glob = $mod.THelper.Glob;',
+    '    return Result;',
+    '  };',
+    '});',
+    'this.o = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.THelper.Two = 1;',
+    '$mod.THelper.Glob = $mod.THelper.Glob;',
+    'var $with1 = $mod.TObject;',
+    '$mod.THelper.Two = 1;',
+    '$mod.THelper.Glob = $mod.THelper.Glob;',
+    '$mod.THelper.Two = 1;',
+    '$mod.THelper.Glob = $mod.THelper.Glob;',
+    'var $with2 = $mod.o;',
+    '$mod.THelper.Two = 1;',
+    '$mod.THelper.Glob = $mod.THelper.Glob;',
+    '']));
+end;
+
 procedure TTestModule.TestProcType;
 begin
   StartProgram(false);

packages/pastojs/tests/tcunitsearch.pas

@@ -135,6 +135,8 @@ type
 
   TTestCLI_UnitSearch = class(TCustomTestCLI)
   published
+    procedure TestUS_CreateRelativePath;
+
     procedure TestUS_Program;
     procedure TestUS_UsesEmptyFileFail;
     procedure TestUS_Program_o;
@@ -145,6 +147,7 @@ type
     procedure TestUS_UsesInFile;
     procedure TestUS_UsesInFile_Duplicate;
     procedure TestUS_UsesInFile_IndirectDuplicate;
+    procedure TestUS_UsesInFile_WorkNotEqProgDir;
   end;
 
 function LinesToStr(const Lines: array of string): string;
@@ -584,6 +587,49 @@ end;
 
 { TTestCLI_UnitSearch }
 
+procedure TTestCLI_UnitSearch.TestUS_CreateRelativePath;
+
+  procedure DoTest(Filename, BaseDirectory, Expected: string;
+    UsePointDirectory: boolean = false);
+  var
+    Actual: String;
+  begin
+    ForcePathDelims(Filename);
+    ForcePathDelims(BaseDirectory);
+    ForcePathDelims(Expected);
+    if not TryCreateRelativePath(Filename,BaseDirectory,UsePointDirectory,true,Actual) then
+      Actual:=Filename;
+    AssertEquals('TryCreateRelativePath(File='+Filename+',Base='+BaseDirectory+')',
+      Expected,Actual);
+  end;
+
+begin
+  DoTest('/a','/a','');
+  DoTest('/a','/a','.',true);
+  DoTest('/a','/a/','');
+  DoTest('/a/b','/a/b','');
+  DoTest('/a/b','/a/b/','');
+  DoTest('/a','/a/','');
+  DoTest('/a','','/a');
+  DoTest('/a/b','/a','b');
+  DoTest('/a/b','/a/','b');
+  DoTest('/a/b','/a//','b');
+  DoTest('/a','/a/b','..');
+  DoTest('/a','/a/b/','..');
+  DoTest('/a','/a/b//','..');
+  DoTest('/a/','/a/b','..');
+  DoTest('/a','/a/b/c','../..');
+  DoTest('/a','/a/b//c','../..');
+  DoTest('/a','/a//b/c','../..');
+  DoTest('/a','/a//b/c/','../..');
+  DoTest('/a','/b','/a');
+  DoTest('~/bin','/','~/bin');
+  DoTest('$(HOME)/bin','/','$(HOME)/bin');
+  {$IFDEF MSWindows}
+  DoTest('D:\a\b\c.pas','D:\a\d\','..\b\c.pas');
+  {$ENDIF}
+end;
+
 procedure TTestCLI_UnitSearch.TestUS_Program;
 begin
   AddUnit('system.pp',[''],['']);
@@ -707,6 +753,22 @@ begin
   AssertEquals('ErrorMsg','Duplicate file found: "'+WorkDir+'unit1.pas" and "'+WorkDir+'sub/unit1.pas"',ErrorMsg);
 end;
 
+procedure TTestCLI_UnitSearch.TestUS_UsesInFile_WorkNotEqProgDir;
+begin
+  AddUnit('system.pp',[''],['']);
+  AddUnit('sub/unit2.pas',
+  ['var a: longint;'],
+  ['']);
+  AddUnit('sub/unit1.pas',
+  ['uses unit2;'],
+  ['']);
+  AddFile('sub/test1.pas',[
+    'uses foo in ''unit1.pas'';',
+    'begin',
+    'end.']);
+  Compile(['sub/test1.pas','-Jc']);
+end;
+
 Initialization
   RegisterTests([TTestCLI_UnitSearch]);
 end.