# revisions: 40702,40703,40704,40747,40750,40765,41277,41535,41536,41537,41548,41549,41770

git-svn-id: branches/fixes_3_2@43399 -

.gitattributes

@@ -7564,6 +7564,7 @@ packages/rtl-objpas/Makefile.fpc svneol=native#text/plain
 packages/rtl-objpas/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/rtl-objpas/fpmake.pp svneol=native#text/plain
 packages/rtl-objpas/src/common/varutils.pp svneol=native#text/plain
+packages/rtl-objpas/src/i386/invoke.inc svneol=native#text/pascal
 packages/rtl-objpas/src/inc/convutil.inc svneol=native#text/plain
 packages/rtl-objpas/src/inc/convutil.pp svneol=native#text/plain
 packages/rtl-objpas/src/inc/convutils.pp svneol=native#text/plain
@@ -13840,6 +13841,7 @@ tests/test/trtti16.pp svneol=native#text/pascal
 tests/test/trtti17.pp svneol=native#text/pascal
 tests/test/trtti18a.pp svneol=native#text/pascal
 tests/test/trtti18b.pp svneol=native#text/pascal
+tests/test/trtti19.pp svneol=native#text/pascal
 tests/test/trtti2.pp svneol=native#text/plain
 tests/test/trtti20.pp svneol=native#text/pascal
 tests/test/trtti3.pp svneol=native#text/plain
@@ -14631,6 +14633,7 @@ tests/webtbf/tw26704.pp svneol=native#text/plain
 tests/webtbf/tw2719.pp svneol=native#text/plain
 tests/webtbf/tw2721.pp svneol=native#text/plain
 tests/webtbf/tw2724.pp svneol=native#text/plain
+tests/webtbf/tw27378.pp svneol=native#text/pascal
 tests/webtbf/tw2739.pp svneol=native#text/plain
 tests/webtbf/tw2751.pp svneol=native#text/plain
 tests/webtbf/tw2752.pp svneol=native#text/plain
@@ -14845,6 +14848,8 @@ tests/webtbf/uw0840b.pp svneol=native#text/plain
 tests/webtbf/uw0856.pp svneol=native#text/plain
 tests/webtbf/uw2414.pp svneol=native#text/plain
 tests/webtbf/uw25283.pp svneol=native#text/plain
+tests/webtbf/uw27378a.pp svneol=native#text/pascal
+tests/webtbf/uw27378b.pp svneol=native#text/pascal
 tests/webtbf/uw3450.pp svneol=native#text/plain
 tests/webtbf/uw3969.pp svneol=native#text/plain
 tests/webtbf/uw4103.pp svneol=native#text/plain
@@ -16169,6 +16174,7 @@ tests/webtbs/tw30179.pp svneol=native#text/pascal
 tests/webtbs/tw30182.pp svneol=native#text/plain
 tests/webtbs/tw30202.pp svneol=native#text/pascal
 tests/webtbs/tw30203.pp svneol=native#text/pascal
+tests/webtbs/tw30205.pp svneol=native#text/pascal
 tests/webtbs/tw30207.pp svneol=native#text/plain
 tests/webtbs/tw30208.pp svneol=native#text/pascal
 tests/webtbs/tw3023.pp svneol=native#text/plain

compiler/globstat.pas

@@ -60,6 +60,7 @@ type
     old_settings : tsettings;
     old_switchesstatestack : tswitchesstatestack;
     old_switchesstatestackpos : Integer;
+    old_verbosity : longint;
 
   { only saved/restored if "full" is true }
     old_asmdata : tasmdata;
@@ -74,7 +75,7 @@ procedure restore_global_state(const state:tglobalstate;full:boolean);
 implementation
 
 uses
-  pbase;
+  pbase,comphook;
 
   procedure save_global_state(out state:tglobalstate;full:boolean);
     begin
@@ -106,6 +107,7 @@ uses
           //flushpendingswitchesstate;
           oldcurrent_filepos:=current_filepos;
           old_settings:=current_settings;
