* synchronised with trunk till r40723

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

.gitattributes

@@ -7586,8 +7586,10 @@ packages/rtl-objpas/src/inc/widestrutils.pp svneol=native#text/plain
 packages/rtl-objpas/src/win/varutils.pp svneol=native#text/plain
 packages/rtl-objpas/src/x86_64/invoke.inc svneol=native#text/plain
 packages/rtl-objpas/tests/testrunner.rtlobjpas.pp svneol=native#text/pascal
+packages/rtl-objpas/tests/tests.rtti.impl.pas svneol=native#text/pascal
 packages/rtl-objpas/tests/tests.rtti.invoke.pas svneol=native#text/pascal
 packages/rtl-objpas/tests/tests.rtti.pas svneol=native#text/plain
+packages/rtl-objpas/tests/tests.rtti.util.pas svneol=native#text/pascal
 packages/rtl-unicode/Makefile svneol=native#text/plain
 packages/rtl-unicode/Makefile.fpc svneol=native#text/plain
 packages/rtl-unicode/fpmake.pp svneol=native#text/plain
@@ -10721,6 +10723,7 @@ tests/Makefile.fpc svneol=native#text/plain
 tests/bench/bansi1.inc svneol=native#text/plain
 tests/bench/bansi1.pp svneol=native#text/plain
 tests/bench/bansi1mt.pp svneol=native#text/plain
+tests/bench/bcase.pp -text svneol=native#text/pascal
 tests/bench/blists1.inc svneol=native#text/plain
 tests/bench/blists1.pp svneol=native#text/plain
 tests/bench/bmd5.pp svneol=native#text/plain
@@ -11087,6 +11090,9 @@ tests/tbf/tb0262.pp svneol=native#text/pascal
 tests/tbf/tb0263.pp svneol=native#text/pascal
 tests/tbf/tb0264.pp svneol=native#text/pascal
 tests/tbf/tb0265.pp svneol=native#text/pascal
+tests/tbf/tb0266a.pp svneol=native#text/pascal
+tests/tbf/tb0266b.pp svneol=native#text/pascal
+tests/tbf/tb0267.pp svneol=native#text/plain
 tests/tbf/tb0588.pp svneol=native#text/pascal
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
@@ -11747,6 +11753,7 @@ tests/tbs/tb0650.pp svneol=native#text/pascal
 tests/tbs/tb0651.pp svneol=native#text/pascal
 tests/tbs/tb0652.pp svneol=native#text/pascal
 tests/tbs/tb0653.pp svneol=native#text/plain
+tests/tbs/tb0654.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tb610.pp svneol=native#text/pascal
 tests/tbs/tb613.pp svneol=native#text/plain
@@ -12906,6 +12913,7 @@ tests/test/tcase47.pp svneol=native#text/pascal
 tests/test/tcase47_2.pp svneol=native#text/pascal
 tests/test/tcase48.pp svneol=native#text/pascal
 tests/test/tcase48_2.pp svneol=native#text/pascal
+tests/test/tcase49.pp svneol=native#text/pascal
 tests/test/tcase5.pp svneol=native#text/pascal
 tests/test/tcase6.pp svneol=native#text/pascal
 tests/test/tcase7.pp svneol=native#text/pascal
@@ -14740,6 +14748,7 @@ tests/webtbf/tw3395.pp svneol=native#text/plain
 tests/webtbf/tw3395a.pp svneol=native#text/plain
 tests/webtbf/tw34355.pp svneol=native#text/pascal
 tests/webtbf/tw3450.pp svneol=native#text/plain
+tests/webtbf/tw34691.pp svneol=native#text/pascal
 tests/webtbf/tw3473.pp svneol=native#text/plain
 tests/webtbf/tw3480.pp svneol=native#text/plain
 tests/webtbf/tw3480a.pp svneol=native#text/plain
@@ -14774,6 +14783,7 @@ tests/webtbf/tw4256.pp svneol=native#text/plain
 tests/webtbf/tw4359.pp svneol=native#text/plain
 tests/webtbf/tw4445.pp svneol=native#text/plain
 tests/webtbf/tw4529.pp svneol=native#text/plain
+tests/webtbf/tw4541.pp svneol=native#text/pascal
 tests/webtbf/tw4554a.pp svneol=native#text/plain
 tests/webtbf/tw4554b.pp svneol=native#text/plain
 tests/webtbf/tw4554c.pp svneol=native#text/plain
@@ -14890,6 +14900,7 @@ tests/webtbf/uw25283.pp svneol=native#text/plain
 tests/webtbf/uw3450.pp svneol=native#text/plain
 tests/webtbf/uw3969.pp svneol=native#text/plain
 tests/webtbf/uw4103.pp svneol=native#text/plain
+tests/webtbf/uw4541.pp svneol=native#text/pascal
 tests/webtbf/uw6922.pp svneol=native#text/plain
 tests/webtbf/uw8738a.pas svneol=native#text/plain
 tests/webtbf/uw8738b.pas svneol=native#text/plain
@@ -16443,6 +16454,8 @@ tests/webtbs/tw3443.pp svneol=native#text/plain
 tests/webtbs/tw34438.pp svneol=native#text/pascal
 tests/webtbs/tw3444.pp svneol=native#text/plain
 tests/webtbs/tw34442.pp svneol=native#text/plain
+tests/webtbs/tw34496.pp svneol=native#text/pascal
+tests/webtbs/tw34509.pp svneol=native#text/pascal
 tests/webtbs/tw3456.pp svneol=native#text/plain
 tests/webtbs/tw3457.pp svneol=native#text/plain
 tests/webtbs/tw3460.pp svneol=native#text/plain
@@ -16626,7 +16639,6 @@ tests/webtbs/tw4533.pp svneol=native#text/plain
 tests/webtbs/tw4534.pp svneol=native#text/plain
 tests/webtbs/tw4537.pp svneol=native#text/plain
 tests/webtbs/tw4540.pp svneol=native#text/plain
-tests/webtbs/tw4541.pp svneol=native#text/plain
 tests/webtbs/tw4557.pp svneol=native#text/plain
 tests/webtbs/tw4566.pp svneol=native#text/plain
 tests/webtbs/tw4574.pp svneol=native#text/plain
@@ -17061,7 +17073,6 @@ tests/webtbs/uw4352b.pp svneol=native#text/plain
 tests/webtbs/uw4352c.pp svneol=native#text/plain
 tests/webtbs/uw4352d.pp svneol=native#text/plain
 tests/webtbs/uw4352e.pp svneol=native#text/plain
-tests/webtbs/uw4541.pp svneol=native#text/plain
 tests/webtbs/uw6203.pp svneol=native#text/plain
 tests/webtbs/uw6767.pp svneol=native#text/plain
 tests/webtbs/uw6822a.pp svneol=native#text/plain

compiler/arm/agarmgas.pas

@@ -102,6 +102,8 @@ unit agarmgas;
     function TArmGNUAssembler.MakeCmdLine: TCmdStr;
       begin
         result:=inherited MakeCmdLine;
+        if tf_section_threadvars in target_info.flags then
+          result:='-mtls-dialect=gnu '+result;
         if (current_settings.fputype = fpu_soft) then
           result:='-mfpu=softvfp '+result;
         if (current_settings.fputype = fpu_vfpv2) then

compiler/avr/cgcpu.pas

@@ -1345,21 +1345,38 @@ unit cgcpu;
            end;
          if not conv_done then
            begin
-             for i:=1 to tcgsize2size[fromsize] do
+             // CC
+             // Write to 16 bit ioreg, first high byte then low byte
+             // sequence required for 16 bit timer registers
+             // See e.g. atmega328p manual para 15.3 Accessing 16 bit registers
+             if (fromsize in [OS_16, OS_S16]) and QuickRef and (href.offset > 31)
+               and (href.offset < cpuinfo.embedded_controllers[current_settings.controllertype].srambase) then
                begin
-                   if not(QuickRef) and (i<tcgsize2size[fromsize]) then
-                     href.addressmode:=AM_POSTINCREMENT
-                   else
-                     href.addressmode:=AM_UNCHANGED;
-
+                 tmpreg:=GetNextReg(reg);
+                 href.addressmode:=AM_UNCHANGED;
+                 inc(href.offset);
+                 list.concat(taicpu.op_ref_reg(GetStore(href),href,tmpreg));
+                 dec(href.offset);
                  list.concat(taicpu.op_ref_reg(GetStore(href),href,reg));
+               end
+             else
+               begin
+                 for i:=1 to tcgsize2size[fromsize] do
+                   begin
+                       if not(QuickRef) and (i<tcgsize2size[fromsize]) then
+                         href.addressmode:=AM_POSTINCREMENT
+                       else
+                         href.addressmode:=AM_UNCHANGED;
 
-                 if QuickRef then
-                   inc(href.offset);
+                     list.concat(taicpu.op_ref_reg(GetStore(href),href,reg));
 
-                 { check if we are not in the last iteration to avoid an internalerror in GetNextReg }
-                 if i<tcgsize2size[fromsize] then
-                   reg:=GetNextReg(reg);
+                     if QuickRef then
+                       inc(href.offset);
+
+                     { check if we are not in the last iteration to avoid an internalerror in GetNextReg }
+                     if i<tcgsize2size[fromsize] then
+                       reg:=GetNextReg(reg);
+                   end;
                end;
            end;
 
@@ -2124,7 +2141,7 @@ unit cgcpu;
 
     procedure tcgavr.g_concatcopy(list : TAsmList;const source,dest : treference;len : tcgint);
       var
-        countreg,tmpreg : tregister;
+        countreg,tmpreg,tmpreg2: tregister;
         srcref,dstref : treference;
         copysize,countregsize : tcgsize;
         l : TAsmLabel;
@@ -2269,40 +2286,91 @@ unit cgcpu;
                 dstref:=dest;
               end;
 
-            for i:=1 to len do
-              begin
-                if not(SrcQuickRef) and (i<len) then
-                  srcref.addressmode:=AM_POSTINCREMENT
-                else
-                  srcref.addressmode:=AM_UNCHANGED;
+              // CC
+              // If dest is an ioreg (31 < offset < srambase) and size = 16 bit then
+              // load high byte first, then low byte
+              if (len = 2) and DestQuickRef
+                and (dest.offset > 31)
+                and (dest.offset < cpuinfo.embedded_controllers[current_settings.controllertype].srambase) then
+                begin
+                  // If src is also a 16 bit ioreg then read low byte then high byte
+                  if SrcQuickRef and (srcref.offset > 31)
+                    and (srcref.offset < cpuinfo.embedded_controllers[current_settings.controllertype].srambase) then
+                    begin
+                      // First read source into temp registers
+                      tmpreg:=getintregister(list, OS_16);
+                      list.concat(taicpu.op_reg_ref(GetLoad(srcref),tmpreg,srcref));
+                      inc(srcref.offset);
+                      tmpreg2:=GetNextReg(tmpreg);
+                      list.concat(taicpu.op_reg_ref(GetLoad(srcref),tmpreg2,srcref));
+
+                      // then move temp registers to dest in reverse order
+                      inc(dstref.offset);
+                      list.concat(taicpu.op_ref_reg(GetStore(dstref),dstref,tmpreg2));
+                      dec(dstref.offset);
+                      list.concat(taicpu.op_ref_reg(GetStore(dstref),dstref,tmpreg));
+                    end
+                  else
+                    begin
+                      srcref.addressmode:=AM_UNCHANGED;
+                      inc(srcref.offset);
+                      dstref.addressmode:=AM_UNCHANGED;
+                      inc(dstref.offset);
+
+                      cg.getcpuregister(list,NR_R0);
+                      list.concat(taicpu.op_reg_ref(GetLoad(srcref),NR_R0,srcref));
+                      list.concat(taicpu.op_ref_reg(GetStore(dstref),dstref,NR_R0));
+                      cg.ungetcpuregister(list,NR_R0);
+
+                      if not(SrcQuickRef) then
+                        srcref.addressmode:=AM_POSTINCREMENT
+                      else
+                        srcref.addressmode:=AM_UNCHANGED;
+
+                      dec(srcref.offset);
+                      dec(dstref.offset);
+
+                      cg.getcpuregister(list,NR_R0);
+                      list.concat(taicpu.op_reg_ref(GetLoad(srcref),NR_R0,srcref));
+                      list.concat(taicpu.op_ref_reg(GetStore(dstref),dstref,NR_R0));
+                      cg.ungetcpuregister(list,NR_R0);
+                    end;
+                end
+              else
+              for i:=1 to len do
+                begin
+                  if not(SrcQuickRef) and (i<len) then
+                    srcref.addressmode:=AM_POSTINCREMENT
+                  else
+                    srcref.addressmode:=AM_UNCHANGED;
 
-                if not(DestQuickRef) and (i<len) then
-                  dstref.addressmode:=AM_POSTINCREMENT
-                else
-                  dstref.addressmode:=AM_UNCHANGED;
+                  if not(DestQuickRef) and (i<len) then
+                    dstref.addressmode:=AM_POSTINCREMENT
+                  else
+                    dstref.addressmode:=AM_UNCHANGED;
 
-                cg.getcpuregister(list,NR_R0);
-                list.concat(taicpu.op_reg_ref(GetLoad(srcref),NR_R0,srcref));
-                list.concat(taicpu.op_ref_reg(GetStore(dstref),dstref,NR_R0));
-                cg.ungetcpuregister(list,NR_R0);
+                  cg.getcpuregister(list,NR_R0);
+                  list.concat(taicpu.op_reg_ref(GetLoad(srcref),NR_R0,srcref));
+                  list.concat(taicpu.op_ref_reg(GetStore(dstref),dstref,NR_R0));
+                  cg.ungetcpuregister(list,NR_R0);
 
-                if SrcQuickRef then
-                  inc(srcref.offset);
-                if DestQuickRef then
-                  inc(dstref.offset);
-              end;
-            if not(SrcQuickRef) then
-              begin
-                ungetcpuregister(list,srcref.base);
-                ungetcpuregister(list,TRegister(ord(srcref.base)+1));
-              end;
-            if not(DestQuickRef) then
-              begin
-                ungetcpuregister(list,dstref.base);
-                ungetcpuregister(list,TRegister(ord(dstref.base)+1));
-              end;
-          end;
-      end;
+                  if SrcQuickRef then
+                    inc(srcref.offset);
+                  if DestQuickRef then
+                    inc(dstref.offset);
+                end;
+              if not(SrcQuickRef) then
+                begin
+                  ungetcpuregister(list,srcref.base);
+                  ungetcpuregister(list,TRegister(ord(srcref.base)+1));
+                end;
+              if not(DestQuickRef) then
+                begin
+                  ungetcpuregister(list,dstref.base);
+                  ungetcpuregister(list,TRegister(ord(dstref.base)+1));
+                end;
+            end;
+        end;
 
 
     procedure tcgavr.g_overflowCheck(list : TAsmList;const l : tlocation;def : tdef);

compiler/globals.pas

@@ -406,9 +406,9 @@ interface
           procalign : 0;
           loopalign : 0;
           jumpalign : 0;
-          jumpalignmax    : 0;
+          jumpalignskipmax    : 0;
           coalescealign   : 0;
-          coalescealignmax: 0;
+          coalescealignskipmax: 0;
           constalignmin : 0;
           constalignmax : 0;
           varalignmin : 0;

compiler/msg/errore.msg

@@ -2028,7 +2028,7 @@ type_w_empty_constant_range_set=04125_W_The first value of a set constructur ran
 #
 # Symtable
 #
-# 05097 is the last used one
+# 05098 is the last used one
 #
 % \section{Symbol handling}
 % This section lists all the messages that concern the handling of symbols.
@@ -2344,6 +2344,8 @@ sym_e_generic_type_param_mismatch=05096_E_Generic type parameter "$1" does not m
 sym_e_generic_type_param_decl=05097_E_Generic type parameter declared as "$1"
 % Shows what the generic type parameter was originally declared as if a mismatch
 % is found between a declaration and the definition.
+sym_e_type_must_be_rec_or_object=05098_E_Record or object type expected
+% The variable or expression isn't of the type \var{record} or \var{object}.
 % \end{description}
 #
 # Codegenerator

compiler/msgidx.inc

@@ -659,6 +659,7 @@ const
   sym_w_duplicate_id=05095;
   sym_e_generic_type_param_mismatch=05096;
   sym_e_generic_type_param_decl=05097;
+  sym_e_type_must_be_rec_or_object=05098;
   cg_e_parasize_too_big=06009;
   cg_e_file_must_call_by_reference=06012;
   cg_e_cant_use_far_pointer_there=06013;
@@ -1105,9 +1106,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 82667;
+  MsgTxtSize = 82706;
 
   MsgIdxMax : array[1..20] of longint=(
-    28,106,349,126,98,59,142,34,221,67,
+    28,106,349,126,99,59,142,34,221,67,
     62,20,30,1,1,1,1,1,1,1
   );

compiler/ncgflw.pas

@@ -225,7 +225,7 @@ implementation
          if not(cs_opt_size in current_settings.optimizerswitches) then
             { align loop target, as an unconditional jump is done before,
               use jump align which assume that the instructions inserted as alignment are never executed }
-            current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.jumpalign,current_settings.alignment.jumpalignmax));
+            current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.jumpalign,current_settings.alignment.jumpalignskipmax));
 
          hlcg.a_label(current_asmdata.CurrAsmList,lloop);
 
@@ -348,7 +348,7 @@ implementation
                    ;
                    hlcg.a_jmp_always(current_asmdata.CurrAsmList,hl);
                    if not(cs_opt_size in current_settings.optimizerswitches) then
-                     current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.jumpalign,current_settings.alignment.jumpalignmax));
+                     current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.jumpalign,current_settings.alignment.jumpalignskipmax));
                 end;
               hlcg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
               secondpass(t1);
@@ -378,13 +378,13 @@ implementation
                 end;
 *)
               if not(cs_opt_size in current_settings.optimizerswitches) then
-                current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.coalescealign,current_settings.alignment.coalescealignmax));
+                current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.coalescealign,current_settings.alignment.coalescealignskipmax));
               hlcg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
            end;
          if not(assigned(right)) then
            begin
              if not(cs_opt_size in current_settings.optimizerswitches) then
-               current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.coalescealign,current_settings.alignment.coalescealignmax));
+               current_asmdata.CurrAsmList.concat(cai_align.create_max(current_settings.alignment.coalescealign,current_settings.alignment.coalescealignskipmax));
              hlcg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
            end;
 

compiler/ncgset.pas

@@ -73,6 +73,13 @@ interface
           jumptable_no_range : boolean;
           { has the implementation jumptable support }
           min_label : tconstexprint;
+          { Number of labels }
+          labelcnt: TCgInt;
+          { Number of individual values checked, counting each value in a range
+            individually (e.g. 0..2 counts as 3). }
+          TrueCount: TCgInt;
+
+          function GetBranchLabel(Block: TNode; out _Label: TAsmLabel): Boolean;
 
           function  blocklabel(id:longint):tasmlabel;
           procedure optimizevalues(var max_linear_list:aint;var max_dist:aword);virtual;
@@ -90,9 +97,10 @@ implementation
 
     uses
       verbose,
-      symconst,symdef,defutil,
+      cutils,
+      symconst,symdef,symsym,defutil,
       pass_2,tgobj,
-      ncon,
+      nbas,ncon,ncgflw,
       ncgutil,hlcgobj;
 
 
@@ -524,6 +532,79 @@ implementation
                             TCGCASENODE
 *****************************************************************************}
 
+
+    { Analyse the nodes following the else label - if empty, change to end label }
+    function tcgcasenode.GetBranchLabel(Block: TNode; out _Label: TAsmLabel): Boolean;
+      var
+        LabelSym: TLabelSym;
+      begin
+        Result := True;
+
+        if not Assigned(Block) then
+          begin
+            { Block doesn't exist / is empty }
+            _Label := endlabel;
+            Exit;
+          end;
+
+        { These optimisations aren't particularly debugger friendly }
+        if not (cs_opt_level2 in current_settings.optimizerswitches) then
+          begin
+            Result := False;
+            current_asmdata.getjumplabel(_Label);
+            Exit;
+          end;
+
+        while Assigned(Block) do
+          begin
+            case Block.nodetype of
+              nothingn:
+                begin
+                  _Label := endlabel;
+                  Exit;
+                end;
+              goton:
+                begin
+                  LabelSym := TCGGotoNode(Block).labelsym;
+                  if not Assigned(LabelSym) then
+                    InternalError(2018121131);
+
+                  _Label := TCGLabelNode(TCGGotoNode(Block).labelnode).getasmlabel;
+                  if Assigned(_Label) then
+                    { Keep tabs on the fact that an actual 'goto' was used }
+                    Include(flowcontrol,fc_gotolabel)
+                  else
+                    Break;
+                  Exit;
+                end;
+              blockn:
+                begin
+                  Block := TBlockNode(Block).Left;
+                  Continue;
+                end;
+              statementn:
+                begin
+                  { If the right node is assigned, then it's a compound block
+                    that can't be simplified, so fall through, set Result to
+                    False and make a new label }
+
+                  if Assigned(TStatementNode(Block).right) then
+                    Break;
+
+                  Block := TStatementNode(Block).Left;
+                  Continue;
+                end;
+            end;
+
+            Break;
+          end;
+
+        { Create unique label }
+        Result := False;
+        current_asmdata.getjumplabel(_Label);
+      end;
+
+
     function tcgcasenode.blocklabel(id:longint):tasmlabel;
       begin
         if not assigned(blocks[id]) then
@@ -560,17 +641,18 @@ implementation
          newsize: tcgsize;
          newdef: tdef;
 
-      procedure genitem(t : pcaselabel);
+      procedure gensub(value:tcgint);
+        begin
+          { here, since the sub and cmp are separate we need
+            to move the result before subtract to help
+            the register allocator
+          }
+          hlcg.a_load_reg_reg(current_asmdata.CurrAsmList, opsize, opsize, hregister, scratch_reg);
+          hlcg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opsize, value, hregister);
+        end;
 
-          procedure gensub(value:tcgint);
-            begin
-              { here, since the sub and cmp are separate we need
-                to move the result before subtract to help
-                the register allocator
-              }
-              hlcg.a_load_reg_reg(current_asmdata.CurrAsmList, opsize, opsize, hregister, scratch_reg);
-              hlcg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opsize, value, hregister);
-            end;
+
+      procedure genitem(t : pcaselabel);
 
         begin
            if assigned(t^.less) then
@@ -641,10 +723,25 @@ implementation
                   hregister:=scratch_reg;
                   opsize:=newdef;
                 end;
-              last:=0;
-              first:=true;
-              scratch_reg:=hlcg.getintregister(current_asmdata.CurrAsmList,opsize);
-              genitem(hp);
+              if (labelcnt>1) or not(cs_opt_level1 in current_settings.optimizerswitches) then
+                begin
+                  last:=0;
+                  first:=true;
+                  scratch_reg:=hlcg.getintregister(current_asmdata.CurrAsmList,opsize);
+                  genitem(hp);
+                end
+              else
+                begin
+                  { If only one label exists, we can greatly simplify the checks to a simple comparison }
+                  if hp^._low=hp^._high then
+                    hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ, tcgint(hp^._low.svalue), hregister, blocklabel(hp^.blockid))
+                  else
+                    begin
+                      scratch_reg:=hlcg.getintregister(current_asmdata.CurrAsmList,opsize);
+                      gensub(tcgint(hp^._low.svalue));
+                      hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_BE, tcgint(hp^._high.svalue-hp^._low.svalue), hregister, blocklabel(hp^.blockid))
+                    end;
+                end;
               hlcg.a_jmp_always(current_asmdata.CurrAsmList,elselabel);
            end;
       end;
@@ -1043,25 +1140,43 @@ implementation
       end;
 
     procedure tcgcasenode.pass_generate_code;
+
+      { Combines "case_count_labels" and "case_true_count" }
+      procedure CountBoth(p : pcaselabel);
+        begin
+          Inc(labelcnt);
+          Inc(TrueCount, (p^._high.svalue - p^._low.svalue) + 1);
+          if assigned(p^.less) then
+            CountBoth(p^.less);
+          if assigned(p^.greater) then
+            CountBoth(p^.greater);
+        end;
+
       var
          oldflowcontrol: tflowcontrol;
          i : longint;
-         dist,distv,
+         dist : aword;
+         distv,
          lv,hv,
          max_label: tconstexprint;
-         labelcnt : tcgint;
          max_linear_list : aint;
          max_dist : aword;
+         ShortcutElse: Boolean;
       begin
          location_reset(location,LOC_VOID,OS_NO);
 
          oldflowcontrol := flowcontrol;
          include(flowcontrol,fc_inflowcontrol);
          { Allocate labels }
+
          current_asmdata.getjumplabel(endlabel);
-         current_asmdata.getjumplabel(elselabel);
+
+         { Do some optimisation to deal with empty else blocks }
+         ShortcutElse := GetBranchLabel(elseblock, elselabel);
+
          for i:=0 to blocks.count-1 do
-           current_asmdata.getjumplabel(pcaseblock(blocks[i])^.blocklabel);
+           with pcaseblock(blocks[i])^ do
+             shortcut := GetBranchLabel(statement, blocklabel);
 
          with_sign:=is_signed(left.resultdef);
          if with_sign then
@@ -1109,6 +1224,9 @@ implementation
          else
 {$endif not cpu64bitalu}
            begin
+              labelcnt := 0;
+              TrueCount := 0;
+
               if cs_opt_level1 in current_settings.optimizerswitches then
                 begin
                    { procedures are empirically passed on }
@@ -1118,8 +1236,11 @@ implementation
                    { moreover can the size only be appro- }
                    { ximated as it is not known if rel8,  }
                    { rel16 or rel32 jumps are used   }
-                   max_label:=case_get_max(labels);
-                   labelcnt:=case_count_labels(labels);
+
+                   CountBoth(labels);
+
+                   max_label := case_get_max(labels);
+
                    { can we omit the range check of the jump table ? }
                    getrange(left.resultdef,lv,hv);
                    jumptable_no_range:=(lv=min_label) and (hv=max_label);
@@ -1128,7 +1249,7 @@ implementation
                    if distv>=0 then
                      dist:=distv.uvalue
                    else
-                     dist:=-distv.svalue;
+                     dist:=aword(-distv.svalue);
 
                    { optimize for size ? }
                    if cs_opt_size in current_settings.optimizerswitches  then
@@ -1137,8 +1258,8 @@ implementation
                           (min_label>=int64(low(aint))) and
                           (max_label<=high(aint)) and
                           not((labelcnt<=2) or
-                              ((max_label-min_label)<0) or
-                              ((max_label-min_label)>3*labelcnt)) then
+                              (distv.svalue<0) or
+                              (dist>3*TrueCount)) then
                          begin
                            { if the labels less or more a continuum then }
                            genjumptable(labels,min_label.svalue,max_label.svalue);
@@ -1151,7 +1272,12 @@ implementation
                      end
                    else
                      begin
-                        max_dist:=4*labelcnt;
+                        max_dist:=4*TrueCount;
+
+                        { Don't allow jump tables to get too large }
+                        if max_dist>4*labelcnt then
+                          max_dist:=min(max_dist,2048);
+
                         if jumptable_no_range then
                           max_linear_list:=4
                         else
@@ -1187,26 +1313,37 @@ implementation
            end;
 
          { generate the instruction blocks }
-         for i:=0 to blocks.count-1 do
+         for i:=0 to blocks.count-1 do with pcaseblock(blocks[i])^ do
            begin
-              current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
-              cg.a_label(current_asmdata.CurrAsmList,pcaseblock(blocks[i])^.blocklabel);
-              secondpass(pcaseblock(blocks[i])^.statement);
-              { don't come back to case line }
-              current_filepos:=current_asmdata.CurrAsmList.getlasttaifilepos^;
+             { If the labels are not equal, then the block label has been shortcut to point elsewhere,
+               so there's no need to implement it }
+             if not shortcut then
+               begin
+                 current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
+                 cg.a_label(current_asmdata.CurrAsmList,blocklabel);
+                 secondpass(statement);
+                 { don't come back to case line }
+                 current_filepos:=current_asmdata.CurrAsmList.getlasttaifilepos^;
 {$ifdef OLDREGVARS}
-              load_all_regvars(current_asmdata.CurrAsmList);
+                 load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
-              hlcg.a_jmp_always(current_asmdata.CurrAsmList,endlabel);
+                 hlcg.a_jmp_always(current_asmdata.CurrAsmList,endlabel);
+               end;
            end;
-         current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
+
          { ...and the else block }
-         hlcg.a_label(current_asmdata.CurrAsmList,elselabel);
-         if assigned(elseblock) then
+         if not ShortcutElse then
            begin
-              secondpass(elseblock);
+             current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
+             hlcg.a_label(current_asmdata.CurrAsmList,elselabel);
+           end;
+
+         if Assigned(elseblock) then
+           begin
+
+             secondpass(elseblock);
 {$ifdef OLDREGVARS}
-              load_all_regvars(current_asmdata.CurrAsmList);
+             load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
            end;
 

compiler/nobj.pas

@@ -511,6 +511,7 @@ implementation
         hclass : tobjectdef;
         hashedid : THashedIDString;
         srsym      : tsym;
+        overload: boolean;
       begin
         result:=nil;
         hashedid.id:=name;
@@ -523,9 +524,12 @@ implementation
                ((hclass=_class) or
                 is_visible_for_object(srsym,_class)) then
               begin
+                overload:=false;
                 for i:=0 to Tprocsym(srsym).ProcdefList.Count-1 do
                   begin
                     implprocdef:=tprocdef(tprocsym(srsym).ProcdefList[i]);
+                    if po_overload in implprocdef.procoptions then
+                      overload:=true;
                     if (implprocdef.procsym=tprocsym(srsym)) and
                        (compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_ignoreuniv])>=te_equal) and
                        (compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and
@@ -546,6 +550,10 @@ implementation
                         exit;
                       end;
                   end;
+                { like with normal procdef resolution (in htypechk), stop if
+                  we encounter a proc without the overload directive }
+                if not overload then
+                  exit;
               end;
             hclass:=hclass.childof;
           end;

compiler/nset.pas

@@ -62,6 +62,12 @@ interface
           { label (only used in pass_generate_code) }
           blocklabel : tasmlabel;
 
+          { shortcut - set to true if blocklabel isn't actually unique to the
+            case block due to one of the following conditions:
+            - if the node contains a jump, then the label is set to that jump's destination,
+            - if the node is empty, the label is set to the end label. }
+          shortcut: Boolean;
+
           statementlabel : tlabelnode;
           { instructions }
           statement  : tnode;
@@ -121,6 +127,9 @@ interface
 
     { counts the labels }
     function case_count_labels(root : pcaselabel) : longint;
+    { Returns the true count in a case block, which includes each individual
+      value in a range (e.g. "0..2" counts as 3) }
+    function case_true_count(root : pcaselabel) : longint;
     { searches the highest label }
     function case_get_max(root : pcaselabel) : tconstexprint;
     { searches the lowest label }
@@ -439,6 +448,29 @@ implementation
       end;
 
 
+    { Returns the true count in a case block, which includes each individual
+      value in a range (e.g. "0..2" counts as 3) }
+    function case_true_count(root : pcaselabel) : longint;
+      var
+         _l : longint;
+
+      procedure count(p : pcaselabel);
+        begin
+           inc(_l, (p^._high.svalue - p^._low.svalue) + 1);
+           if assigned(p^.less) then
+             count(p^.less);
+           if assigned(p^.greater) then
+             count(p^.greater);
+        end;
+
+      begin
+        _l:=0;
+        count(root);
+        case_true_count:=_l;
+      end;
+
+
+
     function case_get_max(root : pcaselabel) : tconstexprint;
       var
          hp : pcaselabel;

compiler/ogomf.pas

@@ -2684,7 +2684,7 @@ implementation
             ObjSec:=TOmfObjSection(ExeSec.ObjSectionList[i]);
             if ObjSec.MemPos<Header.LoadableImageSize then
               begin
-                FWriter.WriteZeros(max(0,ObjSec.MemPos-ComFileOffset-FWriter.Size));
+                FWriter.WriteZeros(max(0,int64(ObjSec.MemPos)-ComFileOffset-int64(FWriter.Size)));
                 if assigned(ObjSec.Data) then
                   begin
                     if ObjSec.MemPos<ComFileOffset then

compiler/pdecvar.pas

@@ -132,6 +132,8 @@ implementation
                      end;
                    _POINT :
                      begin
+                       if not is_object(def) and not is_record(def) then
+                         message(sym_e_type_must_be_rec_or_object);
                        consume(_POINT);
                        if assigned(def) then
                         begin

compiler/scanner.pas

@@ -3042,9 +3042,9 @@ type
             alignment.procalign:=tokenreadlongint;
             alignment.loopalign:=tokenreadlongint;
             alignment.jumpalign:=tokenreadlongint;
-            alignment.jumpalignmax:=tokenreadlongint;
+            alignment.jumpalignskipmax:=tokenreadlongint;
             alignment.coalescealign:=tokenreadlongint;
-            alignment.coalescealignmax:=tokenreadlongint;
+            alignment.coalescealignskipmax:=tokenreadlongint;
             alignment.constalignmin:=tokenreadlongint;
             alignment.constalignmax:=tokenreadlongint;
             alignment.varalignmin:=tokenreadlongint;
@@ -3127,9 +3127,9 @@ type
             tokenwritelongint(alignment.procalign);
             tokenwritelongint(alignment.loopalign);
             tokenwritelongint(alignment.jumpalign);
-            tokenwritelongint(alignment.jumpalignmax);
+            tokenwritelongint(alignment.jumpalignskipmax);
             tokenwritelongint(alignment.coalescealign);
-            tokenwritelongint(alignment.coalescealignmax);
+            tokenwritelongint(alignment.coalescealignskipmax);
             tokenwritelongint(alignment.constalignmin);
             tokenwritelongint(alignment.constalignmax);
             tokenwritelongint(alignment.varalignmin);

compiler/systems.pas

@@ -47,15 +47,15 @@ interface
          { alignment for labels after unconditional jumps, this must be a power of two }
          jumpalign,
          { max. alignment for labels after unconditional jumps:
-           the compiler tries to align jumpalign, however, to do so it inserts at maximum jumpalignmax bytes or uses
+           the compiler tries to align jumpalign, however, to do so it inserts at maximum jumpalignskipmax bytes or uses
            the next smaller power of two of jumpalign }
-         jumpalignmax,
+         jumpalignskipmax,
          { alignment for labels where two flows of the program flow coalesce, this must be a power of two }
          coalescealign,
          { max. alignment for labels where two flows of the program flow coalesce
-           the compiler tries to align to coalescealign, however, to do so it inserts at maximum coalescealignmax bytes or uses
+           the compiler tries to align to coalescealign, however, to do so it inserts at maximum coalescealignskipmax bytes or uses
            the next smaller power of two of coalescealign }
-         coalescealignmax,
+         coalescealignskipmax,
          constalignmin,
          constalignmax,
          varalignmin,
@@ -675,10 +675,10 @@ begin
        coalescealign:=s.coalescealign
      else if s.coalescealign<>0 then
        result:=false;
-     if s.jumpalignmax>0 then
-       jumpalignmax:=s.jumpalignmax;
+     if s.jumpalignskipmax>0 then
+       jumpalignskipmax:=s.jumpalignskipmax;
      if s.coalescealign>0 then
-       coalescealignmax:=s.coalescealignmax;
+       coalescealignskipmax:=s.coalescealignskipmax;
      { general update rules:
        minimum: if higher then update
        maximum: if lower then update or if undefined then update }

compiler/systems/i_aix.pas

@@ -76,9 +76,9 @@ unit i_aix;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -143,9 +143,9 @@ unit i_aix;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 8;
                 constalignmax   : 16;
                 varalignmin     : 8;

compiler/systems/i_amiga.pas

@@ -75,9 +75,9 @@ unit i_amiga;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -141,9 +141,9 @@ unit i_amiga;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_android.pas

@@ -78,9 +78,9 @@ unit i_android;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;
@@ -147,9 +147,9 @@ unit i_android;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -216,9 +216,9 @@ unit i_android;
                  procalign       : 8;
                  loopalign       : 4;
                  jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                  constalignmin   : 0;
                  constalignmax   : 16;
                  varalignmin     : 0;
@@ -285,9 +285,9 @@ unit i_android;
                  procalign       : 16;
                  loopalign       : 8;
                  jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                  constalignmin   : 0;
                  constalignmax   : 16;
                  varalignmin     : 0;
@@ -353,9 +353,9 @@ unit i_android;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;

compiler/systems/i_aros.pas

@@ -75,9 +75,9 @@ unit i_aros;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -141,9 +141,9 @@ unit i_aros;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -206,9 +206,9 @@ unit i_aros;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;

compiler/systems/i_atari.pas

@@ -75,9 +75,9 @@ unit i_atari;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_beos.pas

@@ -76,9 +76,9 @@ unit i_beos;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_bsd.pas

@@ -105,9 +105,9 @@ unit i_bsd;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -176,9 +176,9 @@ unit i_bsd;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -246,9 +246,9 @@ unit i_bsd;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -313,9 +313,9 @@ unit i_bsd;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -379,9 +379,9 @@ unit i_bsd;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -449,9 +449,9 @@ unit i_bsd;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -516,9 +516,9 @@ unit i_bsd;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 1;
                 varalignmin     : 0;
@@ -582,9 +582,9 @@ unit i_bsd;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -652,9 +652,9 @@ unit i_bsd;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -718,9 +718,9 @@ unit i_bsd;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -784,9 +784,9 @@ unit i_bsd;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -850,11 +850,11 @@ unit i_bsd;
             alignment    :
               (
                 procalign       : 16;
-                loopalign       : 4;
-                jumpalign       : 0;
-                jumpalignmax    : 0;
+                loopalign       : 8;
+                jumpalign       : 16;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -918,11 +918,11 @@ unit i_bsd;
             alignment    :
               (
                 procalign       : 16;
-                loopalign       : 4;
-                jumpalign       : 0;
-                jumpalignmax    : 0;
+                loopalign       : 8;
+                jumpalign       : 16;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -988,9 +988,9 @@ unit i_bsd;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 4;
                 constalignmax   : 8;
                 varalignmin     : 4;
@@ -1054,12 +1054,12 @@ unit i_bsd;
             endian       : endian_little;
             alignment    :
               (
-                procalign       : 8;
-                loopalign       : 4;
-                jumpalign       : 0;
-                jumpalignmax    : 0;
+                procalign       : 16;
+                loopalign       : 8;
+                jumpalign       : 16;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -1121,12 +1121,12 @@ unit i_bsd;
             endian       : endian_little;
             alignment    :
               (
-                procalign       : 8;
-                loopalign       : 4;
-                jumpalign       : 0;
-                jumpalignmax    : 0;
+                procalign       : 16;
+                loopalign       : 8;
+                jumpalign       : 16;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -1188,12 +1188,12 @@ unit i_bsd;
             endian       : endian_little;
             alignment    :
               (
-                procalign       : 4;
+                procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;
@@ -1256,12 +1256,12 @@ unit i_bsd;
             endian       : endian_little;
             alignment    :
               (
-                procalign       : 8;
+                procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;

compiler/systems/i_embed.pas

@@ -82,9 +82,9 @@ unit i_embed;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -149,9 +149,9 @@ unit i_embed;
                 procalign       : 1;
                 loopalign       : 1;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 1;
                 varalignmin     : 0;
@@ -216,9 +216,9 @@ unit i_embed;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -283,9 +283,9 @@ unit i_embed;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -350,9 +350,9 @@ unit i_embed;
                 procalign       : 16;
                 loopalign       : 8;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -428,9 +428,9 @@ unit i_embed;
                 procalign       : 1;
                 loopalign       : 1;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 2;
                 varalignmin     : 0;
@@ -495,9 +495,9 @@ unit i_embed;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_emx.pas

@@ -86,9 +86,9 @@ unit i_emx;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_gba.pas

@@ -76,9 +76,9 @@ unit i_gba;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;

compiler/systems/i_go32v2.pas

@@ -75,9 +75,9 @@ unit i_go32v2;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_haiku.pas

@@ -77,9 +77,9 @@ unit i_haiku;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_jvm.pas

@@ -93,9 +93,9 @@ unit i_jvm;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 4;
@@ -162,9 +162,9 @@ unit i_jvm;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 4;

compiler/systems/i_linux.pas

@@ -81,9 +81,9 @@ unit i_linux;
                 procalign       : 16;
                 loopalign       : 8;
                 jumpalign       : 16;
-                jumpalignmax    : 10;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -150,9 +150,9 @@ unit i_linux;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -219,9 +219,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -287,9 +287,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -354,9 +354,9 @@ unit i_linux;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 4;
                 constalignmax   : 16;
                 varalignmin     : 4;
@@ -422,10 +422,10 @@ unit i_linux;
               (
                 procalign       : 16;
                 loopalign       : 8;
-                jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalign       : 16;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -493,9 +493,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 4;
                 constalignmax   : 8;
                 varalignmin     : 4;
@@ -563,9 +563,9 @@ unit i_linux;
                 procalign       : 16;
                 loopalign       : 8;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 4;
                 constalignmax   : 16;
                 varalignmin     : 4;
@@ -636,9 +636,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;
@@ -709,9 +709,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;
@@ -779,9 +779,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -847,9 +847,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -925,9 +925,9 @@ unit i_linux;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -995,9 +995,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;
@@ -1065,9 +1065,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;
@@ -1134,9 +1134,9 @@ unit i_linux;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;
                 varalignmin     : 0;
@@ -1203,9 +1203,9 @@ unit i_linux;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 4;
                 constalignmax   : 16;
                 varalignmin     : 4;

compiler/systems/i_macos.pas

@@ -74,9 +74,9 @@ unit i_macos;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -141,9 +141,9 @@ unit i_macos;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_morph.pas

@@ -76,9 +76,9 @@ unit i_morph;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_msdos.pas

@@ -93,9 +93,9 @@ unit i_msdos;
                 procalign       : 1;
                 loopalign       : 1;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 2;
                 varalignmin     : 0;

compiler/systems/i_nativent.pas

@@ -80,9 +80,9 @@ unit i_nativent;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;

compiler/systems/i_nds.pas

@@ -76,9 +76,9 @@ unit i_nds;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 8;//4;
                 varalignmin     : 0;

compiler/systems/i_nwl.pas

@@ -75,9 +75,9 @@ unit i_nwl;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_nwm.pas

@@ -75,9 +75,9 @@ unit i_nwm;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_os2.pas

@@ -86,9 +86,9 @@ unit i_os2;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_palmos.pas

@@ -76,9 +76,9 @@ unit i_palmos;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -153,9 +153,9 @@ unit i_palmos;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_sunos.pas

@@ -78,9 +78,9 @@ unit i_sunos;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -150,9 +150,9 @@ unit i_sunos;
                 procalign       : 8;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -221,9 +221,9 @@ unit i_sunos;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 4;
                 constalignmax   : 8;
                 varalignmin     : 4;

compiler/systems/i_symbian.pas

@@ -77,9 +77,9 @@ unit i_symbian;
                 procalign       : 16;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -144,9 +144,9 @@ unit i_symbian;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_watcom.pas

@@ -75,9 +75,9 @@ unit i_watcom;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_wdosx.pas

@@ -75,9 +75,9 @@ unit i_wdosx;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_wii.pas

@@ -75,9 +75,9 @@ unit i_wii;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_win.pas

@@ -80,9 +80,9 @@ unit i_win;
                 procalign       : 16;
                 loopalign       : 8;
                 jumpalign       : 16;
-                jumpalignmax    : 10;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -150,10 +150,10 @@ unit i_win;
               (
                 procalign       : 16;
                 loopalign       : 8;
-                jumpalign       : 4;
-                jumpalignmax    : 0;
+                jumpalign       : 16;
+                jumpalignskipmax    : 10;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 16;
                 varalignmin     : 0;
@@ -220,9 +220,9 @@ unit i_win;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;
@@ -289,9 +289,9 @@ unit i_win;
                 procalign       : 4;
                 loopalign       : 4;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 4;
                 varalignmin     : 0;

compiler/systems/i_win16.pas

@@ -94,9 +94,9 @@ unit i_win16;
                 procalign       : 1;
                 loopalign       : 1;
                 jumpalign       : 0;
-                jumpalignmax    : 0;
+                jumpalignskipmax    : 0;
                 coalescealign   : 0;
-                coalescealignmax: 0;
+                coalescealignskipmax: 0;
                 constalignmin   : 0;
                 constalignmax   : 2;
                 varalignmin     : 0;

compiler/x86/nx86set.pas

@@ -47,7 +47,7 @@ implementation
     uses
       systems,
       verbose,globals,
-      symconst,symdef,defutil,
+      symconst,symdef,defutil,cutils,
       aasmbase,aasmtai,aasmdata,aasmcpu,
       cgbase,pass_2,tgobj,
       ncon,
@@ -76,6 +76,12 @@ implementation
         opcgsize: tcgsize;
         jumpreg: tregister;
         labeltyp: taiconst_type;
+        AlmostExhaustive: Boolean;
+        lv, hv: TConstExprInt;
+        ExhaustiveLimit, Range, x, oldmin : aint;
+
+      const
+        ExhaustiveLimitBase = 32;
 
         procedure genitem(list:TAsmList;t : pcaselabel);
           var
@@ -83,6 +89,7 @@ implementation
           begin
             if assigned(t^.less) then
               genitem(list,t^.less);
+
             { fill possible hole }
             i:=last.svalue+1;
             while i<=t^._low.svalue-1 do
@@ -102,20 +109,51 @@ implementation
           end;
 
       begin
+        lv:=0;
+        hv:=0;
+        oldmin:=0;
         last:=min_;
         { This generates near pointers on i8086 }
         labeltyp:=aitconst_ptr;
         opcgsize:=def_cgsize(opsize);
+
+        AlmostExhaustive := False;
+
         if not(jumptable_no_range) then
           begin
-             { a <= x <= b <-> unsigned(x-a) <= (b-a) }
-             cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opcgsize,aint(min_),hregister);
-             { case expr greater than max_ => goto elselabel }
-             cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opcgsize,OC_A,aint(max_)-aint(min_),hregister,elselabel);
-             min_:=0;
-             { do not sign extend when we load the index register, as we applied an offset above }
-             opcgsize:=tcgsize2unsigned[opcgsize];
+
+            getrange(left.resultdef,lv,hv);
+            Range := aint(max_)-aint(min_);
+
+            if (cs_opt_size in current_settings.optimizerswitches) then
+              { Limit size of jump tables for small enumerations so they have
+                to be at least two-thirds full before being considered for the
+                "almost exhaustive" treatment }
+              ExhaustiveLimit := min(ExhaustiveLimitBase, TrueCount shl 1)
+            else
+              ExhaustiveLimit := ExhaustiveLimitBase;
+
+            { If true, then this indicates that almost every possible value of x is covered by
+              a label.  As such, it's more cost-efficient to remove the initial range check and
+              instead insert the remaining values into the jump table, pointing at elselabel. [Kit] }
+            if ((hv - lv) - Range <= ExhaustiveLimit) then
+              begin
+                oldmin := min_;
+                min_ := lv.svalue;
+                AlmostExhaustive := True;
+              end
+            else
+              begin
+                { a <= x <= b <-> unsigned(x-a) <= (b-a) }
+                cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opcgsize,aint(min_),hregister);
+                { case expr greater than max_ => goto elselabel }
+                cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opcgsize,OC_A,aint(max_)-aint(min_),hregister,elselabel);
+                min_:=0;
+                { do not sign extend when we load the index register, as we applied an offset above }
+                opcgsize:=tcgsize2unsigned[opcgsize];
+              end;
           end;
+
         current_asmdata.getglobaldatalabel(table);
         { make it a 32bit register }
         indexreg:=cg.makeregsize(current_asmdata.CurrAsmList,hregister,OS_INT);
@@ -148,7 +186,31 @@ implementation
           jtlist:=current_procinfo.aktlocaldata;
         new_section(jtlist,sec_rodata,current_procinfo.procdef.mangledname,sizeof(aint));
         jtlist.concat(Tai_label.Create(table));
-        genitem(jtlist,hp);
+
+        if AlmostExhaustive then
+          begin
+            { Fill the table with the values below _min }
+            x := lv.svalue;
+            while x < oldmin do
+              begin
+                jtlist.concat(Tai_const.Create_type_sym(labeltyp, elselabel));
+                Inc(x);
+              end;
+
+            genitem(jtlist,hp);
+
+            { Fill the table with the values above _max }
+            { Subtracting one from hv and not adding 1 to max averts the risk of an overflow }
+            x := max_;
+            hv := hv - 1;
+            while x <= hv.svalue do
+              begin
+                jtlist.concat(Tai_const.Create_type_sym(labeltyp, elselabel));
+                Inc(x);
+              end;
+          end
+        else
+          genitem(jtlist,hp)
       end;
 
 
@@ -161,6 +223,8 @@ implementation
         opcgsize: tcgsize;
 
         procedure genitem(t : pcaselabel);
+          var
+             range, gap: aint;
           begin
              if assigned(t^.less) then
                genitem(t^.less);
@@ -183,6 +247,7 @@ implementation
                end
              else
                begin
+                  range := aint(t^._high.svalue - t^._low.svalue);
                   { it begins with the smallest label, if the value }
                   { is even smaller then jump immediately to the    }
                   { ELSE-label                                }
@@ -194,6 +259,7 @@ implementation
                     end
                   else
                     begin
+                      gap := aint(t^._low.svalue - last.svalue);
                       { if there is no unused label between the last and the }
                       { present label then the lower limit can be checked    }
                       { immediately. else check the range in between:       }
@@ -201,23 +267,23 @@ implementation
                       { we need to use A_SUB, if cond_lt uses the carry flags
                         because A_DEC does not set the correct flags, therefor
                         using a_op_const_reg(OP_SUB) is not possible }
-                      if (cond_lt in [F_C,F_NC,F_A,F_AE,F_B,F_BE]) and (aint(t^._low.svalue-last.svalue)=1) then
-                        emit_const_reg(A_SUB,TCGSize2OpSize[opcgsize],aint(t^._low.svalue-last.svalue),hregister)
+                      if (gap = 1) and (cond_lt in [F_C,F_NC,F_A,F_AE,F_B,F_BE]) then
+                        emit_const_reg(A_SUB, TCGSize2OpSize[opcgsize], gap, hregister)
                       else
-                        cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, aint(t^._low.svalue-last.svalue), hregister);
+                        cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, gap, hregister);
                       { no jump necessary here if the new range starts at
                         at the value following the previous one           }
-                      if ((t^._low-last) <> 1) or
+                      if (gap <> 1) or
                          (not lastrange) then
                         cg.a_jmp_flags(current_asmdata.CurrAsmList,cond_lt,elselabel);
                     end;
                   { we need to use A_SUB, if cond_le uses the carry flags
                     because A_DEC does not set the correct flags, therefor
                     using a_op_const_reg(OP_SUB) is not possible }
-                  if (cond_le in [F_C,F_NC,F_A,F_AE,F_B,F_BE]) and (aint(t^._high.svalue-t^._low.svalue)=1) then
-                    emit_const_reg(A_SUB,TCGSize2OpSize[opcgsize],aint(t^._high.svalue-t^._low.svalue),hregister)
+                  if (cond_le in [F_C,F_NC,F_A,F_AE,F_B,F_BE]) and (range = 1) then
+                    emit_const_reg(A_SUB,TCGSize2OpSize[opcgsize], range, hregister)
                   else
-                    cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, aint(t^._high.svalue-t^._low.svalue), hregister);
+                    cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, range, hregister);
 
                   cg.a_jmp_flags(current_asmdata.CurrAsmList,cond_le,blocklabel(t^.blockid));
                   last:=t^._high;
@@ -249,10 +315,24 @@ implementation
              genlinearcmplist(hp)
            else
              begin
-                last:=0;
-                lastrange:=false;
-                first:=true;
-                genitem(hp);
+                if (labelcnt>1) or not(cs_opt_level1 in current_settings.optimizerswitches) then
+                  begin
+                    last:=0;
+                    lastrange:=false;
+                    first:=true;
+                    genitem(hp);
+                  end
+                else
+                  begin
+                    { If only one label exists, we can greatly simplify the checks to a simple comparison }
+                    if hp^._low=hp^._high then
+                      cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opcgsize, OC_EQ, tcgint(hp^._low.svalue), hregister, blocklabel(hp^.blockid))
+                    else
+                      begin
+                        cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, tcgint(hp^._low.svalue), hregister);
+                        cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opcgsize, OC_BE, tcgint(hp^._high.svalue - hp^._low.svalue), hregister,blocklabel(hp^.blockid));
+                      end;
+                  end;
                 cg.a_jmp_always(current_asmdata.CurrAsmList,elselabel);
              end;
         end;

compiler/x86_64/nx64set.pas

@@ -26,6 +26,7 @@ unit nx64set;
 interface
 
     uses
+      constexp,
       globtype,
       nset,nx86set;
 
@@ -39,13 +40,13 @@ interface
 implementation
 
     uses
-      systems,
-      verbose,globals,constexp,
-      defutil,
-      aasmbase,aasmtai,aasmdata,
+      systems,cpuinfo,
+      verbose,globals,
+      defutil,cutils,
+      aasmbase,aasmtai,aasmdata,aasmcpu,
       cgbase,
       cpubase,procinfo,
-      cga,cgutils,cgobj;
+      cga,cgutils,cgobj,cgx86;
 
 
 {*****************************************************************************
@@ -66,73 +67,111 @@ implementation
         tablelabel: TAsmLabel;
         basereg,indexreg,jumpreg: TRegister;
         href: TReference;
+        jtlist: TAsmList;
         opcgsize: tcgsize;
         sectype: TAsmSectiontype;
         jtitemconsttype: taiconst_type;
+        AlmostExhaustive: Boolean;
+        lv, hv: TConstExprInt;
+        ExhaustiveLimit, Range, x, oldmin : aint;
 
-      procedure genitem(list:TAsmList;t : pcaselabel);
+      const
+        ExhaustiveLimitBase = 32;
+
+      procedure genitem(t : pcaselabel);
         var
           i : aint;
         begin
           if assigned(t^.less) then
-            genitem(list,t^.less);
+            genitem(t^.less);
           { fill possible hole }
           i:=last.svalue+1;
           while i<=t^._low.svalue-1 do
             begin
-              list.concat(Tai_const.Create_rel_sym(jtitemconsttype,tablelabel,elselabel));
+              jtlist.concat(Tai_const.Create_rel_sym(jtitemconsttype,tablelabel,elselabel));
               inc(i);
             end;
           i:=t^._low.svalue;
           while i<=t^._high.svalue do
             begin
-              list.concat(Tai_const.Create_rel_sym(jtitemconsttype,tablelabel,blocklabel(t^.blockid)));
+              jtlist.concat(Tai_const.Create_rel_sym(jtitemconsttype,tablelabel,blocklabel(t^.blockid)));
               inc(i);
             end;
           last:=t^._high;
           if assigned(t^.greater) then
-            genitem(list,t^.greater);
+            genitem(t^.greater);
         end;
 
       begin
+        lv:=0;
+        hv:=0;
         if not(target_info.system in systems_darwin) then
           jtitemconsttype:=aitconst_32bit
         else
           { see https://gmplib.org/list-archives/gmp-bugs/2012-December/002836.html }
           jtitemconsttype:=aitconst_darwin_dwarf_delta32;
 
+        jtlist := current_asmdata.CurrAsmList;
         last:=min_;
         opcgsize:=def_cgsize(opsize);
+
+        AlmostExhaustive := False;
+        oldmin := min_;
+
         if not(jumptable_no_range) then
           begin
-             { a <= x <= b <-> unsigned(x-a) <= (b-a) }
-             cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opcgsize,aint(min_),hregister);
-             { case expr greater than max_ => goto elselabel }
-             cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opcgsize,OC_A,aint(max_)-aint(min_),hregister,elselabel);
-             min_:=0;
-             { do not sign extend when we load the index register, as we applied an offset above }
-             opcgsize:=tcgsize2unsigned[opcgsize];
+
+            getrange(left.resultdef,lv,hv);
+            Range := aint(max_)-aint(min_);
+
+            if (cs_opt_size in current_settings.optimizerswitches) then
+              { Limit size of jump tables for small enumerations so they have
+                to be at least two-thirds full before being considered for the
+                "almost exhaustive" treatment }
+              ExhaustiveLimit := min(ExhaustiveLimitBase, TrueCount shl 1)
+            else
+              ExhaustiveLimit := ExhaustiveLimitBase;
+
+            { If true, then this indicates that almost every possible value of x is covered by
+              a label.  As such, it's more cost-efficient to remove the initial range check and
+              instead insert the remaining values into the jump table, pointing at elselabel. [Kit] }
+            if ((hv - lv) - Range <= ExhaustiveLimit) then
+              begin
+                oldmin := min_;
+                min_ := lv.svalue;
+                AlmostExhaustive := True;
+              end
+            else
+              begin
+                { a <= x <= b <-> unsigned(x-a) <= (b-a) }
+                cg.a_op_const_reg(jtlist,OP_SUB,opcgsize,aint(min_),hregister);
+                { case expr greater than max_ => goto elselabel }
+                cg.a_cmp_const_reg_label(jtlist,opcgsize,OC_A,Range,hregister,elselabel);
+                min_:=0;
+                { do not sign extend when we load the index register, as we applied an offset above }
+                opcgsize:=tcgsize2unsigned[opcgsize];
+              end;
           end;
 
         { local label in order to avoid using GOT }
         current_asmdata.getlabel(tablelabel,alt_data);
-        indexreg:=cg.makeregsize(current_asmdata.CurrAsmList,hregister,OS_ADDR);
-        cg.a_load_reg_reg(current_asmdata.CurrAsmList,opcgsize,OS_ADDR,hregister,indexreg);
+        indexreg:=cg.makeregsize(jtlist,hregister,OS_ADDR);
+        cg.a_load_reg_reg(jtlist,opcgsize,OS_ADDR,hregister,indexreg);
         { load table address }
         reference_reset_symbol(href,tablelabel,0,4,[]);
-        basereg:=cg.getaddressregister(current_asmdata.CurrAsmList);
-        cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,href,basereg);
+        basereg:=cg.getaddressregister(jtlist);
+        cg.a_loadaddr_ref_reg(jtlist,href,basereg);
         { load table slot, 32-bit sign extended }
         reference_reset_base(href,basereg,-aint(min_)*4,ctempposinvalid,4,[]);
         href.index:=indexreg;
         href.scalefactor:=4;
-        jumpreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
-        cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_S32,OS_ADDR,href,jumpreg);
+        jumpreg:=cg.getaddressregister(jtlist);
+        cg.a_load_ref_reg(jtlist,OS_S32,OS_ADDR,href,jumpreg);
         { add table address }
         reference_reset_base(href,basereg,0,ctempposinvalid,sizeof(pint),[]);
         href.index:=jumpreg;
         href.scalefactor:=1;
-        cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,href,jumpreg);
+        cg.a_loadaddr_ref_reg(jtlist,href,jumpreg);
         { and finally jump }
         emit_reg(A_JMP,S_NO,jumpreg);
         { generate jump table }
@@ -151,9 +190,36 @@ implementation
             is inserted right after the routine, it will become part of the
             same subsection that contains the routine's code }
           sectype:=sec_code;
-        new_section(current_procinfo.aktlocaldata,sectype,current_procinfo.procdef.mangledname,4);
-        current_procinfo.aktlocaldata.concat(Tai_label.Create(tablelabel));
-        genitem(current_procinfo.aktlocaldata,hp);
+
+        jtlist := current_procinfo.aktlocaldata;
+        new_section(jtlist,sectype,current_procinfo.procdef.mangledname,4);
+        jtlist.concat(Tai_label.Create(tablelabel));
+
+        if AlmostExhaustive then
+          begin
+            { Fill the table with the values below _min }
+            x := lv.svalue;
+            while x < oldmin do
+              begin
+                jtlist.concat(Tai_const.Create_rel_sym(jtitemconsttype,tablelabel,elselabel));
+                Inc(x);
+              end;
+
+            genitem(hp);
+
+            { Fill the table with the values above _max }
+            { Subtracting one from hv and not adding 1 to max_ averts the risk of an overflow }
+            x := max_;
+            hv := hv - 1;
+            while x <= hv.svalue do
+              begin
+                jtlist.concat(Tai_const.Create_rel_sym(jtitemconsttype,tablelabel,elselabel));
+                Inc(x);
+              end;
+
+          end
+        else
+          genitem(hp);
       end;
 
 begin

packages/amunits/src/coreunits/amigados.pas

@@ -1707,7 +1707,7 @@ FUNCTION SetComment(const name : pCHAR location 'd1';const comment : pCHAR locat
 FUNCTION SetConsoleTask(const task : pMsgPort location 'd1') : pMsgPort; syscall _DOSBase 516;
 FUNCTION SetCurrentDirName(const name : pCHAR location 'd1') : LongBool; syscall _DOSBase 558;
 FUNCTION SetFileDate(const name : pCHAR location 'd1'; date : pDateStamp location 'd2') : LongBool; syscall _DOSBase 396;
-FUNCTION SetFileSize(fh : BPTR location 'd1'; pos : LONGINT location 'd2'; mode : LONGINT location 'd3') : LongBool; syscall _DOSBase 456;
+FUNCTION SetFileSize(fh : BPTR location 'd1'; pos : LONGINT location 'd2'; mode : LONGINT location 'd3') : LongInt; syscall _DOSBase 456;
 FUNCTION SetFileSysTask(const task : pMsgPort location 'd1') : pMsgPort; syscall _DOSBase 528;
 FUNCTION SetIoErr(result : LONGINT location 'd1') : LONGINT; syscall _DOSBase 462;
 FUNCTION SetMode(fh : BPTR location 'd1'; mode : LONGINT location 'd2') : LongBool; syscall _DOSBase 426;

packages/fcl-js/src/jswriter.pp

@@ -1255,6 +1255,7 @@ procedure TJSWriter.WriteBinary(El: TJSBinary);
 Var
   S : String;
   AllowCompact, WithBrackets: Boolean;
+  ElC: TClass;
 begin
   {$IFDEF VerboseJSWriter}
   System.writeln('TJSWriter.WriteBinary SkipRoundBrackets=',FSkipRoundBrackets);
@@ -1263,6 +1264,18 @@ begin
   if WithBrackets then
     Write('(');
   FSkipRoundBrackets:=false;
+  ElC:=El.ClassType;
+  if El.A is TJSBinaryExpression then
+    if (El.A.ClassType=ElC)
+        and ((ElC=TJSLogicalOrExpression)
+        or (ElC=TJSLogicalAndExpression)
+        or (ElC=TJSBitwiseAndExpression)
+        or (ElC=TJSBitwiseOrExpression)
+        or (ElC=TJSBitwiseXOrExpression)
+        or (ElC=TJSAdditiveExpressionPlus)
+        or (ElC=TJSAdditiveExpressionMinus)
+        or (ElC=TJSMultiplicativeExpressionMul)) then
+      FSkipRoundBrackets:=true;
   WriteJS(El.A);
   Writer.CurElement:=El;
   AllowCompact:=False;
@@ -1279,6 +1292,13 @@ begin
       S:=' '+S+' ';
     end;
   FSkipRoundBrackets:=false;
+  ElC:=El.ClassType;
+  if El.B is TJSBinaryExpression then
+    if (El.B.ClassType=ElC)
+        and ((ElC=TJSLogicalOrExpression)
+        or (ElC=TJSLogicalAndExpression)) then
+      FSkipRoundBrackets:=true;
+  // Note: a+(b+c) <> a+b+c  e.g. floats, 0+string
   Write(S);
   WriteJS(El.B);
   Writer.CurElement:=El;

packages/fcl-js/tests/tcwriter.pp

@@ -180,10 +180,11 @@ type
 
   { TTestExpressionWriter }
 
-  TTestExpressionWriter= class(TTestJSWriter)
+  TTestExpressionWriter = class(TTestJSWriter)
   Protected
     Procedure TestUnary(Const Msg : String; AClass : TJSUnaryClass; Result : String);
-    Procedure TestBinary(Const Msg : String; AClass : TJSBinaryClass; Result : String;ACompact : Boolean);
+    Procedure TestBinary(Const Msg : String; AClass : TJSBinaryClass; Result : String; ACompact : Boolean);
+    Procedure TestBinaryNested(Const Msg : String; AClass : TJSBinaryClass; Result : String; ACompact : Boolean);
   Published
     Procedure TestIdent;
     Procedure TestThis;
@@ -201,8 +202,10 @@ type
     Procedure TestPostMinusMinus;
     Procedure TestBinaryLogicalOr;
     Procedure TestBinaryLogicalOrCompact;
+    Procedure TestBinaryLogicalOrNested;
     Procedure TestBinaryLogicalAnd;
     Procedure TestBinaryLogicalAndCompact;
+    Procedure TestBinaryLogicalAndNested;
     Procedure TestBinaryBitwiseOr;
     Procedure TestBinaryBitwiseOrCompact;
     Procedure TestBinaryBitwiseAnd;
@@ -237,10 +240,13 @@ type
     Procedure TestBinaryURShiftOfCompact;
     Procedure TestBinaryPlus;
     Procedure TestBinaryPlusCompact;
+    Procedure TestBinaryPlusNested;
     Procedure TestBinaryMinus;
     Procedure TestBinaryMinusCompact;
+    Procedure TestBinaryMinusNested;
     Procedure TestBinaryMultiply;
     Procedure TestBinaryMultiplyCompact;
+    Procedure TestBinaryMultiplyNested;
     Procedure TestBinaryDivide;
     Procedure TestBinaryDivideCompact;
     Procedure TestBinaryMod;
@@ -291,6 +297,23 @@ begin
   AssertWrite(Msg,Result,U);
 end;
 
+procedure TTestExpressionWriter.TestBinaryNested(const Msg: String;
+  AClass: TJSBinaryClass; Result: String; ACompact: Boolean);
+var
+  U: TJSBinary;
+begin
+  if ACompact then
+    Writer.Options:=Writer.Options+[woCompact];
+  U:=AClass.Create(0,0);
+  U.A:=AClass.Create(0,0);
+  TJSBinary(U.A).A:=CreateIdent('a');
+  TJSBinary(U.A).B:=CreateIdent('b');
+  U.B:=AClass.Create(0,0);
+  TJSBinary(U.B).A:=CreateIdent('c');
+  TJSBinary(U.B).B:=CreateIdent('d');
+  AssertWrite(Msg,Result,U);
+end;
+
 procedure TTestExpressionWriter.TestIdent;
 
 begin
@@ -373,6 +396,11 @@ begin
   TestBinary('logical or',TJSLogicalOrExpression,'(a||b)',True);
 end;
 
+procedure TTestExpressionWriter.TestBinaryLogicalOrNested;
+begin
+  TestBinaryNested('logical or',TJSLogicalOrExpression,'(a||b||c||d)',True);
+end;
+
 procedure TTestExpressionWriter.TestBinaryLogicalAnd;
 begin
   TestBinary('logical or',TJSLogicalAndExpression,'(a && b)',False);
@@ -383,6 +411,11 @@ begin
   TestBinary('logical or',TJSLogicalAndExpression,'(a&&b)',True);
 end;
 
+procedure TTestExpressionWriter.TestBinaryLogicalAndNested;
+begin
+  TestBinaryNested('logical and',TJSLogicalAndExpression,'(a&&b&&c&&d)',True);
+end;
+
 procedure TTestExpressionWriter.TestBinaryBitwiseOr;
 begin
   TestBinary('Bitwise or',TJSBitwiseOrExpression,'(a | b)',False);
@@ -553,6 +586,11 @@ begin
   TestBinary('A plus B',TJSAdditiveExpressionPlus,'(a+b)',True);
 end;
 
+procedure TTestExpressionWriter.TestBinaryPlusNested;
+begin
+  TestBinaryNested('(A+B)+(C+D)',TJSAdditiveExpressionPlus,'(a+b+(c+d))',True);
+end;
+
 procedure TTestExpressionWriter.TestBinaryMinus;
 begin
   TestBinary('A minus B',TJSAdditiveExpressionMinus,'(a - b)',False);
@@ -563,6 +601,11 @@ begin
   TestBinary('A minus B',TJSAdditiveExpressionMinus,'(a-b)',True);
 end;
 
+procedure TTestExpressionWriter.TestBinaryMinusNested;
+begin
+  TestBinaryNested('(A-B)-(C-D)',TJSAdditiveExpressionMinus,'(a-b-(c-d))',True);
+end;
+
 procedure TTestExpressionWriter.TestBinaryMultiply;
 begin
   TestBinary('A multiply B',TJSMultiplicativeExpressionMul,'(a * b)',False);
@@ -573,6 +616,11 @@ begin
   TestBinary('A multiply B',TJSMultiplicativeExpressionMul,'(a*b)',True);
 end;
 
+procedure TTestExpressionWriter.TestBinaryMultiplyNested;
+begin
+  TestBinaryNested('(A*B)*(C*D)',TJSMultiplicativeExpressionMul,'(a*b*(c*d))',True);
+end;
+
 procedure TTestExpressionWriter.TestBinaryDivide;
 begin
   TestBinary('A divide B',TJSMultiplicativeExpressionDiv,'(a / b)',False);
@@ -2594,7 +2642,7 @@ Var
   S : AnsiString;
   p: Integer;
 begin
-  S:=FTextWriter.AsAnsistring;
+  S:=FTextWriter.AsString;
   if S=Result then exit;
   p:=1;
   while (p<=length(S)) and (p<=length(Result)) and (S[p]=Result[p]) do inc(p);

packages/fcl-passrc/src/pasresolveeval.pas

@@ -135,9 +135,9 @@ const
   nTextAfterFinalIgnored = 3058;
   nNoMemberIsProvidedToAccessProperty = 3059;
   nTheUseOfXisNotAllowedInARecord = 3060;
-  // free 3061
-  // free 3062
-  // free 3063
+  nParameterlessConstructorsNotAllowedInRecords = 3061;
+  nMultipleXinTypeYNameZCAandB = 3062;
+  nXCannotHaveParameters = 3063;
   nRangeCheckError = 3064;
   nHighRangeLimitLTLowRangeLimit = 3065;
   nRangeCheckEvaluatingConstantsVMinMax = 3066;
@@ -252,6 +252,9 @@ resourcestring
   sTextAfterFinalIgnored = 'Text after final ''end.''. ignored by compiler';
   sNoMemberIsProvidedToAccessProperty = 'No member is provided to access property';
   sTheUseOfXisNotAllowedInARecord = 'The use of "%s" is not allowed in a record';
+  sParameterlessConstructorsNotAllowedInRecords = 'Parameterless constructors are not allowed in records or record/type helpers';
+  sMultipleXinTypeYNameZCAandB = 'Multiple %s in %s %s: %s and %s';
+  sXCannotHaveParameters = '%s cannot have parameters';
   sSymbolXIsNotPortable = 'Symbol "%s" is not portable';
   sSymbolXIsExperimental = 'Symbol "%s" is experimental';
   sSymbolXIsNotImplemented = 'Symbol "%s" is not implemented';

packages/fcl-passrc/src/pasresolver.pp

@@ -854,6 +854,8 @@ type
   TPasClassOrRecordScope = Class(TPasIdentifierScope)
   public
     DefaultProperty: TPasProperty;
+    ClassConstructor: TPasClassConstructor;
+    ClassDestructor: TPasClassDestructor;
   end;
 
   { TPasRecordScope }
@@ -1041,19 +1043,28 @@ type
     procedure WriteIdentifiers(Prefix: string); override;
   end;
 
-  { TPasDotRecordScope - used for aRecord.subidentifier }
+  { TPasDotEnumTypeScope - used for EnumType.EnumValue }
 
-  TPasDotRecordScope = Class(TPasDotIdentifierScope)
+  TPasDotEnumTypeScope = Class(TPasDotIdentifierScope)
   end;
 
-  { TPasDotEnumTypeScope - used for EnumType.EnumValue }
+  { TPasDotClassOrRecordScope }
 
-  TPasDotEnumTypeScope = Class(TPasDotIdentifierScope)
+  TPasDotClassOrRecordScope = Class(TPasDotIdentifierScope)
+  end;
+
+  { TPasDotRecordScope - used for aRecord.subidentifier }
+
+  TPasDotRecordScope = Class(TPasDotClassOrRecordScope)
+  private
+    function GetRecordScope: TPasRecordScope;
+  public
+    property RecordScope: TPasRecordScope read GetRecordScope;
   end;
 
   { TPasDotClassScope - used for aClass.subidentifier }
 
-  TPasDotClassScope = Class(TPasDotIdentifierScope)
+  TPasDotClassScope = Class(TPasDotClassOrRecordScope)
   private
     FClassScope: TPasClassScope;
     procedure SetClassScope(AValue: TPasClassScope);
@@ -1123,11 +1134,11 @@ type
     property Declaration: TPasElement read FDeclaration write SetDeclaration;
   end;
 
-  { TResolvedRefCtxConstructor - constructed class of a newinstance reference }
+  { TResolvedRefCtxConstructor - constructed class/record of a newinstance reference }
 
   TResolvedRefCtxConstructor = Class(TResolvedRefContext)
   public
-    Typ: TPasType; // e.g. TPasClassType
+    Typ: TPasType; // e.g. TPasMembersType
   end;
 
   TPasResolverResultFlag = (
@@ -1402,8 +1413,8 @@ type
     procedure ResolveArrayParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
     procedure ResolveArrayParamsArgs(Params: TParamsExpr;
       const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess); virtual;
-    function ResolveBracketOperatorClass(Params: TParamsExpr;
-      const ResolvedValue: TPasResolverResult; ClassScope: TPasClassScope;
+    function ResolveBracketOperatorClassOrRec(Params: TParamsExpr;
+      const ResolvedValue: TPasResolverResult; ClassOrRecScope: TPasClassOrRecordScope;
       Access: TResolvedRefAccess): boolean; virtual;
     procedure ResolveSetParamsExpr(Params: TParamsExpr); virtual;
     procedure ResolveArrayValues(El: TArrayValues); virtual;
@@ -1418,7 +1429,8 @@ type
     procedure FinishUsesClause; virtual;
     procedure FinishSection(Section: TPasSection); virtual;
     procedure FinishInterfaceSection(Section: TPasSection); virtual;
-    procedure FinishTypeSection(El: TPasDeclarations); virtual;
+    procedure FinishTypeSection(El: TPasElement); virtual;
+    procedure FinishTypeSectionEl(El: TPasType); virtual;
     procedure FinishTypeDef(El: TPasType); virtual;
     procedure FinishEnumType(El: TPasEnumType); virtual;
     procedure FinishSetType(El: TPasSetType); virtual;
@@ -1473,7 +1485,7 @@ type
       out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
       StartEl: TPasElement);
     procedure ComputeArrayParams_Class(Params: TParamsExpr;
-      var ResolvedEl: TPasResolverResult; ClassScope: TPasClassScope;
+      var ResolvedEl: TPasResolverResult; ClassOrRecScope: TPasClassOrRecordScope;
       Flags: TPasResolverComputeFlags; StartEl: TPasElement); virtual;
     procedure ComputeFuncParams(Params: TParamsExpr;
       out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
@@ -1504,7 +1516,7 @@ type
     function IsCharLiteral(const Value: string; ErrorPos: TPasElement): TResolverBaseType; virtual;
     function CheckForIn(Loop: TPasImplForLoop;
       const VarResolved, InResolved: TPasResolverResult): boolean; virtual;
-    function CheckForInClass(Loop: TPasImplForLoop;
+    function CheckForInClassOrRec(Loop: TPasImplForLoop;
       const VarResolved, InResolved: TPasResolverResult): boolean; virtual;
     function CheckBuiltInMinParamCount(Proc: TResElDataBuiltInProc; Expr: TPasExpr;
       MinCount: integer; RaiseOnError: boolean): boolean;
@@ -1880,11 +1892,13 @@ type
     function IsNameExpr(El: TPasExpr): boolean; inline; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
     function GetNameExprValue(El: TPasExpr): string; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
     function GetNextDottedExpr(El: TPasExpr): TPasExpr;
+    function GetLeftMostExpr(El: TPasExpr): TPasExpr;
+    function GetRightMostExpr(El: TPasExpr): TPasExpr;
     function GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
     function GetPathStart(El: TPasExpr): TPasExpr;
     function GetNewInstanceExpr(El: TPasExpr): TPasExpr;
     function ParentNeedsExprResult(El: TPasExpr): boolean;
-    function GetReference_NewInstanceClass(Ref: TResolvedReference): TPasClassType;
+    function GetReference_NewInstance_Type(Ref: TResolvedReference): TPasMembersType;
     function IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean = true): boolean;
     function IsOpenArray(TypeEl: TPasType): boolean;
     function IsDynOrOpenArray(TypeEl: TPasType): boolean;
@@ -3107,6 +3121,13 @@ begin
     AncestorScope.WriteIdentifiers(Prefix+'AS  ');
 end;
 
+{ TPasDotRecordScope }
+
+function TPasDotRecordScope.GetRecordScope: TPasRecordScope;
+begin
+  Result:=TPasRecordScope(IdentifierScope);
+end;
+
 { TPasDotClassScope }
 
 procedure TPasDotClassScope.SetClassScope(AValue: TPasClassScope);
@@ -3848,6 +3869,52 @@ begin
   until false;
 end;
 
+function TPasResolver.GetLeftMostExpr(El: TPasExpr): TPasExpr;
+var
+  C: TClass;
+begin
+  Result:=El;
+  while Result<>nil do
+    begin
+    El:=Result;
+    C:=Result.ClassType;
+    if C=TBinaryExpr then
+      begin
+      if TBinaryExpr(Result).OpCode<>eopSubIdent then
+        exit;
+      Result:=TBinaryExpr(Result).left;
+      end
+    else if C=TParamsExpr then
+      begin
+      if not (TParamsExpr(Result).Kind in [pekFuncParams,pekArrayParams]) then
+        exit;
+      Result:=TParamsExpr(Result).Value;
+      end
+    else
+      exit;
+    end;
+end;
+
+function TPasResolver.GetRightMostExpr(El: TPasExpr): TPasExpr;
+var
+  C: TClass;
+begin
+  Result:=El;
+  while Result<>nil do
+    begin
+    El:=Result;
+    C:=Result.ClassType;
+    if C=TBinaryExpr then
+      begin
+      if TBinaryExpr(Result).OpCode<>eopSubIdent then
+        exit;
+      Result:=TBinaryExpr(Result).right;
+      end
+    else
+      exit;
+    end;
+end;
+
 function TPasResolver.GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
 var
   Value: TResEvalValue;
@@ -4794,7 +4861,35 @@ begin
   if Section=nil then ;
 end;
 
-procedure TPasResolver.FinishTypeSection(El: TPasDeclarations);
+procedure TPasResolver.FinishTypeSection(El: TPasElement);
+var
+  i: Integer;
+  Decl: TPasElement;
+begin
+  // resolve pending forwards
+  if El is TPasDeclarations then
+    begin
+    for i:=0 to TPasDeclarations(El).Declarations.Count-1 do
+      begin
+      Decl:=TPasElement(TPasDeclarations(El).Declarations[i]);
+      if Decl is TPasType then
+        FinishTypeSectionEl(TPasType(Decl));
+      end;
+    end
+  else if El is TPasMembersType then
+    begin
+    for i:=0 to TPasMembersType(El).Members.Count-1 do
+      begin
+      Decl:=TPasElement(TPasMembersType(El).Members[i]);
+      if Decl is TPasType then
+        FinishTypeSectionEl(TPasType(Decl));
+      end;
+    end
+  else
+    RaiseNotYetImplemented(20181226105933,El);
+end;
+
+procedure TPasResolver.FinishTypeSectionEl(El: TPasType);
 
   function ReplaceDestType(Decl: TPasType; var DestType: TPasType;
     const DestName: string; MustExist: boolean; ErrorEl: TPasElement
@@ -4839,81 +4934,74 @@ procedure TPasResolver.FinishTypeSection(El: TPasDeclarations);
   end;
 
 var
-  i: Integer;
-  Decl: TPasElement;
+  C: TClass;
   ClassOfEl: TPasClassOfType;
+  TypeEl: TPasType;
   UnresolvedEl: TUnresolvedPendingRef;
   OldClassType: TPasClassType;
-  TypeEl: TPasType;
-  C: TClass;
   PtrType: TPasPointerType;
 begin
-  // resolve pending forwards
-  for i:=0 to El.Declarations.Count-1 do
+  C:=El.ClassType;
+  if C.InheritsFrom(TPasClassType) then
     begin
-    Decl:=TPasElement(El.Declarations[i]);
-    C:=Decl.ClassType;
-    if C.InheritsFrom(TPasClassType) then
+    if TPasClassType(El).IsForward and (TPasClassType(El).CustomData=nil) then
+      RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[El.Name],El);
+    end
+  else if (C=TPasClassOfType) then
+    begin
+    ClassOfEl:=TPasClassOfType(El);
+    TypeEl:=ResolveAliasType(ClassOfEl.DestType);
+    if (TypeEl.ClassType=TUnresolvedPendingRef) then
       begin
-      if TPasClassType(Decl).IsForward and (TPasClassType(Decl).CustomData=nil) then
-        RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[Decl.Name],Decl);
+      // forward class-of -> resolve now
+      UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
+      {$IFDEF VerbosePasResolver}
+      writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"');
+      {$ENDIF}
+      ReplaceDestType(ClassOfEl,ClassOfEl.DestType,TypeEl.Name,true,UnresolvedEl
+        {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
       end
-    else if (C=TPasClassOfType) then
+    else if TypeEl.ClassType=TPasClassType then
+      begin
+      // class-of has found a type
+      // another later in the same type section has priority -> check
+      OldClassType:=TypeEl as TPasClassType;
+      if OldClassType.Parent=ClassOfEl.Parent then
+        exit; // class in same type section -> ok
+      // class not in same type section -> check
+      {$IFDEF VerbosePasResolver}
+      writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"');
+      {$ENDIF}
+      ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl
+        {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
+      end;
+    end
+  else if C=TPasPointerType then
+    begin
+    PtrType:=TPasPointerType(El);
+    TypeEl:=ResolveAliasType(PtrType.DestType);
+    if (TypeEl.ClassType=TUnresolvedPendingRef) then
       begin
-      ClassOfEl:=TPasClassOfType(Decl);
-      TypeEl:=ResolveAliasType(ClassOfEl.DestType);
-      if (TypeEl.ClassType=TUnresolvedPendingRef) then
-        begin
-        // forward class-of -> resolve now
-        UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
-        {$IFDEF VerbosePasResolver}
-        writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"');
-        {$ENDIF}
-        ReplaceDestType(ClassOfEl,ClassOfEl.DestType,TypeEl.Name,true,UnresolvedEl
-          {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
-        end
-      else if TypeEl.ClassType=TPasClassType then
-        begin
-        // class-of has found a type
-        // another later in the same type section has priority -> check
-        OldClassType:=TypeEl as TPasClassType;
-        if OldClassType.Parent=ClassOfEl.Parent then
-          continue; // class in same type section -> ok
-        // class not in same type section -> check
-        {$IFDEF VerbosePasResolver}
-        writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"');
-        {$ENDIF}
-        ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl
-          {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
-        end;
+      // forward pointer -> resolve now
+      UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
+      {$IFDEF VerbosePasResolver}
+      writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"');
+      {$ENDIF}
+      ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl
+        {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
       end
-    else if C=TPasPointerType then
+    else
       begin
-      PtrType:=TPasPointerType(Decl);
-      TypeEl:=ResolveAliasType(PtrType.DestType);
-      if (TypeEl.ClassType=TUnresolvedPendingRef) then
-        begin
-        // forward pointer -> resolve now
-        UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
-        {$IFDEF VerbosePasResolver}
-        writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"');
-        {$ENDIF}
-        ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl
-          {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
-        end
-      else
-        begin
-        // pointer-of has found a type
-        // another later in the same type section has priority -> check
-        if TypeEl.Parent=Decl.Parent then
-          continue; // class in same type section -> ok
-        // dest not in same type section -> check
-        {$IFDEF VerbosePasResolver}
-        writeln('TPasResolver.FinishTypeSection improving "',PtrType.Name,'" = pointer of resolved "',TypeEl.Name,'"');
-        {$ENDIF}
-        ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,false,PtrType
-          {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
-        end;
+      // pointer-of has found a type
+      // another later in the same type section has priority -> check
+      if TypeEl.Parent=PtrType.Parent then
+        exit; // class in same type section -> ok
+      // dest not in same type section -> check
+      {$IFDEF VerbosePasResolver}
+      writeln('TPasResolver.FinishTypeSection improving "',PtrType.Name,'" = pointer of resolved "',TypeEl.Name,'"');
+      {$ENDIF}
+      ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,false,PtrType
+        {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
       end;
     end;
 end;
@@ -5357,7 +5445,7 @@ var
   ProcName: String;
   FindData: TFindOverloadProcData;
   DeclProc, Proc, ParentProc: TPasProcedure;
-  Abort, HasDots: boolean;
+  Abort, HasDots, IsClassConDestructor: boolean;
   DeclProcScope, ProcScope: TPasProcedureScope;
   ParentScope: TPasScope;
   pm: TProcedureModifier;
@@ -5417,6 +5505,21 @@ begin
             sInvalidXModifierY,[GetElementTypeName(Proc),'external, '+ProcTypeModifiers[ptm]],Proc);
       end;
 
+    IsClassConDestructor:=(Proc.ClassType=TPasClassConstructor)
+      or (Proc.ClassType=TPasClassDestructor);
+    if IsClassConDestructor then
+      begin
+      // class constructor/destructor
+      if Proc.IsVirtual then
+        RaiseMsg(20181231150237,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'virtual'],Proc);
+      if Proc.IsOverride then
+        RaiseMsg(20181231150305,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'override'],Proc);
+      if Proc.IsDynamic then
+        RaiseMsg(20181231150319,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'dynamic'],Proc);
+      if El.Args.Count>0 then
+        RaiseMsg(20181231150404,nXCannotHaveParameters,sXCannotHaveParameters,[GetElementTypeName(Proc)],Proc);
+      end;
+
     HasDots:=Pos('.',ProcName)>1;
 
     if Proc.Parent is TPasClassType then
@@ -5451,6 +5554,11 @@ begin
       end
     else if Proc.Parent is TPasRecordType then
       begin
+      if (Proc.ClassType=TPasConstructor)
+          and ((El.Args.Count=0)
+            or (TPasArgument(El.Args[0]).ValueExpr<>nil)) then
+        RaiseMsg(20181226231333,nParameterlessConstructorsNotAllowedInRecords,
+          sParameterlessConstructorsNotAllowedInRecords,[],El);
       if Proc.IsReintroduced then
         RaiseMsg(20181218195735,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'reintroduce'],Proc);
       if Proc.IsVirtual then
@@ -5622,7 +5730,7 @@ procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure);
   {$ENDIF}
 
 var
-  Abort: boolean;
+  Abort, IsClassConDestructor: boolean;
   ClassOrRecScope: TPasClassOrRecordScope;
   FindData: TFindOverloadProcData;
   OverloadProc: TPasProcedure;
@@ -5640,7 +5748,11 @@ begin
   FindData.Args:=Proc.ProcType.Args;
   FindData.Kind:=fopkMethod;
   Abort:=false;
-  ClassOrRecScope.IterateElements(Proc.Name,ClassOrRecScope,@OnFindOverloadProc,@FindData,Abort);
+  IsClassConDestructor:=(Proc.ClassType=TPasClassConstructor)
+                     or (Proc.ClassType=TPasClassDestructor);
+  if not IsClassConDestructor then
+    ClassOrRecScope.IterateElements(Proc.Name,ClassOrRecScope,
+                                    @OnFindOverloadProc,@FindData,Abort);
 
   if FindData.Found=nil then
     begin
@@ -5703,7 +5815,7 @@ var
   ClassRecType: TPasMembersType;
   ImplProcScope, DeclProcScope: TPasProcedureScope;
   DeclProc: TPasProcedure;
-  CurClassRecScope: TPasClassOrRecordScope;
+  ClassOrRecScope: TPasClassOrRecordScope;
   SelfArg: TPasArgument;
   p: Integer;
 begin
@@ -5730,12 +5842,17 @@ begin
 
   // search proc in class/record
   ImplProcScope:=ImplProc.CustomData as TPasProcedureScope;
-  CurClassRecScope:=ImplProcScope.ClassScope;
-  if CurClassRecScope=nil then
+  ClassOrRecScope:=ImplProcScope.ClassScope;
+  if ClassOrRecScope=nil then
     RaiseInternalError(20161013172346);
-  ClassRecType:=NoNil(CurClassRecScope.Element) as TPasMembersType;
+  ClassRecType:=NoNil(ClassOrRecScope.Element) as TPasMembersType;
 
-  DeclProc:=FindProcOverload(ProcName,ImplProc,CurClassRecScope);
+  if ImplProc.ClassType=TPasClassConstructor then
+    DeclProc:=ClassOrRecScope.ClassConstructor
+  else if ImplProc.ClassType=TPasClassDestructor then
+    DeclProc:=ClassOrRecScope.ClassDestructor
+  else
+    DeclProc:=FindProcOverload(ProcName,ImplProc,ClassOrRecScope);
   if DeclProc=nil then
     RaiseIdentifierNotFound(20170216151720,ImplProc.Name,ImplProc.ProcType);
   DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
@@ -5764,14 +5881,14 @@ begin
         or (DeclProc.ClassType=TPasClassProcedure)
         or (DeclProc.ClassType=TPasClassFunction) then
       begin
-      if (not DeclProc.IsStatic) and (CurClassRecScope is TPasClassScope) then
+      if (not DeclProc.IsStatic) and (ClassOrRecScope is TPasClassScope) then
         begin
         // 'Self' in a class proc is the hidden classtype argument
         SelfArg:=TPasArgument.Create('Self',DeclProc);
         ImplProcScope.SelfArg:=SelfArg;
         {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
         SelfArg.Access:=argConst;
-        SelfArg.ArgType:=TPasClassScope(CurClassRecScope).CanonicalClassOf;
+        SelfArg.ArgType:=TPasClassScope(ClassOrRecScope).CanonicalClassOf;
         SelfArg.ArgType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
         AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
         end;
@@ -5782,8 +5899,11 @@ begin
       SelfArg:=TPasArgument.Create('Self',DeclProc);
       ImplProcScope.SelfArg:=SelfArg;
       {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
-      SelfArg.Access:=argConst;
       SelfArg.ArgType:=ClassRecType;
+      if ClassRecType is TPasRecordType then
+        SelfArg.Access:=argDefault
+      else
+        SelfArg.Access:=argConst;
       ClassRecType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
       AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
       end;
@@ -5944,6 +6064,8 @@ var
       // get inherited type
       PropType:=GetPasPropertyType(AncestorProp);
       // update DefaultProperty
+      if ClassScope=nil then
+        RaiseNotYetImplemented(20181231130642,PropEl);
       if ClassScope.DefaultProperty=AncestorProp then
         ClassScope.DefaultProperty:=PropEl;
       end;
@@ -7457,9 +7579,8 @@ begin
     if (not EnumeratorFound) and (StartResolved.BaseType=btContext) then
       begin
       TypeEl:=StartResolved.LoTypeEl;
-      C:=TypeEl.ClassType;
-      if C=TPasClassType then
-        EnumeratorFound:=CheckForInClass(Loop,VarResolved,StartResolved);
+      if TypeEl is TPasMembersType then
+        EnumeratorFound:=CheckForInClassOrRec(Loop,VarResolved,StartResolved);
       end;
 
     if not EnumeratorFound then
@@ -7673,7 +7794,7 @@ begin
   {$ENDIF}
   // check LHS can be assigned
   ComputeElement(El.left,LeftResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
-  CheckCanBeLHS(LeftResolved,true,El.left);
+  CheckCanBeLHS(LeftResolved,true,GetRightMostExpr(El.left));
 
   // compute RHS
   ResolveExpr(El.right,rraRead);
@@ -8659,7 +8780,7 @@ procedure TPasResolver.ResolveArrayParamsArgs(Params: TParamsExpr;
 
 var
   PropEl: TPasProperty;
-  ClassScope: TPasClassScope;
+  ClassOrRecScope: TPasClassOrRecordScope;
   i: Integer;
   TypeEl: TPasType;
 begin
@@ -8685,10 +8806,10 @@ begin
   else if ResolvedValue.BaseType=btContext then
     begin
     TypeEl:=ResolvedValue.LoTypeEl;
-    if TypeEl.ClassType=TPasClassType then
+    if TypeEl is TPasMembersType then
       begin
-      ClassScope:=NoNil(TypeEl.CustomData) as TPasClassScope;
-      if ResolveBracketOperatorClass(Params,ResolvedValue,ClassScope,Access) then
+      ClassOrRecScope:=NoNil(TypeEl.CustomData) as TPasClassOrRecordScope;
+      if ResolveBracketOperatorClassOrRec(Params,ResolvedValue,ClassOrRecScope,Access) then
         exit;
       end
     else if TypeEl.ClassType=TPasArrayType then
@@ -8710,14 +8831,14 @@ begin
     ['[',GetResolverResultDescription(ResolvedValue,true)],Params);
 end;
 
-function TPasResolver.ResolveBracketOperatorClass(Params: TParamsExpr;
-  const ResolvedValue: TPasResolverResult; ClassScope: TPasClassScope;
-  Access: TResolvedRefAccess): boolean;
+function TPasResolver.ResolveBracketOperatorClassOrRec(Params: TParamsExpr;
+  const ResolvedValue: TPasResolverResult;
+  ClassOrRecScope: TPasClassOrRecordScope; Access: TResolvedRefAccess): boolean;
 var
   PropEl: TPasProperty;
   Value: TPasExpr;
 begin
-  PropEl:=ClassScope.DefaultProperty;
+  PropEl:=ClassOrRecScope.DefaultProperty;
   if PropEl<>nil then
     begin
     // class has default property
@@ -9390,19 +9511,31 @@ begin
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.AddProperty ',GetObjName(El));
   {$ENDIF}
-  if not (TopScope is TPasClassScope) then
+  if not (TopScope is TPasClassOrRecordScope) then
     RaiseInvalidScopeForElement(20160922163520,El);
   AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
   PushScope(El,TPasPropertyScope);
 end;
 
 procedure TPasResolver.AddProcedure(El: TPasProcedure);
+
+  procedure AddClassConDestructor(ClassOrRecordScope: TPasClassOrRecordScope;
+    var Field: TPasProcedure);
+  begin
+    if Field<>nil then
+      RaiseMsg(20181231144353,nMultipleXinTypeYNameZCAandB,
+        sMultipleXinTypeYNameZCAandB,[GetElementTypeName(El),
+          GetElementTypeName(ClassOrRecordScope.Element),
+          ClassOrRecordScope.Element.Name,Field.Name,El.Name],El);
+    Field:=El;
+  end;
+
 var
   ProcName, aClassName: String;
   p: SizeInt;
   ClassOrRecType: TPasMembersType;
   ProcScope: TPasProcedureScope;
-  HasDot: Boolean;
+  HasDot, IsClassConDestructor: Boolean;
   CurEl: TPasElement;
   Identifier: TPasIdentifier;
   ClassOrRecScope: TPasClassOrRecordScope;
@@ -9434,9 +9567,31 @@ begin
     end;
 
   // Note: El.ProcType is nil !  It is parsed later.
+
   HasDot:=Pos('.',ProcName)>1;
-  if (not HasDot) and (ProcName<>'') then
+  IsClassConDestructor:=(El.ClassType=TPasClassConstructor)
+      or (El.ClassType=TPasClassDestructor);
+  if (not HasDot) and IsClassConDestructor then
+    begin
+    if ProcName='' then
+      RaiseNotYetImplemented(20181231145302,El);
+    if not (TopScope is TPasClassOrRecordScope) then
+      RaiseInvalidScopeForElement(20181231143831,El);
+    ClassOrRecScope:=TPasClassOrRecordScope(TopScope);
+    if El.ClassType=TPasClassConstructor then
+      AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassConstructor))
+    else
+      AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassDestructor));
+    end;
+
+  if (not HasDot) and (ProcName<>'')
+      and not IsClassConDestructor // the name of a class con/destructor is irrelevant
+  then
+    begin
+    // add proc name to scope
     AddIdentifier(TPasIdentifierScope(TopScope),ProcName,El,pikProc);
+    end;
+
   ProcScope:=TPasProcedureScope(PushScope(El,FScopeClass_Proc));
   ProcScope.ModeSwitches:=CurrentParser.CurrentModeswitches;
   if HasDot then
@@ -9467,8 +9622,9 @@ begin
         ClassOrRecScope:=TPasClassOrRecordScope(ClassOrRecType.CustomData);
         Identifier:=ClassOrRecScope.FindLocalIdentifier(aClassName);
         if Identifier=nil then
-          RaiseIdentifierNotFound(20180430130635,aClassName,El);
-        CurEl:=Identifier.Element;
+          RaiseIdentifierNotFound(20180430130635,aClassName,El)
+        else
+          CurEl:=Identifier.Element;
         end
       else
         CurEl:=FindElementWithoutParams(aClassName,El,false);
@@ -10428,6 +10584,7 @@ var
   ArgNo: Integer;
   OrigResolved: TPasResolverResult;
   SubParams: TParamsExpr;
+  ClassOrRecordScope: TPasClassOrRecordScope;
 begin
   if Params.Value.CustomData is TResolvedReference then
     begin
@@ -10493,13 +10650,14 @@ begin
   else if ResolvedEl.BaseType=btContext then
     begin
     TypeEl:=ResolvedEl.LoTypeEl;
-    if TypeEl.ClassType=TPasClassType then
+    if (TypeEl.ClassType=TPasClassType)
+        or (TypeEl.ClassType=TPasRecordType) then
       begin
-      ClassScope:=NoNil(TypeEl.CustomData) as TPasClassScope;
-      if ClassScope.DefaultProperty<>nil then
-        ComputeIndexProperty(ClassScope.DefaultProperty)
+      ClassOrRecordScope:=NoNil(TypeEl.CustomData) as TPasClassOrRecordScope;
+      if ClassOrRecordScope.DefaultProperty<>nil then
+        ComputeIndexProperty(ClassOrRecordScope.DefaultProperty)
       else
-        ComputeArrayParams_Class(Params,ResolvedEl,ClassScope,Flags,StartEl);
+        ComputeArrayParams_Class(Params,ResolvedEl,ClassOrRecordScope,Flags,StartEl);
       end
     else if TypeEl.ClassType=TPasClassOfType then
       begin
@@ -10552,12 +10710,12 @@ begin
 end;
 
 procedure TPasResolver.ComputeArrayParams_Class(Params: TParamsExpr;
-  var ResolvedEl: TPasResolverResult; ClassScope: TPasClassScope;
+  var ResolvedEl: TPasResolverResult; ClassOrRecScope: TPasClassOrRecordScope;
   Flags: TPasResolverComputeFlags; StartEl: TPasElement);
 begin
   RaiseInternalError(20161010174916);
   if Params=nil then ;
-  if ClassScope=nil then ;
+  if ClassOrRecScope=nil then ;
   if Flags=[] then ;
   if StartEl=nil then ;
   SetResolverIdentifier(ResolvedEl,btNone,nil,nil,nil,[]);
@@ -10570,11 +10728,11 @@ var
   DeclEl: TPasElement;
   BuiltInProc: TResElDataBuiltInProc;
   Proc: TPasProcedure;
-  aClass: TPasClassType;
   ParamResolved: TPasResolverResult;
   Ref: TResolvedReference;
   DeclType: TPasType;
   Param0: TPasExpr;
+  ClassOrRec: TPasMembersType;
 begin
   if Params.Value.CustomData is TResolvedReference then
     begin
@@ -10633,8 +10791,8 @@ begin
             and (rrfNewInstance in Ref.Flags) then
           begin
           // new instance call -> return value of type class
-          aClass:=GetReference_NewInstanceClass(Ref);
-          SetResolverValueExpr(ResolvedEl,btContext,aClass,aClass,Params.Value,[rrfReadable]);
+          ClassOrRec:=GetReference_NewInstance_Type(Ref);
+          SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,Params.Value,[rrfReadable]);
           end
         else
           // procedure call, result is neither readable nor writable
@@ -11486,12 +11644,14 @@ begin
   if InResolved.BaseType=btCustom then ;
 end;
 
-function TPasResolver.CheckForInClass(Loop: TPasImplForLoop; const VarResolved,
+function TPasResolver.CheckForInClassOrRec(Loop: TPasImplForLoop; const VarResolved,
   InResolved: TPasResolverResult): boolean;
 var
   TypeEl: TPasType;
-  aClass: TPasClassType;
-  ClassScope: TPasDotClassScope;
+  aClass, EnumeratorClass: TPasClassType;
+  aRecord: TPasRecordType;
+  ClassOrRecScope: TPasDotClassOrRecordScope;
+  EnumeratorScope: TPasDotClassScope;
   Getter, MoveNext, Current: TPasIdentifier;
   GetterFunc, MoveNextFunc: TPasFunction;
   ptm: TProcTypeModifier;
@@ -11501,17 +11661,27 @@ var
 begin
   Result:=false;
   TypeEl:=InResolved.LoTypeEl;
-  if TypeEl is TPasClassType then
+  if TypeEl is TPasMembersType then
     begin
     if not (rrfReadable in InResolved.Flags) then
       RaiseMsg(20171221195421,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
         [GetBaseDescription(InResolved)],Loop.StartExpr);
 
-    // check function GetEnumerator: class
-    aClass:=TPasClassType(TypeEl);
-    // find aClass.GetEnumerator
-    ClassScope:=PushClassDotScope(aClass);
-    Getter:=ClassScope.FindIdentifier('GetEnumerator');
+    // check function GetEnumerator: class/record
+    if TypeEl is TPasClassType then
+      begin
+      aClass:=TPasClassType(TypeEl);
+      ClassOrRecScope:=PushClassDotScope(aClass);
+      end
+    else if TypeEl is TPasRecordType then
+      begin
+      aRecord:=TPasRecordType(TypeEl);
+      ClassOrRecScope:=PushRecordDotScope(aRecord);
+      end
+    else
+      RaiseNotYetImplemented(20181228201853,Loop,GetObjName(TypeEl));
+    // find aRecord.GetEnumerator
+    Getter:=ClassOrRecScope.FindIdentifier('GetEnumerator');
     PopScope;
     if Getter=nil then
       RaiseIdentifierNotFound(20171221191511,'GetEnumerator',Loop.StartExpr);
@@ -11539,10 +11709,10 @@ begin
     if not (rrfReadable in ResultResolved.Flags) then
       RaiseContextXExpectedButYFound(20171221195506,'function GetEnumerator','result class instance',GetTypeDescription(ResultResolved.LoTypeEl),Loop.StartExpr);
 
-    // check function MoveNext: boolean
-    aClass:=TPasClassType(TypeEl);
-    ClassScope:=PushClassDotScope(aClass);
-    MoveNext:=ClassScope.FindIdentifier('MoveNext');
+    // find function MoveNext: boolean in Enumerator class
+    EnumeratorClass:=TPasClassType(TypeEl);
+    EnumeratorScope:=PushClassDotScope(EnumeratorClass);
+    MoveNext:=EnumeratorScope.FindIdentifier('MoveNext');
     if MoveNext=nil then
       RaiseIdentifierNotFound(20171221195632,'MoveNext',Loop.StartExpr);
     // check is function
@@ -11565,7 +11735,7 @@ begin
       RaiseContextXExpectedButYFound(20171221200337,'function MoveNext','result boolean',GetTypeDescription(MoveNextResolved),Loop.StartExpr);
 
     // check property Current
-    Current:=ClassScope.FindIdentifier('Current');
+    Current:=EnumeratorScope.FindIdentifier('Current');
     if Current=nil then
       RaiseIdentifierNotFound(20171221200433,'Current',Loop.StartExpr);
     // check is property
@@ -11586,7 +11756,7 @@ begin
     if CheckAssignResCompatibility(VarResolved,CurrentResolved,Loop.VariableName,false)=cIncompatible then
       RaiseIncompatibleTypeRes(20171221200018,nIncompatibleTypesGotExpected,[],VarResolved,CurrentResolved,Loop.VariableName);
 
-    PopScope;
+    PopScope; // pop EnumeratorScope
 
     ForScope:=Loop.CustomData as TPasForLoopScope;
     ForScope.GetEnumerator:=GetterFunc;
@@ -14761,6 +14931,25 @@ procedure TPasResolver.CheckFoundElement(
   const FindData: TPRFindData; Ref: TResolvedReference);
 // check visibility rules
 // Call this method after finding an element by searching the scopes.
+
+  function IsFieldInheritingConst(aRef: TResolvedReference): boolean;
+  // returns true of aRef is a TPasVariable that inherits its const from parent.
+  // For example
+  //  type TRecord = record
+  //    a: word; // inherits const
+  //    const b: word = 3; // does not inherit const
+  //    class var c: word; // does not inherit const
+  //  end;
+  //  procedure DoIt(const r:TRecord)
+  var
+    El: TPasElement;
+  begin
+    El:=aRef.Declaration;
+    Result:=(El.ClassType=TPasVariable)
+        and (TPasVariable(El).VarModifiers*[vmClass, vmStatic]=[]);
+    //writeln('IsFieldInheritingConst ',GetObjName(El),' ',Result,' vmClass=',vmClass in TPasVariable(El).VarModifiers);
+  end;
+
 var
   Proc: TPasProcedure;
   Context: TPasElement;
@@ -14784,7 +14973,8 @@ begin
     if Ref<>nil then
       begin
       Include(Ref.Flags,rrfDotScope);
-      if TPasDotIdentifierScope(StartScope).ConstParent then
+      if TPasDotIdentifierScope(StartScope).ConstParent
+          and IsFieldInheritingConst(Ref) then
         Include(Ref.Flags,rrfConstInherited);
       end;
     end
@@ -14795,7 +14985,8 @@ begin
     if Ref<>nil then
       begin
       Include(Ref.Flags,rrfDotScope);
-      if wesfConstParent in TPasWithExprScope(StartScope).Flags then
+      if (wesfConstParent in TPasWithExprScope(StartScope).Flags)
+          and IsFieldInheritingConst(Ref) then
         Include(Ref.Flags,rrfConstInherited);
       end;
     end
@@ -14838,21 +15029,21 @@ begin
       and TPasClassType(TPasDotClassScope(StartScope).ClassScope.Element).IsExternal then
     begin
     // found member in external class instance
-      C:=FindData.Found.ClassType;
-      if (C=TPasProcedure) or (C=TPasFunction) then
-        // ok
-      else if (C=TPasConst) then
-        // ok
-      else if C.InheritsFrom(TPasVariable)
-          and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then
-        // ok
-      else
-        begin
-        RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX,
-          sExternalClassInstanceCannotAccessStaticX,
-          [GetElementTypeName(FindData.Found)+' '+FindData.Found.Name],
-          FindData.ErrorPosEl);
-        end;
+    C:=FindData.Found.ClassType;
+    if (C=TPasProcedure) or (C=TPasFunction) then
+      // ok
+    else if (C=TPasConst) then
+      // ok
+    else if C.InheritsFrom(TPasVariable)
+        and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then
+      // ok
+    else
+      begin
+      RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX,
+        sExternalClassInstanceCannotAccessStaticX,
+        [GetElementTypeName(FindData.Found)+' '+FindData.Found.Name],
+        FindData.ErrorPosEl);
+      end;
     end;
 
   if (FindData.Found is TPasProcedure) then
@@ -14877,7 +15068,7 @@ begin
       end;
 
     // constructor: NewInstance or normal call
-    //  it is a NewInstance iff the scope is a class, e.g. TObject.Create
+    //  it is a NewInstance iff the scope is a class/record, e.g. TObject.Create
     if (Proc.ClassType=TPasConstructor)
         and OnlyTypeMembers
         and (Ref<>nil) then
@@ -14887,8 +15078,8 @@ begin
       if Ref.Context<>nil then
         RaiseInternalError(20170131141936);
       Ref.Context:=TResolvedRefCtxConstructor.Create;
-      if StartScope is TPasDotClassScope then
-        ClassRecScope:=TPasDotClassScope(StartScope).ClassScope
+      if StartScope is TPasDotClassOrRecordScope then
+        ClassRecScope:=TPasClassOrRecordScope(TPasDotClassOrRecordScope(StartScope).IdentifierScope)
       else if (StartScope is TPasWithExprScope)
           and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then
         ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope)
@@ -15030,7 +15221,7 @@ begin
   case ScopeType of
   stModule: FinishModule(El as TPasModule);
   stUsesClause: FinishUsesClause;
-  stTypeSection: FinishTypeSection(El as TPasDeclarations);
+  stTypeSection: FinishTypeSection(El);
   stTypeDef: FinishTypeDef(El as TPasType);
   stResourceString: FinishResourcestring(El as TPasResString);
   stProcedure: FinishProcedure(El as TPasProcedure);
@@ -19842,7 +20033,7 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
     Ref: TResolvedReference;
     Proc: TPasProcedure;
     ProcType: TPasProcedureType;
-    aClass: TPasClassType;
+    ClassOrRec: TPasMembersType;
   begin
     Ref:=TResolvedReference(Expr.CustomData);
     ComputeElement(Ref.Declaration,ResolvedEl,Flags+[rcNoImplicitProc],StartEl);
@@ -19856,8 +20047,8 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
       writeln('TPasResolver.ComputeElement.ComputeIdentifier "',GetObjName(Expr),'" ',GetResolverResultDbg(ResolvedEl),' Flags=',dbgs(Flags));
     {AllowWriteln-}
     {$ENDIF}
-    if (Expr is TPrimitiveExpr) and (Expr.Parent is TParamsExpr) and (TPrimitiveExpr(Expr).Value='FA') then
-      //RaiseNotYetImplemented(20180621235200,Expr);
+    //if (Expr is TPrimitiveExpr) and (Expr.Parent is TParamsExpr) and (TPrimitiveExpr(Expr).Value='FA') then
+    //  RaiseNotYetImplemented(20180621235200,Expr);
 
     if not (rcSetReferenceFlags in Flags)
         and (rrfNoImplicitCallWithoutParams in Ref.Flags) then
@@ -19883,14 +20074,13 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
             // function => return result
             ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,
               ResolvedEl,Flags+[rcType],StartEl);
-            Exclude(ResolvedEl.Flags,rrfWritable);
             end
           else if (ResolvedEl.IdentEl.ClassType=TPasConstructor)
               and (rrfNewInstance in Ref.Flags) then
             begin
             // new instance constructor -> return value of type class
-            aClass:=GetReference_NewInstanceClass(Ref);
-            SetResolverValueExpr(ResolvedEl,btContext,aClass,aClass,
+            ClassOrRec:=GetReference_NewInstance_Type(Ref);
+            SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,
                                  TPrimitiveExpr(Expr),[rrfReadable]);
             end
           else if ParentNeedsExprResult(Expr) then
@@ -19941,8 +20131,8 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
     Ref: TResolvedReference;
     Proc: TPasProcedure;
     TypeEl: TPasProcedureType;
-    aClass: TPasClassType;
     HasName: Boolean;
+    ClassOrRec: TPasMembersType;
   begin
     // "inherited;"
     Ref:=TResolvedReference(El.CustomData);
@@ -19967,8 +20157,8 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
         and (rrfNewInstance in Ref.Flags) then
       begin
       // new instance constructor -> return value of type class
-      aClass:=GetReference_NewInstanceClass(Ref);
-      SetResolverValueExpr(ResolvedEl,btContext,aClass,aClass,Expr,[rrfReadable]);
+      ClassOrRec:=GetReference_NewInstance_Type(Ref);
+      SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,Expr,[rrfReadable]);
       end
     else if ParentNeedsExprResult(Expr) then
       begin
@@ -20637,10 +20827,10 @@ begin
     Result:=(TPasImplRaise(P).ExceptAddr=El);
 end;
 
-function TPasResolver.GetReference_NewInstanceClass(Ref: TResolvedReference
-  ): TPasClassType;
+function TPasResolver.GetReference_NewInstance_Type(Ref: TResolvedReference
+  ): TPasMembersType;
 begin
-  Result:=(Ref.Context as TResolvedRefCtxConstructor).Typ as TPasClassType;
+  Result:=(Ref.Context as TResolvedRefCtxConstructor).Typ as TPasMembersType;
 end;
 
 function TPasResolver.IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -262,8 +262,7 @@ type
     procedure UseProcedure(Proc: TPasProcedure); virtual;
     procedure UseProcedureType(ProcType: TPasProcedureType; Mark: boolean); virtual;
     procedure UseType(El: TPasType; Mode: TPAUseMode); virtual;
-    procedure UseRecordType(El: TPasRecordType; Mode: TPAUseMode); virtual;
-    procedure UseClassType(El: TPasClassType; Mode: TPAUseMode); virtual;
+    procedure UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode); virtual;
     procedure UseVariable(El: TPasVariable; Access: TResolvedRefAccess;
       UseFull: boolean); virtual;
     procedure UseResourcestring(El: TPasResString); virtual;
@@ -1178,7 +1177,7 @@ begin
   UseInitFinal(aModule.FinalizationSection);
   ModScope:=aModule.CustomData as TPasModuleScope;
   if ModScope.RangeErrorClass<>nil then
-    UseClassType(ModScope.RangeErrorClass,paumElement);
+    UseClassOrRecType(ModScope.RangeErrorClass,paumElement);
   if ModScope.RangeErrorConstructor<>nil then
     UseProcedure(ModScope.RangeErrorConstructor);
 
@@ -1815,10 +1814,8 @@ begin
     {$IFDEF VerbosePasAnalyzer}
     writeln('TPasAnalyzer.UseType searching exports in ',GetElModName(El),' ...');
     {$ENDIF}
-    if C=TPasRecordType then
-      UseRecordType(TPasRecordType(El),Mode)
-    else if C=TPasClassType then
-      UseClassType(TPasClassType(El),Mode);
+    if (C=TPasRecordType) or (C=TPasClassType) then
+      UseClassOrRecType(TPasMembersType(El),Mode);
     end
   else
     begin
@@ -1848,10 +1845,8 @@ begin
         UseExpr(TPasArrayType(El).Ranges[i]);
       UseElType(El,TPasArrayType(El).ElType,Mode);
       end
-    else if C=TPasRecordType then
-      UseRecordType(TPasRecordType(El),Mode)
-    else if C=TPasClassType then
-      UseClassType(TPasClassType(El),Mode)
+    else if (C=TPasRecordType) or (C=TPasClassType) then
+      UseClassOrRecType(TPasMembersType(El),Mode)
     else if C=TPasEnumType then
       begin
       if not MarkElementAsUsed(El) then exit;
@@ -1883,22 +1878,7 @@ begin
     end;
 end;
 
-procedure TPasAnalyzer.UseRecordType(El: TPasRecordType; Mode: TPAUseMode);
-// called by UseType
-var
-  i: Integer;
-begin
-  if Mode=paumAllExports then exit;
-  MarkElementAsUsed(El);
-  if not ElementVisited(El,Mode) then
-    begin
-    if (Mode=paumAllPasUsable) or Resolver.IsTGUID(El) then
-      for i:=0 to El.Members.Count-1 do
-        UseVariable(TObject(El.Members[i]) as TPasVariable,rraNone,true);
-    end;
-end;
-
-procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode);
+procedure TPasAnalyzer.UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode);
 // called by UseType
 
   procedure UseDelegations;
@@ -1936,7 +1916,7 @@ procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode);
         Map:=TPasClassIntfMap(o);
         repeat
           if Map.Intf<>nil then
-            UseClassType(TPasClassType(Map.Intf),paumElement);
+            UseClassOrRecType(TPasClassType(Map.Intf),paumElement);
           if Map.Procs<>nil then
             for j:=0 to Map.Procs.Count-1 do
               UseProcedure(TPasProcedure(Map.Procs[j]));
@@ -1960,6 +1940,7 @@ var
   o: TObject;
   Map: TPasClassIntfMap;
   ImplProc, IntfProc: TPasProcedure;
+  aClass: TPasClassType;
 begin
   FirstTime:=true;
   case Mode of
@@ -1982,35 +1963,54 @@ begin
   {$IFDEF VerbosePasAnalyzer}
   writeln('TPasAnalyzer.UseClassType ',GetElModName(El),' ',Mode,' First=',FirstTime);
   {$ENDIF}
-  if El.IsForward then
+  aClass:=nil;
+  ClassScope:=nil;
+  IsCOMInterfaceRoot:=false;
+
+  if El is TPasClassType then
     begin
-    Ref:=El.CustomData as TResolvedReference;
-    UseClassType(Ref.Declaration as TPasClassType,Mode);
-    exit;
-    end;
+    aClass:=TPasClassType(El);
+    if aClass.IsForward then
+      begin
+      Ref:=aClass.CustomData as TResolvedReference;
+      UseClassOrRecType(Ref.Declaration as TPasClassType,Mode);
+      exit;
+      end;
 
-  ClassScope:=El.CustomData as TPasClassScope;
-  if ClassScope=nil then
-    exit; // ClassScope can be nil if msIgnoreInterfaces
+    ClassScope:=aClass.CustomData as TPasClassScope;
+    if ClassScope=nil then
+      exit; // ClassScope can be nil if msIgnoreInterfaces
 
-  IsCOMInterfaceRoot:=false;
-  if FirstTime then
-    begin
-    UseElType(El,ClassScope.DirectAncestor,paumElement);
-    UseElType(El,El.HelperForType,paumElement);
-    UseExpr(El.GUIDExpr);
-    // El.Interfaces: using a class does not use automatically the interfaces
-    if El.ObjKind=okInterface then
+    if FirstTime then
       begin
-      UseDelegations;
-      if (El.InterfaceType=citCom) and (El.AncestorType=nil) then
-        IsCOMInterfaceRoot:=true;
+      UseElType(El,ClassScope.DirectAncestor,paumElement);
+      UseElType(El,aClass.HelperForType,paumElement);
+      UseExpr(aClass.GUIDExpr);
+      // aClass.Interfaces: using a class does not use automatically the interfaces
+      if aClass.ObjKind=okInterface then
+        begin
+        UseDelegations;
+        if (aClass.InterfaceType=citCom) and (aClass.AncestorType=nil) then
+          IsCOMInterfaceRoot:=true;
+        end;
+      if (aClass.ObjKind=okClass) and (ScopeModule<>nil)
+          and (ClassScope.Interfaces<>nil) then
+        // when checking a single unit, mark all method+properties implementing the interfaces
+        MarkAllInterfaceImplementations(ClassScope);
       end;
-    if (El.ObjKind=okClass) and (ScopeModule<>nil)
-        and (ClassScope.Interfaces<>nil) then
-      // when checking a single unit, mark all method+properties implementing the interfaces
-      MarkAllInterfaceImplementations(ClassScope);
-    end;
+    end
+  else if El is TPasRecordType then
+    begin
+    if (Mode<>paumAllPasUsable) and Resolver.IsTGUID(TPasRecordType(El)) then
+      for i:=0 to El.Members.Count-1 do
+        begin
+        Member:=TPasElement(El.Members[i]);
+        if Member is TPasVariable then
+          UseVariable(TPasVariable(Member),rraNone,true);
+        end;
+    end
+  else
+    RaiseNotSupported(20181229103139,El);
 
   // members
   AllPublished:=(Mode<>paumAllExports);
@@ -2074,11 +2074,11 @@ begin
       UseTypeInfo(Member);
       end
     else
-      ; // else: class is in unit interface, mark all non private members
+      ; // else: class/record is in unit interface, mark all non private members
     UseElement(Member,rraNone,true);
     end;
 
-  if FirstTime then
+  if FirstTime and (ClassScope<>nil) then
     begin
     // method resolution
     List:=ClassScope.Interfaces;
@@ -2090,7 +2090,7 @@ begin
           begin
           // interface delegation
           // Note: This class is used. When the intftype is used, this delegation is used.
-          AddOverride(TPasType(El.Interfaces[i]),TPasProperty(o));
+          AddOverride(TPasType(aClass.Interfaces[i]),TPasProperty(o));
           end
         else if o is TPasClassIntfMap then
           begin
@@ -2111,7 +2111,7 @@ begin
             end;
           end
         else
-          RaiseNotSupported(20180328224632,El,GetObjName(o));
+          RaiseNotSupported(20180328224632,aClass,GetObjName(o));
         end;
     end;
 end;

packages/fcl-passrc/src/pparser.pp

@@ -81,7 +81,7 @@ const
   nErrRecordConstantsNotAllowed = 2035;
   nErrRecordMethodsNotAllowed = 2036;
   nErrRecordPropertiesNotAllowed = 2037;
-  // free , was nErrRecordVisibilityNotAllowed = 2038;
+  nErrRecordTypesNotAllowed = 2038;
   nParserTypeNotAllowedHere = 2039;
   nParserNotAnOperand = 2040;
   nParserArrayPropertiesCannotHaveDefaultValue = 2041;
@@ -142,7 +142,7 @@ resourcestring
   SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.';
   SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.';
   SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location.';
-  // free, was SErrRecordVisibilityNotAllowed = 'Record visibilities not allowed at this location.';
+  SErrRecordTypesNotAllowed = 'Record types not allowed at this location.';
   SParserTypeNotAllowedHere = 'Type "%s" not allowed here';
   SParserNotAnOperand = 'Not an operand: (%d : %s)';
   SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value';
@@ -297,8 +297,8 @@ type
     function GetVariableValueAndLocation(Parent : TPasElement; Out Value: TPasExpr; Out AbsoluteExpr: TPasExpr; Out Location: String): Boolean;
     procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
     procedure HandleProcedureTypeModifier(ProcType: TPasProcedureType; ptm : TProcTypeModifier);
-    procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
-    procedure ParseClassLocalTypes(AType: TPasClassType; AVisibility: TPasMemberVisibility);
+    procedure ParseMembersLocalConsts(AType: TPasMembersType; AVisibility: TPasMemberVisibility);
+    procedure ParseMembersLocalTypes(AType: TPasMembersType; AVisibility: TPasMemberVisibility);
     procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean);
     procedure SetOptions(AValue: TPOptions);
     procedure OnScannerModeChanged(Sender: TObject; NewMode: TModeSwitch;
@@ -1252,7 +1252,10 @@ begin
       end
     else if Parent is TPasRecordType then
       begin
-      if PM in [pmVirtual,pmPublic,pmForward] then exit(false);
+      if not (PM in [pmOverload,
+                     pmInline, pmAssembler,
+                     pmExternal,
+                     pmNoReturn, pmFar, pmFinal]) then exit(false);
       end;
     Parent:=Parent.Parent;
     end;
@@ -1310,7 +1313,7 @@ begin
         end;
       end;
   Until Not Found;
-  UnGetToken;
+  UngetToken;
   If Assigned(Element) then
     Element.Hints:=Result;
   if ExpectSemiColon then
@@ -2829,7 +2832,7 @@ begin
 end;
 
 // Return the parent of a function declaration. This is AParent,
-// except when AParent is a class, and the function is overloaded.
+// except when AParent is a class/record and the function is overloaded.
 // Then the parent is the overload object.
 function TPasParser.CheckIfOverloaded(AParent: TPasElement; const AName: String): TPasElement;
 var
@@ -2838,15 +2841,14 @@ var
 
 begin
   Result:=AParent;
-  If (not (po_nooverloadedprocs in Options)) and (AParent is TPasClassType) then
+  If (not (po_nooverloadedprocs in Options)) and (AParent is TPasMembersType) then
     begin
-    OverloadedProc:=CheckOverLoadList(TPasClassType(AParent).Members,AName,Member);
+    OverloadedProc:=CheckOverLoadList(TPasMembersType(AParent).Members,AName,Member);
     If (OverloadedProc<>Nil) then
       Result:=OverloadedProc;
     end;
 end;
 
-
 procedure TPasParser.ParseMain(var Module: TPasModule);
 begin
   Module:=nil;
@@ -3397,7 +3399,7 @@ begin
       SetBlock(declThreadVar);
     tkProperty:
       SetBlock(declProperty);
-    tkProcedure, tkFunction, tkConstructor, tkDestructor,tkOperator:
+    tkProcedure, tkFunction, tkConstructor, tkDestructor, tkOperator:
       begin
       SetBlock(declNone);
       SaveComments;
@@ -3409,7 +3411,7 @@ begin
         SetBlock(declNone);
         SaveComments;
         NextToken;
-        If CurToken in [tkprocedure,tkFunction,tkConstructor, tkDestructor] then
+        If CurToken in [tkprocedure,tkFunction,tkConstructor,tkDestructor] then
           begin
           pt:=GetProcTypeFromToken(CurToken,True);
           AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt));
@@ -3554,7 +3556,8 @@ begin
              Declarations.Classes.Add(RecordEl);
              RecordEl.SetGenericTemplates(List);
              NextToken;
-             ParseRecordFieldList(RecordEl,tkend,true);
+             ParseRecordFieldList(RecordEl,tkend,
+                              msAdvancedRecords in Scanner.CurrentModeSwitches);
              CheckHint(RecordEl,True);
              Engine.FinishScope(stTypeDef,RecordEl);
              end;
@@ -3794,7 +3797,7 @@ var
 begin
   SaveComments;
   Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent));
-  if Parent is TPasClassType then
+  if Parent is TPasMembersType then
     Include(Result.VarModifiers,vmClass);
   ok:=false;
   try
@@ -3874,7 +3877,7 @@ begin
     else
       CheckToken(tkEqual);
     UngetToken;
-    CheckHint(Result,True);
+    CheckHint(Result,not (Parent is TPasMembersType));
     ok:=true;
   finally
     if not ok then
@@ -4355,7 +4358,7 @@ begin
 
     // Note: external members are allowed for non external classes too
     ExternalStruct:=(msExternalClass in CurrentModeSwitches)
-                    and ((Parent is TPasClassType) or (Parent is TPasRecordType));
+                    and (Parent is TPasMembersType);
 
     H:=H+CheckHint(Nil,False);
     if Full or ExternalStruct then
@@ -4750,7 +4753,7 @@ begin
     NextToken;
     If not CurTokenIsIdentifier('name') then
       begin
-      if P.Parent is TPasClassType then
+      if P.Parent is TPasMembersType then
         begin
         // public section starts
         UngetToken;
@@ -4903,7 +4906,7 @@ begin
         ResultEl:=TPasFunctionType(Element).ResultEl;
         ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
         end
-      // In Delphi mode, the implementation in the implementation section can be
+      // In Delphi mode, the signature in the implementation section can be
       // without result as it was declared
       // We actually check if the function exists in the interface section.
       else if (not IsAnonymous)
@@ -5257,7 +5260,9 @@ begin
       begin
       Result.VarType := ParseType(Result,CurSourcePos);
       NextToken;
-      end;
+      end
+    else if not IsClass then
+      ParseExcTokenError(':');
     if CurTokenIsIdentifier('INDEX') then
       begin
       NextToken;
@@ -6148,7 +6153,6 @@ var
   PC : TPTreeElement;
   Ot : TOperatorType;
   IsTokenBased , ok: Boolean;
-
 begin
   case ProcType of
   ptOperator,ptClassOperator:
@@ -6291,30 +6295,36 @@ procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType;
 
 Var
   VariantName : String;
-  v : TPasmemberVisibility;
+  v : TPasMemberVisibility;
   Proc: TPasProcedure;
   ProcType: TProcType;
   Prop : TPasProperty;
-  Cons : TPasConst;
   isClass : Boolean;
   NamePos: TPasSourcePos;
   OldCount, i: Integer;
 begin
-  v:=visDefault;
+  if AllowMethods then
+    v:=visPublic
+  else
+    v:=visDefault;
   isClass:=False;
   while CurToken<>AEndToken do
     begin
     SaveComments;
     Case CurToken of
+      tkType:
+        begin
+        if Not AllowMethods then
+          ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed);
+        ExpectToken(tkIdentifier);
+        ParseMembersLocalTypes(ARec,v);
+        end;
       tkConst:
         begin
         if Not AllowMethods then
           ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
         ExpectToken(tkIdentifier);
-        Cons:=ParseConstDecl(ARec);
-        Cons.Visibility:=v;
-        ARec.members.Add(Cons);
-        Engine.FinishScope(stDeclaration,Cons);
+        ParseMembersLocalConsts(ARec,v);
         end;
       tkVar:
         begin
@@ -6363,6 +6373,8 @@ begin
         else
           ARec.Members.Add(Proc);
         end;
+      tkDestructor:
+        ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
       tkGeneric, // Counts as field name
       tkIdentifier :
         begin
@@ -6547,40 +6559,46 @@ begin
   end;
 end;
 
-procedure TPasParser.ParseClassLocalTypes(AType: TPasClassType; AVisibility : TPasMemberVisibility);
+procedure TPasParser.ParseMembersLocalTypes(AType: TPasMembersType;
+  AVisibility: TPasMemberVisibility);
 
 Var
   T : TPasType;
   Done : Boolean;
 begin
-//  Writeln('Parsing local types');
+  // Writeln('Parsing local types');
   Repeat
     T:=ParseTypeDecl(AType);
     T.Visibility:=AVisibility;
     AType.Members.Add(t);
-//    Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
+    // Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
     NextToken;
-    Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility);
+    Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility);
     if Done then
       UngetToken;
   Until Done;
+  Engine.FinishScope(stTypeSection,AType);
 end;
 
-procedure TPasParser.ParseClassLocalConsts(AType: TPasClassType; AVisibility : TPasMemberVisibility);
+procedure TPasParser.ParseMembersLocalConsts(AType: TPasMembersType;
+  AVisibility: TPasMemberVisibility);
 
 Var
   C : TPasConst;
   Done : Boolean;
 begin
-//  Writeln('Parsing local consts');
+  // Writeln('Parsing local consts');
   Repeat
     C:=ParseConstDecl(AType);
     C.Visibility:=AVisibility;
     AType.Members.Add(C);
     Engine.FinishScope(stDeclaration,C);
-//    Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
+    //Writeln('TPasParser.ParseMembersLocalConsts ',CurtokenString,' ',TokenInfos[CurToken]);
+    NextToken;
+    if CurToken<>tkSemicolon then
+      exit;
     NextToken;
-    Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility);
+    Done:=(CurToken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility);
     if Done then
       UngetToken;
   Until Done;
@@ -6656,9 +6674,9 @@ begin
             SaveComments;
           Case CurSection of
           stType:
-            ParseClassLocalTypes(AType,CurVisibility);
+            ParseMembersLocalTypes(AType,CurVisibility);
           stConst :
-            ParseClassLocalConsts(AType,CurVisibility);
+            ParseMembersLocalConsts(AType,CurVisibility);
           stNone,
           stVar,
           stClassVar:

packages/fcl-passrc/tests/tcresolver.pas

@@ -489,22 +489,21 @@ type
     // advanced record
     Procedure TestAdvRecord;
     Procedure TestAdvRecord_Private;
-    // ToDO: Procedure TestAdvRecord_PropertyWithoutTypeFail;
-    // Todo: Procedure TestAdvRecord_ForwardFail
-    // ToDo: public, private, strict private
-    // ToDo: TestAdvRecordPublishedFail
-    // ToDo: TestAdvRecord_VirtualFail
-    // ToDo: TestAdvRecord_OverrideFail
-    // ToDo: constructor, destructor
-    // ToDo: class function/procedure
-    // ToDo: nested record type
-    // ToDo: const
-    // todo: var
-    // todo: class var
-    // todo: property
-    // todo: class property
-    // todo: TestRecordAsFuncResult
-    // todo: for in record
+    Procedure TestAdvRecord_StrictPrivate;
+    Procedure TestAdvRecord_VarConst;
+    Procedure TestAdvRecord_LocalForwardType;
+    Procedure TestAdvRecord_Constructor_NewInstance;
+    Procedure TestAdvRecord_ConstructorNoParamsFail;
+    Procedure TestAdvRecord_ClassConstructor;
+    Procedure TestAdvRecord_ClassConstructorParamsFail;
+    Procedure TestAdvRecord_NestedRecordType;
+    Procedure TestAdvRecord_NestedArgConstFail;
+    Procedure TestAdvRecord_Property;
+    Procedure TestAdvRecord_ClassProperty;
+    Procedure TestAdvRecord_PropertyDefault;
+    Procedure TestAdvRecord_RecordAsFuncResult;
+    Procedure TestAdvRecord_InheritedFail;
+    Procedure TestAdvRecord_ForInEnumerator;
 
     // class
     Procedure TestClass;
@@ -7858,6 +7857,462 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestAdvRecord_StrictPrivate;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  strict private',
+  '    A: word;',
+  '  end;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  '  r.a:=r.a;']);
+  CheckResolverException('Can''t access strict private member A',nCantAccessPrivateMember);
+end;
+
+procedure TTestResolver.TestAdvRecord_VarConst;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  type TInt = word;',
+  '  const',
+  '    C1 = 3;',
+  '    C2: TInt = 4;',
+  '  var',
+  '    V1: TInt;',
+  '    V2: TInt;',
+  '  class var',
+  '    VC: TInt;',
+  '    CA: array[1..C1] of TInt;',
+  '  procedure DoIt;',
+  '  end;',
+  'procedure TRec.DoIt;',
+  'begin',
+  '  C2:=Self.C2;',
+  '  V1:=VC;',
+  '  Self.V1:=Self.VC;',
+  '  VC:=V1;',
+  '  Self.VC:=Self.V1;',
+  'end;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  '  trec.C2:=trec.C2;',
+  '  r.V1:=r.VC;',
+  '  r.V1:=trec.VC;',
+  '  r.VC:=r.V1;',
+  '  trec.VC:=trec.c1;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_LocalForwardType;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  type',
+  '    PInt = ^TInt;',
+  '    TInt = word;',
+  '  var i: PInt;',
+  '  end;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_Constructor_NewInstance;
+var
+  aMarker: PSrcMarker;
+  Elements: TFPList;
+  ActualNewInstance: Boolean;
+  i: Integer;
+  El: TPasElement;
+  Ref: TResolvedReference;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '    constructor Create(w: word);',
+  '    class function DoSome: TRec;',
+  '  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',
+  '  r.{#r}Create(6); // normal call',
+  '']);
+  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','r':// 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.TestAdvRecord_ConstructorNoParamsFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '    constructor Create(w: word = 3);',
+  '  end;',
+  'constructor TRec.Create(w: word);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException(sParameterlessConstructorsNotAllowedInRecords,
+    nParameterlessConstructorsNotAllowedInRecords);
+end;
+
+procedure TTestResolver.TestAdvRecord_ClassConstructor;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '    class procedure {#a}Create;',
+  '    class constructor Create;',
+  '  end;',
+  'class constructor TRec.Create;',
+  'begin',
+  'end;',
+  'class procedure TRec.Create;',
+  'begin',
+  'end;',
+  'begin',
+  '  TRec.{@a}Create;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_ClassConstructorParamsFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '    class constructor Create(w: word);',
+  '  end;',
+  'class constructor TRec.Create(w: word);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('class constructor cannot have parameters',nXCannotHaveParameters);
+end;
+
+procedure TTestResolver.TestAdvRecord_NestedRecordType;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  type',
+  '    TSub = record',
+  '      x: word;',
+  '      class var y: word;',
+  '      procedure DoSub;',
+  '    end;',
+  '  var',
+  '    Sub: TSub;',
+  '    procedure DoIt(const r: TRec);',
+  '  end;',
+  'procedure TRec.TSub.DoSub;',
+  'begin',
+  '  x:=3;',
+  'end;',
+  'procedure TRec.DoIt(const r: TRec);',
+  'begin',
+  '  Sub.x:=4;',
+  '  r.Sub.y:=Sub.x;', // class var y is writable, even though r.Sub is not
+  'end;',
+  'var r: TRec;',
+  'begin',
+  '  r.sub.x:=4;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_NestedArgConstFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  type',
+  '    TSub = record',
+  '      x: word;',
+  '    end;',
+  '  var',
+  '    Sub: TSub;',
+  '    procedure DoIt(const r: TRec);',
+  '  end;',
+  'procedure TRec.DoIt(const r: TRec);',
+  'begin',
+  '  r.Sub.x:=4;',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected);
+end;
+
+procedure TTestResolver.TestAdvRecord_Property;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  private',
+  '    FSize: word;',
+  '    function SizeStored: boolean;',
+  '    function GetWidth: word;',
+  '    procedure SetWidth(Value: word);',
+  '  public',
+  '    property Size: word read FSize write FSize stored SizeStored default 3;',
+  '    property Width: word read GetWidth write SetWidth;',
+  '  end;',
+  'function TRec.SizeStored: boolean;',
+  'begin',
+  'end;',
+  'function TRec.GetWidth: word;',
+  'begin',
+  '  Result:=FSize;',
+  'end;',
+  'procedure TRec.SetWidth(Value: word);',
+  'begin',
+  '  FSize:=Value;',
+  'end;',
+  'var r: TRec;',
+  'begin',
+  '  r.Size:=r.Size;',
+  '  r.Width:=r.Width;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_ClassProperty;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  private',
+  '    class var FSize: word;',
+  '    class function GetWidth: word; static;',
+  '    class procedure SetWidth(Value: word); static;',
+  '  public',
+  '    class property Size: word read FSize write FSize;',
+  '    class property Width: word read GetWidth write SetWidth;',
+  '  end;',
+  'class function TRec.GetWidth: word;',
+  'begin',
+  '  Result:=FSize;',
+  'end;',
+  'class procedure TRec.SetWidth(Value: word);',
+  'begin',
+  '  FSize:=Value;',
+  'end;',
+  'begin',
+  '  TRec.Size:=TRec.Size;',
+  '  TRec.Width:=TRec.Width;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_PropertyDefault;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  private',
+  '    function GetItems(Index: word): word;',
+  '    procedure SetItems(Index: word; Value: word);',
+  '  public',
+  '    property Items[Index: word]: word read GetItems write SetItems; default;',
+  '  end;',
+  '  TGlob = record',
+  '  private',
+  '    class function GetSizes(Index: word): word; static;',
+  '    class procedure SetSizes(Index: word; Value: word); static;',
+  '  public',
+  '    class property Sizes[Index: word]: word read GetSizes write SetSizes; default;',
+  '  end;',
+  'function TRec.GetItems(Index: word): word;',
+  'begin',
+  'end;',
+  'procedure TRec.SetItems(Index: word; Value: word);',
+  'begin',
+  'end;',
+  'class function TGlob.GetSizes(Index: word): word;',
+  'begin',
+  'end;',
+  'class procedure TGlob.SetSizes(Index: word; Value: word);',
+  'begin',
+  'end;',
+  'var',
+  '  r: TRec;',
+  '  g: TGlob;',
+  'begin',
+  '  r[1]:=r[2];',
+  '  TGlob[1]:=TGlob[2];',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_RecordAsFuncResult;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  {#A}TRec = record',
+  '     {#A_i}i: longint;',
+  '     class function {#A_CreateA}Create: TRec;',
+  '     class function {#A_CreateB}Create(i: longint): TRec;',
+  '  end;',
+  'function {#F}F: TRec;',
+  'begin',
+  '  Result:=default(TRec);',
+  'end;',
+  'class function TRec.Create: TRec;',
+  'begin',
+  '  Result:=default(TRec);',
+  'end;',
+  'class function TRec.Create(i: longint): TRec;',
+  'begin',
+  '  Result:=default(TRec);',
+  '  Result.i:=i;',
+  'end;',
+  'var',
+  '  {#v}{=A}v: TRec;',
+  'begin',
+  '  {@v}v:={@F}F;',
+  '  {@v}v:={@F}F();',
+  '  if {@v}v={@F}F then ;',
+  '  if {@v}v={@F}F() then ;',
+  '  {@v}v:={@A}TRec.{@A_CreateA}Create;',
+  '  {@v}v:={@A}TRec.{@A_CreateA}Create();',
+  '  {@v}v:={@A}TRec.{@A_CreateB}Create(3);',
+  '  {@A}TRec.{@A_CreateA}Create . {@A_i}i:=4;',
+  '  {@A}TRec.{@A_CreateA}Create().{@A_i}i:=5;',
+  '  {@A}TRec.{@A_CreateB}Create(3).{@A_i}i:=6;']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAdvRecord_InheritedFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '    procedure DoIt;',
+  '  end;',
+  'procedure TRec.DoIt;',
+  'begin',
+  '  inherited;',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('The use of "inherited" is not allowed in a record',
+    nTheUseOfXisNotAllowedInARecord);
+end;
+
+procedure TTestResolver.TestAdvRecord_ForInEnumerator;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TObject = class end;',
+  '  TItem = TObject;',
+  '  TEnumerator = class',
+  '    FCurrent: TItem;',
+  '    property Current: TItem read FCurrent;',
+  '    function MoveNext: boolean;',
+  '  end;',
+  '  TBird = record',
+  '    function GetEnumerator: TEnumerator;',
+  '  end;',
+  'function TEnumerator.MoveNext: boolean;',
+  'begin',
+  'end;',
+  'function TBird.GetEnumerator: TEnumerator;',
+  'begin',
+  'end;',
+  'var',
+  '  b: TBird;',
+  '  i: TItem;',
+  '  {#i2}i2: TItem;',
+  'begin',
+  '  for i in b do {@i2}i2:=i;']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestClass;
 begin
   StartProgram(false);
@@ -9076,42 +9531,43 @@ end;
 procedure TTestResolver.TestClassAsFuncResult;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  {#TOBJ}TObject = class');
-  Add('  end;');
-  Add('  {#A}TClassA = class');
-  Add('     {#A_i}i: longint;');
-  Add('     constructor {#A_CreateA}Create;');
-  Add('     constructor {#A_CreateB}Create(i: longint);');
-  Add('  end;');
-  Add('function {#F}F: TClassA;');
-  Add('begin');
-  Add('  Result:=nil;');
-  Add('end;');
-  Add('constructor TClassA.Create;');
-  Add('begin');
-  Add('end;');
-  Add('constructor TClassA.Create(i: longint);');
-  Add('begin');
-  Add('end;');
-  Add('var');
-  Add('  {#o}{=TOBJ}o: TObject;');
-  Add('  {#v}{=A}v: TClassA;');
-  Add('begin');
-  Add('  {@o}o:={@F}F;');
-  Add('  {@o}o:={@F}F();');
-  Add('  {@v}v:={@F}F;');
-  Add('  {@v}v:={@F}F();');
-  Add('  if {@o}o={@F}F then ;');
-  Add('  if {@o}o={@F}F() then ;');
-  Add('  if {@v}v={@F}F then ;');
-  Add('  if {@v}v={@F}F() then ;');
-  Add('  {@v}v:={@A}TClassA.{@A_CreateA}Create;');
-  Add('  {@v}v:={@A}TClassA.{@A_CreateA}Create();');
-  Add('  {@v}v:={@A}TClassA.{@A_CreateB}Create(3);');
-  Add('  {@A}TClassA.{@A_CreateA}Create.{@A_i}i:=3;');
-  Add('  {@A}TClassA.{@A_CreateA}Create().{@A_i}i:=3;');
-  Add('  {@A}TClassA.{@A_CreateB}Create(3).{@A_i}i:=3;');
+  Add([
+  'type',
+  '  {#TOBJ}TObject = class',
+  '  end;',
+  '  {#A}TClassA = class',
+  '     {#A_i}i: longint;',
+  '     constructor {#A_CreateA}Create;',
+  '     constructor {#A_CreateB}Create(i: longint);',
+  '  end;',
+  'function {#F}F: TClassA;',
+  'begin',
+  '  Result:=nil;',
+  'end;',
+  'constructor TClassA.Create;',
+  'begin',
+  'end;',
+  'constructor TClassA.Create(i: longint);',
+  'begin',
+  'end;',
+  'var',
+  '  {#o}{=TOBJ}o: TObject;',
+  '  {#v}{=A}v: TClassA;',
+  'begin',
+  '  {@o}o:={@F}F;',
+  '  {@o}o:={@F}F();',
+  '  {@v}v:={@F}F;',
+  '  {@v}v:={@F}F();',
+  '  if {@o}o={@F}F then ;',
+  '  if {@o}o={@F}F() then ;',
+  '  if {@v}v={@F}F then ;',
+  '  if {@v}v={@F}F() then ;',
+  '  {@v}v:={@A}TClassA.{@A_CreateA}Create;',
+  '  {@v}v:={@A}TClassA.{@A_CreateA}Create();',
+  '  {@v}v:={@A}TClassA.{@A_CreateB}Create(3);',
+  '  {@A}TClassA.{@A_CreateA}Create.{@A_i}i:=3;',
+  '  {@A}TClassA.{@A_CreateA}Create().{@A_i}i:=3;',
+  '  {@A}TClassA.{@A_CreateB}Create(3).{@A_i}i:=3;']);
   ParseProgram;
 end;
 
@@ -9459,26 +9915,27 @@ var
   ActualNewInstance, ActualImplicitCallWithoutParams: Boolean;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  TObject = class');
-  Add('    constructor Create;');
-  Add('    class function DoSome: TObject;');
-  Add('  end;');
-  Add('constructor TObject.Create;');
-  Add('begin');
-  Add('  {#a}Create; // normal call');
-  Add('  TObject.{#b}Create; // new instance');
-  Add('end;');
-  Add('class function TObject.DoSome: TObject;');
-  Add('begin');
-  Add('  Result:={#c}Create; // new instance');
-  Add('end;');
-  Add('var');
-  Add('  o: TObject;');
-  Add('begin');
-  Add('  TObject.{#p}Create; // new object');
-  Add('  o:=TObject.{#q}Create; // new object');
-  Add('  o.{#r}Create; // normal call');
+  Add([
+  'type',
+  '  TObject = class',
+  '    constructor Create;',
+  '    class function DoSome: TObject;',
+  '  end;',
+  'constructor TObject.Create;',
+  'begin',
+  '  {#a}Create; // normal call',
+  '  TObject.{#b}Create; // new instance',
+  'end;',
+  'class function TObject.DoSome: TObject;',
+  'begin',
+  '  Result:={#c}Create; // new instance',
+  'end;',
+  'var',
+  '  o: TObject;',
+  'begin',
+  '  TObject.{#p}Create; // new object',
+  '  o:=TObject.{#q}Create; // new object',
+  '  o.{#r}Create; // normal call']);
   ParseProgram;
   aMarker:=FirstSrcMarker;
   while aMarker<>nil do

packages/fcl-passrc/tests/tctypeparser.pas

@@ -197,7 +197,7 @@ type
     Procedure DoParseRecord;
     Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
     procedure AssertVariantSelector(AName, AType: string);
-    procedure AssertConst1(Hints: TPasMemberHints);
+    procedure AssertConst1(Hints: TPasMemberHints; Index: integer = 1);
     procedure AssertField1(Hints: TPasMemberHints);
     procedure AssertField2(Hints: TPasMemberHints);
     procedure AssertMethod2(Hints: TPasMemberHints; isClass : Boolean = False);
@@ -257,7 +257,6 @@ type
     Procedure TestOnePlatformField;
     Procedure TestOnePlatformFieldDeprecated;
     Procedure TestOnePlatformFieldPlatform;
-    Procedure TestOneConstOneField;
     Procedure TestOneGenericField;
     Procedure TestTwoFields;
     procedure TestTwoFieldProtected;
@@ -351,8 +350,16 @@ type
     Procedure TestVariantNestedVariantBothDeprecatedPlatform;
     Procedure TestOperatorField;
     Procedure TestPropertyFail;
+    Procedure TestAdvRec_TwoConst;
     Procedure TestAdvRec_Property;
     Procedure TestAdvRec_PropertyImplementsFail;
+    Procedure TestAdvRec_PropertyNoTypeFail;
+    Procedure TestAdvRec_ForwardFail;
+    Procedure TestAdvRec_PublishedFail;
+    Procedure TestAdvRec_ProcVirtualFail;
+    Procedure TestAdvRec_ProcOverrideFail;
+    Procedure TestAdvRec_ProcMessageFail;
+    Procedure TestAdvRec_DestructorFail;
   end;
 
   { TTestProcedureTypeParser }
@@ -1283,7 +1290,8 @@ begin
   except
     on E: EParserError do
       begin
-      AssertEquals('Expected {'+Msg+'}, but got msg {'+Parser.LastMsg+'}',MsgNumber,Parser.LastMsgNumber);
+      AssertEquals('Expected {'+Msg+'} '+IntToStr(MsgNumber)+', but got msg {'+Parser.LastMsg+'} '+IntToStr(Parser.LastMsgNumber),MsgNumber,Parser.LastMsgNumber);
+      AssertEquals('Expected {'+Msg+'}, but got msg {'+Parser.LastMsg+'}',Msg,Parser.LastMsg);
       ok:=true;
       end;
   end;
@@ -1362,15 +1370,15 @@ begin
     end;
 end;
 
-procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints);
+procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints;
+  Index: integer);
 begin
   if Hints=[] then ;
-  AssertEquals('Member 1 type',TPasConst,TObject(TheRecord.Members[0]).ClassType);
-  AssertEquals('Const 1 name','x',Const1.Name);
-  AssertNotNull('Have 1 const expr',Const1.Expr);
+  AssertEquals('Member '+IntToStr(Index+1)+' type',TPasConst,TObject(TheRecord.Members[Index]).ClassType);
+  AssertEquals('Const '+IntToStr(Index+1)+' name','x',Const1.Name);
+  AssertNotNull('Have '+IntToStr(Index+1)+' const expr',Const1.Expr);
 end;
 
-
 procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
 begin
   TestFields([],AHint);
@@ -1383,7 +1391,6 @@ begin
   AssertVariant1(Hints,['0']);
 end;
 
-
 procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints;
   VariantLabels: array of string);
 
@@ -1899,15 +1906,6 @@ begin
   AssertOneIntegerField([hplatform]);
 end;
 
-procedure TTestRecordTypeParser.TestOneConstOneField;
-begin
-  Scanner.Options:=[po_Delphi];
-  TestFields(['public','Const x =123;','y : integer'],'',False);
-  AssertConst1([]);
-  AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility);
-  AssertField2([]);
-end;
-
 procedure TTestRecordTypeParser.TestOneGenericField;
 begin
   TestFields(['Generic : Integer;'],'',False);
@@ -2529,6 +2527,21 @@ begin
   ParseRecordFail(SErrRecordPropertiesNotAllowed,nErrRecordPropertiesNotAllowed);
 end;
 
+procedure TTestRecordTypeParser.TestAdvRec_TwoConst;
+var
+  aConst: TPasConst;
+begin
+  Scanner.Options:=[po_Delphi];
+  TestFields(['public','Const x =123;','y : integer = 456'],'',False);
+  AssertEquals('Two Const',2,TheRecord.Members.Count);
+  AssertConst1([]);
+  AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility);
+  AssertEquals('Member 2 type',TPasConst,TObject(TheRecord.Members[1]).ClassType);
+  aConst:=TPasConst(TheRecord.Members[1]);
+  AssertEquals('Const 2 name','y',aConst.Name);
+  AssertNotNull('Have 2 const expr',aConst.Expr);
+end;
+
 procedure TTestRecordTypeParser.TestAdvRec_Property;
 begin
   StartRecord(true);
@@ -2543,6 +2556,56 @@ begin
   ParseRecordFail('Expected ";"',nParserExpectTokenError);
 end;
 
+procedure TTestRecordTypeParser.TestAdvRec_PropertyNoTypeFail;
+begin
+  StartRecord(true);
+  AddMember('Property Something;');
+  ParseRecordFail('Expected ":"',nParserExpectTokenError);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ForwardFail;
+begin
+  StartRecord(true);
+  FDecl.Add(';TMyRecord = record');
+  ParseRecordFail('Syntax error in type',nParserTypeSyntaxError);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_PublishedFail;
+begin
+  StartRecord(true);
+  AddMember('published');
+  AddMember('A: word;');
+  ParseRecordFail(SParserInvalidRecordVisibility,nParserInvalidRecordVisibility);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ProcVirtualFail;
+begin
+  StartRecord(true);
+  AddMember('procedure DoIt; virtual;');
+  ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ProcOverrideFail;
+begin
+  StartRecord(true);
+  AddMember('procedure DoIt; override;');
+  ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_ProcMessageFail;
+begin
+  StartRecord(true);
+  AddMember('procedure DoIt; message 2;');
+  ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_DestructorFail;
+begin
+  StartRecord(true);
+  AddMember('destructor Free;');
+  ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
+end;
+
 { TBaseTestTypeParser }
 
 Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;

packages/fpmkunit/src/fpmkunit.pp

@@ -158,7 +158,7 @@ Type
   TLogEvent = Procedure (Level : TVerboseLevel; Const Msg : String) of Object;
   TNotifyProcEvent = procedure(Sender: TObject);
 
-  TRunMode = (rmCompile,rmBuild,rmInstall,rmArchive,rmClean,rmDistClean,rmManifest,rmZipInstall,rmPkgList,rmUnInstall,rmInfo);
+  TRunMode = (rmCompile,rmBuild,rmInstall,rmBuildInstall,rmArchive,rmClean,rmDistClean,rmManifest,rmZipInstall,rmPkgList,rmUnInstall,rmInfo);
 
   TBuildMode = (bmOneByOne, bmBuildUnit{, bmSkipImplicitUnits});
   TBuildModes = set of TBuildMode;
@@ -1289,7 +1289,7 @@ Type
     Procedure Usage(const FMT : String; Args : Array of const);
     Procedure Compile(Force : Boolean); virtual;
     Procedure Clean(AllTargets: boolean); virtual;
-    Procedure Install; virtual;
+    Procedure Install(ForceBuild : Boolean); virtual;
     Procedure UnInstall; virtual;
     Procedure ZipInstall; virtual;
     Procedure Archive; virtual;
@@ -1763,6 +1763,7 @@ ResourceString
   SHelpCompile        = 'Compile all units in the package(s).';
   SHelpBuild          = 'Build all units in the package(s).';
   SHelpInstall        = 'Install all units in the package(s).';
+  SHelpBuildInstall   = 'Build and install all units in the package(s).';
   SHelpUnInstall      = 'Uninstall the package(s).';
   SHelpClean          = 'Clean (remove) all generated files in the package(s) for current CPU-OS target.';
   SHelpDistclean      = 'Clean (remove) all generated files in the package(s) for all targets.';
@@ -5197,6 +5198,8 @@ begin
       FRunMode:=rmBuild
     else if CheckCommand(I,'i','install') then
       FRunMode:=rmInstall
+    else if CheckCommand(I,'bi','buildinstall') then
+      FRunMode:=rmBuildInstall
     else if CheckCommand(I,'zi','zipinstall') then
       FRunMode:=rmZipInstall
     else if CheckCommand(I,'c','clean') then
@@ -5347,6 +5350,7 @@ begin
   LogCmd('compile',SHelpCompile);
   LogCmd('build',SHelpBuild);
   LogCmd('install',SHelpInstall);
+  LogCmd('buildinstall',SHelpBuildInstall);
   LogCmd('uninstall',SHelpUnInstall);
   LogCmd('clean',SHelpClean);
   LogCmd('distclean',SHelpDistclean);
@@ -5444,9 +5448,10 @@ begin
 end;
 
 
-procedure TCustomInstaller.Install;
+procedure TCustomInstaller.Install(ForceBuild : Boolean);
 begin
   NotifyEventCollection.CallEvents(neaBeforeInstall, self);
+  BuildEngine.ForceCompile := ForceBuild;
   BuildEngine.Install(Packages);
   NotifyEventCollection.CallEvents(neaAfterInstall, self);
 end;
@@ -5520,7 +5525,8 @@ begin
     Case RunMode of
       rmCompile : Compile(False);
       rmBuild   : Compile(True);
-      rmInstall : Install;
+      rmInstall : Install(False);
+      rmBuildInstall: Install(True);
       rmZipInstall : ZipInstall;
       rmArchive : Archive;
       rmClean    : Clean(False);

packages/fppkg/src/fprepos.pp

@@ -98,6 +98,29 @@ type
     Property Dependencies[Index : Integer] : TFPDependency Read GetDependency Write SetDependency;default;
   end;
 
+
+  { TFPPackageVariant }
+
+  TFPPackageVariant = class(TCollectionItem)
+  private
+    FName: string;
+    FIsInheritable: boolean;
+    FOptions: TStringArray;
+  public
+    property Name: string read FName write FName;
+    property IsInheritable: boolean read FIsInheritable write FIsInheritable;
+    property Options: TStringArray read FOptions write FOptions;
+  end;
+
+  { TFPPackageVariants }
+
+  TFPPackageVariants = class(TCollection)
+  protected
+    function GetItem(Index: Integer): TFPPackageVariant;
+  public
+    property Items[Index: Integer]: TFPPackageVariant read GetItem;
+  end;
+
   { TFPPackage }
 
   TFPPackage = Class(TStreamCollectionItem)
@@ -126,6 +149,7 @@ type
     FChecksum : cardinal;
     FLocalFileName : String;
     FPackagesStructure: TFPCustomPackagesStructure;
+    FPackageVariants: TFPPackageVariants;
     function GetFileName: String;
     function GetRepository: TFPRepository;
     procedure SetName(const AValue: String);
@@ -169,6 +193,8 @@ type
     // Manual package from commandline not in official repository
     Property LocalFileName : String Read FLocalFileName Write FLocalFileName;
     Property PackagesStructure: TFPCustomPackagesStructure read FPackagesStructure write FPackagesStructure;
+    // Read from unit config file, not in official repository
+    Property PackageVariants: TFPPackageVariants read FPackageVariants;
   end;
 
   { TFPPackages }
@@ -325,6 +351,7 @@ const
   KeyFPMakeOptions = 'FPMakeOptions';
   KeyCPU      = 'CPU';
   KeyOS       = 'OS';
+  KeyPkgVar   = 'PackageVariant_';
 
 ResourceString
   SErrInvalidCPU           = 'Invalid CPU name : "%s"';
@@ -359,6 +386,13 @@ begin
   OS:=StringToOs(Copy(S,P+1,Length(S)-P));
 end;
 
+{ TFPPackageVariants }
+
+function TFPPackageVariants.GetItem(Index: Integer): TFPPackageVariant;
+begin
+  Result := inherited GetItem(Index) as TFPPackageVariant;
+end;
+
 { TFPCustomPackagesStructure }
 
 function TFPCustomPackagesStructure.GetUnitDirectory(APackage: TFPPackage): string;
@@ -482,6 +516,7 @@ begin
   FOSes:=AllOSes;
   FCPUs:=AllCPUs;
   FDependencies:=TFPDependencies.Create(TFPDependency);
+  FPackageVariants:=TFPPackageVariants.Create(TFPPackageVariant);
 end;
 
 
@@ -490,6 +525,7 @@ begin
   FreeAndNil(FDependencies);
   FreeAndNil(FVersion);
   FreeAndNil(FUnusedVersion);
+  FreeAndNil(FPackageVariants);
   inherited Destroy;
 end;
 
@@ -625,7 +661,9 @@ var
   VCPU : TCPU;
   i,k : Integer;
   DepChecksum : Cardinal;
-  DepName : String;
+  DepName: String;
+  PackageVariantStr, PackageVariantName: String;
+  PackageVariant: TFPPackageVariant;
   D : TFPDependency;
 begin
   With AStringList do
@@ -668,6 +706,25 @@ begin
       //NeedLibC:=Upcase(Values[KeyNeedLibC])='Y';
       IsFPMakeAddIn:=Upcase(Values[KeyAddIn])='Y';
       FPMakePluginUnits:=Values[KeyPluginUnits];
+
+      // Read packagevariants
+      i := 1;
+      repeat
+      PackageVariantStr := Values[KeyPkgVar+IntToStr(i)];
+      if PackageVariantStr<>'' then
+        begin
+        PackageVariant := FPackageVariants.Add as TFPPackageVariant;
+        PackageVariantName := Copy(PackageVariantStr, 1, pos(':', PackageVariantStr) -1);
+        if RightStr(PackageVariantName, 1) = '*' then
+          begin
+          PackageVariantName := Copy(PackageVariantName, 1, Length(PackageVariantName) -1);
+          PackageVariant.IsInheritable := True;
+          end;
+        PackageVariant.Name := PackageVariantName;
+        PackageVariant.Options := Copy(PackageVariantStr, pos(':', PackageVariantStr) +1).Split(',');
+        end;
+      inc(i);
+      until PackageVariantStr='';
     end;
 end;
 

packages/fppkg/src/pkgfppkg.pp

@@ -211,18 +211,22 @@ begin
   if FileExists(S) then
     begin
       pkgglobals.Log(llDebug,SLogLoadingCompilerConfig,[S]);
-      FCompilerOptions.LoadCompilerFromFile(S)
+      FCompilerOptions.LoadCompilerFromFile(S);
+      if FCompilerOptions.SaveInifileChanges then
+        // The file is in an old format, try to update the file but ignore
+        // any failures.
+        FCompilerOptions.SaveCompilerToFile(S);
     end
   else
     begin
-      // Generate a default configuration if it doesn't exists
-      if FOptions.GlobalSection.CompilerConfig='default' then
+      if FCompilerOptions.SaveInifileChanges then
+        // A new fppkg.cfg has been created, try to create a new compiler-configuration
+        // file too.
         begin
           pkgglobals.Log(llDebug,SLogGeneratingCompilerConfig,[S]);
           FCompilerOptions.InitCompilerDefaults;
-          FCompilerOptions.SaveCompilerToFile(S);
-          if FCompilerOptions.SaveInifileChanges then
-            FCompilerOptions.SaveCompilerToFile(S);
+          if not FCompilerOptions.SaveCompilerToFile(S) then
+            Error(SErrMissingCompilerConfig,[S]);
         end
       else
         Error(SErrMissingCompilerConfig,[S]);
@@ -237,6 +241,8 @@ begin
       pkgglobals.Log(llDebug,SLogLoadingFPMakeCompilerConfig,[S]);
       FFPMakeCompilerOptions.LoadCompilerFromFile(S);
       if FFPMakeCompilerOptions.SaveInifileChanges then
+        // The file is in an old format, try to update the file but ignore
+        // any failures.
         FFPMakeCompilerOptions.SaveCompilerToFile(S);
     end
   else

packages/fppkg/src/pkgmessages.pp

@@ -163,6 +163,7 @@ Resourcestring
   SDbgPackageInstallRequired = 'Installation of package "%s" required for repository "%s"';
 
   SWarnBrokenAfterReinstall  = 'Package %s is still broken, even after re-installation. (%s)';
+  SWarnFailedToWriteCompConf = 'Failed to write compiler-configuration file "%s": %s';
 
   SProgrReinstallDependent   = 'Re-install packages which are dependent on just installed packages';
   SProgrInstallDependencies  = 'Install dependencies';

packages/fppkg/src/pkgoptions.pp

@@ -246,7 +246,7 @@ Type
     Destructor Destroy; override;
     Procedure InitCompilerDefaults;
     Procedure LoadCompilerFromFile(const AFileName : String);
-    Procedure SaveCompilerToFile(const AFileName : String);
+    function SaveCompilerToFile(const AFileName : String): Boolean;
     procedure LogValues(ALogLevel: TLogLevel; const ACfgName:string);
     procedure UpdateLocalRepositoryOption(FppkgOptions: TFppkgOptions);
     procedure CheckCompilerValues;
@@ -984,6 +984,7 @@ begin
   FOptionParser := TTemplateParser.Create;
   FOptionParser.Values['AppConfigDir'] := GetFppkgConfigDir(false);
   FOptionParser.Values['UserDir'] := GetUserDir;
+  FSaveInifileChanges := True;
   {$ifdef unix}
   FLocalInstallDir:='{LocalPrefix}'+'lib'+PathDelim+'fpc'+PathDelim+'{CompilerVersion}'+PathDelim;
   FGlobalInstallDir:='{GlobalPrefix}'+'lib'+PathDelim+'fpc'+PathDelim+'{CompilerVersion}'+PathDelim;
@@ -1175,6 +1176,10 @@ begin
             FSaveInifileChanges:=true;
             if (FConfigVersion>CurrentConfigVersion) then
               Error(SErrUnsupportedConfigVersion,[AFileName]);
+          end
+        else
+          begin
+            FSaveInifileChanges:=False;
           end;
         GlobalPrefix:=ReadString(SDefaults,KeyGlobalPrefix,FGlobalPrefix);
         LocalPrefix:=ReadString(SDefaults,KeyLocalPrefix,FLocalPrefix);
@@ -1191,30 +1196,37 @@ begin
 end;
 
 
-procedure TCompilerOptions.SaveCompilerToFile(const AFileName: String);
+function TCompilerOptions.SaveCompilerToFile(const AFileName: String): Boolean;
 Var
   Ini : TIniFile;
 begin
-  if FileExists(AFileName) then
-    BackupFile(AFileName);
-  Ini:=TIniFile.Create(AFileName);
+  Result := False;
   try
-    With Ini do
-      begin
-        WriteInteger(SDefaults,KeyConfigVersion,CurrentConfigVersion);
-        WriteString(SDefaults,KeyGlobalPrefix,FGlobalPrefix);
-        WriteString(SDefaults,KeyLocalPrefix,FLocalPrefix);
-        WriteString(SDefaults,KeyGlobalInstallDir,FGlobalInstallDir);
-        WriteString(SDefaults,KeyLocalInstallDir,FLocalInstallDir);
-        WriteString(SDefaults,KeyCompiler,FCompiler);
-        WriteString(SDefaults,KeyCompilerOS,OSToString(CompilerOS));
-        WriteString(SDefaults,KeyCompilerCPU,CPUtoString(CompilerCPU));
-        WriteString(SDefaults,KeyCompilerVersion,FCompilerVersion);
-        FSaveInifileChanges:=False;
-      end;
-    Ini.UpdateFile;
-  finally
-    Ini.Free;
+    if FileExists(AFileName) then
+      BackupFile(AFileName);
+    Ini:=TIniFile.Create(AFileName);
+    try
+      With Ini do
+        begin
+          WriteInteger(SDefaults,KeyConfigVersion,CurrentConfigVersion);
+          WriteString(SDefaults,KeyGlobalPrefix,FGlobalPrefix);
+          WriteString(SDefaults,KeyLocalPrefix,FLocalPrefix);
+          WriteString(SDefaults,KeyGlobalInstallDir,FGlobalInstallDir);
+          WriteString(SDefaults,KeyLocalInstallDir,FLocalInstallDir);
+          WriteString(SDefaults,KeyCompiler,FCompiler);
+          WriteString(SDefaults,KeyCompilerOS,OSToString(CompilerOS));
+          WriteString(SDefaults,KeyCompilerCPU,CPUtoString(CompilerCPU));
+          WriteString(SDefaults,KeyCompilerVersion,FCompilerVersion);
+          FSaveInifileChanges:=False;
+        end;
+      Ini.UpdateFile;
+    finally
+      Ini.Free;
+    end;
+    Result := True;
+  except
+    on E: Exception do
+      log(llWarning, SWarnFailedToWriteCompConf, [AFileName, E.Message]);
   end;
 end;
 

packages/libffi/src/ffi.manager.pp

@@ -500,7 +500,6 @@ const
     Invoke: @FFIInvoke;
     CreateCallbackProc: Nil;
     CreateCallbackMethod: Nil;
-    FreeCallback: Nil
   );
 
 var

packages/pastojs/tests/tcfiler.pas

@@ -90,6 +90,7 @@ type
     procedure CheckRestoredPrimitiveExpr(const Path: string; Orig, Rest: TPrimitiveExpr); virtual;
     procedure CheckRestoredBoolConstExpr(const Path: string; Orig, Rest: TBoolConstExpr); virtual;
     procedure CheckRestoredParamsExpr(const Path: string; Orig, Rest: TParamsExpr); virtual;
+    procedure CheckRestoredProcedureExpr(const Path: string; Orig, Rest: TProcedureExpr); virtual;
     procedure CheckRestoredRecordValues(const Path: string; Orig, Rest: TRecordValues); virtual;
     procedure CheckRestoredPasExprArray(const Path: string; Orig, Rest: TPasExprArray); virtual;
     procedure CheckRestoredArrayValues(const Path: string; Orig, Rest: TArrayValues); virtual;
@@ -138,17 +139,21 @@ type
     procedure TestPC_Var;
     procedure TestPC_Enum;
     procedure TestPC_Set;
+    procedure TestPC_Set_InFunction;
     procedure TestPC_SetOfAnonymousEnumType;
     procedure TestPC_Record;
+    procedure TestPC_Record_InFunction;
     procedure TestPC_JSValue;
     procedure TestPC_Array;
     procedure TestPC_ArrayOfAnonymous;
+    procedure TestPC_Array_InFunction;
     procedure TestPC_Proc;
     procedure TestPC_Proc_Nested;
     procedure TestPC_Proc_LocalConst;
     procedure TestPC_Proc_UTF8;
     procedure TestPC_Proc_Arg;
     procedure TestPC_ProcType;
+    procedure TestPC_Proc_Anonymous;
     procedure TestPC_Class;
     procedure TestPC_ClassForward;
     procedure TestPC_ClassConstructor;
@@ -1078,6 +1083,8 @@ begin
     CheckRestoredPasExpr(Path,TPasExpr(Orig),TPasExpr(Rest))
   else if C=TParamsExpr then
     CheckRestoredParamsExpr(Path,TParamsExpr(Orig),TParamsExpr(Rest))
+  else if C=TProcedureExpr then
+    CheckRestoredProcedureExpr(Path,TProcedureExpr(Orig),TProcedureExpr(Rest))
   else if C=TRecordValues then
     CheckRestoredRecordValues(Path,TRecordValues(Orig),TRecordValues(Rest))
   else if C=TArrayValues then
@@ -1259,6 +1266,13 @@ begin
   CheckRestoredPasExpr(Path,Orig,Rest);
 end;
 
+procedure TCustomTestPrecompile.CheckRestoredProcedureExpr(const Path: string;
+  Orig, Rest: TProcedureExpr);
+begin
+  CheckRestoredProcedure(Path+'$Ano',Orig.Proc,Rest.Proc);
+  CheckRestoredPasExpr(Path,Orig,Rest);
+end;
+
 procedure TCustomTestPrecompile.CheckRestoredRecordValues(const Path: string;
   Orig, Rest: TRecordValues);
 var
@@ -1662,6 +1676,32 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Set_InFunction;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'procedure DoIt;',
+  'implementation',
+  'procedure DoIt;',
+  'type',
+  '  TEnum = (red,green,blue);',
+  '  TEnumRg = green..blue;',
+  '  TEnumAlias = TEnum;', // alias
+  '  TSetOfEnum = set of TEnum;',
+  '  TSetOfEnumRg = set of TEnumRg;',
+  '  TSetOfDir = set of (west,east);',
+  'var',
+  '  Empty: TSetOfEnum = [];', // empty set lit
+  '  All: TSetOfEnum = [low(TEnum)..pred(high(TEnum)),high(TEnum)];', // full set lit, range in set
+  '  Dirs: TSetOfDir;',
+  'begin',
+  '  Dirs:=[east];',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_SetOfAnonymousEnumType;
 begin
   StartUnit(false);
@@ -1691,6 +1731,28 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Record_InFunction;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'procedure DoIt;',
+  'implementation',
+  'procedure DoIt;',
+  'type',
+  '  TRec = record',
+  '    i: longint;',
+  '    s: string;',
+  '  end;',
+  '  P = ^TRec;',
+  '  TArrOfRec = array of TRec;',
+  'var',
+  '  r: TRec;',
+  'begin',
+  'end;']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_JSValue;
 begin
   StartUnit(false);
@@ -1729,6 +1791,25 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Array_InFunction;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'procedure DoIt;',
+  'implementation',
+  'procedure DoIt;',
+  'type',
+  '  TArr = array[1..2] of word;',
+  'var',
+  '  arr: TArr;',
+  'begin',
+  '  arr[2]:=arr[1];',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_Proc;
 begin
   StartUnit(false);
@@ -1866,6 +1947,32 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_Proc_Anonymous;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  TFunc = reference to function(w: word): word;',
+  '  function GetIt(f: TFunc): longint;',
+  'implementation',
+  'var k: byte;',
+  'function GetIt(f: TFunc): longint;',
+  'begin',
+  '  f:=function(w: word): word',
+  '    var j: byte;',
+  '      function GetMul(a,b: longint): longint; ',
+  '      begin',
+  '        Result:=a*b;',
+  '      end;',
+  '    begin',
+  '      Result:=j*GetMul(1,2)*k;',
+  '    end;',
+  'end;',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_Class;
 begin
   StartUnit(false);

packages/pastojs/tests/tcmodules.pas

@@ -361,6 +361,7 @@ type
     Procedure TestSet_ConstEnum;
     Procedure TestSet_ConstChar;
     Procedure TestSet_ConstInt;
+    Procedure TestSet_InFunction;
     Procedure TestSet_ForIn;
 
     // statements
@@ -401,6 +402,7 @@ type
     Procedure TestArray_StaticBool;
     Procedure TestArray_StaticChar;
     Procedure TestArray_StaticMultiDim;
+    Procedure TestArray_StaticInFunction;
     Procedure TestArrayOfRecord;
     Procedure TestArray_StaticRecord;
     Procedure TestArrayOfSet;
@@ -431,7 +433,7 @@ type
     Procedure TestRecord_Empty;
     Procedure TestRecord_Var;
     Procedure TestRecord_VarExternal;
-    Procedure TestWithRecordDo;
+    Procedure TestRecord_WithDo;
     Procedure TestRecord_Assign;
     Procedure TestRecord_PassAsArgClone;
     Procedure TestRecord_AsParams;
@@ -445,6 +447,16 @@ type
     Procedure TestRecord_Const;
     Procedure TestRecord_TypecastFail;
     Procedure TestRecord_InFunction;
+    // ToDo: RTTI of local record
+    // ToDo: pcu local record, name clash and rtti
+
+    // advanced record
+    // ToDo: TestAdvRecord_Function;
+    // ToDo: TestAdvRecord_Property;
+    // ToDo: TestAdvRecord_PropertyDefault;
+    // ToDo: TestAdvRecord_InFunction;
+    // ToDo: pcu: record default property
+    // ToDo: class constructor
 
     // classes
     Procedure TestClass_TObjectDefaultConstructor;
@@ -2697,7 +2709,7 @@ begin
     '$mod.vB = $mod.vA + $mod.vA;',
     '$mod.vB = Math.floor($mod.vA / $mod.vB);',
     '$mod.vB = $mod.vA % $mod.vB;',
-    '$mod.vB = ($mod.vA + ($mod.vA * $mod.vB)) + Math.floor($mod.vA / $mod.vB);',
+    '$mod.vB = $mod.vA + ($mod.vA * $mod.vB) + Math.floor($mod.vA / $mod.vB);',
     '$mod.vC = -$mod.vA;',
     '$mod.vA = $mod.vA - $mod.vB;',
     '$mod.vB = $mod.vA;',
@@ -2910,13 +2922,13 @@ begin
     '  function Nesty(pA) {',
     '    var Result$1 = 0;',
     '    var vB = 0;',
-    '    Result$1 = (((pA + vB) + vC) + pD) + $mod.vInUnit;',
+    '    Result$1 = pA + vB + vC + pD + $mod.vInUnit;',
     '    Result$1 = 3;',
     '    Result = 4;',
     '    return Result$1;',
     '    return Result$1;',
     '  };',
-    '  Result = (pA + vB) + vC;',
+    '  Result = pA + vB + vC;',
     '  Result = 6;',
     '  return Result;',
     '  return Result;',
@@ -3846,7 +3858,7 @@ begin
     'this.B = 3 + 1;',
     'var C = 3 + 1;',
     'var D = 4 + 1;',
-    'var E = ((5 + 4) + 4) + 3;',
+    'var E = 5 + 4 + 4 + 3;',
     'this.DoIt = function () {',
     '};',
     '']),
@@ -4731,6 +4743,7 @@ procedure TTestModule.TestEnum_InFunction;
 begin
   StartProgram(false);
   Add([
+  'const TEnum = 3;',
   'procedure DoIt;',
   'type',
   '  TEnum = (Red, Green, Blue);',
@@ -4751,28 +4764,29 @@ begin
   ConvertProgram;
   CheckSource('TestEnum_InFunction',
     LinesToStr([ // statements
+    'this.TEnum = 3;',
+    'var TEnum$1 = {',
+    '  "0":"Red",',
+    '  Red:0,',
+    '  "1":"Green",',
+    '  Green:1,',
+    '  "2":"Blue",',
+    '  Blue:2',
+    '  };',
+    'var TEnumSub = {',
+    '  "0": "Left",',
+    '  Left: 0,',
+    '  "1": "Right",',
+    '  Right: 1',
+    '};',
     'this.DoIt = function () {',
-    '  var TEnum = {',
-    '    "0":"Red",',
-    '    Red:0,',
-    '    "1":"Green",',
-    '    Green:1,',
-    '    "2":"Blue",',
-    '    Blue:2',
-    '    };',
     '  function Sub() {',
-    '    var TEnumSub = {',
-    '      "0": "Left",',
-    '      Left: 0,',
-    '      "1": "Right",',
-    '      Right: 1',
-    '    };',
     '    var es = 0;',
     '    es = TEnumSub.Left;',
     '  };',
     '  var e = 0;',
     '  var e2 = 0;',
-    '  if (e in rtl.createSet(TEnum.Red, TEnum.Blue)) e2 = e;',
+    '  if (e in rtl.createSet(TEnum$1.Red, TEnum$1.Blue)) e2 = e;',
     '};',
     '']),
     LinesToStr([
@@ -5445,6 +5459,59 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestSet_InFunction;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  TEnum = 3;',
+  '  TSetOfEnum = 4;',
+  '  TSetOfAno = 5;',
+  'procedure DoIt;',
+  'type',
+  '  TEnum = (red, blue);',
+  '  TSetOfEnum = set of TEnum;',
+  '  TSetOfAno = set of (up,down);',
+  'var',
+  '  e: TEnum;',
+  '  se: TSetOfEnum;',
+  '  sa: TSetOfAno;',
+  'begin',
+  '  se:=[e];',
+  '  sa:=[up];',
+  'end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestSet_InFunction',
+    LinesToStr([ // statements
+    'this.TEnum = 3;',
+    'this.TSetOfEnum = 4;',
+    'this.TSetOfAno = 5;',
+    'var TEnum$1 = {',
+    '  "0": "red",',
+    '  red: 0,',
+    '  "1": "blue",',
+    '  blue: 1',
+    '};',
+    'var TSetOfAno$a = {',
+    '  "0": "up",',
+    '  up: 0,',
+    '  "1": "down",',
+    '  down: 1',
+    '};',
+    'this.DoIt = function () {',
+    '  var e = 0;',
+    '  var se = {};',
+    '  var sa = {};',
+    '  se = rtl.createSet(e);',
+    '  sa = rtl.createSet(TSetOfAno$a.up);',
+    '};',
+    '']),
+    LinesToStr([
+    '']));
+end;
+
 procedure TTestModule.TestSet_ForIn;
 begin
   StartProgram(false);
@@ -5641,9 +5708,9 @@ begin
     'this.DoIt = function () {',
     '  function Sub() {',
     '    cB$1 = cB$1 + 3;',
-    '    cA = (cA + 3) + 5;',
+    '    cA = cA + 3 + 5;',
     '  };',
-    '  cA = (cA + 2) + 6;',
+    '  cA = cA + 2 + 6;',
     '};'
     ]),
     LinesToStr([
@@ -6599,11 +6666,11 @@ begin
     '$mod.s = ""+$mod.b;',
     '$mod.s = ""+$mod.i;',
     '$mod.s = rtl.floatToStr($mod.d);',
-    '$mod.s = (""+$mod.i)+$mod.i;',
+    '$mod.s = ""+$mod.i+$mod.i;',
     '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
     '$mod.s = rtl.floatToStr($mod.d,3,2);',
     '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
-    '$mod.s = ("" + $mod.i) + rtl.spaceLeft("" + $mod.i, 5);',
+    '$mod.s = "" + $mod.i + rtl.spaceLeft("" + $mod.i, 5);',
     '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
     '$mod.s = $mod.s + $mod.s;',
     '$mod.s = $mod.s + "foo";',
@@ -7484,7 +7551,7 @@ 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;',
     '']));
 end;
 
@@ -7861,6 +7928,50 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestArray_StaticInFunction;
+begin
+  StartProgram(false);
+  Add([
+  'const TArrayInt = 3;',
+  'const TArrayArrayInt = 4;',
+  'procedure DoIt;',
+  'type',
+  '  TArrayInt = array[1..3] of longint;',
+  '  TArrayArrayInt = array[5..6] of TArrayInt;',
+  'var',
+  '  Arr: TArrayInt;',
+  '  Arr2: TArrayArrayInt;',
+  '  Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
+  '  i: longint;',
+  'begin',
+  '  arr2[5]:=arr;',
+  '  arr2:=arr2;',// clone multi dim static array
+  'end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestArray_StaticInFunction',
+    LinesToStr([ // statements
+    'this.TArrayInt = 3;',
+    'this.TArrayArrayInt = 4;',
+    'var TArrayArrayInt$1$clone = function (a) {',
+    '  var r = [];',
+    '  for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
+    '  return r;',
+    '};',
+    'this.DoIt = function () {',
+    '  var Arr = rtl.arraySetLength(null, 0, 3);',
+    '  var Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
+    '  var Arr3 = [[11, 12, 13], [21, 22, 23]];',
+    '  var i = 0;',
+    '  Arr2[0] = Arr.slice(0);',
+    '  Arr2 = TArrayArrayInt$1$clone(Arr2);',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestArrayOfRecord;
 begin
   StartProgram(false);
@@ -7947,7 +8058,7 @@ begin
     'this.Arr = rtl.arraySetLength(null, $mod.TRec, 2);',
     '']),
     LinesToStr([ // $mod.$main
-    '$mod.Arr[0].Int = (2 + 1) + 2;']));
+    '$mod.Arr[0].Int = 2 + 1 + 2;']));
 end;
 
 procedure TTestModule.TestArrayOfSet;
@@ -8396,7 +8507,7 @@ begin
     '  var s = "";',
     '  for (var $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
     '    i = $l1;',
-    '    s = a[(rtl.length(a) - i) - 1];',
+    '    s = a[rtl.length(a) - i - 1];',
     '  };',
     '};',
     'this.s = "";',
@@ -8681,7 +8792,7 @@ begin
     'this.OneStr = [7];',
     'this.Chars = ["a", "o", "c"];',
     'this.Names = ["a", "foo"];',
-    'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
+    'this.NameCount = 0 + (rtl.length($mod.Names) - 1) + rtl.length($mod.Names);',
     'this.i = 0;',
     '']),
     LinesToStr([ // $mod.$main
@@ -8727,7 +8838,7 @@ begin
     'this.OneStr = rtl.arrayConcatN([7],[8]);',
     'this.Chars = ["a", "o", "c"];',
     'this.Names = ["a", "a"];',
-    'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
+    'this.NameCount = 0 + (rtl.length($mod.Names) - 1) + rtl.length($mod.Names);',
     '']),
     LinesToStr([ // $mod.$main
     '']));
@@ -9127,7 +9238,7 @@ begin
     ]));
 end;
 
-procedure TTestModule.TestWithRecordDo;
+procedure TTestModule.TestRecord_WithDo;
 begin
   StartProgram(false);
   Add('type');
@@ -9228,9 +9339,9 @@ begin
     '    this.Enums = {};',
     '  };',
     '  this.$equal = function (b) {',
-    '    return (this.Int === b.Int) && ((this.D === b.D) && ((this.Arr === b.Arr)',
-    ' && (rtl.arrayEq(this.Arr2, b.Arr2)',
-    ' && (this.Small.$equal(b.Small) && rtl.eqSet(this.Enums, b.Enums)))));',
+    '    return (this.Int === b.Int) && (this.D === b.D) && (this.Arr === b.Arr)',
+    ' && rtl.arrayEq(this.Arr2, b.Arr2)',
+    ' && this.Small.$equal(b.Small) && rtl.eqSet(this.Enums, b.Enums);',
     '  };',
     '};',
     'this.r = new $mod.TBigRec();',
@@ -9551,7 +9662,7 @@ begin
     '    this.f = {};',
     '  };',
     '  this.$equal = function (b) {',
-    '    return (this.i === b.i) && (rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f));',
+    '    return (this.i === b.i) && rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f);',
     '  };',
     '};',
     'this.TNested = function (s) {',
@@ -9653,7 +9764,7 @@ begin
     '    this.o = rtl.arraySetLength(null, 0, 2);',
     '  };',
     '  this.$equal = function (b) {',
-    '    return (this.a === b.a) && (rtl.arrayEq(this.s, b.s) && (rtl.arrayEq(this.m, b.m) && rtl.arrayEq(this.o, b.o)));',
+    '    return (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && rtl.arrayEq(this.o, b.o);',
     '  };',
     '};',
     '']),
@@ -9716,7 +9827,7 @@ begin
     '    this.p = new $mod.TPoint();',
     '  };',
     '  this.$equal = function (b) {',
-    '    return (this.i === b.i) && ((this.a === b.a) && (rtl.arrayEq(this.s, b.s) && (rtl.arrayEq(this.m, b.m) && this.p.$equal(b.p))));',
+    '    return (this.i === b.i) && (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && this.p.$equal(b.p);',
     '  };',
     '};',
     'this.r = new $mod.TRec({',
@@ -9760,6 +9871,7 @@ procedure TTestModule.TestRecord_InFunction;
 begin
   StartProgram(false);
   Add([
+  'var TPoint: longint = 3;',
   'procedure DoIt;',
   'type',
   '  TPoint = record x,y: longint; end;',
@@ -9774,22 +9886,23 @@ begin
   ConvertProgram;
   CheckSource('TestRecord_InFunction',
     LinesToStr([ // statements
-    'this.DoIt = function () {',
-    '  function TPoint(s) {',
-    '    if (s) {',
-    '      this.x = s.x;',
-    '      this.y = s.y;',
-    '    } else {',
-    '      this.x = 0;',
-    '      this.y = 0;',
-    '    };',
-    '    this.$equal = function (b) {',
-    '      return (this.x === b.x) && (this.y === b.y);',
-    '    };',
+    'this.TPoint = 3;',
+    'var TPoint$1 = function (s) {',
+    '  if (s) {',
+    '    this.x = s.x;',
+    '    this.y = s.y;',
+    '  } else {',
+    '    this.x = 0;',
+    '    this.y = 0;',
+    '  };',
+    '  this.$equal = function (b) {',
+    '    return (this.x === b.x) && (this.y === b.y);',
     '  };',
-    '  var r = new TPoint();',
+    '};',
+    'this.DoIt = function () {',
+    '  var r = new TPoint$1();',
     '  var p = [];',
-    '  p = rtl.arraySetLength(p, TPoint, 2);',
+    '  p = rtl.arraySetLength(p, TPoint$1, 2);',
     '};',
     '']),
     LinesToStr([ // $mod.$main
@@ -17287,7 +17400,7 @@ begin
     '    this.D4 = 0;',
     '  };',
     '  this.$equal = function (b) {',
-    '    return (this.D1 === b.D1) && ((this.D2 === b.D2) && ((this.D3 === b.D3) && (this.D4 === b.D4)));',
+    '    return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
     '  };',
     '};',
     'this.DoConstGUIDIt = function (g) {',
@@ -17402,7 +17515,7 @@ begin
     '    this.D4 = 0;',
     '  };',
     '  this.$equal = function (b) {',
-    '    return (this.D1 === b.D1) && ((this.D2 === b.D2) && ((this.D3 === b.D3) && (this.D4 === b.D4)));',
+    '    return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
     '  };',
     '};',
     'rtl.createClass($mod, "TObject", null, function () {',
@@ -21857,6 +21970,9 @@ begin
   ConvertProgram;
   CheckSource('TestRTTI_Record',
     LinesToStr([ // statements
+    '$mod.$rtti.$DynArray("TFloatRec.d$a", {',
+    '  eltype: rtl.char',
+    '});',
     'this.TFloatRec = function (s) {',
     '  if (s) {',
     '    this.d = s.d;',
@@ -21867,9 +21983,6 @@ begin
     '    return this.d === b.d;',
     '  };',
     '};',
-    '$mod.$rtti.$DynArray("TFloatRec.d$a", {',
-    '  eltype: rtl.char',
-    '});',
     '$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);',
     'this.p = null;',
     'this.r = new $mod.TFloatRec();',
@@ -21892,26 +22005,28 @@ begin
   '  TPoint = record',
   '    x,y: integer;',
   '  end;',
+  'var p: TPoint;',
   'begin',
   'end;',
   'begin']);
   ConvertProgram;
   CheckSource('TestRTTI_LocalTypes',
     LinesToStr([ // statements
-    'this.DoIt = function () {',
-    '  function TPoint(s) {',
-    '    if (s) {',
-    '      this.x = s.x;',
-    '      this.y = s.y;',
-    '    } else {',
-    '      this.x = 0;',
-    '      this.y = 0;',
-    '    };',
-    '    this.$equal = function (b) {',
-    '      return (this.x === b.x) && (this.y === b.y);',
-    '    };',
+    'var TPoint = function(s) {',
+    '  if (s) {',
+    '    this.x = s.x;',
+    '    this.y = s.y;',
+    '  } else {',
+    '    this.x = 0;',
+    '    this.y = 0;',
+    '  };',
+    '  this.$equal = function (b) {',
+    '    return (this.x === b.x) && (this.y === b.y);',
     '  };',
     '};',
+    'this.DoIt = function () {',
+    '  var p = new TPoint();',
+    '};',
     '']),
     LinesToStr([ // $mod.$main
     '']));

packages/rtl-objpas/src/inc/rtti.pp

@@ -16,6 +16,8 @@ unit Rtti experimental;
 
 {$mode objfpc}{$H+}
 {$modeswitch advancedrecords}
+{$goto on}
+{$Assertions on}
 
 { Note: since the Lazarus IDE is not yet capable of correctly handling generic
   functions it is best to define a InLazIDE define inside the IDE that disables
@@ -47,6 +49,24 @@ type
   TRttiProperty = class;
   TRttiInstanceType = class;
 
+  TFunctionCallCallback = class
+  protected
+    function GetCodeAddress: CodePointer; virtual; abstract;
+  public
+    property CodeAddress: CodePointer read GetCodeAddress;
+  end;
+
+  TFunctionCallFlag = (
+    fcfStatic
+  );
+  TFunctionCallFlags = set of TFunctionCallFlag;
+
+  TFunctionCallParameterInfo = record
+    ParamType: PTypeInfo;
+    ParamFlags: TParamFlags;
+    ParaLocs: PParameterLocations;
+  end;
+
   IValueData = interface
   ['{1338B2F3-2C21-4798-A641-CA2BC5BF2396}']
     procedure ExtractRawData(ABuffer: pointer);
@@ -125,6 +145,8 @@ type
     function IsType(ATypeInfo: PTypeInfo): boolean; inline;
     function TryAsOrdinal(out AResult: int64): boolean;
     function GetReferenceToRawData: Pointer;
+    procedure ExtractRawData(ABuffer: Pointer);
+    procedure ExtractRawDataNoCopy(ABuffer: Pointer);
     class operator := (const AValue: String): TValue; inline;
     class operator := (AValue: LongInt): TValue; inline;
     class operator := (AValue: Single): TValue; inline;
@@ -294,16 +316,48 @@ type
     function ToString: String; override;
   end;
 
+  TMethodImplementationCallbackMethod = procedure(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue) of object;
+  TMethodImplementationCallbackProc = procedure(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue);
+
+  TMethodImplementation = class
+  private
+    fLowLevelCallback: TFunctionCallCallback;
+    fCallbackProc: TMethodImplementationCallbackProc;
+    fCallbackMethod: TMethodImplementationCallbackMethod;
+    fArgs: specialize TArray<TFunctionCallParameterInfo>;
+    fArgLen: SizeInt;
+    fRefArgs: specialize TArray<SizeInt>;
+    fFlags: TFunctionCallFlags;
+    fResult: PTypeInfo;
+    fCC: TCallConv;
+    function GetCodeAddress: CodePointer;
+    procedure InitArgs;
+    procedure HandleCallback(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+    constructor Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod);
+    constructor Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackProc);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    property CodeAddress: CodePointer read GetCodeAddress;
+  end;
+
   TRttiInvokableType = class(TRttiType)
   protected
     function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; virtual; abstract;
     function GetCallingConvention: TCallConv; virtual; abstract;
     function GetReturnType: TRttiType; virtual; abstract;
+    function GetFlags: TFunctionCallFlags; virtual; abstract;
+  public type
+    TCallbackMethod = procedure(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue) of object;
+    TCallbackProc = procedure(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue);
   public
     function GetParameters: specialize TArray<TRttiParameter>; inline;
     property CallingConvention: TCallConv read GetCallingConvention;
     property ReturnType: TRttiType read GetReturnType;
     function Invoke(const aProcOrMeth: TValue; const aArgs: array of TValue): TValue; virtual; abstract;
+    { Note: once "reference to" is supported these will be replaced by a single method }
+    function CreateImplementation(aCallback: TCallbackMethod): TMethodImplementation;
+    function CreateImplementation(aCallback: TCallbackProc): TMethodImplementation;
   end;
 
   TRttiMethodType = class(TRttiInvokableType)
@@ -315,6 +369,7 @@ type
     function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
     function GetCallingConvention: TCallConv; override;
     function GetReturnType: TRttiType; override;
+    function GetFlags: TFunctionCallFlags; override;
   public
     function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
   end;
@@ -326,6 +381,7 @@ type
     function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
     function GetCallingConvention: TCallConv; override;
     function GetReturnType: TRttiType; override;
+    function GetFlags: TFunctionCallFlags; override;
   public
     function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
   end;
@@ -429,12 +485,6 @@ type
   EInvocationError = class(Exception);
   ENonPublicType = class(Exception);
 
-  TFunctionCallParameterInfo = record
-    ParamType: PTypeInfo;
-    ParamFlags: TParamFlags;
-    ParaLocs: PParameterLocations;
-  end;
-
   TFunctionCallParameter = record
     ValueRef: Pointer;
     ValueSize: SizeInt;
@@ -442,22 +492,14 @@ type
   end;
   TFunctionCallParameterArray = specialize TArray<TFunctionCallParameter>;
 
-  TFunctionCallFlag = (
-    fcfStatic
-  );
-  TFunctionCallFlags = set of TFunctionCallFlag;
-
-  TFunctionCallCallback = Pointer;
-
-  TFunctionCallProc = procedure(const aArgs: TValueArray; out aResult: TValue; aContext: Pointer);
-  TFunctionCallMethod = procedure(const aArgs: TValueArray; out aResult: TValue; aContext: Pointer) of object;
+  TFunctionCallProc = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+  TFunctionCallMethod = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer) of object;
 
   TFunctionCallManager = record
     Invoke: procedure(CodeAddress: CodePointer; const Args: TFunctionCallParameterArray; CallingConvention: TCallConv;
               ResultType: PTypeInfo; ResultValue: Pointer; Flags: TFunctionCallFlags);
-    CreateCallbackProc: function(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-    CreateCallbackMethod: function(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-    FreeCallback: procedure(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
+    CreateCallbackProc: function(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+    CreateCallbackMethod: function(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
   end;
   TFunctionCallManagerArray = array[TCallConv] of TFunctionCallManager;
 
@@ -478,9 +520,8 @@ procedure GetFunctionCallManagers(out aFuncCallMgrs: TFunctionCallManagerArray);
 function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray; aCallConv: TCallConv;
   aResultType: PTypeInfo; aIsStatic: Boolean; aIsConstructor: Boolean): TValue;
 
-function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-procedure FreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
+function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 
 function IsManaged(TypeInfo: PTypeInfo): boolean;
 
@@ -502,6 +543,9 @@ resourcestring
 implementation
 
 uses
+{$ifdef windows}
+  Windows,
+{$endif}
   fgl;
 
 type
@@ -651,12 +695,50 @@ resourcestring
   SErrInvokeRttiDataError     = 'The RTTI data is inconsistent for method: %s';
   SErrInvokeCallableNotProc   = 'The callable value is not a procedure variable for: %s';
   SErrInvokeCallableNotMethod = 'The callable value is not a method variable for: %s';
+  SErrMethodImplNoCallback    = 'No callback specified for method implementation';
+  SErrMethodImplInsufficientRtti = 'Insufficient RTTI to create method implementation';
+  SErrMethodImplCreateFailed  = 'Failed to create method implementation';
+  SErrMethodImplCreateNoArg   = 'TMethodImplementation can not be created this way';
 
 var
   PoolRefCount : integer;
   GRttiPool    : TRttiPool;
   FuncCallMgr: TFunctionCallManagerArray;
 
+function AllocateMemory(aSize: PtrUInt): Pointer;
+begin
+{$IF DEFINED(WINDOWS)}
+  Result := VirtualAlloc(Nil, aSize, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);
+{$ELSE}
+  Result := GetMem(aSize);
+{$ENDIF}
+end;
+
+function ProtectMemory(aPtr: Pointer; aSize: PtrUInt; aExecutable: Boolean): Boolean;
+{$IF DEFINED(WINDOWS)}
+var
+  oldprot: DWORD;
+{$ENDIF}
+begin
+{$IF DEFINED(WINDOWS)}
+  if aExecutable then
+    Result := VirtualProtect(aPtr, aSize, PAGE_EXECUTE_READ, oldprot)
+  else
+    Result := VirtualProtect(aPtr, aSize, PAGE_READWRITE, oldprot);
+{$ELSE}
+  Result := True;
+{$ENDIF}
+end;
+
+procedure FreeMemory(aPtr: Pointer);
+begin
+{$IF DEFINED(WINDOWS)}
+  VirtualFree(aPtr, 0, MEM_RELEASE);
+{$ELSE}
+  FreeMem(aPtr);
+{$ENDIF}
+end;
+
 function CCToStr(aCC: TCallConv): String; inline;
 begin
   WriteStr(Result, aCC);
@@ -668,29 +750,23 @@ begin
   raise ENotImplemented.Create(SErrInvokeNotImplemented);
 end;
 
-function NoCreateCallbackProc(aFunc: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function NoCreateCallbackProc(aFunc: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   Result := Nil;
   raise ENotImplemented.Create(SErrCallbackNotImplented);
 end;
 
-function NoCreateCallbackMethod(aFunc: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function NoCreateCallbackMethod(aFunc: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   Result := Nil;
   raise ENotImplemented.Create(SErrCallbackNotImplented);
 end;
 
-procedure NoFreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
-begin
-  raise ENotImplemented.Create(SErrCallbackNotImplented);
-end;
-
 const
   NoFunctionCallManager: TFunctionCallManager = (
     Invoke: @NoInvoke;
     CreateCallbackProc: @NoCreateCallbackProc;
     CreateCallbackMethod: @NoCreateCallbackMethod;
-    FreeCallback: @NoFreeCallback
   );
 
 procedure SetFunctionCallManager(aCallConv: TCallConv; constref aFuncCallMgr: TFunctionCallManager;
@@ -929,7 +1005,7 @@ begin
   mgr.Invoke(aCodeAddress, args, aCallConv, restype, resptr, flags);
 end;
 
-function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   if not Assigned(FuncCallMgr[aCallConv].CreateCallbackProc) then
     raise ENotImplemented.Create(SErrCallbackNotImplented);
@@ -940,7 +1016,7 @@ begin
   Result := FuncCallMgr[aCallConv].CreateCallbackProc(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext);
 end;
 
-function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   if not Assigned(FuncCallMgr[aCallConv].CreateCallbackMethod) then
     raise ENotImplemented.Create(SErrCallbackNotImplented);
@@ -951,12 +1027,6 @@ begin
   Result := FuncCallMgr[aCallConv].CreateCallbackMethod(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext);
 end;
 
-procedure FreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
-begin
-  if Assigned(FuncCallMgr[aCallConv].FreeCallback) then
-    FuncCallMgr[aCallConv].FreeCallback(aCallback, aCallConv);
-end;
-
 function IsManaged(TypeInfo: PTypeInfo): boolean;
 begin
   if Assigned(TypeInfo) then
@@ -1607,11 +1677,8 @@ begin
   { first handle those types that need a TValueData implementation }
   case ATypeInfo^.Kind of
     tkSString  : begin
-                   if Assigned(ABuffer) then
-                     size := Length(PShortString(ABuffer)^) + 1
-                   else
-                     size := 256;
-                   result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, size, ATypeInfo, True);
+                   td := GetTypeData(ATypeInfo);
+                   result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.MaxLength + 1, ATypeInfo, True);
                  end;
     tkWString,
     tkUString,
@@ -1690,7 +1757,7 @@ begin
                  end;
     tkBool     : begin
                    case GetTypeData(ATypeInfo)^.OrdType of
-                     otUByte: result.FData.FAsSByte := ShortInt(PBoolean(ABuffer)^);
+                     otUByte: result.FData.FAsSByte := ShortInt(System.PBoolean(ABuffer)^);
                      otUWord: result.FData.FAsUWord := Byte(PBoolean16(ABuffer)^);
                      otULong: result.FData.FAsULong := SmallInt(PBoolean32(ABuffer)^);
                      otUQWord: result.FData.FAsUInt64 := QWord(PBoolean64(ABuffer)^);
@@ -1932,6 +1999,8 @@ begin
       ftSingle   : result := FData.FAsSingle;
       ftDouble   : result := FData.FAsDouble;
       ftExtended : result := FData.FAsExtended;
+      ftCurr     : result := FData.FAsCurr;
+      ftComp     : result := FData.FAsComp;
     else
       raise EInvalidCast.Create(SErrInvalidTypecast);
     end;
@@ -2046,7 +2115,11 @@ begin
       otULong:  Result := FData.FAsULong;
       otSQWord: Result := FData.FAsSInt64;
       otUQWord: Result := FData.FAsUInt64;
-    end;
+    end
+  else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then
+    Result := Int64(FData.FAsComp)
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.AsUInt64: QWord;
@@ -2061,7 +2134,11 @@ begin
       otULong:  Result := FData.FAsULong;
       otSQWord: Result := FData.FAsSInt64;
       otUQWord: Result := FData.FAsUInt64;
-    end;
+    end
+  else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then
+    Result := QWord(FData.FAsComp)
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.AsInterface: IInterface;
@@ -2293,6 +2370,22 @@ begin
   end;
 end;
 
+procedure TValue.ExtractRawData(ABuffer: Pointer);
+begin
+  if Assigned(FData.FValueData) then
+    FData.FValueData.ExtractRawData(ABuffer)
+  else if Assigned(FData.FTypeInfo) then
+    Move((@FData.FAsPointer)^, ABuffer^, DataSize);
+end;
+
+procedure TValue.ExtractRawDataNoCopy(ABuffer: Pointer);
+begin
+  if Assigned(FData.FValueData) then
+    FData.FValueData.ExtractRawDataNoCopy(ABuffer)
+  else if Assigned(FData.FTypeInfo) then
+    Move((@FData.FAsPointer)^, ABuffer^, DataSize);
+end;
+
 class operator TValue.:=(const AValue: String): TValue;
 begin
   Make(@AValue, System.TypeInfo(AValue), Result);
@@ -2389,6 +2482,116 @@ begin
   Result := FString;
 end;
 
+{ TMethodImplementation }
+
+function TMethodImplementation.GetCodeAddress: CodePointer;
+begin
+  Result := fLowLevelCallback.CodeAddress;
+end;
+
+procedure TMethodImplementation.InitArgs;
+var
+  i, refargs: SizeInt;
+begin
+  i := 0;
+  refargs := 0;
+  SetLength(fRefArgs, Length(fArgs));
+  while i < Length(fArgs) do begin
+    if (fArgs[i].ParamFlags * [pfVar, pfOut] <> []) and not (pfHidden in fArgs[i].ParamFlags) then begin
+      fRefArgs[refargs] := fArgLen;
+      Inc(refargs);
+    end;
+
+    if pfArray in fArgs[i].ParamFlags then begin
+      Inc(i);
+      if (i = Length(fArgs)) or not (pfHigh in fArgs[i].ParamFlags) then
+        raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
+      Inc(fArgLen);
+    end else if not (pfHidden in fArgs[i].ParamFlags) or (pfSelf in fArgs[i].ParamFlags) then
+      Inc(fArgLen)
+    else if (pfResult in fArgs[i].ParamFlags) then
+      fResult := fArgs[i].ParamType;
+
+    Inc(i);
+  end;
+
+  SetLength(fRefArgs, refargs);
+end;
+
+procedure TMethodImplementation.HandleCallback(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+var
+  i, argidx: SizeInt;
+  args: TValueArray;
+  res: TValue;
+begin
+  Assert(fArgLen = Length(aArgs), 'Length of arguments does not match');
+  SetLength(args, fArgLen);
+  argidx := 0;
+  i := 0;
+  while i < Length(fArgs) do begin
+    if pfArray in fArgs[i].ParamFlags then begin
+      Inc(i);
+      Assert((i < Length(fArgs)) and (pfHigh in fArgs[i].ParamFlags), 'Expected high parameter after open array parameter');
+      TValue.MakeOpenArray(aArgs[i - 1], SizeInt(aArgs[i]), fArgs[i].ParamType, args[argidx]);
+    end else if not (pfHidden in fArgs[i].ParamFlags) or (pfSelf in fArgs[i].ParamFlags) then begin
+      TValue.Make(aArgs[i], fArgs[i].ParamType, args[argidx]);
+    end;
+
+    Inc(i);
+    Inc(argidx);
+  end;
+
+  if Assigned(fCallbackMethod) then
+    fCallbackMethod(aContext, args, res)
+  else
+    fCallbackProc(aContext, args, res);
+
+  { copy back var/out parameters }
+  for i := 0 to High(fRefArgs) do begin
+    args[fRefArgs[i]].ExtractRawData(aArgs[fRefArgs[i]]);
+  end;
+
+  if Assigned(fResult) then
+    res.ExtractRawData(aResult);
+end;
+
+constructor TMethodImplementation.Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod);
+begin
+  fCC := aCC;
+  fArgs := aArgs;
+  fResult := aResult;
+  fFlags := aFlags;
+  fCallbackMethod := aCallback;
+  InitArgs;
+  fLowLevelCallback := CreateCallbackMethod(@HandleCallback, fCC, aArgs, aResult, aFlags, aUserData);
+  if not Assigned(fLowLevelCallback) then
+    raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
+end;
+
+constructor TMethodImplementation.Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackProc);
+begin
+  fCC := aCC;
+  fArgs := aArgs;
+  fResult := aResult;
+  fFlags := aFlags;
+  fCallbackProc := aCallback;
+  InitArgs;
+  fLowLevelCallback := CreateCallbackMethod(@HandleCallback, fCC, aArgs, aResult, aFlags, aUserData);
+  if not Assigned(fLowLevelCallback) then
+    raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
+end;
+
+constructor TMethodImplementation.Create;
+begin
+  raise EInvalidOpException.Create(SErrMethodImplCreateNoArg);
+end;
+
+destructor TMethodImplementation.Destroy;
+begin
+  fLowLevelCallback.Free;
+  inherited Destroy;
+end;
+
 { TRttiMethod }
 
 function TRttiMethod.GetHasExtendedInfo: Boolean;
@@ -2507,6 +2710,70 @@ begin
   Result := GetParameters(False);
 end;
 
+function TRttiInvokableType.CreateImplementation(aCallback: TCallbackMethod): TMethodImplementation;
+var
+  params: specialize TArray<TRttiParameter>;
+  args: specialize TArray<TFunctionCallParameterInfo>;
+  res: PTypeInfo;
+  restype: TRttiType;
+  resinparam: Boolean;
+  i: SizeInt;
+begin
+  if not Assigned(aCallback) then
+    raise EArgumentNilException.Create(SErrMethodImplNoCallback);
+
+  resinparam := False;
+  params := GetParameters(True);
+  SetLength(args, Length(params));
+  for i := 0 to High(params) do begin
+    args[i].ParamType := params[i].ParamType.FTypeInfo;
+    args[i].ParamFlags := params[i].Flags;
+    args[i].ParaLocs := Nil;
+    if pfResult in params[i].Flags then
+      resinparam := True;
+  end;
+
+  restype := GetReturnType;
+  if Assigned(restype) and not resinparam then
+    res := restype.FTypeInfo
+  else
+    res := Nil;
+
+  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, Self, TMethodImplementationCallbackMethod(aCallback));
+end;
+
+function TRttiInvokableType.CreateImplementation(aCallback: TCallbackProc): TMethodImplementation;
+var
+  params: specialize TArray<TRttiParameter>;
+  args: specialize TArray<TFunctionCallParameterInfo>;
+  res: PTypeInfo;
+  restype: TRttiType;
+  resinparam: Boolean;
+  i: SizeInt;
+begin
+  if not Assigned(aCallback) then
+    raise EArgumentNilException.Create(SErrMethodImplNoCallback);
+
+  resinparam := False;
+  params := GetParameters(True);
+  SetLength(args, Length(params));
+  for i := 0 to High(params) do begin
+    args[i].ParamType := params[i].ParamType.FTypeInfo;
+    args[i].ParamFlags := params[i].Flags;
+    args[i].ParaLocs := Nil;
+    if pfResult in params[i].Flags then
+      resinparam := True;
+  end;
+
+  restype := GetReturnType;
+  if Assigned(restype) and not resinparam then
+    res := restype.FTypeInfo
+  else
+    res := Nil;
+
+  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, Self, TMethodImplementationCallbackProc(aCallback));
+end;
+
 { TRttiMethodType }
 
 function TRttiMethodType.GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>;
@@ -2621,6 +2888,11 @@ begin
     Result := Nil;
 end;
 
+function TRttiMethodType.GetFlags: TFunctionCallFlags;
+begin
+  Result := [];
+end;
+
 function TRttiMethodType.Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue;
 var
   method: PMethod;
@@ -2709,6 +2981,11 @@ begin
   end;
 end;
 
+function TRttiProcedureType.GetFlags: TFunctionCallFlags;
+begin
+  Result := [fcfStatic];
+end;
+
 function TRttiProcedureType.Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue;
 begin
   if aCallable.Kind <> tkProcVar then

packages/rtl-objpas/src/x86_64/invoke.inc

@@ -28,15 +28,16 @@ asm
 .seh_savereg %rsi, 16
   movq %rdi, 24(%rsp)
 .seh_savereg %rdi, 24
+  movq %r8, 32(%rsp)
+.seh_savereg %r8, 32
 
   movq %rsp, %rbp
 .seh_setframe %rbp, 0
 .seh_endprologue
 
   { align stack size to 16 Byte }
-  add $15, aArgsStackSize
-  and $-16, aArgsStackSize
   sub aArgsStackSize, %rsp
+  and $-16, %rsp
 
   movq aArgsStackSize, %rax
 
@@ -71,6 +72,10 @@ asm
   { restore non-volatile registers }
   movq %rbp, %rsp
 
+  { we abuse the register area pointer for an eventual SSE2 result }
+  movq 32(%rsp), %rdi
+  movq %xmm0, (%rdi)
+
   movq 24(%rsp), %rdi
   movq 16(%rsp), %rsi
   movq 8(%rsp), %rbp
@@ -81,6 +86,43 @@ resourcestring
   SErrFailedToConvertArg = 'Failed to convert argument %d of type %s';
   SErrFailedToConvertRes = 'Failed to convert result of type %s';
 
+function ReturnResultInParam(aType: PTypeInfo): Boolean;
+var
+  td: PTypeData;
+begin
+  Result := False;
+  if Assigned(aType) then begin
+    case aType^.Kind of
+      tkMethod,
+      tkSString,
+      tkAString,
+      tkUString,
+      tkWString,
+      tkInterface,
+      tkDynArray:
+        Result := True;
+      tkArray: begin
+        td := GetTypeData(aType);
+        Result := not (td^.ArrayData.Size in [1, 2, 4, 8]);
+      end;
+      tkRecord: begin
+        td := GetTypeData(aType);
+        Result := not (td^.RecSize in [1, 2, 4, 8]);
+      end;
+      tkSet: begin
+        td := GetTypeData(aType);
+        case td^.OrdType of
+          otUByte:
+            Result := not (td^.SetSize in [1, 2, 4, 8]);
+          otUWord,
+          otULong:
+            Result := False;
+        end;
+      end;
+    end;
+  end;
+end;
+
 procedure SystemInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
             aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
 type
@@ -102,18 +144,7 @@ begin
   if Assigned(aResultType) and not Assigned(aResultValue) then
     raise EInvocationError.Create(SErrInvokeResultTypeNoValue);
 {$ifdef windows}
-  retinparam := False;
-  if Assigned(aResultType) then begin
-    case aResultType^.Kind of
-      tkSString,
-      tkAString,
-      tkUString,
-      tkWString,
-      tkInterface,
-      tkDynArray:
-        retinparam := True;
-    end;
-  end;
+  retinparam := ReturnResultInParam(aResultType);
 
   stackidx := 0;
   regidx := 0;
@@ -205,7 +236,7 @@ begin
         end;
         tkBool: begin
           case td^.OrdType of
-            otUByte: val := ShortInt(PBoolean(aArgs[i].ValueRef)^);
+            otUByte: val := ShortInt(System.PBoolean(aArgs[i].ValueRef)^);
             otUWord: val := Byte(PBoolean16(aArgs[i].ValueRef)^);
             otULong: val := SmallInt(PBoolean32(aArgs[i].ValueRef)^);
             otUQWord: val := QWord(PBoolean64(aArgs[i].ValueRef)^);
@@ -249,17 +280,434 @@ begin
 
   if Assigned(aResultType) and not retinparam then begin
     PPtrUInt(aResultValue)^ := val;
+    if aResultType^.Kind = tkFloat then begin
+      td := GetTypeData(aResultType);
+      if td^.FloatType in [ftSingle, ftDouble] then
+        PPtrUInt(aResultValue)^ := regs[0];
+    end;
   end;
 {$else}
   raise EInvocationError.Create(SErrPlatformNotSupported);
 {$endif}
 end;
 
+{$ifdef windows}
+const
+  PlaceholderContext = QWord($1234567812345678);
+  PlaceholderAddress = QWord($8765432187654321);
+
+label
+  CallbackContext,
+  CallbackAddress,
+  CallbackCall,
+  CallbackEnd;
+
+const
+  CallbackContextPtr: Pointer = @CallbackContext;
+  CallbackAddressPtr: Pointer = @CallbackAddress;
+  CallbackCallPtr: Pointer = @CallbackCall;
+  CallbackEndPtr: Pointer = @CallbackEnd;
+
+procedure Callback; assembler; nostackframe;
+asm
+  { store integer registers }
+
+  movq %rcx, 8(%rsp)
+.seh_savereg %rcx, 8
+  movq %rdx, 16(%rsp)
+.seh_savereg %rdx, 16
+  movq %r8,  24(%rsp)
+.seh_savereg %r8, 24
+  movq %r9,  32(%rsp)
+.seh_savereg %r9, 32
+
+  { establish frame }
+  pushq %rbp
+.seh_pushreg %rbp
+  movq %rsp, %rbp
+.seh_setframe %rbp, 0
+.seh_endprologue
+
+  { store pointer to stack area (including GP registers) }
+  lea 16(%rsp), %rdx
+
+  sub $32, %rsp
+  movq %xmm0, (%rsp)
+  movq %xmm1, 8(%rsp)
+  movq %xmm2, 16(%rsp)
+  movq %xmm3, 24(%rsp)
+
+  { store pointer to FP registers }
+  movq %rsp, %r8
+
+  sub $32, %rsp
+
+  { call function with context }
+CallbackContext:
+  movq $0x1234567812345678, %rcx
+CallbackAddress:
+  movq $0x8765432187654321, %rax
+CallbackCall:
+
+  call *%rax
+
+  { duplicate result to SSE result register }
+  movq %rax, %xmm0
+
+  { restore stack }
+  movq %rbp, %rsp
+  popq %rbp
+
+  ret
+CallbackEnd:
+end;
+{$endif}
+
+type
+  TSystemFunctionCallback = class(TFunctionCallCallback)
+  {$ifdef windows}
+  private type
+    {$ScopedEnums On}
+    TArgType = (
+      GenReg,
+      FPReg,
+      Stack
+    );
+    {$ScopedEnums Off}
+
+    TArgInfo = record
+      ArgType: TArgType;
+      Offset: SizeInt;
+      Deref: Boolean;
+    end;
+  private
+    fData: Pointer;
+    fSize: PtrUInt;
+    fFlags: TFunctionCallFlags;
+    fContext: Pointer;
+    fArgs: specialize TArray<TFunctionCallParameterInfo>;
+    fArgInfos: specialize TArray<TArgInfo>;
+    fRefArgs: specialize TArray<SizeInt>;
+    fResultType: PTypeInfo;
+    fResultIdx: SizeInt;
+    fResultInParam: Boolean;
+  private
+    function Handler(aStack, aFP: Pointer): PtrUInt;
+  protected
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); virtual; abstract;
+    procedure CreateCallback;
+    procedure CreateArgInfos;
+    function GetCodeAddress: CodePointer; override;
+  {$endif}
+  public
+    constructor Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+    destructor Destroy; override;
+  end;
+
+  TSystemFunctionCallbackMethod = class(TSystemFunctionCallback)
+  private
+    fHandler: TFunctionCallMethod;
+  protected
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); override;
+  public
+    constructor Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+  end;
+
+  TSystemFunctionCallbackProc = class(TSystemFunctionCallback)
+  private
+    fHandler: TFunctionCallProc;
+  protected
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); override;
+  public
+    constructor Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+  end;
+
+{$ifdef windows}
+function TSystemFunctionCallback.Handler(aStack, aFP: Pointer): PtrUInt;
+var
+  args: specialize TArray<Pointer>;
+  i, len: SizeInt;
+  val: PPtrUInt;
+  resptr: Pointer;
+begin
+  len := Length(fArgInfos);
+  if fResultInParam then
+    Dec(len);
+  SetLength(args, len);
+  for i := 0 to High(fArgInfos) do begin
+    if i = fResultIdx then
+      Continue;
+    case fArgInfos[i].ArgType of
+      TArgType.GenReg,
+      TArgType.Stack:
+        val := @PPtrUInt(aStack)[fArgInfos[i].Offset];
+      TArgType.FPReg:
+        val := @PPtrUInt(aFP)[fArgInfos[i].Offset];
+    end;
+    if fArgInfos[i].Deref then
+      args[i] := PPtrUInt(val^)
+    else
+      args[i] := val;
+  end;
+
+  if fResultInParam then begin
+    case fArgInfos[fResultIdx].ArgType of
+      TArgType.GenReg,
+      TArgType.Stack:
+        resptr := @PPtrUInt(aStack)[fArgInfos[fResultIdx].Offset];
+      TArgType.FPReg:
+        resptr := @PPtrUInt(aFP)[fArgInfos[fResultIdx].Offset];
+    end;
+    if fArgInfos[fResultIdx].Deref then
+      resptr := PPointer(resptr)^;
+  end else
+    resptr := @Result;
+
+  CallHandler(args, resptr, fContext);
+end;
+
+procedure TSystemFunctionCallback.CreateCallback;
+
+  procedure ReplacePlaceholder(aPlaceholder: PtrUInt; aValue: PtrUInt; aOfs, aSize: PtrUInt);
+  var
+    found: Boolean;
+    i: PtrUInt;
+  begin
+    found := False;
+    for i := aOfs to aOfs + aSize - 1 do begin
+      if PPtrUInt(@PByte(fData)[i])^ = PtrUInt(aPlaceholder) then begin
+        PPtrUInt(@(PByte(fData)[i]))^ := PtrUInt(aValue);
+        found := True;
+        Break;
+      end;
+    end;
+
+    if not found then
+      raise Exception.Create(SErrMethodImplCreateFailed);
+  end;
+
+var
+  src: Pointer;
+  ofs, size: PtrUInt;
+  method: TMethod;
+begin
+  fSize := PtrUInt(CallbackEndPtr) - PtrUInt(@Callback) + 1;
+  fData := AllocateMemory(fSize);
+  if not Assigned(fData) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+
+  src := @Callback;
+  Move(src^, fData^, fSize);
+
+  ofs := PtrUInt(CallbackContextPtr) - PtrUInt(@Callback);
+  size := PtrUInt(CallbackAddressPtr) - PtrUInt(CallbackContextPtr);
+
+  method := TMethod(@Handler);
+
+  ReplacePlaceholder(PlaceholderContext, PtrUInt(method.Data), ofs, size);
+
+  ofs := PtrUInt(CallbackAddressPtr) - PtrUInt(@Callback);
+  size := PtrUInt(CallbackCallPtr) - PtrUInt(CallbackAddressPtr);
+
+  ReplacePlaceholder(PlaceholderAddress, PtrUInt(method.Code), ofs, size);
+
+  if not ProtectMemory(fData, fSize, True) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+end;
+
+procedure TSystemFunctionCallback.CreateArgInfos;
+type
+  PBoolean16 = ^Boolean16;
+  PBoolean32 = ^Boolean32;
+  PBoolean64 = ^Boolean64;
+  PByteBool = ^ByteBool;
+  PQWordBool = ^QWordBool;
+var
+  stackarea: array of PtrUInt;
+  stackptr: Pointer;
+  regs: array[0..3] of PtrUInt;
+  i, argidx, ofs: LongInt;
+  val: PtrUInt;
+  td: PTypeData;
+  argcount, resreg, refargs: SizeInt;
+begin
+  fResultInParam := ReturnResultInParam(fResultType);
+
+  ofs := 0;
+  argidx := 0;
+  refargs := 0;
+  argcount := Length(fArgs);
+  if fResultInParam then begin
+    if fcfStatic in fFlags then
+      fResultIdx := 0
+    else
+      fResultIdx := 1;
+    Inc(argcount);
+  end else
+    fResultIdx := -1;
+  SetLength(fArgInfos, argcount);
+  SetLength(fRefArgs, argcount);
+  if fResultIdx >= 0 then begin
+    fArgInfos[fResultIdx].ArgType := TArgType.GenReg;
+    fArgInfos[fResultIdx].Offset := fResultIdx;
+  end;
+  for i := 0 to High(fArgs) do begin
+    if argidx = fResultIdx then
+      Inc(argidx);
+    if pfResult in fArgs[i].ParamFlags then begin
+      fResultIdx := argidx;
+      fResultInParam := True;
+    end;
+    fArgInfos[argidx].ArgType := TArgType.GenReg;
+    fArgInfos[argidx].Deref := False;
+    if pfArray in fArgs[i].ParamFlags then
+      fArgInfos[argidx].Deref := True
+    else if fArgs[i].ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
+      fArgInfos[argidx].Deref := True
+    else begin
+      td := GetTypeData(fArgs[i].ParamType);
+      case fArgs[i].ParamType^.Kind of
+        tkSString,
+        tkMethod:
+          fArgInfos[argidx].Deref := True;
+        tkArray:
+          if not (td^.ArrayData.Size in [1, 2, 4, 8]) then
+            fArgInfos[argidx].Deref := True;
+        tkRecord:
+          if not (td^.RecSize in [1, 2, 4, 8]) then
+            fArgInfos[argidx].Deref := True;
+        { ToDo: handle object like record? }
+        tkObject,
+        tkWString,
+        tkUString,
+        tkAString,
+        tkDynArray,
+        tkClass,
+        tkClassRef,
+        tkInterface,
+        tkInterfaceRaw,
+        tkProcVar,
+        tkPointer:
+          ;
+        tkInt64,
+        tkQWord:
+          ;
+        tkSet: begin
+          case td^.OrdType of
+            otUByte: begin
+              case td^.SetSize of
+                0, 1, 2, 4, 8:
+                  ;
+                else
+                  fArgInfos[argidx].Deref := True;
+              end;
+            end;
+            otUWord,
+            otULong:
+              ;
+          end;
+        end;
+        tkEnumeration,
+        tkInteger,
+        tkBool:
+          ;
+        tkFloat: begin
+          case td^.FloatType of
+            ftCurr,
+            ftComp:
+              ;
+            ftSingle,
+            ftDouble : fArgInfos[argidx].ArgType := TArgType.FPReg;
+            ftExtended: {val := PInt64(PExtended(aArgs[i].ValueRef))^};
+          end;
+        end;
+      else
+        raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [i, fArgs[i].ParamType^.Name]);
+      end;
+    end;
+
+    if (fArgInfos[argidx].ArgType = TArgType.FPReg) and (ofs >= 4) then
+      fArgInfos[argidx].ArgType := TArgType.Stack;
+    if (fArgInfos[argidx].ArgType = TArgType.GenReg) and (ofs >= 4) then
+      fArgInfos[argidx].ArgType := TArgType.Stack;
+
+    fArgInfos[argidx].Offset := ofs;
+    Inc(ofs);
+    Inc(argidx);
+  end;
+end;
+
+function TSystemFunctionCallback.GetCodeAddress: CodePointer;
+begin
+  Result := fData;
+end;
+{$endif}
+
+constructor TSystemFunctionCallback.Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+{$ifdef windows}
+var
+  i: SizeInt;
+{$endif}
+begin
+{$ifdef windows}
+  fContext := aContext;
+  SetLength(fArgs, Length(aArgs));
+  for i := 0 to High(aArgs) do
+    fArgs[i] := aArgs[i];
+  fResultType := aResultType;
+  fFlags := aFlags;
+  CreateCallback;
+  CreateArgInfos;
+{$else}
+  raise EInvocationError.Create(SErrPlatformNotSupported);
+{$endif}
+end;
+
+destructor TSystemFunctionCallback.Destroy;
+begin
+{$ifdef windows}
+  if Assigned(fData) then
+    FreeMemory(fData);
+{$endif}
+end;
+
+constructor TSystemFunctionCallbackProc.Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+begin
+  inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags);
+  fHandler := aHandler;
+end;
+
+procedure TSystemFunctionCallbackProc.CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+begin
+  fHandler(aArgs, aResult, aContext);
+end;
+
+constructor TSystemFunctionCallbackMethod.Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+begin
+  inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags);
+  fHandler := aHandler;
+end;
+
+procedure TSystemFunctionCallbackMethod.CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+begin
+  fHandler(aArgs, aResult, aContext);
+end;
+
+function SystemCreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+begin
+  Result := TSystemFunctionCallbackProc.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags);
+end;
+
+function SystemCreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+begin
+  Result := TSystemFunctionCallbackMethod.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags);
+end;
+
 const
   SystemFunctionCallManager: TFunctionCallManager = (
     Invoke: @SystemInvoke;
-    CreateCallbackProc: Nil;
-    CreateCallbackMethod: Nil;
+    CreateCallbackProc: @SystemCreateCallbackProc;
+    CreateCallbackMethod: @SystemCreateCallbackMethod;
   );
 
 procedure InitSystemFunctionCallManager;

packages/rtl-objpas/tests/testrunner.rtlobjpas.pp

@@ -21,6 +21,9 @@ uses
   consoletestrunner,
 {$ifdef testinvoke}
   tests.rtti.invoke,
+{$endif}
+{$ifdef testimpl}
+  tests.rtti.impl,
 {$endif}
   tests.rtti;
 

packages/rtl-objpas/tests/tests.rtti.impl.pas

@@ -0,0 +1,582 @@
+unit Tests.Rtti.Impl;
+
+{$ifdef fpc}
+{$mode objfpc}{$H+}
+{$endif}
+
+{.$define debug}
+
+interface
+
+uses
+{$IFDEF FPC}
+  fpcunit,testregistry, testutils,
+{$ELSE FPC}
+  TestFramework,
+{$ENDIF FPC}
+  sysutils, typinfo, Rtti,
+  Tests.Rtti.Util;
+
+{ Note: Delphi does not provide a CreateImplementation for TRttiInvokableType
+        and its descendants, so these tests are disabled for Delphi }
+
+type
+  TTestImpl = class(TTestCase)
+  private
+    InputArgs: array of TValue;
+    OutputArgs: array of TValue;
+    ResultValue: TValue;
+    InOutMapping: array of SizeInt;
+
+{$ifdef fpc}
+    procedure OnHandleInvokable(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue);
+    procedure DoMethodImpl(aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+    procedure DoProcImpl(aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+{$ifndef InLazIDE}
+    {$ifdef fpc}generic{$endif} procedure GenDoMethodImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+    {$ifdef fpc}generic{$endif} procedure GenDoProcImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+{$endif}
+{$endif}
+{$ifdef fpc}
+    procedure Status(const aMsg: String); inline;
+    procedure Status(const aMsg: String; const aArgs: array of const); inline;
+{$endif}
+  published
+{$ifdef fpc}
+    procedure TestMethodVars;
+    procedure TestProcVars;
+{$endif}
+  end;
+
+implementation
+
+type
+  TTestMethod1 = procedure of object;
+  TTestMethod2 = function(aArg1: SizeInt): SizeInt of object;
+  TTestMethod3 = procedure(aArg1: AnsiString) of object;
+  TTestMethod4 = procedure(aArg1: ShortString) of object;
+  TTestMethod5 = function: AnsiString of object;
+  TTestMethod6 = function: ShortString of object;
+  TTestMethod7 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: SizeInt) of object;
+  TTestMethod8 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: AnsiString) of object;
+  TTestMethod9 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: ShortString) of object;
+  TTestMethod10 = procedure(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Single) of object;
+  TTestMethod11 = procedure(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Double) of object;
+  TTestMethod12 = procedure(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Extended) of object;
+  TTestMethod13 = procedure(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Comp) of object;
+  TTestMethod14 = procedure(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Currency) of object;
+  TTestMethod15 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt of object;
+  TTestMethod16 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single of object;
+  TTestMethod17 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double of object;
+  TTestMethod18 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended of object;
+  TTestMethod19 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp of object;
+  TTestMethod20 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency of object;
+
+  TTestProc1 = procedure;
+  TTestProc2 = function(aArg1: SizeInt): SizeInt;
+  TTestProc3 = procedure(aArg1: AnsiString);
+  TTestProc4 = procedure(aArg1: ShortString);
+  TTestProc5 = function: AnsiString;
+  TTestProc6 = function: ShortString;
+  TTestProc7 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: SizeInt);
+  TTestProc8 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: AnsiString);
+  TTestProc9 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: ShortString);
+  TTestProc10 = procedure(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Single);
+  TTestProc11 = procedure(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Double);
+  TTestProc12 = procedure(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Extended);
+  TTestProc13 = procedure(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Comp);
+  TTestProc14 = procedure(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Currency);
+  TTestProc15 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
+  TTestProc16 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+  TTestProc17 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+  TTestProc18 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+  TTestProc19 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+  TTestProc20 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
+
+const
+  SingleArg1: Single = 1.23;
+  SingleArg2In: Single = 3.21;
+  SingleArg2Out: Single = 2.34;
+  SingleArg3Out: Single = 9.87;
+  SingleArg4: Single = 7.89;
+  SingleRes: Single = 4.32;
+  SingleAddArg1 = Single(1.23);
+  SingleAddArg2 = Single(2.34);
+  SingleAddArg3 = Single(3.45);
+  SingleAddArg4 = Single(4.56);
+  SingleAddArg5 = Single(5.67);
+  SingleAddArg6 = Single(9.87);
+  SingleAddArg7 = Single(8.76);
+  SingleAddArg8 = Single(7.65);
+  SingleAddArg9 = Single(6.54);
+  SingleAddArg10 = Single(5.43);
+  SingleAddRes = SingleAddArg1 + SingleAddArg2 + SingleAddArg3 + SingleAddArg4 + SingleAddArg5 +
+                 SingleAddArg6 + SingleAddArg7 + SingleAddArg8 + SingleAddArg9 + SingleAddArg10;
+
+  DoubleArg1: Double = 1.23;
+  DoubleArg2In: Double = 3.21;
+  DoubleArg2Out: Double = 2.34;
+  DoubleArg3Out: Double = 9.87;
+  DoubleArg4: Double = 7.89;
+  DoubleRes: Double = 4.32;
+  DoubleAddArg1 = Double(1.23);
+  DoubleAddArg2 = Double(2.34);
+  DoubleAddArg3 = Double(3.45);
+  DoubleAddArg4 = Double(4.56);
+  DoubleAddArg5 = Double(5.67);
+  DoubleAddArg6 = Double(9.87);
+  DoubleAddArg7 = Double(8.76);
+  DoubleAddArg8 = Double(7.65);
+  DoubleAddArg9 = Double(6.54);
+  DoubleAddArg10 = Double(5.43);
+  DoubleAddRes = DoubleAddArg1 + DoubleAddArg2 + DoubleAddArg3 + DoubleAddArg4 + DoubleAddArg5 +
+                 DoubleAddArg6 + DoubleAddArg7 + DoubleAddArg8 + DoubleAddArg9 + DoubleAddArg10;
+
+  ExtendedArg1: Extended = 1.23;
+  ExtendedArg2In: Extended = 3.21;
+  ExtendedArg2Out: Extended = 2.34;
+  ExtendedArg3Out: Extended = 9.87;
+  ExtendedArg4: Extended = 7.89;
+  ExtendedRes: Extended = 4.32;
+  ExtendedAddArg1 = Extended(1.23);
+  ExtendedAddArg2 = Extended(2.34);
+  ExtendedAddArg3 = Extended(3.45);
+  ExtendedAddArg4 = Extended(4.56);
+  ExtendedAddArg5 = Extended(5.67);
+  ExtendedAddArg6 = Extended(9.87);
+  ExtendedAddArg7 = Extended(8.76);
+  ExtendedAddArg8 = Extended(7.65);
+  ExtendedAddArg9 = Extended(6.54);
+  ExtendedAddArg10 = Extended(5.43);
+  ExtendedAddRes = ExtendedAddArg1 + ExtendedAddArg2 + ExtendedAddArg3 + ExtendedAddArg4 + ExtendedAddArg5 +
+                 ExtendedAddArg6 + ExtendedAddArg7 + ExtendedAddArg8 + ExtendedAddArg9 + ExtendedAddArg10;
+
+  CurrencyArg1: Currency = 1.23;
+  CurrencyArg2In: Currency = 3.21;
+  CurrencyArg2Out: Currency = 2.34;
+  CurrencyArg3Out: Currency = 9.87;
+  CurrencyArg4: Currency = 7.89;
+  CurrencyRes: Currency = 4.32;
+  CurrencyAddArg1 = Currency(1.23);
+  CurrencyAddArg2 = Currency(2.34);
+  CurrencyAddArg3 = Currency(3.45);
+  CurrencyAddArg4 = Currency(4.56);
+  CurrencyAddArg5 = Currency(5.67);
+  CurrencyAddArg6 = Currency(9.87);
+  CurrencyAddArg7 = Currency(8.76);
+  CurrencyAddArg8 = Currency(7.65);
+  CurrencyAddArg9 = Currency(6.54);
+  CurrencyAddArg10 = Currency(5.43);
+  CurrencyAddRes = CurrencyAddArg1 + CurrencyAddArg2 + CurrencyAddArg3 + CurrencyAddArg4 + CurrencyAddArg5 +
+                 CurrencyAddArg6 + CurrencyAddArg7 + CurrencyAddArg8 + CurrencyAddArg9 + CurrencyAddArg10;
+
+  CompArg1: Comp = 123;
+  CompArg2In: Comp = 321;
+  CompArg2Out: Comp = 234;
+  CompArg3Out: Comp = 987;
+  CompArg4: Comp = 789;
+  CompRes: Comp = 432;
+  CompAddArg1 = Comp(123);
+  CompAddArg2 = Comp(234);
+  CompAddArg3 = Comp(345);
+  CompAddArg4 = Comp(456);
+  CompAddArg5 = Comp(567);
+  CompAddArg6 = Comp(987);
+  CompAddArg7 = Comp(876);
+  CompAddArg8 = Comp(765);
+  CompAddArg9 = Comp(654);
+  CompAddArg10 = Comp(543);
+  CompAddRes = CompAddArg1 + CompAddArg2 + CompAddArg3 + CompAddArg4 + CompAddArg5 +
+                 CompAddArg6 + CompAddArg7 + CompAddArg8 + CompAddArg9 + CompAddArg10;
+
+{ TTestImpl }
+
+{$ifdef fpc}
+procedure TTestImpl.Status(const aMsg: String);
+begin
+{$ifdef debug}
+  Writeln(aMsg);
+{$endif}
+end;
+
+procedure TTestImpl.Status(const aMsg: String; const aArgs: array of const);
+begin
+{$ifdef debug}
+  Writeln(Format(aMsg, aArgs));
+{$endif}
+end;
+{$endif}
+
+{$ifdef fpc}
+procedure TTestImpl.OnHandleInvokable(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out
+  aResult: TValue);
+var
+  selfofs, i: SizeInt;
+begin
+  CheckTrue((aInvokable is TRttiMethodType) or (aInvokable is TRttiProcedureType), 'Invokable is not a method or procedure variable: ' + aInvokable.ClassName);
+
+  selfofs := 0;
+  if aInvokable is TRttiMethodType then
+    selfofs := 1;
+
+  Status('In Callback');
+  Status('Self: ' + HexStr(Self));
+  if Assigned(aInvokable.ReturnType) then
+    aResult := CopyValue(ResultValue);
+  Status('Setting input args');
+  SetLength(InputArgs, Length(aArgs));
+  for i := 0 to High(aArgs) do begin
+    Status('Arg %d: %p %p', [i, aArgs[i].GetReferenceToRawData, PPointer(aArgs[i].GetReferenceToRawData)^]);
+    InputArgs[i] := CopyValue(aArgs[i]);
+  end;
+  Status('Setting output args');
+  { Note: account for Self }
+  for i := 0 to High(InOutMapping) do begin
+    Status('OutputArg %d -> Arg %d', [i, InOutMapping[i] + selfofs]);
+    { check input arg type? }
+    Move(OutputArgs[i].GetReferenceToRawData^, aArgs[InOutMapping[i] + selfofs].GetReferenceToRawData^, OutputArgs[i].DataSize);
+  end;
+  Status('Callback done');
+end;
+
+procedure TTestImpl.DoMethodImpl(aTypeInfo: PTypeInfo; aInputArgs,
+  aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+var
+  context: TRttiContext;
+  t: TRttiType;
+  callable, res: TValue;
+  method: TRttiMethodType;
+  i: SizeInt;
+  input: array of TValue;
+  impl: TMethodImplementation;
+  mrec: TMethod;
+  name: String;
+begin
+  name := aTypeInfo^.Name;
+
+  impl := Nil;
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(aTypeInfo);
+    Check(t is TRttiMethodType, 'Not a method variable: ' + name);
+    method := t as TRttiMethodType;
+
+    Status('Executing method %s', [name]);
+
+    CheckEquals(Length(aOutputArgs), Length(aInOutMapping), 'Invalid in/out mapping');
+    Check(Length(aOutputArgs) <= Length(aInputArgs), 'Output args not part of input args');
+
+    { arguments might be modified by Invoke (Note: Copy() does not uniquify the
+      IValueData of managed types) }
+    SetLength(input, Length(aInputArgs) + 1);
+    input[0] := GetPointerValue(Self);
+    for i := 0 to High(aInputArgs) do
+      input[i + 1] := CopyValue(aInputArgs[i]);
+
+    impl := method.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    CheckNotNull(impl, 'Method implementation is Nil');
+
+    mrec.Data := Self;
+    mrec.Code := impl.CodeAddress;
+    TValue.Make(@mrec, aTypeInfo, callable);
+
+    SetLength(InOutMapping, Length(aInOutMapping));
+    for i := 0 to High(InOutMapping) do
+      InOutMapping[i] := aInOutMapping[i];
+    SetLength(OutputArgs, Length(aOutputArgs));
+    for i := 0 to High(OutputArgs) do
+      OutputArgs[i] := CopyValue(aOutputArgs[i]);
+    ResultValue := aResult;
+
+    res := method.Invoke(callable, aInputArgs);
+    Status('After invoke');
+
+    Check(EqualValues(ResultValue, res), 'Reported result value differs from returned for ' + name);
+    Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
+    CheckEquals(Length(input), Length(InputArgs), 'Count of input args differs for ' + name);
+    for i := 0 to High(input) do begin
+      Check(EqualValues(input[i], InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
+    end;
+    for i := 0 to High(aOutputArgs) do begin
+      Check(EqualValues(aOutputArgs[i], aInputArgs[InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
+    end;
+  finally
+    impl.Free;
+    context.Free;
+  end;
+end;
+
+procedure TTestImpl.DoProcImpl(aTypeInfo: PTypeInfo; aInputArgs,
+  aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+var
+  context: TRttiContext;
+  t: TRttiType;
+  callable, res: TValue;
+  proc: TRttiProcedureType;
+  i: SizeInt;
+  input: array of TValue;
+  impl: TMethodImplementation;
+  name: String;
+  cp: CodePointer;
+begin
+  name := aTypeInfo^.Name;
+
+  impl := Nil;
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(aTypeInfo);
+    Check(t is TRttiProcedureType, 'Not a procedure variable: ' + name);
+    proc := t as TRttiProcedureType;
+
+    Status('Executing procedure %s', [name]);
+
+    CheckEquals(Length(aOutputArgs), Length(aInOutMapping), 'Invalid in/out mapping');
+    Check(Length(aOutputArgs) <= Length(aInputArgs), 'Output args not part of input args');
+
+    { arguments might be modified by Invoke (Note: Copy() does not uniquify the
+      IValueData of managed types) }
+    SetLength(input, Length(aInputArgs));
+    for i := 0 to High(aInputArgs) do
+      input[i] := CopyValue(aInputArgs[i]);
+
+    impl := proc.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    CheckNotNull(impl, 'Method implementation is Nil');
+
+    cp := impl.CodeAddress;
+    TValue.Make(@cp, aTypeInfo, callable);
+
+    SetLength(InOutMapping, Length(aInOutMapping));
+    for i := 0 to High(InOutMapping) do
+      InOutMapping[i] := aInOutMapping[i];
+    SetLength(OutputArgs, Length(aOutputArgs));
+    for i := 0 to High(OutputArgs) do
+      OutputArgs[i] := CopyValue(aOutputArgs[i]);
+    ResultValue := aResult;
+
+    res := proc.Invoke(callable, aInputArgs);
+    Status('After invoke');
+
+    Check(EqualValues(ResultValue, res), 'Reported result value differs from returned for ' + name);
+    Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
+    CheckEquals(Length(input), Length(InputArgs), 'Count of input args differs for ' + name);
+    for i := 0 to High(input) do begin
+      Check(EqualValues(input[i], InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
+    end;
+    for i := 0 to High(aOutputArgs) do begin
+      Check(EqualValues(aOutputArgs[i], aInputArgs[InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
+    end;
+  finally
+    impl.Free;
+    context.Free;
+  end;
+end;
+{$endif}
+
+{$ifndef InLazIDE}
+{$ifdef fpc}generic{$endif} procedure TTestImpl.GenDoMethodImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+begin
+  DoMethodImpl(TypeInfo(T), aInputArgs, aOutputArgs, aInOutMapping, aResult);
+end;
+
+{$ifdef fpc}generic{$endif} procedure TTestImpl.GenDoProcImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+begin
+  DoProcImpl(TypeInfo(T), aInputArgs, aOutputArgs, aInOutMapping, aResult);
+end;
+{$endif}
+
+{$ifdef fpc}
+procedure TTestImpl.TestMethodVars;
+begin
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod1>([], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod2>([GetIntValue(42)], [], [], GetIntValue(21));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod3>([GetAnsiString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod4>([GetShortString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod5>([], [], [], GetAnsiString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod6>([], [], [], GetShortString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod7>([
+    GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876)
+  ], [
+    GetIntValue(5678), GetIntValue(6789)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod8>([
+    GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
+  ], [
+    GetAnsiString('Gamma'), GetAnsiString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod9>([
+    GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
+  ], [
+    GetShortString('Gamma'), GetShortString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod10>([
+    GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+  ], [
+    GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod11>([
+    GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+  ], [
+    GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod12>([
+    GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+  ], [
+    GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod13>([
+    GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+  ], [
+    GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod14>([
+    GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+  ], [
+    GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod15>([
+    GetIntValue(1), GetIntValue(2), GetIntValue(3), GetIntValue(4), GetIntValue(5),
+    GetIntValue(6), GetIntValue(7), GetIntValue(8), GetIntValue(9), GetIntValue(10)
+  ], [], [], GetIntValue(11));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod16>([
+    GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+    GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+  ], [], [], GetSingleValue(SingleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod17>([
+    GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+    GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+  ], [], [], GetDoubleValue(DoubleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod18>([
+    GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+    GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+  ], [], [], GetExtendedValue(ExtendedAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod19>([
+    GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+    GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+  ], [], [], GetCompValue(CompAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod20>([
+    GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+    GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+  ], [], [], GetCurrencyValue(CurrencyAddRes));
+end;
+
+procedure TTestImpl.TestProcVars;
+begin
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc1>([], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc2>([GetIntValue(42)], [], [], GetIntValue(21));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc3>([GetAnsiString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc4>([GetShortString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc5>([], [], [], GetAnsiString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc6>([], [], [], GetShortString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc7>([
+    GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876)
+  ], [
+    GetIntValue(5678), GetIntValue(6789)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc8>([
+    GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
+  ], [
+    GetAnsiString('Gamma'), GetAnsiString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc9>([
+    GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
+  ], [
+    GetShortString('Gamma'), GetShortString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc10>([
+    GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+  ], [
+    GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc11>([
+    GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+  ], [
+    GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc12>([
+    GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+  ], [
+    GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc13>([
+    GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+  ], [
+    GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc14>([
+    GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+  ], [
+    GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc15>([
+    GetIntValue(1), GetIntValue(2), GetIntValue(3), GetIntValue(4), GetIntValue(5),
+    GetIntValue(6), GetIntValue(7), GetIntValue(8), GetIntValue(9), GetIntValue(10)
+  ], [], [], GetIntValue(11));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc16>([
+    GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+    GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+  ], [], [], GetSingleValue(SingleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc17>([
+    GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+    GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+  ], [], [], GetDoubleValue(DoubleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc18>([
+    GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+    GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+  ], [], [], GetExtendedValue(ExtendedAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc19>([
+    GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+    GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+  ], [], [], GetCompValue(CompAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc20>([
+    GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+    GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+  ], [], [], GetCurrencyValue(CurrencyAddRes));
+end;
+{$endif}
+
+initialization
+{$ifdef fpc}
+  RegisterTest(TTestImpl);
+{$else fpc}
+  RegisterTest(TTestImpl.Suite);
+{$endif fpc}
+end.
+

packages/rtl-objpas/tests/tests.rtti.invoke.pas

@@ -14,13 +14,10 @@ uses
 {$ELSE FPC}
   TestFramework,
 {$ENDIF FPC}
-  sysutils, typinfo, Rtti;
+  sysutils, typinfo, Rtti,
+  Tests.Rtti.Util;
 
 type
-{$ifndef fpc}
-  CodePointer = Pointer;
-{$endif}
-
   TTestInvoke = class(TTestCase)
   private type
     TInvokeFlag = (
@@ -29,8 +26,6 @@ type
     );
     TInvokeFlags = set of TInvokeFlag;
   private
-    function EqualValues(aValue1, aValue2: TValue): Boolean;
-
     function DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
     procedure DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
     procedure DoStaticInvokeTestAnsiStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
@@ -38,9 +33,11 @@ type
     procedure DoIntfInvoke(aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
     procedure DoMethodInvoke(aInst: TObject; aMethod: TMethod; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
     procedure DoProcVarInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
+    procedure DoProcInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
 {$ifndef InLazIDE}
     {$ifdef fpc}generic{$endif} procedure GenDoMethodInvoke<T>(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
     {$ifdef fpc}generic{$endif} procedure GenDoProcvarInvoke<T>(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
+    {$ifdef fpc}generic{$endif} procedure GenDoProcInvoke<T>(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
     {$ifdef fpc}generic{$endif} function GetRecValue<T>(aReverse: Boolean): TValue;
 {$endif}
 {$ifdef fpc}
@@ -65,119 +62,13 @@ type
 
     procedure TestProcVars;
     procedure TestProcVarsRecs;
-  end;
 
-{$ifndef fpc}
-  TValueHelper = record helper for TValue
-    function AsUnicodeString: UnicodeString;
-    function AsAnsiString: AnsiString;
+    procedure TestProc;
+    procedure TestProcRecs;
   end;
-{$endif}
 
 implementation
 
-{$ifndef fpc}
-function TValueHelper.AsUnicodeString: UnicodeString;
-begin
-  Result := UnicodeString(AsString);
-end;
-
-function TValueHelper.AsAnsiString: AnsiString;
-begin
-  Result := AnsiString(AsString);
-end;
-{$endif}
-
-function TTestInvoke.EqualValues(aValue1, aValue2: TValue): Boolean;
-var
-  td1, td2: PTypeData;
-  i: SizeInt;
-begin
-{$ifdef debug}
-  Writeln('Empty: ', aValue1.IsEmpty, ' ', aValue2.IsEmpty);
-  Writeln('Kind: ', aValue1.Kind, ' ', aValue2.Kind);
-  Writeln('Array: ', aValue1.IsArray, ' ', aValue2.IsArray);
-{$endif}
-  if aValue1.IsEmpty and aValue2.IsEmpty then
-    Result := True
-  else if aValue1.IsEmpty and not aValue2.IsEmpty then
-    Result := False
-  else if not aValue1.IsEmpty and aValue2.IsEmpty then
-    Result := False
-  else if aValue1.IsArray and aValue2.IsArray then begin
-    if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
-      Result := True;
-      for i := 0 to aValue1.GetArrayLength - 1 do
-        if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
-          Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4));
-          Result := False;
-          Break;
-        end;
-    end else
-      Result := False;
-  end else if aValue1.Kind = aValue2.Kind then begin
-    td1 := aValue1.TypeData;
-    td2 := aValue2.TypeData;
-    case aValue1.Kind of
-      tkBool:
-        Result := aValue1.AsBoolean xor not aValue2.AsBoolean;
-      tkSet:
-        if td1^.SetSize = td2^.SetSize then
-          if td1^.SetSize < SizeOf(SizeInt) then
-            Result := aValue1.AsOrdinal = aValue2.AsOrdinal
-          else
-            Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, td1^.SetSize)
-        else
-          Result := False;
-      tkEnumeration,
-      tkChar,
-      tkWChar,
-      tkUChar,
-      tkInt64,
-      tkInteger:
-        Result := aValue1.AsOrdinal = aValue2.AsOrdinal;
-      tkQWord:
-        Result := aValue1.AsUInt64 = aValue2.AsUInt64;
-      tkSString,
-      tkUString,
-      tkAString,
-      tkWString:
-        Result := aValue1.AsString = aValue2.AsString;
-      tkDynArray,
-      tkArray:
-        if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
-          Result := True;
-          for i := 0 to aValue1.GetArrayLength - 1 do
-            if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
-              Result := False;
-              Break;
-            end;
-        end else
-          Result := False;
-      tkClass,
-      tkClassRef,
-      tkInterface,
-      tkInterfaceRaw,
-      tkPointer:
-        Result := PPointer(aValue1.GetReferenceToRawData)^ = PPointer(aValue2.GetReferenceToRawData)^;
-      tkProcVar:
-        Result := PCodePointer(aValue1.GetReferenceToRawData)^ = PCodePointer(aValue2.GetReferenceToRawData)^;
-      tkRecord,
-      tkObject,
-      tkMethod,
-      tkVariant: begin
-        if aValue1.DataSize = aValue2.DataSize then
-          Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, aValue1.DataSize)
-        else
-          Result := False;
-      end
-      else
-        Result := False;
-    end;
-  end else
-    Result := False;
-end;
-
 function TTestInvoke.DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray;
   aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
 begin
@@ -634,6 +525,102 @@ begin
   DoStaticInvokeTestClassCompare('TTestClass Pascal', @TestTTestClassPascal, ccPascal, values, TypeInfo(TTestClass), rescls);
 end;
 
+const
+  SingleArg1: Single = 1.23;
+  SingleArg2In: Single = 3.21;
+  SingleArg2Out: Single = 2.34;
+  SingleArg3Out: Single = 9.87;
+  SingleArg4: Single = 7.89;
+  SingleRes: Single = 4.32;
+  SingleAddArg1 = Single(1.23);
+  SingleAddArg2 = Single(2.34);
+  SingleAddArg3 = Single(3.45);
+  SingleAddArg4 = Single(4.56);
+  SingleAddArg5 = Single(5.67);
+  SingleAddArg6 = Single(9.87);
+  SingleAddArg7 = Single(8.76);
+  SingleAddArg8 = Single(7.65);
+  SingleAddArg9 = Single(6.54);
+  SingleAddArg10 = Single(5.43);
+  SingleAddRes = SingleAddArg1 + SingleAddArg2 + SingleAddArg3 + SingleAddArg4 + SingleAddArg5 +
+                 SingleAddArg6 + SingleAddArg7 + SingleAddArg8 + SingleAddArg9 + SingleAddArg10;
+
+  DoubleArg1: Double = 1.23;
+  DoubleArg2In: Double = 3.21;
+  DoubleArg2Out: Double = 2.34;
+  DoubleArg3Out: Double = 9.87;
+  DoubleArg4: Double = 7.89;
+  DoubleRes: Double = 4.32;
+  DoubleAddArg1 = Double(1.23);
+  DoubleAddArg2 = Double(2.34);
+  DoubleAddArg3 = Double(3.45);
+  DoubleAddArg4 = Double(4.56);
+  DoubleAddArg5 = Double(5.67);
+  DoubleAddArg6 = Double(9.87);
+  DoubleAddArg7 = Double(8.76);
+  DoubleAddArg8 = Double(7.65);
+  DoubleAddArg9 = Double(6.54);
+  DoubleAddArg10 = Double(5.43);
+  DoubleAddRes = DoubleAddArg1 + DoubleAddArg2 + DoubleAddArg3 + DoubleAddArg4 + DoubleAddArg5 +
+                 DoubleAddArg6 + DoubleAddArg7 + DoubleAddArg8 + DoubleAddArg9 + DoubleAddArg10;
+
+  ExtendedArg1: Extended = 1.23;
+  ExtendedArg2In: Extended = 3.21;
+  ExtendedArg2Out: Extended = 2.34;
+  ExtendedArg3Out: Extended = 9.87;
+  ExtendedArg4: Extended = 7.89;
+  ExtendedRes: Extended = 4.32;
+  ExtendedAddArg1 = Extended(1.23);
+  ExtendedAddArg2 = Extended(2.34);
+  ExtendedAddArg3 = Extended(3.45);
+  ExtendedAddArg4 = Extended(4.56);
+  ExtendedAddArg5 = Extended(5.67);
+  ExtendedAddArg6 = Extended(9.87);
+  ExtendedAddArg7 = Extended(8.76);
+  ExtendedAddArg8 = Extended(7.65);
+  ExtendedAddArg9 = Extended(6.54);
+  ExtendedAddArg10 = Extended(5.43);
+  ExtendedAddRes = ExtendedAddArg1 + ExtendedAddArg2 + ExtendedAddArg3 + ExtendedAddArg4 + ExtendedAddArg5 +
+                 ExtendedAddArg6 + ExtendedAddArg7 + ExtendedAddArg8 + ExtendedAddArg9 + ExtendedAddArg10;
+
+  CurrencyArg1: Currency = 1.23;
+  CurrencyArg2In: Currency = 3.21;
+  CurrencyArg2Out: Currency = 2.34;
+  CurrencyArg3Out: Currency = 9.87;
+  CurrencyArg4: Currency = 7.89;
+  CurrencyRes: Currency = 4.32;
+  CurrencyAddArg1 = Currency(1.23);
+  CurrencyAddArg2 = Currency(2.34);
+  CurrencyAddArg3 = Currency(3.45);
+  CurrencyAddArg4 = Currency(4.56);
+  CurrencyAddArg5 = Currency(5.67);
+  CurrencyAddArg6 = Currency(9.87);
+  CurrencyAddArg7 = Currency(8.76);
+  CurrencyAddArg8 = Currency(7.65);
+  CurrencyAddArg9 = Currency(6.54);
+  CurrencyAddArg10 = Currency(5.43);
+  CurrencyAddRes = CurrencyAddArg1 + CurrencyAddArg2 + CurrencyAddArg3 + CurrencyAddArg4 + CurrencyAddArg5 +
+                 CurrencyAddArg6 + CurrencyAddArg7 + CurrencyAddArg8 + CurrencyAddArg9 + CurrencyAddArg10;
+
+  CompArg1: Comp = 123;
+  CompArg2In: Comp = 321;
+  CompArg2Out: Comp = 234;
+  CompArg3Out: Comp = 987;
+  CompArg4: Comp = 789;
+  CompRes: Comp = 432;
+  CompAddArg1 = Comp(123);
+  CompAddArg2 = Comp(234);
+  CompAddArg3 = Comp(345);
+  CompAddArg4 = Comp(456);
+  CompAddArg5 = Comp(567);
+  CompAddArg6 = Comp(987);
+  CompAddArg7 = Comp(876);
+  CompAddArg8 = Comp(765);
+  CompAddArg9 = Comp(654);
+  CompAddArg10 = Comp(543);
+  CompAddRes = CompAddArg1 + CompAddArg2 + CompAddArg3 + CompAddArg4 + CompAddArg5 +
+                 CompAddArg6 + CompAddArg7 + CompAddArg8 + CompAddArg9 + CompAddArg10;
+
 type
   TTestRecord1 = packed record
     b: array[0..0] of Byte;
@@ -689,6 +676,16 @@ type
     procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
     procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
     procedure Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
+    function Test13(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Single): Single;
+    function Test14(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Double): Double;
+    function Test15(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Extended): Extended;
+    function Test16(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Comp): Comp;
+    function Test17(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Currency): Currency;
+    function Test18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+    function Test19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+    function Test20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+    function Test21(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+    function Test22(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
 
     function TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
     function TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
@@ -717,6 +714,16 @@ type
     procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
     procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
     procedure Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
+    function Test13(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Single): Single;
+    function Test14(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Double): Double;
+    function Test15(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Extended): Extended;
+    function Test16(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Comp): Comp;
+    function Test17(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Currency): Currency;
+    function Test18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+    function Test19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+    function Test20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+    function Test21(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+    function Test22(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
 
     function TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
     function TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
@@ -754,6 +761,16 @@ type
   TMethodTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString) of object;
   TMethodTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString) of object;
   TMethodTest12 = procedure(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt) of object;
+  TMethodTest13 = function(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Single): Single of object;
+  TMethodTest14 = function(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Double): Double of object;
+  TMethodTest15 = function(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Extended): Extended of object;
+  TMethodTest16 = function(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Comp): Comp of object;
+  TMethodTest17 = function(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Currency): Currency of object;
+  TMethodTest18 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single of object;
+  TMethodTest19 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double of object;
+  TMethodTest20 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended of object;
+  TMethodTest21 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp of object;
+  TMethodTest22 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency of object;
 
   TMethodTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1 of object;
   TMethodTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2 of object;
@@ -778,6 +795,16 @@ type
   TProcVarTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
   TProcVarTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
   TProcVarTest12 = procedure(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
+  TProcVarTest13 = function(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Single): Single;
+  TProcVarTest14 = function(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Double): Double;
+  TProcVarTest15 = function(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Extended): Extended;
+  TProcVarTest16 = function(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Comp): Comp;
+  TProcVarTest17 = function(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Currency): Currency;
+  TProcVarTest18 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+  TProcVarTest19 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+  TProcVarTest20 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+  TProcVarTest21 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+  TProcVarTest22 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
 
   TProcVarTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1;
   TProcVarTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2;
@@ -961,6 +988,206 @@ begin
 {$endif}
 end;
 
+function TTestInterfaceClass.Test13(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Single): Single;
+begin
+  SetLength(InputArgs, 4);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  aArg2 := SingleArg2Out;
+  aArg3 := SingleArg3Out;
+  SetLength(OutputArgs, 2);
+  TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
+  SetLength(InOutMapping, 2);
+  InOutMapping[0] := 1;
+  InOutMapping[1] := 2;
+  Result := SingleRes;
+  TValue.Make(@Result, TypeInfo(Result), ResultValue);
+  CalledMethod := 13;
+end;
+
+function TTestInterfaceClass.Test14(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Double): Double;
+begin
+  SetLength(InputArgs, 4);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  aArg2 := DoubleArg2Out;
+  aArg3 := DoubleArg3Out;
+  SetLength(OutputArgs, 2);
+  TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
+  SetLength(InOutMapping, 2);
+  InOutMapping[0] := 1;
+  InOutMapping[1] := 2;
+  Result := DoubleRes;
+  TValue.Make(@Result, TypeInfo(Result), ResultValue);
+  CalledMethod := 14;
+end;
+
+function TTestInterfaceClass.Test15(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Extended): Extended;
+begin
+  SetLength(InputArgs, 4);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  aArg2 := ExtendedArg2Out;
+  aArg3 := ExtendedArg3Out;
+  SetLength(OutputArgs, 2);
+  TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
+  SetLength(InOutMapping, 2);
+  InOutMapping[0] := 1;
+  InOutMapping[1] := 2;
+  Result := ExtendedRes;
+  TValue.Make(@Result, TypeInfo(Result), ResultValue);
+  CalledMethod := 15;
+end;
+
+function TTestInterfaceClass.Test16(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Comp): Comp;
+begin
+  SetLength(InputArgs, 4);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  aArg2 := CompArg2Out;
+  aArg3 := CompArg3Out;
+  SetLength(OutputArgs, 2);
+  TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
+  SetLength(InOutMapping, 2);
+  InOutMapping[0] := 1;
+  InOutMapping[1] := 2;
+  Result := CompRes;
+  TValue.Make(@Result, TypeInfo(Result), ResultValue);
+  CalledMethod := 16;
+end;
+
+function TTestInterfaceClass.Test17(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Currency): Currency;
+begin
+  SetLength(InputArgs, 4);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  aArg2 := CurrencyArg2Out;
+  aArg3 := CurrencyArg3Out;
+  SetLength(OutputArgs, 2);
+  TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
+  SetLength(InOutMapping, 2);
+  InOutMapping[0] := 1;
+  InOutMapping[1] := 2;
+  Result := CurrencyRes;
+  TValue.Make(@Result, TypeInfo(Result), ResultValue);
+  CalledMethod := 17;
+end;
+
+function TTestInterfaceClass.Test18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+begin
+  SetLength(InputArgs, 10);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]);
+  TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]);
+  TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]);
+  TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]);
+  TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]);
+  TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]);
+  SetLength(OutputArgs, 0);
+  SetLength(InOutMapping, 0);
+  Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6 + aArg7 + aArg8 + aArg9 + aArg10;
+  TValue.Make(@Result ,TypeInfo(Result), ResultValue);
+  CalledMethod := 18;
+end;
+
+function TTestInterfaceClass.Test19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+begin
+  SetLength(InputArgs, 10);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]);
+  TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]);
+  TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]);
+  TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]);
+  TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]);
+  TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]);
+  SetLength(OutputArgs, 0);
+  SetLength(InOutMapping, 0);
+  Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6 + aArg7 + aArg8 + aArg9 + aArg10;
+  TValue.Make(@Result ,TypeInfo(Result), ResultValue);
+  CalledMethod := 19;
+end;
+
+function TTestInterfaceClass.Test20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+begin
+  SetLength(InputArgs, 10);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]);
+  TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]);
+  TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]);
+  TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]);
+  TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]);
+  TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]);
+  SetLength(OutputArgs, 0);
+  SetLength(InOutMapping, 0);
+  Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6 + aArg7 + aArg8 + aArg9 + aArg10;
+  TValue.Make(@Result ,TypeInfo(Result), ResultValue);
+  CalledMethod := 20;
+end;
+
+function TTestInterfaceClass.Test21(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+begin
+  SetLength(InputArgs, 10);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]);
+  TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]);
+  TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]);
+  TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]);
+  TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]);
+  TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]);
+  SetLength(OutputArgs, 0);
+  SetLength(InOutMapping, 0);
+  Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6 + aArg7 + aArg8 + aArg9 + aArg10;
+  TValue.Make(@Result ,TypeInfo(Result), ResultValue);
+  CalledMethod := 21;
+end;
+
+function TTestInterfaceClass.Test22(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
+begin
+  SetLength(InputArgs, 10);
+  TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
+  TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
+  TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
+  TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
+  TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]);
+  TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]);
+  TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]);
+  TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]);
+  TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]);
+  TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]);
+  SetLength(OutputArgs, 0);
+  SetLength(InOutMapping, 0);
+  Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6 + aArg7 + aArg8 + aArg9 + aArg10;
+  TValue.Make(@Result ,TypeInfo(Result), ResultValue);
+  CalledMethod := 22;
+end;
+
 function TTestInterfaceClass.TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
 var
   i: LongInt;
@@ -1160,6 +1387,56 @@ begin
   TTestInterfaceClass.ProcVarInst.Test12(aArg1, aArg2, aArg3, aArg4);
 end;
 
+function ProcTest13(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Single): Single;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test13(aArg1, aArg2, aArg3, aArg4);
+end;
+
+function ProcTest14(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Double): Double;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test14(aArg1, aArg2, aArg3, aArg4);
+end;
+
+function ProcTest15(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Extended): Extended;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test15(aArg1, aArg2, aArg3, aArg4);
+end;
+
+function ProcTest16(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Comp): Comp;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test16(aArg1, aArg2, aArg3, aArg4);
+end;
+
+function ProcTest17(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Currency): Currency;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test17(aArg1, aArg2, aArg3, aArg4);
+end;
+
+function ProcTest18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
+end;
+
+function ProcTest19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
+end;
+
+function ProcTest20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
+end;
+
+function ProcTest21(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test21(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
+end;
+
+function ProcTest22(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
+begin
+  Result := TTestInterfaceClass.ProcVarInst.Test22(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
+end;
+
 function ProcTestRecSize1(aArg1: TTestRecord1): TTestRecord1;
 begin
   Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize1(aArg1);
@@ -1210,24 +1487,6 @@ begin
   Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize10(aArg1);
 end;
 
-function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
-var
-  arrptr: Pointer;
-  len, i: SizeInt;
-begin
-  if aValue.Kind = tkDynArray then begin
-    { we need to decouple the source reference, so we're going to be a bit
-      cheeky here }
-    len := aValue.GetArrayLength;
-    arrptr := Nil;
-    DynArraySetLength(arrptr, aValue.TypeInfo, 1, @len);
-    TValue.Make(@arrptr, aValue.TypeInfo, Result);
-    for i := 0 to len - 1 do
-      Result.SetArrayElement(i, aValue.GetArrayElement(i));
-  end else
-    TValue.Make(aValue.GetReferenceToRawData, aValue.TypeInfo, Result);
-end;
-
 procedure TTestInvoke.DoIntfInvoke(aIndex: SizeInt; aInputArgs,
   aOutputArgs: TValueArray; aResult: TValue);
 var
@@ -1396,6 +1655,69 @@ begin
   end;
 end;
 
+procedure TTestInvoke.DoProcInvoke(aInst: TObject; aProc: CodePointer;
+  aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray;
+  aResult: TValue);
+var
+  cls: TTestInterfaceClass;
+  name: String;
+  context: TRttiContext;
+  t: TRttiType;
+  callable, res: TValue;
+  proc: TRttiProcedureType;
+  i: SizeInt;
+  input: array of TValue;
+  restype: PTypeInfo;
+begin
+  cls := aInst as TTestInterfaceClass;
+  cls.Reset;
+
+  if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin
+    name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker);
+    TTestInterfaceClass.ProcVarRecInst := cls;
+  end else begin
+    name := 'Test' + IntToStr(aIndex);
+    TTestInterfaceClass.ProcVarInst := cls;
+  end;
+
+  TValue.Make(@aProc, aTypeInfo, callable);
+
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(aTypeInfo);
+    Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
+    proc := t as TRttiProcedureType;
+
+    { arguments might be modified by Invoke (Note: Copy() does not uniquify the
+      IValueData of managed types) }
+    SetLength(input, Length(aInputArgs));
+    for i := 0 to High(input) do
+      input[i] := CopyValue(aInputArgs[i]);
+
+    if Assigned(proc.ReturnType) then
+      restype := PTypeInfo(proc.ReturnType.Handle)
+    else
+      restype := Nil;
+
+    res := Rtti.Invoke(aProc, aInputArgs, proc.CallingConvention, restype, True, False);
+    CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
+    Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
+    Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
+    CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
+    CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
+    CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
+    for i := 0 to High(aInputArgs) do begin
+      Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
+    end;
+    for i := 0 to High(aOutputArgs) do begin
+      Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
+      Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
+    end;
+  finally
+    context.Free;
+  end;
+end;
+
 {$ifndef InLazIDE}
 {$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoMethodInvoke<T>(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
 begin
@@ -1407,6 +1729,11 @@ begin
   DoProcVarInvoke(aInst, CodePointer(aProc), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult);
 end;
 
+{$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoProcInvoke<T>(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
+begin
+  DoProcInvoke(aInst, CodePointer(aProc), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult);
+end;
+
 {$ifdef fpc}generic{$endif} function TTestInvoke.GetRecValue<T>(aReverse: Boolean): TValue;
 var
   i: LongInt;
@@ -1425,28 +1752,6 @@ begin
 end;
 {$endif}
 
-function GetIntValue(aValue: SizeInt): TValue;
-begin
-  Result := TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(aValue);
-end;
-
-function GetAnsiString(const aValue: AnsiString): TValue;
-begin
-  Result := TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>(aValue);
-end;
-
-function GetShortString(const aValue: ShortString): TValue;
-begin
-  Result := TValue.{$ifdef fpc}specialize{$endif}From<ShortString>(aValue);
-end;
-
-{$ifdef fpc}
-function GetArray(const aArg: array of SizeInt): TValue;
-begin
-  Result := specialize OpenArrayToDynArrayValue<SizeInt>(aArg);
-end;
-{$endif}
-
 procedure TTestInvoke.TestIntfMethods;
 begin
   DoIntfInvoke(1, [], [], TValue.Empty);
@@ -1493,6 +1798,61 @@ begin
     GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
     ], TValue.Empty);
 {$endif}
+
+  DoIntfInvoke(13, [
+    GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+    ], [
+    GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+    ], GetSingleValue(SingleRes));
+
+  DoIntfInvoke(14, [
+    GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+    ], [
+    GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+    ], GetDoubleValue(DoubleRes));
+
+  DoIntfInvoke(15, [
+    GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+    ], [
+    GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+    ], GetExtendedValue(ExtendedRes));
+
+  DoIntfInvoke(16, [
+    GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+    ], [
+    GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+    ], GetCompValue(CompRes));
+
+  DoIntfInvoke(17, [
+    GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+    ], [
+    GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+    ], GetCurrencyValue(CurrencyRes));
+
+  DoIntfInvoke(18, [
+    GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+    GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+    ], [], GetSingleValue(SingleAddRes));
+
+  DoIntfInvoke(19, [
+    GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+    GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+    ], [], GetDoubleValue(DoubleAddRes));
+
+  DoIntfInvoke(20, [
+    GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+    GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+    ], [], GetExtendedValue(ExtendedAddRes));
+
+  DoIntfInvoke(21, [
+    GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+    GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+    ], [], GetCompValue(CompAddRes));
+
+  DoIntfInvoke(22, [
+    GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+    GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+    ], [], GetCurrencyValue(CurrencyAddRes));
 end;
 
 procedure TTestInvoke.TestIntfMethodsRecs;
@@ -1588,6 +1948,61 @@ begin
       GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
       ], TValue.Empty);
   {$endif}
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest13>(cls, {$ifdef fpc}@{$endif}cls.Test13, 13, [
+      GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+      ], [
+      GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+      ], GetSingleValue(SingleRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest14>(cls, {$ifdef fpc}@{$endif}cls.Test14, 14, [
+      GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+      ], [
+      GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+      ], GetDoubleValue(DoubleRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest15>(cls, {$ifdef fpc}@{$endif}cls.Test15, 15, [
+      GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+      ], [
+      GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+      ], GetExtendedValue(ExtendedRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest16>(cls, {$ifdef fpc}@{$endif}cls.Test16, 16, [
+      GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+      ], [
+      GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+      ], GetCompValue(CompRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest17>(cls, {$ifdef fpc}@{$endif}cls.Test17, 17, [
+      GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+      ], [
+      GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+      ], GetCurrencyValue(CurrencyRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest18>(cls, {$ifdef fpc}@{$endif}cls.Test18, 18, [
+      GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+      GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+      ], [], GetSingleValue(SingleAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest19>(cls, {$ifdef fpc}@{$endif}cls.Test19, 19, [
+      GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+      GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+      ], [], GetDoubleValue(DoubleAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest20>(cls, {$ifdef fpc}@{$endif}cls.Test20, 20, [
+      GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+      GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+      ], [], GetExtendedValue(ExtendedAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest21>(cls, {$ifdef fpc}@{$endif}cls.Test21, 21, [
+      GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+      GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+      ], [], GetCompValue(CompAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest22>(cls, {$ifdef fpc}@{$endif}cls.Test22, 22, [
+      GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+      GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+      ], [], GetCurrencyValue(CurrencyAddRes));
   finally
     cls.Free;
   end;
@@ -1693,6 +2108,61 @@ begin
       GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
       ], TValue.Empty);
   {$endif}
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest13>(cls, {$ifdef fpc}@{$endif}ProcTest13, 13, [
+      GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+      ], [
+      GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+      ], GetSingleValue(SingleRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest14>(cls, {$ifdef fpc}@{$endif}ProcTest14, 14, [
+      GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+      ], [
+      GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+      ], GetDoubleValue(DoubleRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest15>(cls, {$ifdef fpc}@{$endif}ProcTest15, 15, [
+      GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+      ], [
+      GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+      ], GetExtendedValue(ExtendedRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest16>(cls, {$ifdef fpc}@{$endif}ProcTest16, 16, [
+      GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+      ], [
+      GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+      ], GetCompValue(CompRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest17>(cls, {$ifdef fpc}@{$endif}ProcTest17, 17, [
+      GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+      ], [
+      GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+      ], GetCurrencyValue(CurrencyRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest18>(cls, {$ifdef fpc}@{$endif}ProcTest18, 18, [
+      GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+      GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+      ], [], GetSingleValue(SingleAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest19>(cls, {$ifdef fpc}@{$endif}ProcTest19, 19, [
+      GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+      GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+      ], [], GetDoubleValue(DoubleAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest20>(cls, {$ifdef fpc}@{$endif}ProcTest20, 20, [
+      GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+      GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+      ], [], GetExtendedValue(ExtendedAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest21>(cls, {$ifdef fpc}@{$endif}ProcTest21, 21, [
+      GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+      GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+      ], [], GetCompValue(CompAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcvarInvoke<TProcVarTest22>(cls, {$ifdef fpc}@{$endif}ProcTest22, 22, [
+      GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+      GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+      ], [], GetCurrencyValue(CurrencyAddRes));
   finally
     cls.Free;
   end;
@@ -1748,6 +2218,168 @@ begin
   end;
 end;
 
+procedure TTestInvoke.TestProc;
+var
+  cls: TTestInterfaceClass;
+begin
+  cls := TTestInterfaceClass.Create;
+  try
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest1>(cls, {$ifdef fpc}@{$endif}ProcTest1, 1, [], [], TValue.Empty);
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest2>(cls, {$ifdef fpc}@{$endif}ProcTest2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From<SizeInt>(42));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest3>(cls, {$ifdef fpc}@{$endif}ProcTest3, 3, [
+      GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
+      ], [], GetIntValue(42));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest4>(cls, {$ifdef fpc}@{$endif}ProcTest4, 4, [
+      TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
+      TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
+      TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
+      TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
+      ], [], TValue.Empty);
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest5>(cls, {$ifdef fpc}@{$endif}ProcTest5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest6>(cls, {$ifdef fpc}@{$endif}ProcTest6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest7>(cls, {$ifdef fpc}@{$endif}ProcTest7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest8>(cls, {$ifdef fpc}@{$endif}ProcTest8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
+
+{$ifdef NEEDS_POINTER_HELPER}
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest9>(cls, {$ifdef fpc}@{$endif}ProcTest9, 9, [
+      GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
+      ], [
+      GetIntValue($1234), GetIntValue($5678)
+      ], TValue.Empty);
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest10>(cls, {$ifdef fpc}@{$endif}ProcTest10, 10, [
+      GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
+      ], [
+      GetAnsiString('Foo'), GetAnsiString('Bar')
+      ], TValue.Empty);
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest11>(cls, {$ifdef fpc}@{$endif}ProcTest11, 11, [
+      GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
+      ], [
+      GetShortString('Foo'), GetShortString('Bar')
+      ], TValue.Empty);
+
+  {$ifdef fpc}
+    specialize GenDoProcInvoke<TProcVarTest12>(cls, {$ifdef fpc}@{$endif}ProcTest12, 12, [
+      GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
+      ], [
+      GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
+      ], TValue.Empty);
+  {$endif}
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest13>(cls, {$ifdef fpc}@{$endif}ProcTest13, 13, [
+      GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+      ], [
+      GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+      ], GetSingleValue(SingleRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest14>(cls, {$ifdef fpc}@{$endif}ProcTest14, 14, [
+      GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+      ], [
+      GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+      ], GetDoubleValue(DoubleRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest15>(cls, {$ifdef fpc}@{$endif}ProcTest15, 15, [
+      GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+      ], [
+      GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+      ], GetExtendedValue(ExtendedRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest16>(cls, {$ifdef fpc}@{$endif}ProcTest16, 16, [
+      GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+      ], [
+      GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+      ], GetCompValue(CompRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest17>(cls, {$ifdef fpc}@{$endif}ProcTest17, 17, [
+      GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+      ], [
+      GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+      ], GetCurrencyValue(CurrencyRes));
+{$endif NEEDS_POINTER_HELPER}
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest18>(cls, {$ifdef fpc}@{$endif}ProcTest18, 18, [
+      GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+      GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+      ], [], GetSingleValue(SingleAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest19>(cls, {$ifdef fpc}@{$endif}ProcTest19, 19, [
+      GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+      GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+      ], [], GetDoubleValue(DoubleAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest20>(cls, {$ifdef fpc}@{$endif}ProcTest20, 20, [
+      GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+      GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+      ], [], GetExtendedValue(ExtendedAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest21>(cls, {$ifdef fpc}@{$endif}ProcTest21, 21, [
+      GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+      GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+      ], [], GetCompValue(CompAddRes));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTest22>(cls, {$ifdef fpc}@{$endif}ProcTest22, 22, [
+      GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+      GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+      ], [], GetCurrencyValue(CurrencyAddRes));
+  finally
+    cls.Free;
+  end;
+end;
+
+procedure TTestInvoke.TestProcRecs;
+var
+  cls: TTestInterfaceClass;
+begin
+  cls := TTestInterfaceClass.Create;
+  try
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize1>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize2>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize3>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize4>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize5>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize6>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize7>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize8>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize9>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
+
+    {$ifdef fpc}specialize{$endif} GenDoProcInvoke<TProcVarTestRecSize10>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker,
+      [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
+      {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
+  finally
+    cls.Free;
+  end;
+end;
+
 begin
 {$ifdef fpc}
   RegisterTest(TTestInvoke);

packages/rtl-objpas/tests/tests.rtti.pas

@@ -55,6 +55,11 @@ type
 {$ifdef fpc}
     procedure TestMakeArrayOpen;
 {$endif}
+    procedure TestMakeSingle;
+    procedure TestMakeDouble;
+    procedure TestMakeExtended;
+    procedure TestMakeCurrency;
+    procedure TestMakeComp;
 
     procedure TestDataSize;
     procedure TestDataSizeEmpty;
@@ -482,8 +487,184 @@ begin
   CheckEquals(arr[0], 84);
   CheckEquals(arr[1], 128);
 end;
+
 {$endif}
 
+procedure TTestCase1.TestMakeSingle;
+var
+  fs: Single;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fs := 3.14;
+
+  TValue.Make(@fs, TypeInfo(fs), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fs);
+  Check(v.GetReferenceToRawData <> @fs);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeDouble;
+var
+  fd: Double;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fd := 3.14;
+
+  TValue.Make(@fd, TypeInfo(fd), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fd);
+  Check(v.GetReferenceToRawData <> @fd);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeExtended;
+var
+  fe: Extended;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fe := 3.14;
+
+  TValue.Make(@fe, TypeInfo(fe), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fe);
+  Check(v.GetReferenceToRawData <> @fe);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeCurrency;
+var
+  fcu: Currency;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fcu := 3.14;
+
+  TValue.Make(@fcu, TypeInfo(fcu), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fcu);
+  Check(v.AsCurrency=fcu);
+  Check(v.GetReferenceToRawData <> @fcu);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeComp;
+var
+  fco: Comp;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fco := 314;
+
+  TValue.Make(@fco, TypeInfo(fco), v);
+
+  if v.Kind <> tkFloat then
+    Exit;
+
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fco);
+  Check(v.GetReferenceToRawData <> @fco);
+
+  try
+    hadexcept := False;
+    CheckEquals(v.AsInt64, 314);
+  except
+    hadexcept := True;
+  end;
+
+  CheckFalse(hadexcept, 'Had signed type conversion exception');
+
+  try
+    hadexcept := False;
+    CheckEquals(v.AsUInt64, 314);
+  except
+    hadexcept := True;
+  end;
+
+  CheckFalse(hadexcept, 'Had unsigned type conversion exception');
+end;
+
 procedure TTestCase1.TestGetIsReadable;
 var
   c: TRttiContext;

packages/rtl-objpas/tests/tests.rtti.util.pas

@@ -0,0 +1,244 @@
+unit Tests.Rtti.Util;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Rtti;
+
+{$ifndef fpc}
+type
+  CodePointer = Pointer;
+
+  TValueHelper = record helper for TValue
+    function AsUnicodeString: UnicodeString;
+    function AsAnsiString: AnsiString;
+  end;
+{$endif}
+
+function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
+function EqualValues({$ifdef fpc}constref{$else}const [ref]{$endif} aValue1, aValue2: TValue): Boolean;
+
+function TypeKindToStr(aTypeKind: TTypeKind): String; inline;
+
+function GetInstValue(aValue: TObject): TValue;
+function GetPointerValue(aValue: Pointer): TValue;
+function GetIntValue(aValue: SizeInt): TValue;
+function GetAnsiString(const aValue: AnsiString): TValue;
+function GetShortString(const aValue: ShortString): TValue;
+function GetSingleValue(aValue: Single): TValue;
+function GetDoubleValue(aValue: Double): TValue;
+function GetExtendedValue(aValue: Extended): TValue;
+function GetCompValue(aValue: Comp): TValue;
+function GetCurrencyValue(aValue: Currency): TValue;
+function GetArray(const aArg: array of SizeInt): TValue;
+
+implementation
+
+uses
+  TypInfo, SysUtils;
+
+{$ifndef fpc}
+function TValueHelper.AsUnicodeString: UnicodeString;
+begin
+  Result := UnicodeString(AsString);
+end;
+
+function TValueHelper.AsAnsiString: AnsiString;
+begin
+  Result := AnsiString(AsString);
+end;
+{$endif}
+
+function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
+var
+  arrptr: Pointer;
+  len, i: SizeInt;
+begin
+  if aValue.Kind = tkDynArray then begin
+    { we need to decouple the source reference, so we're going to be a bit
+      cheeky here }
+    len := aValue.GetArrayLength;
+    arrptr := Nil;
+    DynArraySetLength(arrptr, aValue.TypeInfo, 1, @len);
+    TValue.Make(@arrptr, aValue.TypeInfo, Result);
+    for i := 0 to len - 1 do
+      Result.SetArrayElement(i, aValue.GetArrayElement(i));
+  end else
+    TValue.Make(aValue.GetReferenceToRawData, aValue.TypeInfo, Result);
+end;
+
+function EqualValues({$ifdef fpc}constref{$else}const [ref]{$endif} aValue1, aValue2: TValue): Boolean;
+var
+  td1, td2: PTypeData;
+  i: SizeInt;
+begin
+{$ifdef debug}
+  Writeln('Empty: ', aValue1.IsEmpty, ' ', aValue2.IsEmpty);
+  Writeln('Kind: ', aValue1.Kind, ' ', aValue2.Kind);
+  Writeln('Array: ', aValue1.IsArray, ' ', aValue2.IsArray);
+{$endif}
+  if aValue1.IsEmpty and aValue2.IsEmpty then
+    Result := True
+  else if aValue1.IsEmpty and not aValue2.IsEmpty then
+    Result := False
+  else if not aValue1.IsEmpty and aValue2.IsEmpty then
+    Result := False
+  else if aValue1.IsArray and aValue2.IsArray then begin
+    if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
+      Result := True;
+      for i := 0 to aValue1.GetArrayLength - 1 do
+        if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
+          Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4));
+          Result := False;
+          Break;
+        end;
+    end else
+      Result := False;
+  end else if aValue1.Kind = aValue2.Kind then begin
+    td1 := aValue1.TypeData;
+    td2 := aValue2.TypeData;
+    case aValue1.Kind of
+      tkBool:
+        Result := aValue1.AsBoolean xor not aValue2.AsBoolean;
+      tkSet:
+        if td1^.SetSize = td2^.SetSize then
+          if td1^.SetSize < SizeOf(SizeInt) then
+            Result := aValue1.AsOrdinal = aValue2.AsOrdinal
+          else
+            Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, td1^.SetSize)
+        else
+          Result := False;
+      tkEnumeration,
+      tkChar,
+      tkWChar,
+      tkUChar,
+      tkInt64,
+      tkInteger:
+        Result := aValue1.AsOrdinal = aValue2.AsOrdinal;
+      tkQWord:
+        Result := aValue1.AsUInt64 = aValue2.AsUInt64;
+      tkFloat:
+        if td1^.FloatType <> td2^.FloatType then
+          Result := False
+        else begin
+          case td1^.FloatType of
+            ftSingle,
+            ftDouble,
+            ftExtended:
+              Result := aValue1.AsExtended = aValue2.AsExtended;
+            ftComp:
+              Result := aValue1.AsInt64 = aValue2.AsInt64;
+            ftCurr:
+              Result := aValue1.AsCurrency = aValue2.AsCurrency;
+          end;
+        end;
+      tkSString,
+      tkUString,
+      tkAString,
+      tkWString:
+        Result := aValue1.AsString = aValue2.AsString;
+      tkDynArray,
+      tkArray:
+        if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
+          Result := True;
+          for i := 0 to aValue1.GetArrayLength - 1 do
+            if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
+              Result := False;
+              Break;
+            end;
+        end else
+          Result := False;
+      tkClass,
+      tkClassRef,
+      tkInterface,
+      tkInterfaceRaw,
+      tkPointer:
+        Result := PPointer(aValue1.GetReferenceToRawData)^ = PPointer(aValue2.GetReferenceToRawData)^;
+      tkProcVar:
+        Result := PCodePointer(aValue1.GetReferenceToRawData)^ = PCodePointer(aValue2.GetReferenceToRawData)^;
+      tkRecord,
+      tkObject,
+      tkMethod,
+      tkVariant: begin
+        if aValue1.DataSize = aValue2.DataSize then
+          Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, aValue1.DataSize)
+        else
+          Result := False;
+      end
+      else
+        Result := False;
+    end;
+  end else
+    Result := False;
+end;
+
+function TypeKindToStr(aTypeKind: TTypeKind): String;
+begin
+{$ifdef fpc}
+  Str(aTypeKind, Result);
+{$else}
+  Result := GetEnumName(TypeInfo(TTypeKind), Ord(aTypeKind));
+{$endif}
+end;
+
+function GetInstValue(aValue: TObject): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<TObject>(aValue);
+end;
+
+function GetPointerValue(aValue: Pointer): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Pointer>(aValue);
+end;
+
+function GetIntValue(aValue: SizeInt): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(aValue);
+end;
+
+function GetAnsiString(const aValue: AnsiString): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>(aValue);
+end;
+
+function GetShortString(const aValue: ShortString): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<ShortString>(aValue);
+end;
+
+function GetSingleValue(aValue: Single): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Single>(aValue);
+end;
+
+function GetDoubleValue(aValue: Double): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Double>(aValue);
+end;
+
+function GetExtendedValue(aValue: Extended): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Extended>(aValue);
+end;
+
+function GetCompValue(aValue: Comp): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Comp>(aValue);
+end;
+
+function GetCurrencyValue(aValue: Currency): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Currency>(aValue);
+end;
+
+{$ifdef fpc}
+function GetArray(const aArg: array of SizeInt): TValue;
+begin
+  Result := specialize OpenArrayToDynArrayValue<SizeInt>(aArg);
+end;
+{$endif}
+
+end.
+

rtl/objpas/classes/classes.inc

@@ -299,6 +299,9 @@ end;
 
 
 procedure ThreadQueueAppend(aEntry: TThread.PThreadQueueEntry; aQueueIfMain: Boolean);
+var
+  thd: TThread;
+  issync: Boolean;
 begin
   { do we really need a synchronized call? }
 {$ifdef FPC_HAS_FEATURE_THREADING}
@@ -310,6 +313,14 @@ begin
       Dispose(aEntry);
 {$ifdef FPC_HAS_FEATURE_THREADING}
   end else begin
+    { store thread and whether we're dealing with a synchronized event; the
+      event record itself might already be freed after the ThreadQueueLock is
+      released (in case of a Queue() call; for a Synchronize() call the record
+      will stay valid, thus accessing SyncEvent later on (if issync is true) is
+      okay) }
+    thd := aEntry^.Thread;
+    issync := Assigned(aEntry^.SyncEvent);
+
     System.EnterCriticalSection(ThreadQueueLock);
     try
       { add the entry to the thread queue }
@@ -325,10 +336,10 @@ begin
     { ensure that the main thread knows that something awaits }
     RtlEventSetEvent(SynchronizeTimeoutEvent);
     if assigned(WakeMainThread) then
-      WakeMainThread(aEntry^.Thread);
+      WakeMainThread(thd);
 
     { is this a Synchronize or Queue entry? }
-    if Assigned(aEntry^.SyncEvent) then begin
+    if issync then begin
       RtlEventWaitFor(aEntry^.SyncEvent);
       if Assigned(aEntry^.Exception) then
         raise aEntry^.Exception;
@@ -451,7 +462,7 @@ function CheckSynchronize(timeout : longint=0) : boolean;
 
 { assumes being called from GUI thread }
 var
-  ExceptObj: Exception;
+  ExceptObj: TObject;
   tmpentry: TThread.PThreadQueueEntry;
 
 begin
@@ -475,7 +486,7 @@ begin
     try
       ExecuteThreadQueueEntry(tmpentry);
     except
-      exceptobj := Exception(AcquireExceptionObject);
+      exceptobj := TObject(AcquireExceptionObject);
     end;
     { step 3: error handling and cleanup }
     if Assigned(tmpentry^.SyncEvent) then

rtl/objpas/classes/classesh.inc

@@ -1635,7 +1635,7 @@ type
       //ThreadProc: TThreadProcedure;
       Thread: TThread;
       ThreadID: TThreadID;
-      Exception: Exception;
+      Exception: TObject;
       SyncEvent: PRtlEvent;
       Next: PThreadQueueEntry;
     end;

tests/bench/bcase.pp

@@ -0,0 +1,2658 @@
+{$goto on}
+program bcase;
+
+{$mode objfpc}{$H+}
+
+uses
+  SysUtils;
+
+{ Utility functions }
+function GetRealTime(const st: TSystemTime): Real;
+  begin
+    Result := st.Hour*3600.0 + st.Minute*60.0 + st.Second + st.MilliSecond/1000.0;
+  end;
+
+function GetRealTime : Real;
+  var
+    st:TSystemTime;
+  begin
+    GetLocalTime(st);
+    result:=GetRealTime(st);
+  end;
+
+function IIf(Condition: Boolean; TrueRes, FalseRes: Integer): Integer; inline;
+  begin
+    if Condition then
+      Result := TrueRes
+    else
+      Result := FalseRes;
+  end;
+
+const
+  ITERATIONS = 33554432;
+
+  AES_S_Box: array[Byte] of Byte = (
+    $63, $7c, $77, $7b, $f2, $6b, $6f, $c5, $30, $01, $67, $2b, $fe, $d7, $ab, $76,
+    $ca, $82, $c9, $7d, $fa, $59, $47, $f0, $ad, $d4, $a2, $af, $9c, $a4, $72, $c0,
+    $b7, $fd, $93, $26, $36, $3f, $f7, $cc, $34, $a5, $e5, $f1, $71, $d8, $31, $15,
+    $04, $c7, $23, $c3, $18, $96, $05, $9a, $07, $12, $80, $e2, $eb, $27, $b2, $75,
+    $09, $83, $2c, $1a, $1b, $6e, $5a, $a0, $52, $3b, $d6, $b3, $29, $e3, $2f, $84,
+    $53, $d1, $00, $ed, $20, $fc, $b1, $5b, $6a, $cb, $be, $39, $4a, $4c, $58, $cf,
+    $d0, $ef, $aa, $fb, $43, $4d, $33, $85, $45, $f9, $02, $7f, $50, $3c, $9f, $a8,
+    $51, $a3, $40, $8f, $92, $9d, $38, $f5, $bc, $b6, $da, $21, $10, $ff, $f3, $d2,
+    $cd, $0c, $13, $ec, $5f, $97, $44, $17, $c4, $a7, $7e, $3d, $64, $5d, $19, $73,
+    $60, $81, $4f, $dc, $22, $2a, $90, $88, $46, $ee, $b8, $14, $de, $5e, $0b, $db,
+    $e0, $32, $3a, $0a, $49, $06, $24, $5c, $c2, $d3, $ac, $62, $91, $95, $e4, $79,
+    $e7, $c8, $37, $6d, $8d, $d5, $4e, $a9, $6c, $56, $f4, $ea, $65, $7a, $ae, $08,
+    $ba, $78, $25, $2e, $1c, $a6, $b4, $c6, $e8, $dd, $74, $1f, $4b, $bd, $8b, $8a,
+    $70, $3e, $b5, $66, $48, $03, $f6, $0e, $61, $35, $57, $b9, $86, $c1, $1d, $9e,
+    $e1, $f8, $98, $11, $69, $d9, $8e, $94, $9b, $1e, $87, $e9, $ce, $55, $28, $df,
+    $8c, $a1, $89, $0d, $bf, $e6, $42, $68, $41, $99, $2d, $0f, $b0, $54, $bb, $16
+  );
+
+  FirstWeighted: array[0..255] of Byte = (
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63, $63,
+    $ba, $78, $25, $2e, $1c, $a6, $b4, $c6, $e8, $dd, $74, $1f, $4b, $bd, $8b, $8a,
+    $70, $3e, $b5, $66, $48, $03, $f6, $0e, $61, $35, $57, $b9, $86, $c1, $1d, $9e,
+    $e1, $f8, $98, $11, $69, $d9, $8e, $94, $9b, $1e, $87, $e9, $ce, $55, $28, $df,
+    $8c, $a1, $89, $0d, $bf, $e6, $42, $68, $41, $99, $2d, $0f, $b0, $54, $bb, $16
+  );
+
+  LastWeighted: array[0..255] of Byte = (
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16, $16,
+    $ba, $78, $25, $2e, $1c, $a6, $b4, $c6, $e8, $dd, $74, $1f, $4b, $bd, $8b, $8a,
+    $70, $3e, $b5, $66, $48, $03, $f6, $0e, $61, $35, $57, $b9, $86, $c1, $1d, $9e,
+    $e1, $f8, $98, $11, $69, $d9, $8e, $94, $9b, $1e, $87, $e9, $ce, $55, $28, $df,
+    $8c, $a1, $89, $0d, $bf, $e6, $42, $68, $41, $99, $2d, $0f, $b0, $54, $bb, $16
+  );
+
+  AlmostFullExpected: array[0..255] of Byte = (
+    $63, $7c, $77, $7b, $f2, $6b, $6f, $c5, $30, $01, $67, $2b, $fe, $d7, $ab, $76,
+    $ca, $82, $c9, $7d, $fa, $59, $47, $f0, $ad, $d4, $a2, $af, $9c, $a4, $72, $c0,
+    $b7, $fd, $93, $26, $36, $3f, $f7, $cc, $34, $a5, $e5, $f1, $71, $d8, $31, $15,
+    $04, $c7, $23, $c3, $18, $96, $05, $9a, $07, $12, $80, $e2, $eb, $27, $b2, $75,
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
+    $d0, $ef, $aa, $fb, $43, $4d, $33, $85, $45, $f9, $02, $7f, $50, $3c, $9f, $a8,
+    $51, $a3, $40, $8f, $92, $9d, $38, $f5, $bc, $b6, $da, $21, $10, $ff, $f3, $d2,
+    $cd, $0c, $13, $ec, $5f, $97, $44, $17, $c4, $a7, $7e, $3d, $64, $5d, $19, $73,
+    $60, $81, $4f, $dc, $22, $2a, $90, $88, $46, $ee, $b8, $14, $de, $5e, $0b, $db,
+    $e0, $32, $3a, $0a, $49, $06, $24, $5c, $c2, $d3, $ac, $62, $91, $95, $e4, $79,
+    $e7, $c8, $37, $6d, $8d, $d5, $4e, $a9, $6c, $56, $f4, $ea, $65, $7a, $ae, $08,
+    $ba, $78, $25, $2e, $1c, $a6, $b4, $c6, $e8, $dd, $74, $1f, $4b, $bd, $8b, $8a,
+    $70, $3e, $b5, $66, $48, $03, $f6, $0e, $61, $35, $57, $b9, $86, $c1, $1d, $9e,
+    $e1, $f8, $98, $11, $69, $d9, $8e, $94, $9b, $1e, $87, $e9, $ce, $55, $28, $df,
+    $8c, $a1, $89, $0d, $bf, $e6, $42, $68, $41, $99, $2d, $0f, $b0, $54, $bb, $16
+  );
+
+type
+  TInstructionSet = ( { Truncated to 1024 entries }
+    A_NONE = -512, A_ADC, A_ADD, A_AND, A_BSF, A_BSR, A_BSWAP, A_BT, A_BTC, A_BTR, A_BTS,
+    A_CALL, A_CBW, A_CDQ, A_CLC, A_CLD, A_CLI, A_CLTS, A_CMC, A_CMP, A_CMPSB,
+    A_CMPSD, A_CMPSW, A_CMPXCHG, A_CMPXCHG486, A_CMPXCHG8B, A_CPUID, A_CWD, A_CWDE,
+    A_DEC, A_DIV, A_EMMS, A_ENTER, A_F2XM1, A_FABS, A_FADD, A_FADDP, A_FBLD, A_FBSTP,
+    A_FCHS, A_FCLEX,A_FCMOVB, A_FCMOVBE, A_FCMOVE, A_FCMOVNB, A_FCMOVNBE, A_FCMOVNE,
+    A_FCMOVNU, A_FCMOVU, A_FCOM, A_FCOMI, A_FCOMIP, A_FCOMP, A_FCOMPP, A_FCOS,
+    A_FDECSTP, A_FDISI, A_FDIV, A_FDIVP, A_FDIVR, A_FDIVRP, A_FEMMS, A_FENI, A_FFREE,
+    A_FIADD, A_FICOM, A_FICOMP, A_FIDIV, A_FIDIVR, A_FILD, A_FIMUL, A_FINCSTP,
+    A_FINIT, A_FIST, A_FISTP, A_FISTTP, A_FISUB, A_FISUBR, A_FLD, A_FLD1, A_FLDCW,
+    A_FLDENV, A_FLDL2E, A_FLDL2T, A_FLDLG2, A_FLDLN2, A_FLDPI, A_FLDZ, A_FMUL,
+    A_FMULP, A_FNCLEX, A_FNDISI, A_FNENI, A_FNINIT, A_FNOP, A_FNSAVE, A_FNSTCW,
+    A_FNSTENV, A_FNSTSW, A_FPATAN, A_FPREM, A_FPREM1, A_FPTAN, A_FRNDINT, A_FRSTOR,
+    A_FSAVE, A_FSCALE, A_FSETPM, A_FSIN, A_FSINCOS, A_FSQRT, A_FST, A_FSTCW,
+    A_FSTENV, A_FSTP, A_FSTSW, A_FSUB, A_FSUBP, A_FSUBR, A_FSUBRP, A_FTST, A_FUCOM,
+    A_FUCOMI, A_FUCOMIP, A_FUCOMP, A_FUCOMPP, A_FWAIT, A_FXAM, A_FXCH, A_FXTRACT,
+    A_FYL2X, A_FYL2XP1, A_HLT, A_IBTS, A_ICEBP, A_IDIV, A_IMUL, A_IN, A_INC, A_INSB,
+    A_INSD, A_INSW, A_INT, A_INT01, A_INT1, A_INT03, A_INT3, A_INVD, A_INVLPG,
+    A_IRET, A_IRETD, A_IRETW, A_IRETQ, A_JECXZ, A_JRCXZ, A_JMP, A_LAHF, A_LAR,
+    A_LCALL, A_LEA, A_LEAVE, A_LFS, A_LGDT, A_LGS, A_LIDT, A_LJMP, A_LLDT, A_LMSW,
+    A_LOADALL, A_LOADALL286, A_LOCK, A_LODSB, A_LODSD, A_LODSW, A_LOOP, A_LOOPE,
+    A_LOOPNE, A_LOOPNZ, A_LOOPZ, A_LSL, A_LSS, A_LTR, A_MONITOR, A_MOV, A_MOVD,
+    A_MOVQ, A_MOVSB, A_MOVSD, A_MOVSQ, A_MOVSW, A_MOVSX, A_MOVZX, A_MUL, A_MWAIT,
+    A_NEG, A_NOP, A_NOT, A_OR, A_OUT, A_OUTSB, A_OUTSD, A_OUTSW, A_PACKSSDW,
+    A_PACKSSWB, A_PACKUSWB, A_PADDB, A_PADDD, A_PADDSB, A_PADDSIW, A_PADDSW,
+    A_PADDUSB, A_PADDUSW, A_PADDW, A_PAND, A_PANDN, A_PAVEB, A_PAVGUSB, A_PCMPEQB,
+    A_PCMPEQD, A_PCMPEQW, A_PCMPGTB, A_PCMPGTD, A_PCMPGTW, A_PDISTIB, A_PF2ID,
+    A_PFACC, A_PFADD, A_PFCMPEQ, A_PFCMPGE, A_PFCMPGT, A_PFMAX, A_PFMIN, A_PFMUL,
+    A_PFRCP, A_PFRCPIT1, A_PFRCPIT2, A_PFRSQIT1, A_PFRSQRT, A_PFSUB, A_PFSUBR,
+    A_PI2FD, A_PMACHRIW, A_PMADDWD, A_PMAGW, A_PMULHRIW, A_PMULHRWA, A_PMULHRWC,
+    A_PMULHW, A_PMULLW, A_PMVGEZB, A_PMVLZB, A_PMVNZB, A_PMVZB, A_POP, A_POPF,
+    A_POPFW, A_POPFQ, A_POR, A_PREFETCH, A_PREFETCHW, A_PSLLD, A_PSLLDQ, A_PSLLQ,
+    A_PSLLW, A_PSRAD, A_PSRAW, A_PSRLD, A_PSRLQ, A_PSRLW, A_PSUBB, A_PSUBD, A_PSUBSB,
+    A_PSUBSIW, A_PSUBSW, A_PSUBUSB, A_PSUBUSW, A_PSUBW, A_PUNPCKHBW, A_PUNPCKHDQ,
+    A_PUNPCKHWD, A_PUNPCKLBW, A_PUNPCKLDQ, A_PUNPCKLWD, A_PUSH, A_PUSHF, A_PUSHFW,
+    A_PUSHFQ, A_PXOR, A_RCL, A_RCR, A_RDSHR, A_RDMSR, A_RDPMC, A_RDTSC, A_REP,
+    A_REPE, A_REPNE, A_REPNZ, A_REPZ, A_RET, A_RETF, A_RETN, A_RETW, A_RETFW,
+    A_RETNW, A_RETFD, A_RETQ, A_RETFQ, A_RETNQ, A_ROL, A_ROR, A_RSDC, A_RSLDT, A_RSM,
+    A_SAHF, A_SAL, A_SAR, A_SBB, A_SCASB, A_SCASD, A_SCASQ, A_SCASW, A_SEGCS,
+    A_SEGDS, A_SEGES, A_SEGFS, A_SEGGS, A_SEGSS, A_SGDT, A_SHL, A_SHLD, A_SHR,
+    A_SHRD, A_SIDT, A_SLDT, A_SMI, A_SMINT, A_SMINTOLD, A_SMSW, A_STC, A_STD, A_STI,
+    A_STOSB, A_STOSD, A_STOSW, A_STR, A_SUB, A_SVDC, A_SVLDT, A_SVTS, A_SYSCALL,
+    A_SYSENTER, A_SYSEXIT, A_SYSRET, A_TEST, A_UD1, A_UD2, A_UMOV, A_VERR, A_VERW,
+    A_WAIT, A_WBINVD, A_WRSHR, A_WRMSR, A_XADD, A_XBTS, A_XCHG, A_XLAT, A_XLATB,
+    A_XOR, A_XSTORE, A_XCRYPTECB, A_XCRYPTCBC, A_XCRYPTCFB, A_XCRYPTOFB, A_CMOVcc,
+    A_Jcc, A_SETcc, A_MOVS, A_CMPS, A_SCAS, A_LODS, A_STOS, A_INS, A_OUTS, A_ADDPS,
+    A_ADDSS, A_ANDNPS, A_ANDPS, A_CMPEQPS, A_CMPEQSS, A_CMPLEPS, A_CMPLESS,
+    A_CMPLTPS, A_CMPLTSS, A_CMPNEQPS, A_CMPNEQSS, A_CMPNLEPS, A_CMPNLESS,
+    A_CMPNLTPS, A_CMPNLTSS, A_CMPORDPS, A_CMPORDSS, A_CMPUNORDPS, A_CMPUNORDSS,
+    A_CMPPS, A_CMPSS, A_COMISS, A_CVTPI2PS, A_CVTPS2PI, A_CVTSI2SS, A_CVTSS2SI,
+    A_CVTTPS2PI, A_CVTTSS2SI, A_DIVPS, A_DIVSS, A_LDMXCSR, A_MAXPS, A_MAXSS, A_MINPS,
+    A_MINSS, A_MOVAPS, A_MOVHPS, A_MOVLHPS, A_MOVLPS, A_MOVHLPS, A_MOVMSKPS,
+    A_MOVNTPS, A_MOVSS, A_MOVUPS, A_MULPS, A_MULSS, A_ORPS, A_RCPPS, A_RCPSS,
+    A_RSQRTPS, A_RSQRTSS, A_SHUFPS, A_SQRTPS, A_SQRTSS, A_STMXCSR, A_SUBPS, A_SUBSS,
+    A_UCOMISS, A_UNPCKHPS, A_UNPCKLPS, A_XORPS, A_FXRSTOR, A_FXSAVE, A_PREFETCHNTA,
+    A_PREFETCHT0, A_PREFETCHT1, A_PREFETCHT2, A_SFENCE, A_MASKMOVQ, A_MOVNTQ,
+    A_PAVGB, A_PAVGW, A_PEXTRW, A_PINSRW, A_PMAXSW, A_PMAXUB, A_PMINSW, A_PMINUB,
+    A_PMOVMSKB, A_PMULHUW, A_PSADBW, A_PSHUFW, A_PFNACC, A_PFPNACC, A_PI2FW, A_PF2IW,
+    A_PSWAPD, A_FFREEP, A_MASKMOVDQU, A_CLFLUSH, A_MOVNTDQ, A_MOVNTI, A_MOVNTPD,
+    A_PAUSE, A_LFENCE, A_MFENCE, A_MOVDQA, A_MOVDQU, A_MOVDQ2Q, A_MOVQ2DQ, A_PADDQ,
+    A_PMULUDQ, A_PSHUFD, A_PSHUFHW, A_PSHUFLW, A_PSRLDQ, A_PSUBQ, A_PUNPCKHQDQ,
+    A_PUNPCKLQDQ, A_ADDPD, A_ADDSD, A_ANDNPD, A_ANDPD, A_CMPEQPD, A_CMPEQSD,
+    A_CMPLEPD, A_CMPLESD, A_CMPLTPD, A_CMPLTSD, A_CMPNEQPD, A_CMPNEQSD, A_CMPNLEPD,
+    A_CMPNLESD, A_CMPNLTPD, A_CMPNLTSD, A_CMPORDPD, A_CMPORDSD, A_CMPUNORDPD,
+    A_CMPUNORDSD, A_CMPPD, A_COMISD, A_CVTDQ2PD, A_CVTDQ2PS, A_CVTPD2DQ, A_CVTPD2PI,
+    A_CVTPD2PS, A_CVTPI2PD, A_CVTPS2DQ, A_CVTPS2PD, A_CVTSD2SI, A_CVTSD2SS,
+    A_CVTSI2SD, A_CVTSS2SD, A_CVTTPD2PI, A_CVTTPD2DQ, A_CVTTPS2DQ, A_CVTTSD2SI,
+    A_DIVPD, A_DIVSD, A_MAXPD, A_MAXSD, A_MINPD, A_MINSD, A_MOVAPD, A_MOVHPD,
+    A_MOVLPD, A_MOVMSKPD, A_MOVUPD, A_MULPD, A_MULSD, A_ORPD, A_SHUFPD, A_SQRTPD,
+    A_SQRTSD, A_SUBPD, A_SUBSD, A_UCOMISD, A_UNPCKHPD, A_UNPCKLPD, A_XORPD,
+    A_ADDSUBPD, A_ADDSUBPS, A_HADDPD, A_HADDPS, A_HSUBPD, A_HSUBPS, A_LDDQU,
+    A_MOVDDUP, A_MOVSHDUP, A_MOVSLDUP, A_VMREAD, A_VMWRITE, A_VMCALL, A_VMLAUNCH,
+    A_VMRESUME, A_VMXOFF, A_VMXON, A_VMCLEAR, A_VMPTRLD, A_VMPTRST, A_VMRUN,
+    A_VMMCALL, A_VMLOAD, A_VMSAVE, A_STGI, A_CLGI, A_SKINIT, A_INVLPGA, A_MONTMUL,
+    A_XSHA1, A_XSHA256, A_DMINT, A_RDM, A_MOVABS, A_MOVSXD, A_CQO, A_CDQE,
+    A_CMPXCHG16B, A_MOVNTSS, A_MOVNTSD, A_INSERTQ, A_EXTRQ, A_LZCNT, A_PABSB,
+    A_PABSW, A_PABSD, A_PALIGNR, A_PHADDW, A_PHADDD, A_PHADDSW, A_PHSUBW, A_PHSUBD,
+    A_PHSUBSW, A_PMADDUBSW, A_PMULHRSW, A_PSHUFB, A_PSIGNB, A_PSIGNW, A_PSIGND,
+    A_BLENDPS, A_BLENDPD, A_BLENDVPS, A_BLENDVPD, A_DPPS, A_DPPD, A_EXTRACTPS,
+    A_INSERTPS, A_MOVNTDQA, A_MPSADBW, A_PACKUSDW, A_PBLENDVB, A_PBLENDW, A_PCMPEQQ,
+    A_PEXTRB, A_PEXTRD, A_PEXTRQ, A_PHMINPOSUW, A_PINSRB, A_PINSRD, A_PINSRQ, A_PMAXSB,
+    A_PMAXSD, A_PMAXUD, A_PMAXUW, A_PMINSB, A_PMINSD, A_PMINUW, A_PMINUD, A_PMOVSXBW,
+    A_PMOVSXBD, A_PMOVSXBQ, A_PMOVSXWD, A_PMOVSXWQ, A_PMOVSXDQ, A_PMOVZXBW, A_PMOVZXBD,
+    A_PMOVZXBQ, A_PMOVZXWD, A_PMOVZXWQ, A_PMOVZXDQ, A_PMULDQ, A_PMULLD, A_PTEST,
+    A_ROUNDPS, A_ROUNDPD, A_ROUNDSS, A_ROUNDSD, A_CRC32, A_PCMPESTRI, A_PCMPESTRM,
+    A_PCMPISTRI, A_PCMPISTRM, A_PCMPGTQ, A_POPCNT, A_AESENC, A_AESENCLAST, A_AESDEC,
+    A_AESDECLAST, A_AESIMC, A_AESKEYGENASSIST, A_RDTSCP, A_STOSQ, A_LODSQ, A_CMPSQ,
+    A_VADDPD, A_VADDPS, A_VADDSD, A_VADDSS, A_VADDSUBPD, A_VADDSUBPS, A_VAESDEC,
+    A_VAESDECLAST, A_VAESENC, A_VAESENCLAST, A_VAESIMC, A_VAESKEYGENASSIST, A_VANDNPD,
+    A_VANDNPS, A_VANDPD, A_VANDPS, A_VBLENDPD, A_VBLENDPS, A_VBLENDVPD, A_VBLENDVPS,
+    A_VBROADCASTF128, A_VBROADCASTSD, A_VBROADCASTSS, A_VCMPEQPS, A_VCMPLTPS,
+    A_VCMPLEPS, A_VCMPUNORDPS, A_VCMPNEQPS, A_VCMPNLTPS, A_VCMPNLEPS, A_VCMPORDPS,
+    A_VCMPEQ_UQPS, A_VCMPNGEPS, A_VCMPNGTPS, A_VCMPFALSEPS, A_VCMPNEQ_OQPS,
+    A_VCMPGEPS, A_VCMPGTPS, A_VCMPTRUEPS, A_VCMPEQ_OSPS, A_VCMPLT_OQPS, A_VCMPLE_OQPS,
+    A_VCMPUNORD_SPS, A_VCMPNEQ_USPS, A_VCMPNLT_UQPS, A_VCMPNLE_UQPS, A_VCMPORD_SPS,
+    A_VCMPEQ_USPS, A_VCMPNGE_UQPS, A_VCMPNGT_UQPS, A_VCMPFALSE_OSPS, A_VCMPNEQ_OSPS,
+    A_VCMPGE_OQPS, A_VCMPGT_OQPS, A_VCMPTRUE_USPS, A_VCMPEQPD, A_VCMPLTPD, A_VCMPLEPD,
+    A_VCMPUNORDPD, A_VCMPNEQPD, A_VCMPNLTPD, A_VCMPNLEPD, A_VCMPORDPD, A_VCMPEQ_UQPD,
+    A_VCMPNGEPD, A_VCMPNGTPD, A_VCMPFALSEPD, A_VCMPNEQ_OQPD, A_VCMPGEPD, A_VCMPGTPD,
+    A_VCMPTRUEPD, A_VCMPEQ_OSPD, A_VCMPLT_OQPD, A_VCMPLE_OQPD, A_VCMPUNORD_SPD,
+    A_VCMPNEQ_USPD, A_VCMPNLT_UQPD, A_VCMPNLE_UQPD, A_VCMPORD_SPD, A_VCMPEQ_USPD,
+    A_VCMPNGE_UQPD, A_VCMPNGT_UQPD, A_VCMPFALSE_OSPD, A_VCMPNEQ_OSPD, A_VCMPGE_OQPD,
+    A_VCMPGT_OQPD, A_VCMPTRUE_USPD, A_VCMPPD, A_VCMPPS, A_VCMPSD, A_VCMPSS, A_VCOMISD,
+    A_VCOMISS, A_VCVTDQ2PD, A_VCVTDQ2PS, A_VCVTPD2DQ, A_VCVTPD2PS, A_VCVTPS2DQ,
+    A_VCVTPS2PD, A_VCVTSD2SI, A_VCVTSD2SS, A_VCVTSI2SD, A_VCVTSI2SS, A_VCVTSS2SD,
+    A_VCVTSS2SI, A_VCVTTPD2DQ, A_VCVTTPS2DQ, A_VCVTTSD2SI, A_VCVTTSS2SI, A_VDIVPD,
+    A_VDIVPS, A_VDIVSD, A_VDIVSS, A_VDPPD, A_VDPPS, A_VEXTRACTF128, A_VEXTRACTPS,
+    A_VHADDPD, A_VHADDPS, A_VHSUBPD, A_VHSUBPS, A_VINSERTF128, A_VINSERTPS, A_VLDDQU,
+    A_VLDMXCSR, A_VMASKMOVDQU, A_VMASKMOVPD, A_VMASKMOVPS, A_VMAXPD, A_VMAXPS,
+    A_VMAXSD, A_VMAXSS, A_VMINPD, A_VMINPS, A_VMINSD, A_VMINSS, A_VMOVAPD, A_VMOVAPS,
+    A_VMOVD, A_VMOVDDUP, A_VMOVDQA, A_VMOVDQU, A_VMOVHLPS, A_VMOVHPD, A_VMOVHPS,
+    A_VMOVLHPS, A_VMOVLPD, A_VMOVLPS, A_VMOVMSKPD, A_VMOVMSKPS, A_VMOVNTDQ,
+    A_VMOVNTDQA, A_VMOVNTPD, A_VMOVNTPS, A_VMOVQ, A_VMOVSD, A_VMOVSHDUP, A_VMOVSLDUP,
+    A_VMOVSS, A_VMOVUPD, A_VMOVUPS, A_VMPSADBW, A_VMULPD, A_VMULPS, A_VMULSD,
+    A_VMULSS, A_VORPD, A_VORPS, A_VPABSB, A_VPABSD, A_VPABSW, A_VPACKSSDW,
+    A_VPACKSSWB, A_VPACKUSDW, A_VPACKUSWB, A_VPADDB, A_VPADDD, A_VPADDQ, A_VPADDSB,
+    A_VPADDSW, A_VPADDUSB, A_VPADDUSW, A_VPADDW, A_VPALIGNR, A_VPAND, A_VPANDN,
+    A_VPAVGB, A_VPAVGW, A_VPBLENDVB, A_VPBLENDW, A_VPCLMULQDQ, A_VPCMPEQB, A_VPCMPEQD,
+    A_VPCMPEQQ, A_VPCMPEQW, A_VPCMPESTRI, A_VPCMPESTRM, A_VPCMPGTB, A_VPCMPGTD,
+    A_VPCMPGTQ, A_VPCMPGTW, A_VPCMPISTRI, A_VPCMPISTRM, A_VPERM2F128, A_VPERMILPD,
+    A_VPERMILPS, A_VPEXTRB, A_VPEXTRD, A_VPEXTRQ, A_VPEXTRW, A_VPHADDD, A_VPHADDSW,
+    A_VPHADDW, A_VPHMINPOSUW, A_VPHSUBD, A_VPHSUBSW, A_VPHSUBW, A_VPINSRB, A_VPINSRD,
+    A_VPINSRQ, A_VPINSRW, A_VPMADDUBSW, A_VPMADDWD, A_VPMAXSB, A_VPMAXSD, A_VPMAXSW,
+    A_VPMAXUB, A_VPMAXUD, A_VPMAXUW, A_VPMINSB, A_VPMINSD, A_VPMINSW, A_VPMINUB,
+    A_VPMINUD, A_VPMINUW, A_VPMOVMSKB, A_VPMOVSXBD, A_VPMOVSXBQ, A_VPMOVSXBW,
+    A_VPMOVSXDQ, A_VPMOVSXWD, A_VPMOVSXWQ, A_VPMOVZXBD, A_VPMOVZXBQ, A_VPMOVZXBW,
+    A_VPMOVZXDQ, A_VPMOVZXWD, A_VPMOVZXWQ, A_VPMULDQ, A_VPMULHRSW, A_VPMULHUW,
+    A_VPMULHW, A_VPMULLD, A_VPMULLW, A_VPMULUDQ, A_VPOR, A_VPSADBW, A_VPSHUFB,
+    A_VPSHUFD, A_VPSHUFHW, A_VPSHUFLW, A_VPSIGNB, A_VPSIGND, A_VPSIGNW, A_VPSLLD,
+    A_VPSLLDQ, A_VPSLLQ, A_VPSLLW, A_VPSRAD, A_VPSRAW, A_VPSRLD, A_VPSRLDQ, A_VPSRLQ,
+    A_VPSRLW, A_VPSUBB, A_VPSUBD, A_VPSUBQ, A_VPSUBSB, A_VPSUBSW, A_VPSUBUSB,
+    A_VPSUBUSW, A_VPSUBW, A_VPTEST, A_VPUNPCKHBW, A_VPUNPCKHDQ, A_VPUNPCKHQDQ,
+    A_VPUNPCKHWD, A_VPUNPCKLBW, A_VPUNPCKLDQ, A_VPUNPCKLQDQ, A_VPUNPCKLWD, A_VPXOR,
+    A_VRCPPS, A_VRCPSS, A_VROUNDPD, A_VROUNDPS, A_VROUNDSD, A_VROUNDSS, A_VRSQRTPS,
+    A_VRSQRTSS, A_VSHUFPD, A_VSHUFPS, A_VSQRTPD, A_VSQRTPS, A_VSQRTSD, A_VSQRTSS,
+    A_VSTMXCSR, A_VSUBPD, A_VSUBPS, A_VSUBSD, A_VSUBSS, A_VTESTPD, A_VTESTPS,
+    A_VUCOMISD, A_VUCOMISS, A_VUNPCKHPD, A_VUNPCKHPS, A_VUNPCKLPD, A_VUNPCKLPS,
+    A_VXORPD, A_VXORPS, A_VZEROALL, A_VZEROUPPER, A_ANDN, A_BEXTR, A_TZCNT, A_BZHI,
+    A_MULX, A_PDEP, A_PEXT, A_RORX, A_SARX, A_SHLX, A_SHRX, A_VBROADCASTI128,
+    A_VEXTRACTI128, A_VINSERTI128, A_VPBLENDD, A_VPBROADCASTB, A_VPBROADCASTD,
+    A_VPBROADCASTQ, A_VPBROADCASTW, A_VPERM2I128, A_VPERMD);
+
+const
+  ExtremeRange1Expected: array[0..1023] of Byte = (
+    $00, $00, $00, $01, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 0 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 16 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 32 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 48 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 64 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 80 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 96 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 112 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 128 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $09, { 144 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 160 }
+    $00, $00, $00, $00, $00, $00, $00, $02, $00, $00, $00, $08, $00, $00, $03, $03, { 176 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 192 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 208 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 224 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 240 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 256 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 272 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 288 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $0B, $00, $00, $00, $00, { 304 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $0B, $00, $00, $00, $00, $00, $00, { 320 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $0A, $00, $00, $00, $00, $00, { 336 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 352 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $0C, $00, $00, $00, $00, $00, $00, { 368 }
+    $00, $00, $07, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 384 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 400 }
+    $00, $00, $00, $00, $00, $05, $00, $00, $00, $00, $00, $00, $08, $05, $00, $07, { 416 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 432 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 448 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 464 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 480 }
+    $07, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 496 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 512 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $05, $00, $00, $00, $05, { 528 }
+    $00, $07, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 544 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 560 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 576 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 592 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 608 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 624 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 640 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 656 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $06, $06, $00, $00, $00, $00, { 672 }
+    $00, $00, $00, $00, $00, $00, $06, $06, $00, $00, $00, $00, $00, $00, $00, $00, { 688 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 704 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 720 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 736 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 752 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 768 }
+    $00, $00, $00, $00, $00, $00, $00, $06, $06, $00, $00, $00, $00, $00, $00, $00, { 784 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 800 }
+    $04, $04, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 816 }
+    $00, $00, $00, $08, $00, $00, $08, $04, $04, $00, $00, $00, $06, $06, $06, $06, { 832 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 848 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 864 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 880 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 896 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 912 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 928 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 944 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 960 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $06, $06, $00, { 976 }
+    $00, $00, $00, $00, $00, $00, $00, $06, $06, $00, $00, $00, $00, $00, $00, $00, { 992 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00  { 1008 }
+  );
+
+  ExtremeRange2Expected: array[0..1023] of Byte = (
+    $00, $00, $00, $01, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 0 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 16 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 32 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 48 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 64 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 80 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 96 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 112 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 128 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $09, { 144 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 160 }
+    $00, $00, $00, $00, $00, $00, $00, $02, $00, $00, $00, $26, $00, $00, $0D, $03, { 176 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 192 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 208 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 224 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 240 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 256 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 272 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 288 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $0B, $00, $00, $00, $00, { 304 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $27, $00, $00, $00, $00, $00, $00, { 320 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $0A, $00, $00, $00, $00, $00, { 336 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 352 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $0C, $00, $00, $00, $00, $00, $00, { 368 }
+    $00, $00, $07, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 384 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 400 }
+    $00, $00, $00, $00, $00, $12, $00, $00, $00, $00, $00, $00, $08, $05, $00, $22, { 416 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 432 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 448 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 464 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 480 }
+    $23, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 496 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 512 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $11, $00, $00, $00, $13, { 528 }
+    $00, $21, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 544 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 560 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 576 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 592 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 608 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 624 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 640 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 656 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $1A, $1B, $00, $00, $00, $00, { 672 }
+    $00, $00, $00, $00, $00, $00, $1C, $1D, $00, $00, $00, $00, $00, $00, $00, $00, { 688 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 704 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 720 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 736 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 752 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 768 }
+    $00, $00, $00, $00, $00, $00, $00, $14, $15, $00, $00, $00, $00, $00, $00, $00, { 784 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 800 }
+    $0F, $0E, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 816 }
+    $00, $00, $00, $24, $00, $00, $25, $04, $10, $00, $00, $00, $18, $19, $1E, $1F, { 832 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 848 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 864 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 880 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 896 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 912 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 928 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 944 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 960 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $16, $17, $00, { 976 }
+    $00, $00, $00, $00, $00, $00, $00, $20, $06, $00, $00, $00, $00, $00, $00, $00, { 992 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00  { 1008 }
+  );
+
+  ExtremeRange3Expected: array[0..1023] of Byte = (
+    $00, $00, $44, $01, $3F, $40, $00, $00, $00, $41, $42, $00, $00, $00, $00, $00, { 0 }
+    $00, $00, $00, $45, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 16 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 32 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 48 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 64 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 80 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 96 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 112 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 128 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $09, { 144 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 160 }
+    $00, $00, $00, $00, $00, $00, $00, $02, $00, $00, $00, $26, $00, $00, $0D, $03, { 176 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 192 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 208 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 224 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 240 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 256 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 272 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 288 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $0B, $00, $00, $00, $00, { 304 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $27, $00, $00, $00, $00, $00, $00, { 320 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $0A, $00, $00, $00, $00, $00, { 336 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 352 }
+    $00, $43, $00, $00, $00, $00, $00, $00, $00, $0C, $00, $00, $00, $00, $00, $00, { 368 }
+    $00, $00, $07, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 384 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 400 }
+    $00, $00, $00, $00, $00, $12, $00, $00, $00, $00, $00, $00, $08, $05, $00, $22, { 416 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 432 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 448 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 464 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 480 }
+    $23, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 496 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 512 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $11, $00, $00, $00, $13, { 528 }
+    $00, $21, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 544 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 560 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 576 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 592 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $33, $34, $00, $00, $00, { 608 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 624 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 640 }
+    $00, $00, $00, $2E, $2F, $30, $31, $32, $00, $00, $00, $00, $00, $00, $00, $00, { 656 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $2C, $2D, $1A, $1B, $00, $00, $35, $36, { 672 }
+    $37, $38, $39, $3A, $00, $00, $1C, $1D, $00, $00, $00, $00, $29, $00, $00, $00, { 688 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 704 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 720 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 736 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 752 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 768 }
+    $00, $00, $00, $00, $00, $00, $00, $14, $15, $00, $00, $00, $00, $00, $00, $00, { 784 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 800 }
+    $0F, $0E, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 816 }
+    $00, $00, $00, $24, $00, $00, $25, $04, $10, $00, $00, $00, $18, $19, $1E, $1F, { 832 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 848 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 864 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 880 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 896 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 912 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $3B, $3C, $3D, $3E, $00, $00, $00, { 928 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 944 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, { 960 }
+    $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $16, $17, $00, { 976 }
+    $00, $00, $00, $00, $00, $00, $00, $20, $06, $00, $00, $00, $00, $00, $00, $28, { 992 }
+    $00, $00, $00, $00, $46, $47, $2A, $00, $00, $00, $00, $00, $00, $00, $00, $2B  { 1008 }
+  );
+
+{ TTestAncestor }
+type
+  TTestAncestor = class
+    private
+      FStartTime: Real;
+      FEndTime: Real;
+      FAvgTime: Real;
+      procedure SetStartTime;
+      procedure SetEndTime;
+    protected
+      procedure DoTestIteration(Iteration: Integer); virtual; abstract;
+    public
+      constructor Create; virtual;
+      destructor Destroy; override;
+      procedure Run;
+      function TestTitle: shortstring; virtual; abstract;
+      function WriteResults: Boolean; virtual; abstract;
+      property RunTime: Real read FAvgTime;
+  end;
+
+  TTestClass = class of TTestAncestor;
+
+  TByteTest = class(TTestAncestor)
+    protected
+      FResultStorage: array[Byte] of Byte;
+  end;
+
+  TWordTest = class(TTestAncestor)
+    protected
+      FResultStorage: array[Word] of Byte;
+  end;
+
+  TMappedTest = class(TByteTest)
+    protected
+      procedure DoMapping(Index, Input: Integer); virtual; abstract;
+  end;
+
+  TCompleteByteRange = class(TMappedTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+      procedure DoMapping(Index, Input: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TCompleteByteRangeFirstWeighted = class(TCompleteByteRange)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TCompleteByteRangeLastWeighted = class(TCompleteByteRange)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TAlmostFullByteRange = class(TMappedTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+      procedure DoMapping(Index, Input: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TAlmostFullByteRangeFirstWeighted = class(TAlmostFullByteRange)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TAlmostFullByteRangeLastWeighted = class(TAlmostFullByteRange)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWithDefault = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWithDefaultUnlikely = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWithDefaultWeighted = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWithElse = class(TSingleEntryWithDefault)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+  end;
+
+  TSingleEntryWithElseUnlikely = class(TSingleEntryWithDefaultUnlikely)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+  end;
+
+  TSingleEntryWithElseWeighted = class(TSingleEntryWithDefaultWeighted)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+  end;
+
+  TSingleEntryAtZeroWithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryAtMinus1WithDefault = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryAtMinus4WithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWith0To5RangeWithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWith0To50RangeWithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWith1To5RangeWithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWith1To50RangeWithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWithMinus1To5RangeWithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSingleEntryWithMinus1To50RangeWithElse = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TExtremeRange1 = class(TWordTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TExtremeRange2 = class(TWordTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TExtremeRange3 = class(TWordTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TExtremeRange4 = class(TWordTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataTest1 = class(TWordTest)
+    protected
+      procedure DoCaseBlock(Index: Integer; Input: TInstructionSet); inline;
+  end;
+
+  TSparseDataEqual1 = class(TSparseDataTest1)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataMOVWeighted1 = class(TSparseDataTest1)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataMidpointWeighted1 = class(TSparseDataTest1)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataTest2 = class(TWordTest)
+    protected
+      procedure DoCaseBlock(Index: Integer; Input: TInstructionSet); inline;
+  end;
+
+  TSparseDataEqual2 = class(TSparseDataTest2)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataMOVWeighted2 = class(TSparseDataTest2)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataMidpointWeighted2 = class(TSparseDataTest2)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataTest3 = class(TWordTest)
+    protected
+      procedure DoCaseBlock(Index: Integer; Input: TInstructionSet); inline;
+  end;
+
+  TSparseDataEqual3 = class(TSparseDataTest3)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataMOVWeighted3 = class(TSparseDataTest3)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TSparseDataMidpointWeighted3 = class(TSparseDataTest3)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TLinearListDependsOnInput = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+  TCStyleCascade = class(TByteTest)
+    protected
+      procedure DoTestIteration(Iteration: Integer); override;
+    public
+      function TestTitle: shortstring; override;
+      function WriteResults: Boolean; override;
+  end;
+
+{ TTestAncestor }
+constructor TTestAncestor.Create;
+  begin
+    FStartTime := 0;
+    FEndTime := 0;
+    FAvgTime := 0;
+  end;
+
+destructor TTestAncestor.Destroy;
+  begin
+    inherited Destroy;
+  end;
+
+procedure TTestAncestor.SetStartTime;
+  begin
+    FStartTime := GetRealTime();
+  end;
+
+procedure TTestAncestor.SetEndTime;
+  begin
+    FEndTime := GetRealTime();
+    if FEndTime < FStartTime then { Happens if the test runs past midnight }
+      FEndTime := FEndTime + 86400.0;
+  end;
+
+procedure TTestAncestor.Run;
+  var
+    X: Integer;
+  begin
+    SetStartTime;
+    for X := 0 to ITERATIONS - 1 do
+      DoTestIteration(X);
+
+    SetEndTime;
+
+    FAvgTime := FEndTime - FStartTime;
+  end;
+
+{ TCompleteByteRange }
+function TCompleteByteRange.TestTitle: shortstring;
+  begin
+    Result := 'Byte domain, entirely covered; equal polling';
+  end;
+
+function TCompleteByteRange.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> AES_S_Box[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(AES_S_Box[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TCompleteByteRange.DoMapping(Index, Input: Integer);
+  begin
+    case Input of
+      { First row of S-Box (except zero) }
+      $00: FResultStorage[Index] := $63;
+      $01: FResultStorage[Index] := $7c;
+      $02: FResultStorage[Index] := $77;
+      $03: FResultStorage[Index] := $7b;
+      $04: FResultStorage[Index] := $f2;
+      $05: FResultStorage[Index] := $6b;
+      $06: FResultStorage[Index] := $6f;
+      $07: FResultStorage[Index] := $c5;
+      $08: FResultStorage[Index] := $30;
+      $09: FResultStorage[Index] := $01;
+      $0A: FResultStorage[Index] := $67;
+      $0B: FResultStorage[Index] := $2b;
+      $0C: FResultStorage[Index] := $fe;
+      $0D: FResultStorage[Index] := $d7;
+      $0E: FResultStorage[Index] := $ab;
+      $0F: FResultStorage[Index] := $76;
+      {Last row of S-Box }
+      $F0: FResultStorage[Index] := $8c;
+      $F1: FResultStorage[Index] := $a1;
+      $F2: FResultStorage[Index] := $89;
+      $F3: FResultStorage[Index] := $0d;
+      $F4: FResultStorage[Index] := $bf;
+      $F5: FResultStorage[Index] := $e6;
+      $F6: FResultStorage[Index] := $42;
+      $F7: FResultStorage[Index] := $68;
+      $F8: FResultStorage[Index] := $41;
+      $F9: FResultStorage[Index] := $99;
+      $FA: FResultStorage[Index] := $2d;
+      $FB: FResultStorage[Index] := $0f;
+      $FC: FResultStorage[Index] := $b0;
+      $FD: FResultStorage[Index] := $54;
+      $FE: FResultStorage[Index] := $bb;
+      $FF: FResultStorage[Index] := $16;
+      { Everything else }
+      $10..$EF: FResultStorage[Index] := AES_S_Box[Input];
+    end;
+  end;
+
+procedure TCompleteByteRange.DoTestIteration(Iteration: Integer);
+  var
+    Input: Byte;
+  begin
+    Input := Iteration and $FF;
+    DoMapping(Input, Input);
+  end;
+
+{ TCompleteByteRangeFirstWeighted }
+
+function TCompleteByteRangeFirstWeighted.TestTitle: shortstring;
+  begin
+    Result := 'Byte domain, entirely covered; first weighted';
+  end;
+
+function TCompleteByteRangeFirstWeighted.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> FirstWeighted[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(FirstWeighted[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TCompleteByteRangeFirstWeighted.DoTestIteration(Iteration: Integer);
+  var
+    Input: Byte;
+  begin
+    Input := Iteration and $FF;
+    if Input < $C0 then
+      DoMapping(Input, 0)
+    else
+      DoMapping(Input, Input);
+  end;
+
+{ TCompleteByteRangeLastWeighted }
+
+function TCompleteByteRangeLastWeighted.TestTitle: shortstring;
+  begin
+    Result := 'Byte domain, entirely covered; last weighted';
+  end;
+
+function TCompleteByteRangeLastWeighted.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> LastWeighted[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(LastWeighted[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TCompleteByteRangeLastWeighted.DoTestIteration(Iteration: Integer);
+  var
+    Input: Byte;
+  begin
+    Input := Iteration and $FF;
+    if Input < $C0 then
+      DoMapping(Input, $FF)
+    else
+      DoMapping(Input, Input);
+  end;
+
+{ TAlmostFullByteRange }
+
+function TAlmostFullByteRange.TestTitle: shortstring;
+  begin
+    Result := 'Byte domain, almost entirely covered; equal polling';
+  end;
+
+function TAlmostFullByteRange.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> AlmostFullExpected[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(AlmostFullExpected[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TAlmostFullByteRange.DoMapping(Index, Input: Integer);
+  begin
+    case Input of
+      { First row of S-Box }
+      $00: FResultStorage[Index] := $63;
+      $01: FResultStorage[Index] := $7c;
+      $02: FResultStorage[Index] := $77;
+      $03: FResultStorage[Index] := $7b;
+      $04: FResultStorage[Index] := $f2;
+      $05: FResultStorage[Index] := $6b;
+      $06: FResultStorage[Index] := $6f;
+      $07: FResultStorage[Index] := $c5;
+      $08: FResultStorage[Index] := $30;
+      $09: FResultStorage[Index] := $01;
+      $0A: FResultStorage[Index] := $67;
+      $0B: FResultStorage[Index] := $2b;
+      $0C: FResultStorage[Index] := $fe;
+      $0D: FResultStorage[Index] := $d7;
+      $0E: FResultStorage[Index] := $ab;
+      $0F: FResultStorage[Index] := $76;
+      { Other rows }
+      $10..$3F: FResultStorage[Index] := AES_S_Box[Input];
+      $60..$FF: FResultStorage[Index] := AES_S_Box[Input];
+      { Zeroed rows }
+      else FResultStorage[Index] := $00;
+    end;
+  end;
+
+procedure TAlmostFullByteRange.DoTestIteration(Iteration: Integer);
+  var
+    Input: Byte;
+  begin
+    Input := Iteration and $FF;
+    DoMapping(Input, Input);
+  end;
+
+{ TAlmostFullByteRangeFirstWeighted }
+
+function TAlmostFullByteRangeFirstWeighted.TestTitle: shortstring;
+  begin
+    Result := 'Byte domain, almost entirely covered; first weighted';
+  end;
+
+function TAlmostFullByteRangeFirstWeighted.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> FirstWeighted[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(FirstWeighted[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TAlmostFullByteRangeFirstWeighted.DoTestIteration(Iteration: Integer);
+  var
+    Input: Byte;
+  begin
+    Input := Iteration and $FF;
+    if Input < $C0 then
+      DoMapping(Input, 0)
+    else
+      DoMapping(Input, Input);
+  end;
+
+{ TAlmostFullByteRangeLastWeighted }
+
+function TAlmostFullByteRangeLastWeighted.TestTitle: shortstring;
+  begin
+    Result := 'Byte domain, almost entirely covered; last weighted';
+  end;
+
+function TAlmostFullByteRangeLastWeighted.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> LastWeighted[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(LastWeighted[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TAlmostFullByteRangeLastWeighted.DoTestIteration(Iteration: Integer);
+  var
+    Input: Byte;
+  begin
+    Input := Iteration and $FF;
+    if Input < $C0 then
+      DoMapping(Input, $FF)
+    else
+      DoMapping(Input, Input);
+  end;
+
+{ TSingleEntryWithDefault }
+function TSingleEntryWithDefault.TestTitle: shortstring;
+  begin
+    Result := 'Single entry with default value; 1/256 match chance';
+  end;
+
+function TSingleEntryWithDefault.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> IIf(X = 71, 1, 0) then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(IIf(X = 71, 1, 0), 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryWithDefault.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    FResultStorage[Index] := 0;
+    case Index of
+      71: FResultStorage[Index] := 1;
+    end;
+  end;
+
+{ TSingleEntryWithDefaultUnlikely }
+
+function TSingleEntryWithDefaultUnlikely.TestTitle: shortstring;
+  begin
+    Result := 'Single entry with default value; 75% match chance';
+  end;
+
+function TSingleEntryWithDefaultUnlikely.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> IIf(((X and $2) shr 1) or (X and $1) = 1, 1, 0) then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(IIf(((X and $2) shr 1) or (X and $1) = 1, 1, 0), 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryWithDefaultUnlikely.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    FResultStorage[Index] := 0;
+    case ((Index and $2) shr 1) or (Index and $1) of
+      1: FResultStorage[Index] := 1;
+    end;
+  end;
+
+{ TSingleEntryWithDefaultWeighted }
+
+function TSingleEntryWithDefaultWeighted.TestTitle: shortstring;
+  begin
+    Result := 'Single entry with default value; 25% match chance';
+  end;
+
+function TSingleEntryWithDefaultWeighted.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+
+    for X := 0 to 255 do
+      if FResultStorage[X] <> IIf(((X and $2) shr 1) and (X and $1) = 1, 1, 0) then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(IIf(((X and $2) shr 1) and (X and $1) = 1, 1, 0), 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryWithDefaultWeighted.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    FResultStorage[Index] := 0;
+    case ((Index and $2) shr 1) and (Index and $1) of
+      1: FResultStorage[Index] := 1;
+    end;
+  end;
+
+{ TSingleEntryWithElse }
+function TSingleEntryWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry with else block; 1/256 match chance';
+  end;
+
+procedure TSingleEntryWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case Index of
+      71: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryWithElseUnlikely }
+function TSingleEntryWithElseUnlikely.TestTitle: shortstring;
+  begin
+    Result := 'Single entry with else block; 75% match chance';
+  end;
+
+procedure TSingleEntryWithElseUnlikely.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case ((Index and $2) shr 1) or (Index and $1) of
+      1: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryWithElseWeighted }
+
+function TSingleEntryWithElseWeighted.TestTitle: shortstring;
+  begin
+    Result := 'Single entry with else block; 25% match chance';
+  end;
+
+procedure TSingleEntryWithElseWeighted.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case ((Index and $2) shr 1) and (Index and $1) of
+      1: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryAtZeroWithElse }
+
+function TSingleEntryAtZeroWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "0:" and else block';
+  end;
+
+function TSingleEntryAtZeroWithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    if FResultStorage[0] <> 1 then
+      begin
+        WriteLn('FAIL - Index 0; expected $01 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 1 to $FF do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryAtZeroWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case Index of
+      0: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryAtMinus1WithDefault }
+
+function TSingleEntryAtMinus1WithDefault.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "-1:" with default value';
+  end;
+
+function TSingleEntryAtMinus1WithDefault.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to $FE do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    if FResultStorage[255] <> 1 then
+      begin
+        WriteLn('FAIL - Index 255; expected $01 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+  end;
+
+procedure TSingleEntryAtMinus1WithDefault.DoTestIteration(Iteration: Integer);
+  var
+    Index: ShortInt;
+  begin
+    Index := ShortInt(Iteration and $FF);
+    FResultStorage[Byte(Index)] := 0;
+    case Index of
+      -1: FResultStorage[255] := 1;
+    end;
+  end;
+
+{ TSingleEntryAtMinus4WithElse }
+
+function TSingleEntryAtMinus4WithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "-4:" and else block';
+  end;
+
+function TSingleEntryAtMinus4WithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+    for X := 0 to 251 do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    if FResultStorage[252] <> 1 then
+      begin
+        WriteLn('FAIL - Index 0; expected $01 got $', hexstr(FResultStorage[252], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 253 to 255 do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryAtMinus4WithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: ShortInt;
+  begin
+    Index := ShortInt(Iteration and $FF);
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Byte(Index)] := $FF;
+    case Index of
+      -4: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryWith0To5RangeWithElse }
+
+function TSingleEntryWith0To5RangeWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "0..5" and else block';
+  end;
+
+function TSingleEntryWith0To5RangeWithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 5 do
+      if FResultStorage[X] <> 1 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $01 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 6 to $FF do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryWith0To5RangeWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case Index of
+      0..5: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryWith0To50RangeWithElse }
+
+function TSingleEntryWith0To50RangeWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "0..50" and else block';
+  end;
+
+function TSingleEntryWith0To50RangeWithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 50 do
+      if FResultStorage[X] <> 1 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $01 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 51 to $FF do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryWith0To50RangeWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case Index of
+      0..50: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryWith1To5RangeWithElse }
+
+function TSingleEntryWith1To5RangeWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "1..5" and else block';
+  end;
+
+function TSingleEntryWith1To5RangeWithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+    if FResultStorage[0] <> 0 then
+      begin
+        WriteLn('FAIL - Index 0; expected $00 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 1 to 5 do
+      if FResultStorage[X] <> 1 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $01 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 6 to $FF do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryWith1To5RangeWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case Index of
+      1..5: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryWith1To50RangeWithElse }
+
+function TSingleEntryWith1To50RangeWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "1..50" and else block';
+  end;
+
+function TSingleEntryWith1To50RangeWithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+    if FResultStorage[0] <> 0 then
+      begin
+        WriteLn('FAIL - Index 0; expected $00 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 1 to 50 do
+      if FResultStorage[X] <> 1 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $01 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 51 to $FF do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSingleEntryWith1To50RangeWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case Index of
+      1..50: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+
+{ TSingleEntryWithMinus1To5RangeWithElse }
+
+function TSingleEntryWithMinus1To5RangeWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "-1..5" and else block';
+  end;
+
+function TSingleEntryWithMinus1To5RangeWithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+    for X := 0 to 5 do
+      if FResultStorage[X] <> 1 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $01 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 6 to $FE do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    if FResultStorage[$FF] <> 1 then
+      begin
+        WriteLn('FAIL - Index 255; expected $00 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+  end;
+
+procedure TSingleEntryWithMinus1To5RangeWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: ShortInt;
+  begin
+    Index := ShortInt(Iteration and $FF);
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Byte(Index)] := $FF;
+    case Index of
+      -1..5: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSingleEntryWithMinus1To50RangeWithElse }
+
+function TSingleEntryWithMinus1To50RangeWithElse.TestTitle: shortstring;
+  begin
+    Result := 'Single entry of "-1..50" and else block';
+  end;
+
+function TSingleEntryWithMinus1To50RangeWithElse.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+    for X := 0 to 50 do
+      if FResultStorage[X] <> 1 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $01 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 51 to $FE do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    if FResultStorage[$FF] <> 1 then
+      begin
+        WriteLn('FAIL - Index 255; expected $00 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+  end;
+
+procedure TSingleEntryWithMinus1To50RangeWithElse.DoTestIteration(Iteration: Integer);
+  var
+    Index: ShortInt;
+  begin
+    Index := ShortInt(Iteration and $FF);
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Byte(Index)] := $FF;
+    case Index of
+      -1..50: FResultStorage[Index] := 1;
+      else FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TExtremeRange1 }
+
+function TExtremeRange1.TestTitle: shortstring;
+  begin
+    Result := 'Two labels, one with extreme spread, equal polling';
+  end;
+
+function TExtremeRange1.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    if FResultStorage[0] <> 1 then
+      begin
+        WriteLn('FAIL - Index 0; expected $01 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 1 to $FFFE do
+      if FResultStorage[X] <> 2 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $02 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    if FResultStorage[65535] <> 0 then
+      begin
+        WriteLn('FAIL - Index 65535; expected $02 got $', hexstr(FResultStorage[65535], 2));
+        Result := False;
+        Exit;
+      end;
+  end;
+
+procedure TExtremeRange1.DoTestIteration(Iteration: Integer);
+  var
+    Index: Word;
+  begin
+    Index := Iteration and $FFFF;
+    FResultStorage[Index] := 0; { Covers $FFFF }
+    case Index of
+      0:
+        FResultStorage[Index] := 1;
+      1..$FFFE:
+        FResultStorage[Index] := 2;
+    end;
+  end;
+
+{ TExtremeRange2 }
+
+function TExtremeRange2.TestTitle: shortstring;
+  begin
+    Result := 'Two labels, one with extreme spread, 50% else chance';
+  end;
+
+function TExtremeRange2.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to $FFFF do
+      if FResultStorage[X] <> (X and $1) then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(X and $1, 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TExtremeRange2.DoTestIteration(Iteration: Integer);
+  var
+    Index, Input: Word;
+  begin
+    Index := (Iteration and $FFFF);
+    Input := (Iteration and $1) - 1;
+    FResultStorage[Index] := 0; { Covers $FFFF }
+    case Input of
+      0..$FFFD:
+        FResultStorage[Index] := 1;
+      $FFFE:
+        FResultStorage[Index] := 2;
+    end;
+  end;
+
+{ TExtremeRange3 }
+
+function TExtremeRange3.TestTitle: shortstring;
+  begin
+    Result := 'Two labels, sparse values, equal polling across range';
+  end;
+
+function TExtremeRange3.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    if FResultStorage[0] <> 1 then
+      begin
+        WriteLn('FAIL - Index 0; expected $01 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 1 to $FFFE do
+      if FResultStorage[X] <> 2 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $02 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    if FResultStorage[65535] <> 0 then
+      begin
+        WriteLn('FAIL - Index 65535; expected $02 got $', hexstr(FResultStorage[65535], 2));
+        Result := False;
+        Exit;
+      end;
+  end;
+
+procedure TExtremeRange3.DoTestIteration(Iteration: Integer);
+  var
+    Index: Word;
+  begin
+    Index := Iteration and $FFFF;
+    FResultStorage[Index] := 2; { Covers 1..$FFFE }
+    case Index of
+      0:
+        FResultStorage[Index] := 1;
+      $FFFF:
+        FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TExtremeRange4 }
+
+function TExtremeRange4.TestTitle: shortstring;
+  begin
+    Result := 'Two labels, sparse values, always triggered';
+  end;
+
+function TExtremeRange4.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to $FFFF do
+      if FResultStorage[X] <> (X and $1) then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(X and $1, 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TExtremeRange4.DoTestIteration(Iteration: Integer);
+  var
+    Index, Input: Word;
+  begin
+    Index := (Iteration and $FFFF);
+    Input := (Iteration and $1) - 1;
+    FResultStorage[Index] := 2; { Covers 1..$FFFE }
+    case Input of
+      0:
+        FResultStorage[Index] := 1;
+      $FFFF:
+        FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSparseDataTest1 }
+
+procedure TSparseDataTest1.DoCaseBlock(Index: Integer; Input: TInstructionSet);
+  begin
+    case Input of
+      A_AND:
+        FResultStorage[Index] := 1;
+      A_MOV:
+        FResultStorage[Index] := 2;
+      A_MOVSX,
+      A_MOVZX:
+        FResultStorage[Index] := 3;
+      A_VMOVAPS,
+      A_VMOVAPD,
+      A_VMOVUPS,
+      A_VMOVUPD:
+        FResultStorage[Index] := 4;
+      A_MOVAPD,
+      A_MOVAPS,
+      A_MOVUPD,
+      A_MOVUPS:
+        FResultStorage[Index] := 5;
+      A_VDIVSD,
+      A_VDIVSS,
+      A_VSUBSD,
+      A_VSUBSS,
+      A_VMULSD,
+      A_VMULSS,
+      A_VADDSD,
+      A_VADDSS,
+      A_VANDPD,
+      A_VANDPS,
+      A_VORPD,
+      A_VORPS,
+      A_VXORPD,
+      A_VXORPS:
+        FResultStorage[Index] := 6;
+      A_MULSD,
+      A_MULSS,
+      A_ADDSD,
+      A_ADDSS:
+        FResultStorage[Index] := 7;
+      A_VMOVSD,
+      A_VMOVSS,
+      A_MOVSD,
+      A_MOVSS:
+        FResultStorage[Index] := 8;
+      A_LEA:
+        FResultStorage[Index] := 9;
+      A_SUB:
+        FResultStorage[Index] := 10;
+      A_SHL,A_SAL:
+        FResultStorage[Index] := 11;
+      A_SETcc:
+        FResultStorage[Index] := 12;
+      else
+        FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSparseDataEqual1 }
+
+function TSparseDataEqual1.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 12 sparse labels, equal polling';
+  end;
+
+function TSparseDataEqual1.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      if FResultStorage[X] <> ExtremeRange1Expected[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(ExtremeRange1Expected[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSparseDataEqual1.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt;
+  begin
+    X := Iteration and 1023;
+    DoCaseBlock(X, TInstructionSet(X - 512))
+  end;
+
+{ TSparseDataMOVWeightedl }
+
+function TSparseDataMOVWeighted1.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 12 sparse labels, 75% particular match';
+  end;
+
+function TSparseDataMOVWeighted1.WriteResults: Boolean;
+  var
+    X, Expected: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      begin
+        Expected := IIf((X and $3) = 0, ExtremeRange1Expected[X], 2);
+        if FResultStorage[X] <> Expected then
+          begin
+            WriteLn('FAIL - Index ', X, '; expected $', hexstr(Expected, 2), ' got $', hexstr(FResultStorage[X], 2));
+            Result := False;
+            Exit;
+          end;
+      end;
+  end;
+
+procedure TSparseDataMOVWeighted1.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt; P: TInstructionSet;
+  begin
+    X := Iteration and 1023;
+    P := TInstructionSet(IIf((X and $3) = 0, X - 512, Ord(A_MOV)));
+    DoCaseBlock(X, P);
+  end;
+
+{ TSparseDataMidpointWeighted1 }
+
+function TSparseDataMidpointWeighted1.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 12 sparse labels, 75% midpoint match';
+  end;
+
+function TSparseDataMidpointWeighted1.WriteResults: Boolean;
+  var
+    X, Expected: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      begin
+        Expected := IIf((X and $3) = 0, ExtremeRange1Expected[X], 6);
+        if FResultStorage[X] <> Expected then
+          begin
+            WriteLn('FAIL - Index ', X, '; expected $', hexstr(Expected, 2), ' got $', hexstr(FResultStorage[X], 2));
+            Result := False;
+            Exit;
+          end;
+      end;
+  end;
+
+procedure TSparseDataMidpointWeighted1.DoTestIteration(Iteration: Integer);
+  var
+    X: Word; P: TInstructionSet;
+  begin
+    X := Iteration and 1023;
+    P := TInstructionSet(IIf((X and $3) = 0, X - 512, Ord(A_VADDSD)));
+    DoCaseBlock(X, P);
+  end;
+
+{ TSparseDataTest2 }
+
+procedure TSparseDataTest2.DoCaseBlock(Index: Integer; Input: TInstructionSet);
+  begin
+    case Input of
+      A_AND:
+        FResultStorage[Index] := 1;
+      A_MOV:
+        FResultStorage[Index] := 2;
+      A_MOVSX:
+        FResultStorage[Index] := 13;
+      A_MOVZX:
+        FResultStorage[Index] := 3;
+      A_VMOVAPS:
+        FResultStorage[Index] := 14;
+      A_VMOVAPD:
+        FResultStorage[Index] := 15;
+      A_VMOVUPS:
+        FResultStorage[Index] := 16;
+      A_VMOVUPD:
+        FResultStorage[Index] := 4;
+      A_MOVAPD:
+        FResultStorage[Index] := 17;
+      A_MOVAPS:
+        FResultStorage[Index] := 18;
+      A_MOVUPD:
+        FResultStorage[Index] := 19;
+      A_MOVUPS:
+        FResultStorage[Index] := 5;
+      A_VDIVSD:
+        FResultStorage[Index] := 20;
+      A_VDIVSS:
+        FResultStorage[Index] := 21;
+      A_VSUBSD:
+        FResultStorage[Index] := 22;
+      A_VSUBSS:
+        FResultStorage[Index] := 23;
+      A_VMULSD:
+        FResultStorage[Index] := 24;
+      A_VMULSS:
+        FResultStorage[Index] := 25;
+      A_VADDSD:
+        FResultStorage[Index] := 26;
+      A_VADDSS:
+        FResultStorage[Index] := 27;
+      A_VANDPD:
+        FResultStorage[Index] := 28;
+      A_VANDPS:
+        FResultStorage[Index] := 29;
+      A_VORPD:
+        FResultStorage[Index] := 30;
+      A_VORPS:
+        FResultStorage[Index] := 31;
+      A_VXORPD:
+        FResultStorage[Index] := 32;
+      A_VXORPS:
+        FResultStorage[Index] := 6;
+      A_MULSD:
+        FResultStorage[Index] := 33;
+      A_MULSS:
+        FResultStorage[Index] := 34;
+      A_ADDSD:
+        FResultStorage[Index] := 35;
+      A_ADDSS:
+        FResultStorage[Index] := 7;
+      A_VMOVSD:
+        FResultStorage[Index] := 36;
+      A_VMOVSS:
+        FResultStorage[Index] := 37;
+      A_MOVSD:
+        FResultStorage[Index] := 38;
+      A_MOVSS:
+        FResultStorage[Index] := 8;
+      A_LEA:
+        FResultStorage[Index] := 9;
+      A_SUB:
+        FResultStorage[Index] := 10;
+      A_SHL:
+        FResultStorage[Index] := 39;
+      A_SAL:
+        FResultStorage[Index] := 11;
+      A_SETcc:
+        FResultStorage[Index] := 12;
+      else
+        FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSparseDataEqual2 }
+
+function TSparseDataEqual2.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 39 sparse labels, equal polling';
+  end;
+
+function TSparseDataEqual2.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      if FResultStorage[X] <> ExtremeRange2Expected[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(ExtremeRange2Expected[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSparseDataEqual2.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt;
+  begin
+    X := Iteration and 1023;
+    DoCaseBlock(X, TInstructionSet(X - 512))
+  end;
+
+{ TSparseDataMOVWeighted2 }
+
+function TSparseDataMOVWeighted2.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 39 sparse labels, 75% particular match';
+  end;
+
+function TSparseDataMOVWeighted2.WriteResults: Boolean;
+  var
+    X, Expected: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      begin
+        Expected := IIf((X and $3) = 0, ExtremeRange2Expected[X], 2);
+        if FResultStorage[X] <> Expected then
+          begin
+            WriteLn('FAIL - Index ', X, '; expected $', hexstr(Expected, 2), ' got $', hexstr(FResultStorage[X], 2));
+            Result := False;
+            Exit;
+          end;
+      end;
+  end;
+
+procedure TSparseDataMOVWeighted2.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt; P: TInstructionSet;
+  begin
+    X := Iteration and 1023;
+    P := TInstructionSet(IIf((X and $3) = 0, X - 512, Ord(A_MOV)));
+    DoCaseBlock(X, P);
+  end;
+
+{ TSparseDataMidpointWeighted2 }
+
+function TSparseDataMidpointWeighted2.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 39 sparse labels, 75% midpoint match';
+  end;
+
+function TSparseDataMidpointWeighted2.WriteResults: Boolean;
+  var
+    X, Expected: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      begin
+        Expected := IIf((X and $3) = 0, ExtremeRange2Expected[X], 26);
+        if FResultStorage[X] <> Expected then
+          begin
+            WriteLn('FAIL - Index ', X, '; expected $', hexstr(Expected, 2), ' got $', hexstr(FResultStorage[X], 2));
+            Result := False;
+            Exit;
+          end;
+      end;
+  end;
+
+procedure TSparseDataMidpointWeighted2.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt; P: TInstructionSet;
+  begin
+    X := Iteration and 1023;
+    P := TInstructionSet(IIf((X and $3) = 0, X - 512, Ord(A_VADDSD)));
+    DoCaseBlock(X, P);
+  end;
+
+{ TSparseDataTest3 }
+
+procedure TSparseDataTest3.DoCaseBlock(Index: Integer; Input: TInstructionSet);
+  begin
+    case Input of
+      A_AND:
+        FResultStorage[Index] := 1;
+      A_MOV:
+        FResultStorage[Index] := 2;
+      A_MOVSX:
+        FResultStorage[Index] := 13;
+      A_MOVZX:
+        FResultStorage[Index] := 3;
+      A_VMOVAPS:
+        FResultStorage[Index] := 14;
+      A_VMOVAPD:
+        FResultStorage[Index] := 15;
+      A_VMOVUPS:
+        FResultStorage[Index] := 16;
+      A_VMOVUPD:
+        FResultStorage[Index] := 4;
+      A_MOVAPD:
+        FResultStorage[Index] := 17;
+      A_MOVAPS:
+        FResultStorage[Index] := 18;
+      A_MOVUPD:
+        FResultStorage[Index] := 19;
+      A_MOVUPS:
+        FResultStorage[Index] := 5;
+      A_VDIVSD:
+        FResultStorage[Index] := 20;
+      A_VDIVSS:
+        FResultStorage[Index] := 21;
+      A_VSUBSD:
+        FResultStorage[Index] := 22;
+      A_VSUBSS:
+        FResultStorage[Index] := 23;
+      A_VMULSD:
+        FResultStorage[Index] := 24;
+      A_VMULSS:
+        FResultStorage[Index] := 25;
+      A_VADDSD:
+        FResultStorage[Index] := 26;
+      A_VADDSS:
+        FResultStorage[Index] := 27;
+      A_VANDPD:
+        FResultStorage[Index] := 28;
+      A_VANDPS:
+        FResultStorage[Index] := 29;
+      A_VORPD:
+        FResultStorage[Index] := 30;
+      A_VORPS:
+        FResultStorage[Index] := 31;
+      A_VXORPD:
+        FResultStorage[Index] := 32;
+      A_VXORPS:
+        FResultStorage[Index] := 6;
+      A_MULSD:
+        FResultStorage[Index] := 33;
+      A_MULSS:
+        FResultStorage[Index] := 34;
+      A_ADDSD:
+        FResultStorage[Index] := 35;
+      A_ADDSS:
+        FResultStorage[Index] := 7;
+      A_VMOVSD:
+        FResultStorage[Index] := 36;
+      A_VMOVSS:
+        FResultStorage[Index] := 37;
+      A_MOVSD:
+        FResultStorage[Index] := 38;
+      A_MOVSS:
+        FResultStorage[Index] := 8;
+      A_LEA:
+        FResultStorage[Index] := 9;
+      A_SUB:
+        FResultStorage[Index] := 10;
+      A_SHL:
+        FResultStorage[Index] := 39;
+      A_SAL:
+        FResultStorage[Index] := 11;
+      A_SETcc:
+        FResultStorage[Index] := 12;
+      A_MULX:
+        FResultStorage[Index] := 40;
+      A_VBROADCASTF128:
+        FResultStorage[Index] := 41;
+      A_VBROADCASTI128:
+        FResultStorage[Index] := 42;
+      A_VPERMD:
+        FResultStorage[Index] := 43;
+      A_VADDPD:
+        FResultStorage[Index] := 44;
+      A_VADDPS:
+        FResultStorage[Index] := 45;
+      A_ROUNDPS:
+        FResultStorage[Index] := 46;
+      A_ROUNDPD:
+        FResultStorage[Index] := 47;
+      A_ROUNDSS:
+        FResultStorage[Index] := 48;
+      A_ROUNDSD:
+        FResultStorage[Index] := 49;
+      A_CRC32:
+        FResultStorage[Index] := 50;
+      A_DPPS:
+        FResultStorage[Index] := 51;
+      A_DPPD:
+        FResultStorage[Index] := 52;
+      A_VAESDEC:
+        FResultStorage[Index] := 53;
+      A_VAESDECLAST:
+        FResultStorage[Index] := 54;
+      A_VAESENC:
+        FResultStorage[Index] := 55;
+      A_VAESENCLAST:
+        FResultStorage[Index] := 56;
+      A_VAESIMC:
+        FResultStorage[Index] := 57;
+      A_VAESKEYGENASSIST:
+        FResultStorage[Index] := 58;
+      A_VPSHUFB:
+        FResultStorage[Index] := 59;
+      A_VPSHUFD:
+        FResultStorage[Index] := 60;
+      A_VPSHUFHW:
+        FResultStorage[Index] := 61;
+      A_VPSHUFLW:
+        FResultStorage[Index] := 62;
+      A_BSF:
+        FResultStorage[Index] := 63;
+      A_BSR:
+        FResultStorage[Index] := 64;
+      A_BTR:
+        FResultStorage[Index] := 65;
+      A_BTS:
+        FResultStorage[Index] := 66;
+      A_XOR:
+        FResultStorage[Index] := 67;
+      A_ADD:
+        FResultStorage[Index] := 68;
+      A_CMP:
+        FResultStorage[Index] := 69;
+      A_SHLX:
+        FResultStorage[Index] := 70;
+      A_SHRX:
+        FResultStorage[Index] := 71;
+      else
+        FResultStorage[Index] := 0;
+    end;
+  end;
+
+{ TSparseDataEqual3 }
+
+function TSparseDataEqual3.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 71 sparse labels, equal polling';
+  end;
+
+function TSparseDataEqual3.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      if FResultStorage[X] <> ExtremeRange3Expected[X] then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(ExtremeRange3Expected[X], 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TSparseDataEqual3.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt;
+  begin
+    X := Iteration and 1023;
+    DoCaseBlock(X, TInstructionSet(X - 512))
+  end;
+
+{ TSparseDataMOVWeightedl }
+
+function TSparseDataMOVWeighted3.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 71 sparse labels, 75% particular match';
+  end;
+
+function TSparseDataMOVWeighted3.WriteResults: Boolean;
+  var
+    X, Expected: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      begin
+        Expected := IIf((X and $3) = 0, ExtremeRange3Expected[X], 2);
+        if FResultStorage[X] <> Expected then
+          begin
+            WriteLn('FAIL - Index ', X, '; expected $', hexstr(Expected, 2), ' got $', hexstr(FResultStorage[X], 2));
+            Result := False;
+            Exit;
+          end;
+      end;
+  end;
+
+procedure TSparseDataMOVWeighted3.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt; P: TInstructionSet;
+  begin
+    X := Iteration and 1023;
+    P := TInstructionSet(IIf((X and $3) = 0, X - 512, Ord(A_MOV)));
+    DoCaseBlock(X, P);
+  end;
+
+{ TSparseDataMidpointWeighted3 }
+
+function TSparseDataMidpointWeighted3.TestTitle: shortstring;
+  begin
+    Result := 'Domain of 1024, 71 sparse labels, 75% midpoint match';
+  end;
+
+function TSparseDataMidpointWeighted3.WriteResults: Boolean;
+  var
+    X, Expected: Word;
+  begin
+    Result := True;
+
+    for X := 0 to 1023 do
+      begin
+        Expected := IIf((X and $3) = 0, ExtremeRange3Expected[X], 26);
+        if FResultStorage[X] <> Expected then
+          begin
+            WriteLn('FAIL - Index ', X, '; expected $', hexstr(Expected, 2), ' got $', hexstr(FResultStorage[X], 2));
+            Result := False;
+            Exit;
+          end;
+      end;
+  end;
+
+procedure TSparseDataMidpointWeighted3.DoTestIteration(Iteration: Integer);
+  var
+    X: SmallInt; P: TInstructionSet;
+  begin
+    X := Iteration and 1023;
+    P := TInstructionSet(IIf((X and $3) = 0, X - 512, Ord(A_VADDSD)));
+    DoCaseBlock(X, P);
+  end;
+
+
+{ TLinearListDependsOnInput }
+
+function TLinearListDependsOnInput.TestTitle: shortstring;
+  begin
+    Result := 'Linear list depends on input';
+  end;
+
+function TLinearListDependsOnInput.WriteResults: Boolean;
+  var
+    X: Word;
+  begin
+    Result := True;
+    if FResultStorage[0] <> 0 then
+      begin
+        WriteLn('FAIL - Index 0; expected $00 got $', hexstr(FResultStorage[0], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 1 to 7 do
+      if FResultStorage[X] <> (X and $3) then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr(X and $3, 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 8 to 11 do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    if FResultStorage[12] <> $10 then
+      begin
+        WriteLn('FAIL - Index 12; expected $10 got $', hexstr(FResultStorage[12], 2));
+        Result := False;
+        Exit;
+      end;
+
+    for X := 13 to $FF do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TLinearListDependsOnInput.DoTestIteration(Iteration: Integer);
+  var
+    Index: Byte;
+  begin
+    Index := Iteration and $FF;
+    { This helps catch errors where all branches, including else, are skipped }
+    FResultStorage[Index] := $FF;
+    case Index of
+      1..3: FResultStorage[Index] := Index;
+      4..7: FResultStorage[Index] := Index - 4;
+      12:   FResultStorage[Index] := $10;
+      else  FResultStorage[Index] := 0;
+    end;
+  end;
+
+
+{ TCStyleCascade }
+
+function TCStyleCascade.TestTitle: shortstring;
+  begin
+    Result := 'C-style cascade using ''goto''';
+  end;
+
+function TCStyleCascade.WriteResults: Boolean;
+  var
+    X: Byte;
+  begin
+    Result := True;
+    for X := 0 to 5 do
+      if FResultStorage[X] <> ((1 shl X) - 1) then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $', hexstr((1 shl X) - 1, 2), ' got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+
+    for X := 6 to $FF do
+      if FResultStorage[X] <> 0 then
+        begin
+          WriteLn('FAIL - Index ', X, '; expected $00 got $', hexstr(FResultStorage[X], 2));
+          Result := False;
+          Exit;
+        end;
+  end;
+
+procedure TCStyleCascade.DoTestIteration(Iteration: Integer);
+  var
+    X, Tmp: Byte; P: TInstructionSet;
+  label
+    Set1, Set2, Set3, Set4, Default;
+  begin
+    X := Iteration and $FF;
+    Tmp := 0;
+    case X of
+      $1: goto Set1;
+      $2: goto Set2;
+      $3: goto Set3;
+      $4: goto Set4;
+      $5: Tmp := 16;
+    else
+      goto Default;
+    end;
+  Set4:
+    Tmp := Tmp or $8;
+  Set3:
+    Tmp := Tmp or $4;
+  Set2:
+    Tmp := Tmp or $2;
+  Set1:
+    Tmp := Tmp or $1;
+  Default:
+    FResultStorage[X] := Tmp;
+  end;
+
+
+{ Main function }
+const
+  { TCompleteByteRange and descendants
+      - Entirely-covered jump tree
+      - 33 labels, no else block; full coverage (all 256 byte values covered)
+        - Root: values are polled with equal probability
+        - FirstWeighted: first branch is polled 3 times as often
+        - LastWeighted: last branch is polled 3 times as often
+    TAlmostFullByteRange
+      - Almost full jump tree - 18 labels, else block covers 32 values; 224 byte values covered
+        - Root: values are polled with equal probability
+        - FirstWeighted: first branch is polled 3 times as often
+        - LastWeighted: last branch is polled 3 times as often
+  }
+
+  TestClasses: array[0..35] of TTestClass = (
+    TCompleteByteRange,
+    TCompleteByteRangeFirstWeighted,
+    TCompleteByteRangeLastWeighted,
+    TAlmostFullByteRange,
+    TAlmostFullByteRangeFirstWeighted,
+    TAlmostFullByteRangeLastWeighted,
+    TSingleEntryWithDefault,
+    TSingleEntryWithDefaultUnlikely,
+    TSingleEntryWithDefaultWeighted,
+    TSingleEntryWithElse,
+    TSingleEntryWithElseUnlikely,
+    TSingleEntryWithElseWeighted,
+    TSingleEntryAtZeroWithElse,
+    TSingleEntryAtMinus1WithDefault,
+    TSingleEntryAtMinus4WithElse,
+    TSingleEntryWith0To5RangeWithElse,
+    TSingleEntryWith0To50RangeWithElse,
+    TSingleEntryWith1To5RangeWithElse,
+    TSingleEntryWith1To50RangeWithElse,
+    TSingleEntryWithMinus1To5RangeWithElse,
+    TSingleEntryWithMinus1To50RangeWithElse,
+    TExtremeRange1,
+    TExtremeRange2,
+    TExtremeRange3,
+    TExtremeRange4,
+    TSparseDataEqual1,
+    TSparseDataMOVWeighted1,
+    TSparseDataMidpointWeighted1,
+    TSparseDataEqual2,
+    TSparseDataMOVWeighted2,
+    TSparseDataMidpointWeighted2,
+    TSparseDataEqual3,
+    TSparseDataMOVWeighted3,
+    TSparseDataMidpointWeighted3,
+    TLinearListDependsOnInput,
+    TCStyleCascade
+  );
+
+var
+  CurrentObject: TTestAncestor;
+  Failed: Boolean;
+  X: Integer;
+  SummedUpAverageDuration, AverageDuration : Double;
+begin
+  SummedUpAverageDuration := 0.0;
+  Failed := False;
+  WriteLn('Case node compilation and timing test');
+  WriteLn('-------------------------------------');
+  for X := low(TestClasses) to High(TestClasses) do
+    begin
+      try
+        CurrentObject := TestClasses[X].Create;
+        try
+          Write(CurrentObject.TestTitle:56, ' - ');
+          CurrentObject.Run;
+
+          if CurrentObject.WriteResults then
+            begin
+              AverageDuration := ((CurrentObject.RunTime * 1000000000.0) / ITERATIONS);
+              WriteLn('Pass - average iteration duration: ', AverageDuration:1:3, ' ns');
+              SummedUpAverageDuration := SummedUpAverageDuration + AverageDuration;
+            end
+          else
+            { Final average isn't processed if a test failed, so there's no need
+              to calculate and add the average duration to it }
+            Failed := True;
+
+        finally
+          CurrentObject.Free;
+        end;
+      except on E: Exception do
+        begin
+          WriteLn('Exception "', E.ClassName, '" raised while running test object of class "', TestClasses[X].ClassName, '"');
+          Failed := True;
+        end;
+      end;
+    end;
+
+  if Failed then
+    Halt(1);
+
+  WriteLn(#10'ok');
+  WriteLn('- Sum of average durations: ', SummedUpAverageDuration:1:3, ' ns');
+  WriteLn('- Overall average duration: ', (SummedUpAverageDuration / Length(TestClasses)):1:3, ' ns');
+end.

tests/tbf/tb0266a.pp

@@ -0,0 +1,24 @@
+{ %FAIL }
+
+unit tb0266a;
+
+{$mode objfpc}{$H+}
+
+interface
+
+type
+  TTest1 = class
+    fTest: String;
+  end;
+
+  TTest2 = class
+  private
+    fTest: TTest1;
+  public
+    property Test: String read fTest.fTest;
+  end;
+
+implementation
+
+end.
+

tests/tbf/tb0266b.pp

@@ -0,0 +1,28 @@
+{ %FAIL }
+
+unit tb0266b;
+
+{$mode objfpc}{$H+}
+
+interface
+
+type
+  TTest1 = class
+    fTest: String;
+  end;
+
+  TTest2 = record
+    fTest: TTest1;
+  end;
+
+  TTest3 = class
+  private
+    fTest: TTest2;
+  public
+    property Test: String read fTest.fTest.fTest;
+  end;
+
+implementation
+
+end.
+

tests/tbf/tb0267.pp

@@ -0,0 +1,34 @@
+{ %fail }
+
+{$mode objfpc}{$h+}
+{$interfaces corba}
+
+type
+  tintf = interface
+    procedure test(l: longint);
+    procedure test(s: string);
+  end;
+
+  tp = class
+    procedure test(l: longint); virtual;
+    procedure test(s: string); virtual;
+  end;
+
+  tc = class(tp, tintf)
+    procedure test(l: longint); override;
+  end;
+
+procedure tp.test(l: longint);
+  begin
+  end;
+
+procedure tp.test(s: string);
+  begin
+  end;
+
+procedure tc.test(l: longint);
+  begin
+  end;
+
+begin
+end.

tests/tbs/tb0654.pp

@@ -0,0 +1,34 @@
+{ %norun }
+
+{$mode objfpc}{$h+}
+{$interfaces corba}
+
+type
+  tintf = interface
+    procedure test(l: longint);
+    procedure test(s: string);
+  end;
+
+  tp = class
+    procedure test(l: longint); overload; virtual;
+    procedure test(s: string); overload; virtual;
+  end;
+
+  tc = class(tp, tintf)
+    procedure test(l: longint); override;
+  end;
+
+procedure tp.test(l: longint);
+  begin
+  end;
+
+procedure tp.test(s: string);
+  begin
+  end;
+
+procedure tc.test(l: longint);
+  begin
+  end;
+
+begin
+end.

tests/test/tcase49.pp

@@ -0,0 +1,2 @@
+{ this benchmark can be used also as a test case }
+{$I ../bench/bcase.pp}

tests/webtbf/tw34691.pp

@@ -0,0 +1,29 @@
+{ %FAIL }
+
+unit tw34691;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+type
+  {$M+}
+  TObjA = class
+  public
+    Icon: String;
+  end;
+
+  TObjB = class
+    FObjA: TObjA;
+
+  published
+    property Icon: String read FObjA.Icon;
+  end;
+
+implementation
+
+end.
+

tests/webtbs/tw4541.pp → tests/webtbf/tw4541.pp

@@ -1,3 +1,5 @@
+{ %FAIL }
+
 { Source provided for Free Pascal Bug Report 4541 }
 { Submitted by "Vincent Snijders" on  2005-11-23 }
 { e-mail: [email protected] }

tests/webtbs/tw27349.pp

@@ -13,7 +13,7 @@ type
    type
 
     tmyintf = class(TInterfacedObject, iinterface)
-     function _AddRef : longint; stdcall;
+     function _AddRef : longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
     end;
 
   end;
@@ -23,17 +23,17 @@ type
    type
 
     tmyintf = class(TInterfacedObject, iinterface)
-     function _AddRef : longint; stdcall;
+     function _AddRef : longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
     end;
 
   end;
 
-function C.tmyintf._AddRef: longint; stdcall;
+function C.tmyintf._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
 begin
  result := inherited _AddRef; // OK
 end;
 
-function R.tmyintf._AddRef: longint; stdcall;
+function R.tmyintf._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
 begin
  result := inherited _AddRef; // FAIL
 end;

tests/webtbs/tw34496.pp

@@ -0,0 +1,30 @@
+{ %TARGET = Win64 }
+
+program tw34496;
+
+{$MODE DELPHI}
+{$WARN 5079 OFF}
+
+uses
+  TypInfo,
+  Rtti;
+
+procedure Test1(const d1, d2: Double);
+begin
+  WriteLn(d1:0:2,' - ', d2:0:2);
+end;
+
+procedure Test2(const d1, d2: Extended);
+begin
+  WriteLn(d1:0:2,' - ', d2:0:2);
+end;
+
+var
+  a, b: Double;
+begin
+  a := 12.34;
+  b := 56.78;
+  Rtti.Invoke(@Test1, [a, b], ccReg, nil, True, False);
+  Rtti.Invoke(@Test2, [a, b], ccReg, nil, True, False);
+  //ReadLn;
+end.

tests/webtbs/tw34509.pp

@@ -0,0 +1,33 @@
+{ %TARGET = win64 }
+
+program tw34509;
+
+{$MODE DELPHI}
+
+uses
+  TypInfo,
+  RTTI;
+
+type
+  TRec = record
+    S: string;
+    I: Integer;
+  end;
+
+function Test(P: TRec): TRec;
+begin
+  Result := P;
+  WriteLn('P: ', P.S, ' - ', P.I);
+end;
+
+var
+  V: TValue;
+  R1, R2: TRec;
+begin
+  R1.S := 'abc';
+  R1.I := 123;
+  TValue.Make(@R1, TypeInfo(TRec), V);
+  R2 := TRec(Rtti.Invoke(@Test, [V], ccReg, TypeInfo(TRec), True, False).GetReferenceToRawData^);
+  WriteLn('R: ', R2.S, ' - ', R2.I);
+  //ReadLn;
+end.

utils/fpcmkcfg/fppkg.cfg

@@ -17,12 +17,11 @@ Description=Packages which are installed along with the Free Pascal Compiler
 Path=%GlobalPath%/{CompilerVersion}/
 Prefix=%GlobalPrefix%
 
+[IncludeFiles]
+FileMask=%CompilerConfigDir%/conf.d/*.conf
+
 [Repository]
 Name=user
 Description=User-installed packages
 Path={LocalRepository}lib/fpc/{CompilerVersion}/
 Prefix={LocalRepository}
-
-[IncludeFiles]
-FileMask=%CompilerConfigDir%/conf.d/*.conf
-

utils/fpcmkcfg/fppkg.inc

@@ -23,13 +23,12 @@ const fppkg : array[0..2,1..240] of char=(
   'Path=%GlobalPath%/{CompilerVersio','n}/'#010+
   'Prefix=%GlobalPrefix%'#010+
   #010+
+  '[IncludeFiles]'#010+
+  'FileMask=%CompilerConfigDir%/conf.d/*.conf'#010+
+  #010+
   '[Repository]'#010+
   'Name=user'#010+
   'Description=User-installed packages'#010+
   'Path={LocalRepository}lib/fpc/{CompilerVersion}/'#010+
-  'Prefix={LocalRepository}'#010+
-  #010+
-  '[IncludeFiles]'#010+
-  'FileMask=%CompilerConfigDir%/conf.d/*.conf'#010+
-  #010
+  'Prefix={LocalRepository}'#010
 );