+          old_verbosity:=status.verbosity;
 
           if full then
             begin
@@ -142,6 +144,7 @@ uses
           current_procinfo:=oldcurrent_procinfo;
           current_filepos:=oldcurrent_filepos;
           current_settings:=old_settings;
+          status.verbosity:=old_verbosity;
 
           if full then
             begin

compiler/ncgrtti.pas

@@ -241,6 +241,8 @@ implementation
 
                           if is_open_array(para.vardef) or is_array_of_const(para.vardef) then
                             write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti)
+                          else if para.vardef=cformaltype then
+                            write_rtti_reference(tcb,nil,fullrtti)
                           else
                             write_rtti_reference(tcb,para.vardef,fullrtti);
                           write_param_flag(tcb,para);
@@ -1361,6 +1363,8 @@ implementation
                { write param type }
                if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
                  write_rtti_reference(tcb,tarraydef(parasym.vardef).elementdef,fullrtti)
+               else if parasym.vardef=cformaltype then
+                 write_rtti_reference(tcb,nil,fullrtti)
                else
                  write_rtti_reference(tcb,parasym.vardef,fullrtti);
                { write name of current parameter }
@@ -1408,6 +1412,8 @@ implementation
                  begin
                    if is_open_array(tparavarsym(def.paras[i]).vardef) or is_array_of_const(tparavarsym(def.paras[i]).vardef) then
                      write_rtti_reference(tcb,tarraydef(tparavarsym(def.paras[i]).vardef).elementdef,fullrtti)
+                   else if tparavarsym(def.paras[i]).vardef=cformaltype then
+                     write_rtti_reference(tcb,nil,fullrtti)
                    else
                      write_rtti_reference(tcb,tparavarsym(def.paras[i]).vardef,fullrtti);
                  end;

compiler/procdefutil.pas

@@ -36,7 +36,7 @@ implementation
 
   uses
     cutils,
-    symbase,symsym,symtable,pparautl;
+    symbase,symsym,symtable,pparautl,globtype;
 
 
   function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef;
@@ -72,6 +72,9 @@ implementation
         nested procvars modeswitch is active. We must be independent of this switch. }
       exclude(result.procoptions,po_delphi_nested_cc);
       result.proctypeoption:=potype;
+      { always use the default calling convention }
+      result.proccalloption:=pocall_default;
+      include(result.procoptions,po_hascallingconvention);
       handle_calling_convention(result,hcc_default_actions_impl);
       sym:=cprocsym.create(basesymname+result.unique_id_str);
       st.insert(sym);

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

@@ -0,0 +1,455 @@
+{%MainUnit ../inc/rtti.pp}
+
+{
+  This file is part of the Free Pascal run time library.
+  Copyright (C) 2019 Sven Barth
+  member of the Free Pascal development team.
+
+  Function call manager for i386
+
+  See the file COPYING.FPC, included in this distribution,
+  for details about the copyright.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+
+{$define SYSTEM_HAS_INVOKE}
+
+function ReturnResultInParam(aType: PTypeInfo): Boolean;
+var
+  td: PTypeData;
+begin
+  { Only on Win32 structured types of sizes 1, 2 and 4 are returned directly
+    instead of a result parameter }
+  Result := False;
+  if Assigned(aType) then begin
+    case aType^.Kind of
+      tkMethod,
+      tkSString,
+      tkAString,
+      tkUString,
+      tkWString,
+      tkInterface,
+      tkDynArray:
+        Result := True;
+      tkArray: begin
+{$ifdef win32}
+        td := GetTypeData(aType);
+        Result := not (td^.ArrayData.Size in [1, 2, 4]);
+{$else}
+        Result := True;
+{$endif}
+      end;
+      tkRecord: begin
+{$ifdef win32}
+        td := GetTypeData(aType);
+        Result := not (td^.RecSize in [1, 2, 4]);
+{$else}
+        Result := True;
+{$endif}
+      end;
+      tkSet: begin
+        td := GetTypeData(aType);
+        case td^.OrdType of
+          otUByte:
+            Result := not (td^.SetSize in [1, 2, 4]);
+          otUWord,
+          otULong:
+            Result := False;
+        end;
+      end;
+    end;
+  end;
+end;
+
+procedure InvokeKernelRegister(aCodeAddress: CodePointer; aArgs: Pointer; aArgCount: LongInt); assembler; nostackframe;
+label
+  nostackargs;
+asm
+  pushl %ebp
+  movl %esp, %ebp
+
+  pushl %edi
+  pushl %esi
+
+  pushl %eax
+  pushl %edx
+
+  cmpl $3, %ecx
+  jle nostackargs
+
+  { copy arguments to stack }
+
+  subl $3, %ecx
+
+  { allocate count (%ecx) * 4 space on stack }
+  movl %ecx, %eax
+  shll $2, %eax
+
+  sub %eax, %esp
+
+  movl %esp, %edi
+
+  lea 12(%edx), %esi
+
+  cld
+  rep movsd
+
+nostackargs:
+
+  movl 8(%edx), %ecx
+  movl (%edx), %eax
+  movl 4(%edx), %edx
+
+  call -12(%ebp)
+
+  popl %ecx
+  movl %eax, (%ecx)
+  movl %edx, 4(%ecx)
+
+  popl %ecx
+
+  popl %esi
+  popl %edi
+
+  movl %ebp, %esp
+  popl %ebp
+end;
+
+resourcestring
+  SErrFailedToConvertArg = 'Failed to convert argument %d of type %s';
+
+procedure SystemInvokeRegister(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
+            aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
+type
+  PBoolean16 = ^Boolean16;
+  PBoolean32 = ^Boolean32;
+  PBoolean64 = ^Boolean64;
+  PByteBool = ^ByteBool;
+  PQWordBool = ^QWordBool;
+var
+  regstack: array of PtrUInt;
+  stackargs: array of SizeInt;
+  argcount, regidx, stackidx, stackcnt, i: LongInt;
+  retinparam, isstack: Boolean;
+  td: PTypeData;
+  floatres: Extended;
+
+  procedure AddRegArg(aValue: PtrUInt);
+  begin
+    if regidx < 3 then begin
+      regstack[regidx] := aValue;
+      Inc(regidx);
+    end else begin
+      if 3 + stackidx = Length(regstack) then
+        SetLength(regstack, Length(regstack) * 2);
+      regstack[3 + stackidx] := aValue;
+      Inc(stackidx);
+    end;
+  end;
+
+  procedure AddStackArg(aValue: PtrUInt);
+  begin
+    if 3 + stackidx = Length(regstack) then
+      SetLength(regstack, Length(regstack) * 2);
+    regstack[3 + stackidx] := aValue;
+    Inc(stackidx);
+  end;
+
+begin
+  { for the register calling convention we always have the registers EAX, EDX, ECX
+    and then the stack; if a parameter does not fit into a register its moved to the
+    next available stack slot and the next parameter gets a chance to be in a register }
+
+  retinparam := ReturnResultInParam(aResultType);
+
+  { we allocate at least three slots for EAX, ECX and EDX }
+  argcount := Length(aArgs);
+  if retinparam then
+    Inc(argcount);
+  if argcount < 3 then
+    SetLength(regstack, 3)
+  else
+    SetLength(regstack, argcount);
+
+  regidx := 0;
+  stackidx := 0;
+
+  SetLength(stackargs, Length(aArgs));
+  stackcnt := 0;
+
+  { first pass: handle register parameters }
+  for i := 0 to High(aArgs) do begin
+    if regidx >= 3 then begin
+      { all register locations already used up }
+      stackargs[stackcnt] := i;
+      Inc(stackcnt);
+      Continue;
+    end;
+
+    isstack := False;
+
+    if pfArray in aArgs[i].Info.ParamFlags then
+      AddRegArg(PtrUInt(aArgs[i].ValueRef))
+    else if aArgs[i].Info.ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
+      AddRegArg(PtrUInt(aArgs[i].ValueRef))
+    else begin
+      td := GetTypeData(aArgs[i].Info.ParamType);
+      case aArgs[i].Info.ParamType^.Kind of
+        tkSString,
+        tkMethod:
+          AddRegArg(PtrUInt(aArgs[i].ValueRef));
+        tkArray:
+          if td^.ArrayData.Size <= 4 then
+            isstack := True
+          else
+            AddRegArg(PtrUInt(aArgs[i].ValueRef));
+        tkRecord:
+          if td^.RecSize <= 4 then
+            isstack := True
+          else
+            AddRegArg(PtrUInt(aArgs[i].ValueRef));
+        tkObject,
+        tkWString,
+        tkUString,
+        tkAString,
+        tkDynArray,
+        tkClass,
+        tkClassRef,
+        tkInterface,
+        tkInterfaceRaw,
+        tkProcVar,
+        tkPointer:
+          AddRegArg(PPtrUInt(aArgs[i].ValueRef)^);
+        tkInt64,
+        tkQWord:
+          isstack := True;
+        tkSet: begin
+          case td^.OrdType of
+            otUByte: begin
+              case td^.SetSize of
+                0, 1:
+                  AddRegArg(PByte(aArgs[i].ValueRef)^);
+                2:
+                  AddRegArg(PWord(aArgs[i].ValueRef)^);
+                3:
+                  AddRegArg(PtrUInt(aArgs[i].ValueRef));
+                4:
+                  AddRegArg(PLongWord(aArgs[i].ValueRef)^);
+                else
+                  AddRegArg(PtrUInt(aArgs[i].ValueRef));
+              end;
+            end;
+            otUWord:
+              AddRegArg(PWord(aArgs[i].ValueRef)^);
+            otULong:
+              AddRegArg(PLongWord(aArgs[i].ValueRef)^);
+          end;
+        end;
+        tkEnumeration,
+        tkInteger: begin
+          case td^.OrdType of
+            otSByte: AddRegArg(PShortInt(aArgs[i].ValueRef)^);
+            otUByte: AddRegArg(PByte(aArgs[i].ValueRef)^);
+            otSWord: AddRegArg(PSmallInt(aArgs[i].ValueRef)^);
+            otUWord: AddRegArg(PWord(aArgs[i].ValueRef)^);
+            otSLong: AddRegArg(PLongInt(aArgs[i].ValueRef)^);
+            otULong: AddRegArg(PLongWord(aArgs[i].ValueRef)^);
+          end;
+        end;
+        tkBool: begin
+          case td^.OrdType of
+            otUByte: AddRegArg(ShortInt(System.PBoolean(aArgs[i].ValueRef)^));
+            otUWord: AddRegArg(Byte(PBoolean16(aArgs[i].ValueRef)^));
+            otULong: AddRegArg(SmallInt(PBoolean32(aArgs[i].ValueRef)^));
+            otUQWord: isstack := True;
+            otSByte: AddRegArg(Word(PByteBool(aArgs[i].ValueRef)^));
+            otSWord: AddRegArg(LongInt(PWordBool(aArgs[i].ValueRef)^));
+            otSLong: AddRegArg(LongWord(PLongBool(aArgs[i].ValueRef)^));
+            otSQWord: isstack := True;
+          end;
+        end;
+        tkFloat:
+          { all float types are passed in on stack }
+          isstack := True;
+      else
+        raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [i, aArgs[i].Info.ParamType^.Name]);
+      end;
+    end;
+
+    if isstack then begin
+      stackargs[stackcnt] := i;
+      Inc(stackcnt);
+    end;
+  end;
+
+  { then add the result parameter reference (if any) }
+  if Assigned(aResultType) and retinparam then
+    AddRegArg(PtrUInt(aResultValue));
+
+  { second pass: handle stack arguments from right to left }
+  if stackcnt > 0 then begin
+    for i := stackcnt - 1 downto 0 do begin
+      if pfArray in aArgs[stackargs[i]].Info.ParamFlags then
+        AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef))
+      else if aArgs[stackargs[i]].Info.ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
+        AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef))
+      else begin
+        td := GetTypeData(aArgs[stackargs[i]].Info.ParamType);
+        case aArgs[stackargs[i]].Info.ParamType^.Kind of
+          tkSString,
+          tkMethod:
+            AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
+          tkArray:
+            if td^.ArrayData.Size <= 4 then
+              AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^)
+            else
+              AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
+          tkRecord:
+            if td^.RecSize <= 4 then
+              AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^)
+            else
+              AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
+          tkObject,
+          tkWString,
+          tkUString,
+          tkAString,
+          tkDynArray,
+          tkClass,
+          tkClassRef,
+          tkInterface,
+          tkInterfaceRaw,
+          tkProcVar,
+          tkPointer:
+            AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^);
+          tkInt64,
+          tkQWord: begin
+            AddStackArg(PInt32(PInt64(aArgs[stackargs[i]].ValueRef))[0]);
+            AddStackArg(PInt32(PInt64(aArgs[stackargs[i]].ValueRef))[1]);
+          end;
+          tkSet: begin
+            case td^.OrdType of
+              otUByte: begin
+                case td^.SetSize of
+                  0, 1:
+                    AddStackArg(PByte(aArgs[stackargs[i]].ValueRef)^);
+                  2:
+                    AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^);
+                  3:
+                    AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
+                  4:
+                    AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^);
+                  else
+                    AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef));
+                end;
+              end;
+              otUWord:
+                AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^);
+              otULong:
+                AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^);
+            end;
+          end;
+          tkEnumeration,
+          tkInteger: begin
+            case td^.OrdType of
+              otSByte: AddStackArg(PShortInt(aArgs[stackargs[i]].ValueRef)^);
+              otUByte: AddStackArg(PByte(aArgs[stackargs[i]].ValueRef)^);
+              otSWord: AddStackArg(PSmallInt(aArgs[stackargs[i]].ValueRef)^);
+              otUWord: AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^);
+              otSLong: AddStackArg(PLongInt(aArgs[stackargs[i]].ValueRef)^);
+              otULong: AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^);
+            end;
+          end;
+          tkBool: begin
+            case td^.OrdType of
+              otUByte: AddStackArg(ShortInt(System.PBoolean(aArgs[stackargs[i]].ValueRef)^));
+              otUWord: AddStackArg(Byte(PBoolean16(aArgs[stackargs[i]].ValueRef)^));
+              otULong: AddStackArg(SmallInt(PBoolean32(aArgs[stackargs[i]].ValueRef)^));
+              otUQWord: AddStackArg(QWord(PBoolean64(aArgs[stackargs[i]].ValueRef)));
+              otSByte: AddStackArg(Word(PByteBool(aArgs[stackargs[i]].ValueRef)^));
+              otSWord: AddStackArg(LongInt(PWordBool(aArgs[stackargs[i]].ValueRef)^));
+              otSLong: AddStackArg(LongWord(PLongBool(aArgs[stackargs[i]].ValueRef)^));
+              otSQWord: AddStackArg(PtrUInt(PQWordBool(aArgs[stackargs[i]].ValueRef)));
+            end;
+          end;
+          tkFloat: begin
+            case td^.FloatType of
+              ftCurr   : begin
+                AddStackArg(PInt32(PCurrency(aArgs[stackargs[i]].ValueRef))[0]);
+                AddStackArg(PInt32(PCurrency(aArgs[stackargs[i]].ValueRef))[1]);
+              end;
+              ftSingle : AddStackArg(PInt32(PSingle(aArgs[stackargs[i]].ValueRef))^);
+              ftDouble : begin
+                AddStackArg(PInt32(PDouble(aArgs[stackargs[i]].ValueRef))[0]);
+                AddStackArg(PInt32(PDouble(aArgs[stackargs[i]].ValueRef))[1]);
+              end;
+              ftExtended: begin
+                AddStackArg(PInt32(PExtended(aArgs[stackargs[i]].ValueRef))[0]);
+                AddStackArg(PInt32(PExtended(aArgs[stackargs[i]].ValueRef))[1]);
+                AddStackArg(PWord(PExtended(aArgs[stackargs[i]].ValueRef))[4]);
+              end;
+              ftComp   : begin
+                AddStackArg(PInt32(PComp(aArgs[stackargs[i]].ValueRef))[0]);
+                AddStackArg(PInt32(PComp(aArgs[stackargs[i]].ValueRef))[1]);
+              end;
+            end;
+          end;
+        else
+          raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [stackargs[i], aArgs[stackargs[i]].Info.ParamType^.Name]);
+        end;
+      end;
+    end;
+  end;
+
+  InvokeKernelRegister(aCodeAddress, @regstack[0], 3 + stackidx);
+
+  if Assigned(aResultType) and not retinparam then begin
+    if aResultType^.Kind = tkFloat then begin
+      td := GetTypeData(aResultType);
+      asm
+        lea floatres, %eax
+        fstpt (%eax)
+      end ['eax'];
+      case td^.FloatType of
+        ftSingle:
+          PSingle(aResultValue)^ := floatres;
+        ftDouble:
+          PDouble(aResultValue)^ := floatres;
+        ftExtended:
+          PExtended(aResultValue)^ := floatres;
+        ftCurr:
+          PCurrency(aResultValue)^ := floatres / 10000;
+        ftComp:
+          PComp(aResultValue)^ := floatres;
+      end;
+    end else if aResultType^.Kind in [tkQWord, tkInt64] then
+      PQWord(aResultValue)^ := regstack[0] or (QWord(regstack[1]) shl 32)
+    else
+      PPtrUInt(aResultValue)^ := regstack[0];
+  end;
+end;
+
+procedure SystemInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
+            aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
+begin
+  case aCallConv of
+    ccReg:
+      SystemInvokeRegister(aCodeAddress, aArgs, aCallConv, aResultType, aResultValue, aFlags);
+    otherwise
+      Assert(False, 'Unsupported calling convention');
+  end;
+end;
+
+const
+  SystemFunctionCallManager: TFunctionCallManager = (
+    Invoke: @SystemInvoke;
+    CreateCallbackProc: Nil;
+    CreateCallbackMethod: Nil;
+  );
+
+procedure InitSystemFunctionCallManager;
+begin
+  SetFunctionCallManager([ccReg{, ccCdecl, ccPascal, ccStdCall}], SystemFunctionCallManager);
+end;

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

@@ -93,6 +93,7 @@ begin
   Result := False;
   if Assigned(aType) then begin
     case aType^.Kind of
+      tkMethod,
       tkSString,
       tkAString,
       tkUString,
@@ -290,11 +291,423 @@ begin
 {$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 CreateCallback;
+    procedure CreateArgInfos;
+    function GetCodeAddress: CodePointer; override;
+  {$endif}
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); virtual; abstract;
+  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

@@ -8,6 +8,8 @@ program testrunner.rtlobjpas;
 {.$define useffi}
 {$if defined(CPUX64) and defined(WINDOWS)}
 {$define testinvoke}
+{$elseif defined(CPUI386)}
+{$define testinvoke}
 {$else}
 {$ifdef useffi}
 {$define testinvoke}

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

@@ -604,7 +604,7 @@ begin
   CheckEquals(v.IsClass, False);
   CheckEquals(v.IsObject, False);
   CheckEquals(v.IsOrdinal, False);
-  Check(v.AsExtended=fcu);
+  Check(v.AsExtended=Extended(fcu));
   Check(v.AsCurrency=fcu);
   Check(v.GetReferenceToRawData <> @fcu);
 
@@ -643,7 +643,7 @@ begin
   CheckEquals(v.IsClass, False);
   CheckEquals(v.IsObject, False);
   CheckEquals(v.IsOrdinal, False);
-  Check(v.AsExtended=fco);
+  Check(v.AsExtended=Extended(fco));
   Check(v.GetReferenceToRawData <> @fco);
 
   try

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

@@ -37,7 +37,7 @@ function GetArray(const aArg: array of SizeInt): TValue;
 implementation
 
 uses
-  TypInfo, SysUtils;
+  TypInfo, SysUtils, Math;
 
 {$ifndef fpc}
 function TValueHelper.AsUnicodeString: UnicodeString;
@@ -124,10 +124,12 @@ begin
           Result := False
         else begin
           case td1^.FloatType of
-            ftSingle,
-            ftDouble,
+            ftSingle:
+              Result := SameValue(Single(aValue1.AsExtended), Single(aValue2.AsExtended));
+            ftDouble:
+              Result := SameValue(Double(aValue1.AsExtended), Double(aValue2.AsExtended));
             ftExtended:
-              Result := aValue1.AsExtended = aValue2.AsExtended;
+              Result := SameValue(aValue1.AsExtended, aValue2.AsExtended);
             ftComp:
               Result := aValue1.AsInt64 = aValue2.AsInt64;
             ftCurr:

tests/test/trtti15.pp

@@ -24,6 +24,7 @@ type
     function Test7(arg1: LongInt; arg2: String): String; pascal;
     {$endif}
     function Test8(arg1: LongInt; arg2: String): String; cdecl;
+    procedure Test9(var arg1; out arg2; constref arg3);
     property T: LongInt read Test2;
     property T2: LongInt read Test2;
   end;
@@ -52,10 +53,15 @@ begin
     ErrorHalt('Expected parameter name %s, but got %s', [aName, aParam^.Name]);
   if aParam^.Flags <> aFlags then
     ErrorHalt('Expected parameter flags %s, but got %s', [HexStr(Word(aFlags), 4), HexStr(Word(aParam^.Flags), 4)]);
-  if not Assigned(aParam^.ParamType) then
-    ErrorHalt('Expected parameter type %s, but got Nil', [aTypeInfo^.Name]);
-  if aParam^.ParamType^ <> aTypeInfo then
-    ErrorHalt('Expected parameter type %s, but got %s', [aTypeInfo^.Name, aParam^.ParamType^^.Name]);
+  if Assigned(aTypeInfo) then begin
+    if not Assigned(aParam^.ParamType) then
+      ErrorHalt('Expected parameter type %s, but got Nil', [aTypeInfo^.Name]);
+    if aParam^.ParamType^ <> aTypeInfo then
+      ErrorHalt('Expected parameter type %s, but got %s', [aTypeInfo^.Name, aParam^.ParamType^^.Name]);
+  end else begin
+    if Assigned(aParam^.ParamType) then
+      ErrorHalt('Expected Nil parameter type, but got %s', [aParam^.ParamType^^.Name])
+  end;
 end;
 
 type
@@ -218,6 +224,12 @@ begin
           MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
           MakeParam('arg1', [], TypeInfo(LongInt)),
           MakeParam('arg2', [], TypeInfo(String))
+        ]),
+      MakeMethod('Test9', DefaultCallingConvention, mkProcedure, Nil, [
+          MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
+          MakeParam('arg1', [pfVar], Nil),
+          MakeParam('arg2', [pfOut], Nil),
+          MakeParam('arg3', [pfConstRef], Nil)
         ])
     ]);
 end.

tests/test/trtti19.pp

@@ -0,0 +1,77 @@
+program trtti19;
+
+{$mode objfpc}
+
+uses
+  TypInfo;
+
+type
+  TTestProc = procedure(var arg1; out arg2; constref arg3);
+  TTestMethod = procedure(var arg1; out arg2; constref arg3) of object;
+
+  PParamFlags = ^TParamFlags;
+  PPPTypeInfo = ^PPTypeInfo;
+
+var
+  ti: PTypeInfo;
+  td: PTypeData;
+  procparam: PProcedureParam;
+  pb: PByte;
+  i: SizeInt;
+begin
+  ti := PTypeInfo(TypeInfo(TTestProc));
+  td := GetTypeData(ti);
+  if td^.ProcSig.ParamCount <> 3 then
+    Halt(1);
+  procparam := td^.ProcSig.GetParam(0);
+  if Assigned(procparam^.ParamType) then
+    Halt(2);
+  if procparam^.ParamFlags * [pfVar] <> [pfVar] then
+    Halt(3);
+  procparam := td^.ProcSig.GetParam(1);
+  if Assigned(procparam^.ParamType) then
+    Halt(4);
+  if procparam^.ParamFlags * [pfOut] <> [pfOut] then
+    Halt(5);
+  procparam := td^.ProcSig.GetParam(2);
+  if Assigned(procparam^.ParamType) then
+    Halt(6);
+  if procparam^.ParamFlags * [pfConstRef] <> [pfConstRef] then
+    Halt(7);
+
+  ti := PTypeInfo(TypeInfo(TTestMethod));
+  td := GetTypeData(ti);
+  if td^.ParamCount <> 4 then
+    Halt(8);
+  pb := @td^.ParamList[0];
+  if PParamFlags(pb)^ * [pfHidden, pfSelf] <> [pfHidden, pfSelf] then
+    Halt(9);
+  pb := pb + SizeOf(TParamFlags);
+  pb := pb + SizeOf(Byte) + pb^;
+  pb := pb + SizeOf(Byte) + pb^;
+  if PParamFlags(pb)^ * [pfVar] <> [pfVar] then
+    Halt(10);
+  pb := pb + SizeOf(TParamFlags);
+  pb := pb + SizeOf(Byte) + pb^;
+  pb := pb + SizeOf(Byte) + pb^;
+  if PParamFlags(pb)^ * [pfOut] <> [pfOut] then
+    Halt(11);
+  pb := pb + SizeOf(TParamFlags);
+  pb := pb + SizeOf(Byte) + pb^;
+  pb := pb + SizeOf(Byte) + pb^;
+  if PParamFlags(pb)^ * [pfConstRef] <> [pfConstRef] then
+    Halt(12);
+  pb := pb + SizeOf(TParamFlags);
+  pb := pb + SizeOf(Byte) + pb^;
+  pb := pb + SizeOf(Byte) + pb^;
+
+  pb := pb + SizeOf(TCallConv);
+  for i := 1 to td^.ParamCount - 1 do begin
+    if PPPTypeInfo(pb)[i] <> Nil then begin
+      Writeln(PPPTypeInfo(pb)[i]^^.Name);
+      Halt(12 + i);
+    end;
+  end;
+
+  Writeln('ok');
+end.

tests/webtbf/tw27378.pp

@@ -0,0 +1,14 @@
+{ %FAIL }
+{ %OPT=-B -Sen }
+
+{ we want the "Local variable "Var2" not used" hint as an error; if we don't
+  get the error then resetting the verbosity when switching the unit failed }
+
+program tw27378;
+
+uses
+  uw27378a, uw27378b;
+
+begin
+
+end.

tests/webtbf/tw34691.pp

@@ -10,11 +10,12 @@ uses
   Classes, SysUtils;
 
 type
+  {$M+}
   TObjA = class
+  public
     Icon: String;
   end;
 
-  {$M+}
   TObjB = class
     FObjA: TObjA;
 

tests/webtbf/uw27378a.pp

@@ -0,0 +1,13 @@
+unit uw27378a;
+
+interface
+
+{$NOTES OFF}
+
+implementation
+
+var
+  Var1: Boolean;
+
+end.
+

tests/webtbf/uw27378b.pp

@@ -0,0 +1,11 @@
+unit uw27378b;
+
+interface
+
+implementation
+
+var
+  Var2: Boolean;
+
+end.
+

tests/webtbs/tw30205.pp

@@ -0,0 +1,12 @@
+{ %TARGET=win32 }
+program tw30205;
+{$calling cdecl}
+procedure ietest( var f: ansistring );
+var
+  x: ansistring;
+begin
+  x :='1234';
+  f := x;
+end;
+begin
+end.