TMarshal & TMarshaller, strange things from Delphi.

rtl/inc/objpas.inc

@@ -1285,41 +1285,35 @@ end;
 
 function TPtrWrapper.ToPointer: Pointer;
 begin
-  Result:=Value;
+  Result:=FValue;
 end;
 
-class function TPtrWrapper.GetNilValue: TPtrWrapper; inline; static;
+class function TPtrWrapper.GetNilValue: TPtrWrapper;
 
 begin
-  Result.Value:=Nil;
+  Result.FValue:=Nil;
 end;
 
-constructor TPtrWrapper.Create(AValue: PtrInt); overload;
+constructor TPtrWrapper.Create(AValue: PtrInt);
 
 begin
-  Value:=Pointer(aValue);
+  FValue:=Pointer(aValue);
 end;
 
-constructor TPtrWrapper.Create(AValue: Pointer); overload;
+constructor TPtrWrapper.Create(AValue: Pointer);
 
 begin
-  Value:=aValue;
+  FValue:=aValue;
 end;
 
 
 function TPtrWrapper.ToInteger: PtrInt;
 begin
-  Result:=PtrInt(Value);
+  Result:=PtrInt(FValue);
 end;
 
-operator =(Left, Right: TPtrWrapper) c : Boolean;
+class operator TPtrWrapper.=(Left, Right: TPtrWrapper): Boolean;
 
 begin
-  c:=(Left.Value=Right.Value);
-end;
-
-operator <>(Left, Right: TPtrWrapper) c : Boolean;
-
-begin
-  Result:=(Left.Value<>Right.Value);
+  Result:=Left.FValue=Right.FValue;
 end;

rtl/inc/objpash.inc

@@ -626,17 +626,15 @@
 Type
   TPtrWrapper = record
   private
-    Value: PByte;
+    FValue: Pointer;
     class function GetNilValue: TPtrWrapper; inline; static;
   public
     constructor Create(AValue: PtrInt); overload;
     constructor Create(AValue: Pointer); overload;
-    function ToPointer: Pointer;
-    function ToInteger: PtrInt;
+    function ToPointer: Pointer; inline;
+    function ToInteger: PtrInt; inline;
     class property NilValue: TPtrWrapper read GetNilValue;
-    // class operator Equal(Left, Right: TPtrWrapper): Boolean;
-    // class operator NotEqual(Left, Right: TPtrWrapper): Boolean;
+    class operator =(Left, Right: TPtrWrapper): Boolean; inline;
+    { ...to allow convenient and direct reading without relying on inline... and convenient writing from SysUtils until TMarshal is moved here... }
+    property Value: Pointer read FValue write FValue;
   end;
-  
-operator =(Left, Right: TPtrWrapper) c : Boolean;  
-operator <>(Left, Right: TPtrWrapper) c : Boolean;

rtl/objpas/sysutils/sysmarshal.inc

@@ -0,0 +1,741 @@
+constructor TMarshal.Create;
+begin
+  System.Error(reInvalidPtr);
+end;
+
+class function TMarshal.AllocMem(Size: SizeInt): TPtrWrapper;
+begin
+  Result.Value := System.AllocMem(Size);
+end;
+
+class function TMarshal.ReallocMem(OldPtr: TPtrWrapper; NewSize: SizeInt): TPtrWrapper;
+var
+  P: Pointer;
+begin
+  P := OldPtr.Value;
+  Result.Value := System.ReallocMem(P, NewSize);
+end;
+
+class procedure TMarshal.FreeMem(Ptr: TPtrWrapper);
+begin
+  System.FreeMem(Ptr.Value);
+end;
+
+class procedure TMarshal.Move(Src, Dest: TPtrWrapper; Count: SizeInt); static;
+begin
+  System.Move(Src.Value^, Dest.Value^, Count);
+end;
+
+class function TMarshal.AsAnsi(const S: UnicodeString): AnsiString;
+begin
+  Result := AnsiString(S);
+end;
+
+class function TMarshal.AsAnsi(S: PUnicodeChar): AnsiString;
+begin
+  result := AnsiString(S);
+end;
+
+class function TMarshal.InOutString(const S: UnicodeString): PUnicodeChar;
+begin
+  Result := PUnicodeChar(S);
+end;
+
+class function TMarshal.InString(const S: UnicodeString): PUnicodeChar;
+begin
+  Result := PUnicodeChar(S);
+end;
+
+class function TMarshal.OutString(const S: UnicodeString): PUnicodeChar;
+begin
+  Result := PUnicodeChar(S);
+end;
+
+class function TMarshal.UnsafeAddrOf(var Value): TPtrWrapper;
+begin
+  Result.Value := @Value;
+end;
+
+class function TMarshal.AllocStringAsAnsi(const Str: UnicodeString): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), DefaultSystemCodePage);
+end;
+
+class function TMarshal.AllocStringAsAnsi(const Str: UnicodeString; CodePage: Word): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), CodePage);
+end;
+
+class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(S, Length(S), DefaultSystemCodePage);
+end;
+
+class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar; CodePage: Word): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(S, Length(S), CodePage);
+end;
+
+class function TMarshal.AllocStringAsUnicode(const Str: UnicodeString): TPtrWrapper;
+var
+  NBytes: SizeUint;
+begin
+  NBytes := (Length(Str) + 1) * SizeOf(UnicodeChar);
+  Result.Value := System.GetMem(NBytes);
+  System.Move(PUnicodeChar(Str)^, Result.Value^, NBytes);
+end;
+
+class function TMarshal.AllocStringAsUtf8(const Str: UnicodeString): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), CP_UTF8);
+end;
+
+class function TMarshal.AllocStringAsUtf8(S: PUnicodeChar): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(S, Length(S), CP_UTF8);
+end;
+
+class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar; Len: SizeInt; CodePage: Word): TPtrWrapper;
+var
+  U2ARes: AnsiString;
+  NBytes: SizeInt;
+begin
+  U2ARes := ''; { Suppress warning. }
+  WideStringManager.Unicode2AnsiMoveProc(S, U2ARes, CodePage, Len);
+  if Length(U2ARes) = 0 then
+  begin
+    Result.Value := nil;
+    Exit;
+  end;
+  { Could instead avoid the second allocation, assuming U2ARes.RefCount = 1:
+    System.Move(Pointer(U2ARes)^, (Pointer(U2ARes) - AnsiStringHeaderSize)^, (Length(U2ARes) + 1) * SizeOf(AnsiChar));
+    Result.FValue := Pointer(U2ARes) - AnsiStringHeaderSize;
+    Pointer(U2ARes) := nil; }
+  NBytes := (Length(U2ARes) + 1) * SizeOf(AnsiChar);
+  Result.Value := System.GetMem(NBytes);
+  System.Move(PAnsiChar(U2ARes)^, Result.Value^, NBytes);
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<UnicodeChar>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PUnicodeChar(Src)[StartIndex], Dest.Value^, Count * SizeOf(UnicodeChar));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<UnicodeChar>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PUnicodeChar(Dest)[StartIndex], Count * SizeOf(UnicodeChar));
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<UInt8>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PUInt8(Src)[StartIndex], Dest.Value^, Count * SizeOf(UInt8));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<UInt8>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PUInt8(Dest)[StartIndex], Count * SizeOf(UInt8));
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<Int8>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PInt8(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int8));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int8>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PInt8(Dest)[StartIndex], Count * SizeOf(Int8));
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<UInt16>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PUInt16(Src)[StartIndex], Dest.Value^, Count * SizeOf(UInt16));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<UInt16>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PUInt16(Dest)[StartIndex], Count * SizeOf(UInt16));
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<Int16>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PInt16(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int16));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int16>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PInt16(Dest)[StartIndex], Count * SizeOf(Int16));
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<Int32>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PInt32(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int32));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int32>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PInt32(Dest)[StartIndex], Count * SizeOf(Int32));
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<Int64>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PInt64(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int64));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int64>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PInt64(Dest)[StartIndex], Count * SizeOf(Int64));
+end;
+
+class procedure TMarshal.Copy(const Src: specialize TArray<TPtrWrapper>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
+begin
+  System.Move(PPointer(Src)[StartIndex], Dest.Value^, Count * SizeOf(TPtrWrapper));
+end;
+
+class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: specialize TArray<TPtrWrapper>; StartIndex: SizeInt; Count: SizeInt);
+begin
+  System.Move(Src.Value^, PPointer(Dest)[StartIndex], Count * SizeOf(TPtrWrapper));
+end;
+
+generic class function TMarshal.FixArray<T>(const Arr: specialize TArray<T>): TPtrWrapper;
+begin
+  Result.Value := nil;
+  specialize TArray<T>(Result) := Arr;
+end;
+
+generic class procedure TMarshal.UnfixArray<T>(ArrPtr: TPtrWrapper);
+begin
+  Finalize(specialize TArray<T>(ArrPtr));
+end;
+
+class function TMarshal.FixString(var Str: UnicodeString): TPtrWrapper;
+begin
+  UniqueString(Str);
+  Result := UnsafeFixString(Str);
+end;
+
+class procedure TMarshal.UnfixString(Ptr: TPtrWrapper);
+begin
+  if Ptr.Value <> PUnicodeChar('') then
+    Finalize(UnicodeString(Ptr));
+end;
+
+class function TMarshal.UnsafeFixString(const Str: UnicodeString): TPtrWrapper;
+begin
+  if Length(Str) = 0 then
+  begin
+    Result.Value := PUnicodeChar('');
+    Exit;
+  end;
+  Result.Value := nil;
+  UnicodeString(Result) := Str;
+end;
+
+class function TMarshal.ReadByte(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Byte;
+begin
+  Result := PByte(Ptr.Value + Ofs)^;
+end;
+
+class procedure TMarshal.WriteByte(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Byte);
+begin
+  PByte(Ptr.Value + Ofs)^ := Value;
+end;
+
+class procedure TMarshal.WriteByte(Ptr: TPtrWrapper; Value: Byte);
+begin
+  PByte(Ptr.Value)^ := Value;
+end;
+
+class function TMarshal.ReadInt16(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int16;
+begin
+  Result := PInt16(Ptr.Value + Ofs)^;
+end;
+
+class procedure TMarshal.WriteInt16(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int16);
+begin
+  PInt16(Ptr.Value + Ofs)^ := Value;
+end;
+
+class procedure TMarshal.WriteInt16(Ptr: TPtrWrapper; Value: Int16);
+begin
+  PInt16(Ptr.Value)^ := Value;
+end;
+
+class function TMarshal.ReadInt32(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int32;
+begin
+  Result := PInt32(Ptr.Value + Ofs)^;
+end;
+
+class procedure TMarshal.WriteInt32(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int32);
+begin
+  PInt32(Ptr.Value + Ofs)^ := Value;
+end;
+
+class procedure TMarshal.WriteInt32(Ptr: TPtrWrapper; Value: Int32);
+begin
+  PInt32(Ptr.Value)^ := Value;
+end;
+
+class function TMarshal.ReadInt64(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int64;
+begin
+  Result := PInt64(Ptr.Value + Ofs)^;
+end;
+
+class procedure TMarshal.WriteInt64(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int64);
+begin
+  PInt64(Ptr.Value + Ofs)^ := Value;
+end;
+
+class procedure TMarshal.WriteInt64(Ptr: TPtrWrapper; Value: Int64);
+begin
+  PInt64(Ptr.Value)^ := Value;
+end;
+
+class function TMarshal.ReadPtr(Ptr: TPtrWrapper; Ofs: SizeInt = 0): TPtrWrapper;
+begin
+  Result.Value := PPointer(Ptr.Value + Ofs)^;
+end;
+
+class procedure TMarshal.WritePtr(Ptr: TPtrWrapper; Ofs: SizeInt; Value: TPtrWrapper);
+begin
+  PPointer(Ptr.Value + Ofs)^ := Value.Value;
+end;
+
+class procedure TMarshal.WritePtr(Ptr, Value: TPtrWrapper);
+begin
+  PPointer(Ptr.Value)^ := Value.Value;
+end;
+
+class function TMarshal.ReadStringAsAnsi(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
+begin
+  Result := ReadStringAsAnsi(DefaultSystemCodePage, Ptr, Len);
+end;
+
+class function TMarshal.ReadStringAsAnsi(CodePage: Word; Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
+begin
+  { Here and below, IndexByte/Word assume that, when Len >= 0, either:
+    - Up to Len characters are accessible in Ptr;
+    - IndexByte/Word cannot access invalid memory past the searched character
+      (e.g. i386.inc and x86_64.inc IndexByte/Word versions are specifically designed not to). }
+  if Len < 0 then
+    Len := IndexByte(Ptr.Value^, Len, 0);
+  Result := ''; { Suppress warning. }
+  WideStringManager.Ansi2UnicodeMoveProc(Ptr.Value, CodePage, Result, Len);
+end;
+
+class function TMarshal.ReadStringAsAnsiUpTo(CodePage: Word; Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
+var
+  Len: SizeInt;
+begin
+  Len := IndexByte(Ptr.Value^, MaxLen, 0);
+  if Len < 0 then
+    Len := MaxLen;
+  Result := ReadStringAsAnsi(CodePage, Ptr, Len);
+end;
+
+class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
+begin
+  WriteStringAsAnsi(Ptr, 0, Value, MaxCharsIncNull, DefaultSystemCodePage);
+end;
+
+class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word);
+begin
+  WriteStringAsAnsi(Ptr, 0, Value, MaxCharsIncNull, CodePage);
+end;
+
+class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
+begin
+  WriteStringAsAnsi(Ptr, Ofs, Value, MaxCharsIncNull, DefaultSystemCodePage);
+end;
+
+class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word);
+var
+  U2ARes: AnsiString;
+  ValueLen, U2AResLen: SizeInt;
+begin
+  U2ARes := ''; { Suppress warning. }
+  ValueLen := Length(Value);
+  { Delphi null-terminates iff MaxCharsIncNull < 0, so MaxCharsIncNull is actually just MaxChars. }
+  if (MaxCharsIncNull > 0) and (MaxCharsIncNull < ValueLen) then
+    ValueLen := MaxCharsIncNull; { UTF-16 → ANSI should never shrink element count, so limit the number of characters analyzed. }
+  WideStringManager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(Value)), U2ARes, CodePage, ValueLen);
+  U2AResLen := Length(U2ARes);
+  if (MaxCharsIncNull >= 0) and (MaxCharsIncNull < U2AResLen) then
+    U2AResLen := MaxCharsIncNull;
+  System.Move(PAnsiChar(Pointer(U2ARes))^, (Ptr.Value + Ofs)^, U2AResLen * SizeOf(AnsiChar));
+  if MaxCharsIncNull < 0 then
+    PAnsiChar(Ptr.Value + Ofs)[U2AResLen] := #0;
+end;
+
+class function TMarshal.ReadStringAsUnicode(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
+begin
+  if Len < 0 then
+    Len := Length(PUnicodeChar(Ptr.Value));
+  Result := ''; { Suppress warning. }
+  SetLength(Result, Len);
+  System.Move(Ptr.Value^, Pointer(Result)^, Len * SizeOf(UnicodeChar));
+end;
+
+class function TMarshal.ReadStringAsUnicodeUpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
+var
+  Len: SizeInt;
+begin
+  Len := IndexWord(Ptr.Value^, MaxLen, 0);
+  if Len < 0 then
+    Len := MaxLen;
+  Result := ReadStringAsUnicode(Ptr, Len);
+end;
+
+class procedure TMarshal.WriteStringAsUnicode(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
+begin
+  WriteStringAsUnicode(Ptr, 0, Value, MaxCharsIncNull);
+end;
+
+class procedure TMarshal.WriteStringAsUnicode(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
+var
+  Len: SizeInt;
+begin
+  { Again, Delphi null-terminates iff MaxCharsIncNull < 0, so MaxCharsIncNull is actually just MaxChars. }
+  Len := Length(Value);
+  if (MaxCharsIncNull >= 0) and (MaxCharsIncNull < Len) then
+    Len := MaxCharsIncNull;
+  System.Move(Pointer(Value)^, (Ptr.Value + Ofs)^, Len * SizeOf(UnicodeChar));
+  if MaxCharsIncNull < 0 then
+    PUnicodeChar(Ptr.Value + Ofs)[Len] := #0;
+end;
+
+class function TMarshal.ReadStringAsUtf8(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
+begin
+  Result := ReadStringAsAnsi(CP_UTF8, Ptr, Len);
+end;
+
+class function TMarshal.ReadStringAsUtf8UpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
+begin
+  Result := ReadStringAsAnsiUpTo(CP_UTF8, Ptr, MaxLen);
+end;
+
+class procedure TMarshal.WriteStringAsUtf8(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
+begin
+  WriteStringAsAnsi(Ptr, Value, MaxCharsIncNull, CP_UTF8);
+end;
+
+class procedure TMarshal.WriteStringAsUtf8(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
+begin
+  WriteStringAsAnsi(Ptr, Ofs, Value, MaxCharsIncNull, CP_UTF8);
+end;
+
+constructor TMarshaller.TState.Create;
+begin
+  inherited Create;
+  DeferHead.Alloc := sizeof(TDeferQueueNode.StaticStore);
+  DeferTail := @DeferHead;
+end;
+
+destructor TMarshaller.TState.Destroy;
+begin
+  Flush;
+  inherited Destroy;
+end;
+
+procedure TMarshaller.TState.Flush;
+begin
+  try
+    FlushQueue;
+  finally
+    ClearQueue;
+  end;
+end;
+
+procedure TMarshaller.TState.FlushQueue;
+var
+  Qn: PDeferQueueNode;
+  D: PDeferBase;
+  Pos: SizeInt;
+begin
+  Qn := @DeferHead;
+  repeat
+    Pos := 0;
+    while Pos < Qn^.Used do
+    begin
+      Pointer(D) := Pointer(PByte(Qn^.Mem)) + Pos;
+      Pos := Pos + SizeOf(D^); { This is runtime SizeOf of the actual instance that accesses VMT. }
+      D^.Done;
+    end;
+    Qn := Qn^.Next;
+  until not Assigned(Qn);
+end;
+
+procedure TMarshaller.TState.ClearQueue;
+var
+  Qn, Nx: PDeferQueueNode;
+begin
+  Qn := DeferHead.Next;
+  DeferHead.Next := nil;
+  DeferHead.Used := 0;
+  while Assigned(Qn) do
+  begin
+    Nx := Qn^.Next;
+    System.FreeMem(Qn);
+    Qn := Nx;
+  end;
+end;
+
+procedure TMarshaller.TState.NotePointerChanged(OldPtr, NewPtr: TPtrWrapper);
+var
+  Qn: PDeferQueueNode;
+  D: PDeferBase;
+  Pos: SizeInt;
+begin
+  Qn := @DeferHead;
+  repeat
+    Pos := 0;
+    while Pos < Qn^.Used do
+    begin
+      Pointer(D) := Pointer(PByte(Qn^.Mem)) + Pos;
+      Pos := Pos + SizeOf(D^); { This is runtime SizeOf of the actual instance that accesses VMT. }
+      D^.NotePointerChanged(OldPtr, NewPtr);
+    end;
+    Qn := Qn^.Next;
+  until not Assigned(Qn);
+end;
+
+constructor TMarshaller.TDeferBase.Init;
+begin
+end;
+
+procedure TMarshaller.TDeferBase.NotePointerChanged(OldPtr, NewPtr: TPtrWrapper);
+begin
+end;
+
+destructor TMarshaller.TDeferFreeMem.Done;
+begin
+  TMarshal.FreeMem(P);
+  P := TPtrWrapper.NilValue;
+end;
+
+procedure TMarshaller.TDeferFreeMem.NotePointerChanged(OldPtr, NewPtr: TPtrWrapper);
+begin
+  if P = OldPtr then
+    P := NewPtr;
+end;
+
+class procedure TMarshaller.TAddressableUnfixArraySpecialization.UnfixArray(ArrPtr: TPtrWrapper);
+begin
+  TMarshal.specialize UnfixArray<T>(ArrPtr);
+end;
+
+destructor TMarshaller.TDeferUnfix.Done;
+begin
+  if Assigned(P.Value) then
+    Unfix(P);
+  P := TPtrWrapper.NilValue;
+end;
+
+destructor TMarshaller.TDeferMoveToSBAndFree.Done;
+begin
+  try
+    if Assigned(SB) then
+    begin
+      SB.Clear;
+      SB.Append(TMarshal.ReadStringAsUnicodeUpTo(Src, MaxLen));
+    end;
+  finally
+    TMarshal.FreeMem(Src);
+    Src := TPtrWrapper.NilValue;
+  end;
+end;
+
+function TMarshaller.PushDefer(InstanceSize: SizeInt): PDeferBase;
+var
+  Qn: PDeferQueueNode;
+  Alloc: SizeInt;
+begin
+  { Careful: FState starts uninitialized, Assigned(FStateLife) must be used rather than Assigned(FState). }
+  if not Assigned(FStateLife) then
+  begin
+    FState := TState.Create;
+    FStateLife := FState;
+  end;
+  Qn := FState.DeferTail;
+  if InstanceSize <= Qn^.Alloc - Qn^.Used then
+  begin
+    { Enough space. }
+    Result := Pointer(PByte(Qn^.Mem)) + Qn^.Used;
+    Qn^.Used := Qn^.Used + InstanceSize;
+  end else
+  begin
+    { Not enough space; allocate new node. }
+    Alloc := InstanceSize + Qn^.Alloc + SizeInt(SizeUint(Qn^.Alloc) div 2);
+    Qn := GetMem(SizeOf(TDeferQueueNode) - SizeOf(TDeferQueueNode.StaticStore) + Alloc);
+    Qn^.Used := InstanceSize;
+    Qn^.Alloc := Alloc;
+    Qn^.Next := nil;
+    FState.DeferTail^.Next := Qn;
+    FState.DeferTail := Qn;
+    Result := Pointer(PByte(Qn^.Mem));
+  end;
+end;
+
+procedure TMarshaller.Flush;
+begin
+  if Assigned(FStateLife) then
+    FState.Flush;
+end;
+
+function TMarshaller.AllocMem(Size: SizeInt): TPtrWrapper;
+var
+  D: PDeferFreeMem;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferFreeMem));
+  D^.Init;
+  Result := TMarshal.AllocMem(Size);
+  D^.P := Result;
+end;
+
+function TMarshaller.ReallocMem(OldPtr: TPtrWrapper; NewSize: NativeInt): TPtrWrapper;
+begin
+  if not Assigned(OldPtr.Value) then
+    Exit(AllocMem(NewSize));
+  Result := TMarshal.ReallocMem(OldPtr, NewSize);
+  if (Result <> OldPtr) and Assigned(FStateLife) then
+    FState.NotePointerChanged(OldPtr, Result);
+end;
+
+function TMarshaller.AllocStringAsAnsi(const Str: UnicodeString): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), DefaultSystemCodePage);
+end;
+
+function TMarshaller.AllocStringAsAnsi(const Str: UnicodeString; CodePage: Word): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), CodePage);
+end;
+
+function TMarshaller.AllocStringAsUnicode(const Str: UnicodeString): TPtrWrapper;
+var
+  D: PDeferFreeMem;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferFreeMem));
+  D^.Init;
+  Result := TMarshal.AllocStringAsUnicode(Str);
+  D^.P := Result;
+end;
+
+function TMarshaller.AllocStringAsUtf8(const Str: UnicodeString): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(Str, CP_UTF8);
+end;
+
+function TMarshaller.AsAnsi(const S: UnicodeString): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(S)), Length(S), DefaultSystemCodePage);
+end;
+
+function TMarshaller.AsAnsi(S: PUnicodeChar): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(S, Length(S), DefaultSystemCodePage);
+end;
+
+function TMarshaller.AsAnsi(const S: UnicodeString; CodePage: Word): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(S)), Length(S), CodePage);
+end;
+
+function TMarshaller.AsAnsi(S: PUnicodeChar; CodePage: Word): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(S, Length(S), CodePage);
+end;
+
+function TMarshaller.AsUtf8(const S: UnicodeString): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(S)), Length(S), CP_UTF8);
+end;
+
+function TMarshaller.AsUtf8(S: PUnicodeChar): TPtrWrapper;
+begin
+  Result := AllocStringAsAnsi(S, Length(S), CP_UTF8);
+end;
+
+function TMarshaller.AllocStringAsAnsi(S: PUnicodeChar; Len: SizeInt; CodePage: Word): TPtrWrapper;
+var
+  D: PDeferFreeMem;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferFreeMem));
+  D^.Init;
+  Result := TMarshal.AllocStringAsAnsi(S, Len, CodePage);
+  D^.P := Result;
+end;
+
+function TMarshaller.AsRaw(const B: TBytes): TPtrWrapper;
+begin
+  Result := specialize FixArray<Byte>(B);
+end;
+
+generic function TMarshaller.FixArray<T>(const Arr: specialize TArray<T>): TPtrWrapper;
+var
+  D: PDeferUnfix;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferUnfix));
+  D^.Init;
+  Result := TMarshal.specialize FixArray<T>(Arr);
+  D^.Unfix := @specialize TAddressableUnfixArraySpecialization<T>.UnfixArray;
+  D^.P := Result;
+end;
+
+function TMarshaller.FixString(var Str: UnicodeString): TPtrWrapper;
+var
+  D: PDeferUnfix;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferUnfix));
+  D^.Init;
+  Result := TMarshal.FixString(Str);
+  D^.Unfix := @TMarshal.UnfixString;
+  D^.P := Result;
+end;
+
+function TMarshaller.UnsafeFixString(const Str: UnicodeString): TPtrWrapper;
+var
+  D: PDeferUnfix;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferUnfix));
+  D^.Init;
+  Result := TMarshal.UnsafeFixString(Str);
+  D^.Unfix := @TMarshal.UnfixString;
+  D^.P := Result;
+end;
+
+function TMarshaller.InString(SB: TUnicodeStringBuilder; MaxLen: SizeInt): TPtrWrapper;
+var
+  D: PDeferMoveToSBAndFree;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferMoveToSBAndFree));
+  D^.Init;
+  Result := TMarshal.AllocMem((MaxLen + 1) * SizeOf(UnicodeChar));
+  D^.Src := Result;
+  D^.SB := SB;
+  D^.MaxLen := MaxLen;
+end;
+
+function TMarshaller.OutString(const S: UnicodeString): TPtrWrapper;
+var
+  TS: UnicodeString;
+begin
+  TS := S;
+  Result := FixString(TS);
+end;
+
+function TMarshaller.InOutString(SB: TUnicodeStringBuilder; MaxLen: SizeInt): TPtrWrapper;
+var
+  D: PDeferMoveToSBAndFree;
+  NCopy: SizeInt;
+begin
+  Pointer(D) := PushDefer(SizeOf(TDeferMoveToSBAndFree));
+  D^.Init;
+  Result := TMarshal.AllocMem((MaxLen + 1) * SizeOf(UnicodeChar));
+  D^.Src := Result;
+  NCopy := SB.Length;
+  if MaxLen < NCopy then
+    NCopy := MaxLen;
+  TMarshal.WriteStringAsUnicode(Result, SB.ToString(0, NCopy), NCopy);
+  D^.SB := SB;
+  D^.MaxLen := MaxLen;
+end;

rtl/objpas/sysutils/sysmarshalh.inc

@@ -0,0 +1,193 @@
+type
+  { Must be in System rather than SysUtils once “generic procedure” are stabilized. }
+  TMarshal = class sealed
+    constructor Create;
+
+    class function AllocMem(Size: SizeInt): TPtrWrapper; static; inline;
+    class function ReallocMem(OldPtr: TPtrWrapper; NewSize: SizeInt): TPtrWrapper; static; inline;
+    class procedure FreeMem(Ptr: TPtrWrapper); static; inline;
+    class procedure Move(Src, Dest: TPtrWrapper; Count: SizeInt); static; inline;
+
+    class function AsAnsi(const S: UnicodeString): AnsiString; static; inline;
+    class function AsAnsi(S: PUnicodeChar): AnsiString; static; inline;
+
+    class function InOutString(const S: UnicodeString): PUnicodeChar; static; inline;
+    class function InString(const S: UnicodeString): PUnicodeChar; static; inline;
+    class function OutString(const S: UnicodeString): PUnicodeChar; static; inline;
+
+    class function UnsafeAddrOf(var Value): TPtrWrapper; static; inline;
+
+    class function AllocStringAsAnsi(const Str: UnicodeString): TPtrWrapper; static; inline;
+    class function AllocStringAsAnsi(const Str: UnicodeString; CodePage: Word): TPtrWrapper; static; inline;
+    class function AllocStringAsAnsi(S: PUnicodeChar): TPtrWrapper; static; inline;
+    class function AllocStringAsAnsi(S: PUnicodeChar; CodePage: Word): TPtrWrapper; static; inline;
+    class function AllocStringAsUnicode(const Str: UnicodeString): TPtrWrapper; static;
+    class function AllocStringAsUtf8(const Str: UnicodeString): TPtrWrapper; static; inline;
+    class function AllocStringAsUtf8(S: PUnicodeChar): TPtrWrapper; static; inline;
+
+    { Generalization of all AllocStringAsAnsi* above, public because used in TMarshaller. }
+    class function AllocStringAsAnsi(S: PUnicodeChar; Len: SizeInt; CodePage: Word): TPtrWrapper; static;
+
+    class procedure Copy(const Src: specialize TArray<UnicodeChar>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<UnicodeChar>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+    class procedure Copy(const Src: specialize TArray<UInt8>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<UInt8>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+    class procedure Copy(const Src: specialize TArray<Int8>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int8>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+    class procedure Copy(const Src: specialize TArray<UInt16>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<UInt16>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+    class procedure Copy(const Src: specialize TArray<Int16>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int16>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+    class procedure Copy(const Src: specialize TArray<Int32>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int32>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+    class procedure Copy(const Src: specialize TArray<Int64>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<Int64>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+    class procedure Copy(const Src: specialize TArray<TPtrWrapper>; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt); static; inline;
+    class procedure Copy(Src: TPtrWrapper; var Dest: specialize TArray<TPtrWrapper>; StartIndex: SizeInt; Count: SizeInt); static; inline;
+
+    generic class function FixArray<T>(const Arr: specialize TArray<T>): TPtrWrapper; static;
+    generic class procedure UnfixArray<T>(ArrPtr: TPtrWrapper); static;
+
+    class function FixString(var Str: UnicodeString): TPtrWrapper; static;
+    class procedure UnfixString(Ptr: TPtrWrapper); static;
+    class function UnsafeFixString(const Str: UnicodeString): TPtrWrapper; static;
+
+    class function ReadByte(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Byte; static; inline;
+    class procedure WriteByte(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Byte); static; inline;
+    class procedure WriteByte(Ptr: TPtrWrapper; Value: Byte); static; inline;
+
+    class function ReadInt16(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int16; static; inline;
+    class procedure WriteInt16(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int16); static; inline;
+    class procedure WriteInt16(Ptr: TPtrWrapper; Value: Int16); static; inline;
+
+    class function ReadInt32(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int32; static; inline;
+    class procedure WriteInt32(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int32); static; inline;
+    class procedure WriteInt32(Ptr: TPtrWrapper; Value: Int32); static; inline;
+
+    class function ReadInt64(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int64; static; inline;
+    class procedure WriteInt64(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int64); static; inline;
+    class procedure WriteInt64(Ptr: TPtrWrapper; Value: Int64); static; inline;
+
+    class function ReadPtr(Ptr: TPtrWrapper; Ofs: SizeInt = 0): TPtrWrapper; static; inline;
+    class procedure WritePtr(Ptr: TPtrWrapper; Ofs: SizeInt; Value: TPtrWrapper); static; inline;
+    class procedure WritePtr(Ptr, Value: TPtrWrapper); static; inline;
+
+    class function ReadStringAsAnsi(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString; static; inline;
+    class function ReadStringAsAnsi(CodePage: Word; Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString; static;
+    class function ReadStringAsAnsiUpTo(CodePage: Word; Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString; static;
+    class procedure WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt); static; inline;
+    class procedure WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word); static; inline;
+    class procedure WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt); static; inline;
+    class procedure WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word); static;
+
+    class function ReadStringAsUnicode(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString; static;
+    class function ReadStringAsUnicodeUpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString; static;
+    class procedure WriteStringAsUnicode(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt); static;
+    class procedure WriteStringAsUnicode(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt); static;
+
+    class function ReadStringAsUtf8(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString; static; inline;
+    class function ReadStringAsUtf8UpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString; static; inline;
+    class procedure WriteStringAsUtf8(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt); static; inline;
+    class procedure WriteStringAsUtf8(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt); static; inline;
+  end;
+
+  TMarshaller = record
+  private type
+    { Descendants of TDeferBase are stored in-place inside TDeferQueueNode.Mem.
+      First node is built into TState and uses StaticStore. }
+    PDeferQueueNode = ^TDeferQueueNode;
+    TDeferQueueNode = record
+      Used, Alloc: Int32;
+      Next: PDeferQueueNode;
+    case Cardinal of
+      0: (Mem: array[0 .. 0] of Byte);
+      1: (StaticStore: array[0 .. 15] of Pointer); { Also aligns variable part on SizeOf(Pointer). }
+    end;
+
+    TState = class(TInterfacedObject, IInterface)
+      DeferHead: TDeferQueueNode;
+      DeferTail: PDeferQueueNode;
+      constructor Create;
+      destructor Destroy; override;
+      procedure Flush;
+      procedure FlushQueue;
+      procedure ClearQueue;
+      procedure NotePointerChanged(OldPtr, NewPtr: TPtrWrapper);
+    end;
+
+    { Deferred operation (performed by Done). }
+    PDeferBase = ^TDeferBase;
+    TDeferBase = object
+      constructor Init;
+      destructor Done; virtual; abstract;
+      procedure NotePointerChanged(OldPtr, NewPtr: TPtrWrapper); virtual;
+    end;
+
+    PDeferFreeMem = ^TDeferFreeMem;
+    TDeferFreeMem = object(TDeferBase)
+      P: TPtrWrapper;
+      destructor Done; virtual;
+      procedure NotePointerChanged(OldPtr, NewPtr: TPtrWrapper); virtual;
+    end;
+
+    TUnfixProc = procedure(Ptr: TPtrWrapper);
+
+    { Not required if there is a way to take an address of a generic procedure specialization... }
+    generic TAddressableUnfixArraySpecialization<T> = record
+      class procedure UnfixArray(ArrPtr: TPtrWrapper); static;
+    end;
+
+    PDeferUnfix = ^TDeferUnfix;
+    TDeferUnfix = object(TDeferBase)
+      Unfix: TUnfixProc;
+      P: TPtrWrapper;
+      destructor Done; virtual;
+    end;
+
+    PDeferMoveToSBAndFree = ^TDeferMoveToSBAndFree;
+    TDeferMoveToSBAndFree = object(TDeferBase)
+      Src: TPtrWrapper;
+      SB: TUnicodeStringBuilder;
+      MaxLen: SizeInt;
+      destructor Done; virtual;
+    end;
+
+    function PushDefer(InstanceSize: SizeInt): PDeferBase;
+
+  var
+    FState: TState;
+    FStateLife: IInterface;
+
+  public
+    procedure Flush;
+
+    function AllocMem(Size: SizeInt): TPtrWrapper;
+    function ReallocMem(OldPtr: TPtrWrapper; NewSize: NativeInt): TPtrWrapper;
+
+    function AllocStringAsAnsi(const Str: UnicodeString): TPtrWrapper; inline;
+    function AllocStringAsAnsi(const Str: UnicodeString; CodePage: Word): TPtrWrapper; inline;
+    function AllocStringAsUnicode(const Str: UnicodeString): TPtrWrapper;
+    function AllocStringAsUtf8(const Str: UnicodeString): TPtrWrapper; inline;
+
+    function AsAnsi(const S: UnicodeString): TPtrWrapper; inline;
+    function AsAnsi(S: PUnicodeChar): TPtrWrapper; inline;
+    function AsAnsi(const S: UnicodeString; CodePage: Word): TPtrWrapper; inline;
+    function AsAnsi(S: PUnicodeChar; CodePage: Word): TPtrWrapper; inline;
+
+    function AsUtf8(const S: UnicodeString): TPtrWrapper; inline;
+    function AsUtf8(S: PUnicodeChar): TPtrWrapper; inline;
+  private
+    function AllocStringAsAnsi(S: PUnicodeChar; Len: SizeInt; CodePage: Word): TPtrWrapper;
+
+  public
+    { No clue what's it, let it be a synonym of FixArray for now... }
+    function AsRaw(const B: TBytes): TPtrWrapper; inline;
+
+    generic function FixArray<T>(const Arr: specialize TArray<T>): TPtrWrapper;
+    function FixString(var Str: UnicodeString): TPtrWrapper;
+    function UnsafeFixString(const Str: UnicodeString): TPtrWrapper;
+
+    function InString(SB: TUnicodeStringBuilder; MaxLen: SizeInt): TPtrWrapper;
+    function OutString(const S: UnicodeString): TPtrWrapper; inline;
+    function InOutString(SB: TUnicodeStringBuilder; MaxLen: SizeInt): TPtrWrapper;
+  end;

rtl/objpas/sysutils/sysutilh.inc

@@ -335,6 +335,9 @@ Type
   { interface handling }
   {$i intfh.inc}
 
+  { strange Delphi thing }
+  {$i sysmarshalh.inc}
+
   function SafeLoadLibrary(const FileName: AnsiString;
     ErrorMode: DWord = {$ifdef windows}SEM_NOOPENFILEERRORBOX{$else windows}0{$endif windows}): HMODULE;
 

rtl/objpas/sysutils/sysutils.inc

@@ -43,6 +43,9 @@
   { Type helpers}
   {$i syshelp.inc}
 
+  { strange Delphi thing }
+  {$i sysmarshal.inc}
+
   {$ifndef OS_FILEISREADONLY}
   Function FileIsReadOnly(const FileName: RawByteString): Boolean;
   begin

tests/test/units/sysutils/tmarshaller.pp

@@ -0,0 +1,367 @@
+{$ifdef fpc}
+	{$mode objfpc} {$longstrings on} {$codepage utf8} {$modeswitch advancedrecords}
+
+	{$warn 4055 off : Conversion between ordinals and pointers is not portable}
+{$else}
+	{$define delphi}
+	{$define endian_little}
+	{$apptype console}
+{$endif}
+
+{-$define test_things_broken_in_fpc}
+{-$define test_things_broken_in_xe3}
+
+uses
+	SysUtils;
+
+var
+	anythingFailed: boolean = false;
+
+	procedure Fail(const msg: unicodestring);
+	begin
+		writeln(msg + sLineBreak);
+		anythingFailed := true;
+	end;
+
+	procedure Expect(const got, expected, what: ansistring); overload;
+	begin
+		if got <> expected then
+			Fail(unicodestring(what + ' failed: got ' + got + ', expected ' + expected + '.'));
+	end;
+
+	// My Delphi XE3 has a bug: its TMarshal occasionally does not append #0 to returned unicodestrings (!),
+	// and its unicodestring comparison for equality compares terminators, making ExpectU(TMarshal.ReadStringThatDefinitelyWasあ, 'あ') fail.
+	function UStrEq(const a, b: unicodestring): boolean;
+	begin
+	{$ifdef delphi}
+		result := (length(a) = length(b)) and CompareMem(pointer(a), pointer(b), length(a) * sizeof(a[1]));
+	{$else}
+		result := a = b;
+	{$endif}
+	end;
+
+	procedure ExpectU(const got, expected, what: unicodestring); overload;
+	begin
+		if not UStrEq(got, expected) then
+			Fail(what + ' failed: got ' + got + ', expected ' + expected + '.');
+	end;
+
+	procedure Expect(got: pointer; const expected: array of byte; const what: ansistring); overload;
+	var
+		i: NativeInt;
+		lines: array[0 .. 4] of ansistring;
+		ba, bb: byte;
+	begin
+		if not CompareMem(got, @expected[0], length(expected)) then
+		begin
+			for i := 0 to High(lines) do lines[i] := '';
+			for i := 0 to High(expected) do
+			begin
+				ba := pByte(got)[i];
+				bb := expected[i];
+				if (ba >= 32) and (ba <= 127) then lines[0] := lines[0] + '  ' + chr(ba) else lines[0] := lines[0] + '---';
+				lines[1] := lines[1] + ' ' + IntToHex(ba, 2);
+				if ba <> bb then lines[2] := lines[2] + ' !!' else lines[2] := lines[2] + '   ';
+				lines[3] := lines[3] + ' ' + IntToHex(bb, 2);
+				if (bb >= 32) and (bb <= 127) then lines[4] := lines[4] + '  ' + chr(bb) else lines[4] := lines[4] + '---';
+			end;
+			Fail(unicodestring(what + ' failed:' + sLineBreak +
+				'         ' + lines[0] + sLineBreak +
+				'got      ' + lines[1] + sLineBreak +
+				'         ' + lines[2] + sLineBreak +
+				'expected ' + lines[3] + sLineBreak +
+				'         ' + lines[4]));
+			exit;
+		end;
+	end;
+
+{$ifdef delphi}
+const
+	CP_UTF8 = 65001;
+
+type
+	TUnicodeStringBuilder = TStringBuilder;
+
+	function NtoLE(x: smallint): smallint; overload; begin result := x; end;
+	function NtoLE(x: longint): longint; overload; begin result := x; end;
+	function NtoLE(x: int64): int64; overload; begin result := x; end;
+	function LEtoN(x: smallint): smallint; overload; begin result := x; end;
+	function LEtoN(x: longint): longint; overload; begin result := x; end;
+	function LEtoN(x: int64): int64; overload; begin result := x; end;
+{$endif}
+
+const
+	ShiftJIS = 932;
+	SjJaA: array[0 .. 1] of byte = ($82, $A0); // Bytes of あ in Shift JIS.
+	SjJaKa: array[0 .. 1] of byte = ($82, $A9); // Bytes of か in Shift JIS.
+	Utf8JaA: array[0 .. 2] of byte = ($E3, $81, $82); // Bytes of あ in UTF-8.
+	Utf8JaKa: array[0 .. 2] of byte = ($E3, $81, $8B); // Bytes of か in UTF-8.
+	Utf16JaA: array[0 .. 1] of byte = {$ifdef endian_little} ($42, $30) {$else} ($30, $42) {$endif}; // Bytes of あ in UTF-16.
+	Utf16JaKa: array[0 .. 1] of byte = {$ifdef endian_little} ($4B, $30) {$else} ($30, $4B) {$endif}; // Bytes of か in UTF-16.
+
+	function Concat(const a, b: array of byte): {$ifdef fpc} specialize {$endif} TArray<byte>;
+	begin
+		result := nil; // suppress warning
+		SetLength(result, length(a) + length(b));
+		Move(a[0], result[0], length(a));
+		Move(b[0], result[length(a)], length(b));
+	end;
+
+	function MemBytes(mem: pointer; n: NativeInt): {$ifdef fpc} specialize {$endif} TArray<byte>;
+	begin
+		result := nil; // suppress warning
+		SetLength(result, n);
+		Move(mem^, result[0], n);
+	end;
+
+	procedure TestTMarshal;
+	var
+		pw, pw2, pfa, pfs: TPtrWrapper;
+		i: NativeInt;
+		ptrVal: pointer;
+		i32arr: {$ifdef fpc} specialize {$endif} TArray<longint>;
+		us, us2: unicodestring;
+	begin
+		pw := TPtrWrapper.NilValue;
+		pw2 := TPtrWrapper.NilValue;
+		pfa := TPtrWrapper.NilValue;
+		pfs := TPtrWrapper.NilValue;
+
+		try
+			pw := TMarshal.AllocMem(19 + sizeof(pointer));
+			TMarshal.WriteByte(pw, 4, $1);
+			TMarshal.WriteInt16(pw, 5, NtoLE($2345));
+			TMarshal.WriteInt32(pw, 7, NtoLE($6789ABCD));
+			TMarshal.WriteInt64(pw, 11, NtoLE(int64($EF00112233445566)));
+
+			// Create a nontrivial pointer value...
+			NativeUint(ptrVal) := 0;
+			for i := 0 to sizeof(pointer) - 1 do
+				NativeUint(ptrVal) := NativeUint(ptrVal) shl 8 or NativeUint(1 + i);
+
+			TMarshal.WritePtr(pw, 19, TPtrWrapper.Create(ptrVal));
+
+			pw2 := TMarshal.ReallocMem(pw, 100);
+			pw := TPtrWrapper.NilValue;
+			Expect(pw2.ToPointer, Concat([0, 0, 0, 0, $1, $45, $23, $CD, $AB, $89, $67, $66, $55, $44, $33, $22, $11, $00, $EF], MemBytes(@ptrVal, sizeof(ptrVal))),
+				'TMarshal.AllocMem/WriteByte/Int16/Int32/Int64/Ptr/ReallocMem');
+
+			Expect(IntToHex(TMarshal.ReadByte(pw2, 4), 2), '01', 'ReadByte');
+			Expect(IntToHex(LEtoN(TMarshal.ReadInt16(pw2, 5)), 4), '2345', 'ReadInt16');
+			Expect(IntToHex(LEtoN(TMarshal.ReadInt32(pw2, 7)), 8), '6789ABCD', 'ReadInt32');
+			Expect(IntToHex(LEtoN(TMarshal.ReadInt64(pw2, 11)), 16), 'EF00112233445566', 'ReadInt64');
+			Expect(IntToHex(LEtoN(TMarshal.ReadPtr(pw2, 19).ToInteger), sizeof(pointer) * 2), IntToHex(NativeUint(ptrVal), sizeof(pointer) * 2), 'ReadPtr');
+
+			pw := TMarshal.AllocMem(19);
+			TMarshal.Move(pw2, pw, 19);
+			Expect(pw.ToPointer, [0, 0, 0, 0, $1, $45, $23, $CD, $AB, $89, $67, $66, $55, $44, $33, $22, $11, $00, $EF], 'Move');
+
+			i32arr := nil; // suppress warning
+			SetLength(i32arr, 4);
+			i32arr[0] := NtoLE(longint($11223344));
+			i32arr[1] := NtoLE(longint($55667788));
+			i32arr[2] := NtoLE(longint($99AABBCC));
+			i32arr[3] := NtoLE(longint($DDEEFF00));
+			TMarshal.Copy(i32arr, 1, pw, 2);
+			Expect(pw.ToPointer, [$88, $77, $66, $55, $CC, $BB, $AA, $99, $AB, $89, $67, $66, $55, $44, $33, $22, $11, $00, $EF], 'Copy(Int32[] -> TPtrWrapper)');
+			TMarshal.FreeMem(pw);
+			pw := TPtrWrapper.NilValue;
+
+			pw := TMarshal.AllocStringAsAnsi('あか', ShiftJIS);
+			Expect(pw.ToPointer, Concat(Concat(SjJaA, SjJaKa), [0]), 'AllocStringAsAnsi');
+			TMarshal.FreeMem(pw);
+			pw := TPtrWrapper.NilValue;
+
+			pw := TMarshal.AllocStringAsUnicode('あか');
+			Expect(pw.ToPointer, Concat(Concat(Utf16JaA, Utf16JaKa), [0, 0]), 'AllocStringAsUnicode');
+			TMarshal.FreeMem(pw);
+			pw := TPtrWrapper.NilValue;
+
+			pw := TMarshal.AllocStringAsUtf8('あか');
+			Expect(pw.ToPointer, Concat(Concat(Utf8JaA, Utf8JaKa), [0]), 'AllocStringAsUtf8');
+			TMarshal.FreeMem(pw);
+			pw := TPtrWrapper.NilValue;
+
+			pfa := TMarshal.{$ifdef fpc} specialize {$endif} FixArray<longint>(i32arr);
+			i32arr := nil;
+			Expect(pfa.ToPointer, [$44, $33, $22, $11, $88, $77, $66, $55, $CC, $BB, $AA, $99, $00, $FF, $EE, $DD], 'FixArray');
+			TMarshal.{$ifdef fpc} specialize {$endif} UnfixArray<longint>(pfa);
+			pfa := TPtrWrapper.NilValue;
+
+			us := 'h' + unicodestring(IntToStr(random(0)));
+			us2 := us;
+			pfs := TMarshal.FixString(us2);
+			PWideChar(Pointer(us))[0] := 'q'; // Doing this with us2 (which was passed to FixString) WILL alter the string pfs points to, same in Delphi.
+			Expect(pfs.ToPointer, [LEtoN(smallint('h')) and $FF, LEtoN(smallint('h')) shr 8, LEtoN(smallint('0')) and $FF, LEtoN(smallint('0')) shr 8], 'FixString');
+			TMarshal.UnfixString(pfs);
+			pfs := TPtrWrapper.NilValue;
+
+			FillChar(pw2.ToPointer^, 8, $EE);
+			// For now, FP TMarshal does not handle multi-byte characters atomically unlike Delphi TMarshal,
+			// but I think this must be addressed in the WideStringManager rather than TMarshal.
+		{$if defined(delphi) or defined(test_things_broken_in_fpc)}
+			TMarshal.WriteStringAsAnsi(pw2, 2, 'あか', 3, ShiftJIS);
+			Expect(pw2.ToPointer, [$EE, $EE, SjJaA[0], SjJaA[1], $EE, $EE, $EE, $EE], 'WriteStringAsAnsi(max=3)');
+		{$endif}
+			TMarshal.WriteStringAsAnsi(pw2, 2, 'あか', 4, ShiftJIS);
+			Expect(pw2.ToPointer, [$EE, $EE, SjJaA[0], SjJaA[1], SjJaKa[0], SjJaKa[1], $EE, $EE], 'WriteStringAsAnsi(max=4)');
+			TMarshal.WriteStringAsAnsi(pw2, 2, 'あか', -1, ShiftJIS);
+			Expect(pw2.ToPointer, [$EE, $EE, SjJaA[0], SjJaA[1], SjJaKa[0], SjJaKa[1], 0, $EE], 'WriteStringAsAnsi(max=-1)');
+			TMarshal.WriteStringAsAnsi(pw2, 7, 'あか', 0, ShiftJIS);
+			Expect(pw2.ToPointer, [$EE, $EE, SjJaA[0], SjJaA[1], SjJaKa[0], SjJaKa[1], 0, $EE], 'WriteStringAsAnsi(max=0)');
+
+			ExpectU(TMarshal.ReadStringAsAnsi(ShiftJIS, TPtrWrapper.Create(pw2.ToInteger + 2), -1), 'あか', 'ReadStringAsAnsi(Len = -1)');
+			ExpectU(TMarshal.ReadStringAsAnsi(ShiftJIS, TPtrWrapper.Create(pw2.ToInteger + 2), 2), 'あ', 'ReadStringAsAnsi(Len = 2)');
+		{$if defined(delphi) or defined(test_things_broken_in_fpc)}
+			ExpectU(TMarshal.ReadStringAsAnsi(ShiftJIS, TPtrWrapper.Create(pw2.ToInteger + 2), 3), 'あ', 'ReadStringAsAnsi(Len = 3)');
+		{$endif}
+
+			FillChar(pw2.ToPointer^, 9, $EE);
+			TMarshal.WriteStringAsUnicode(pw2, 2, 'あか', 1);
+			Expect(pw2.ToPointer, [$EE, $EE, Utf16JaA[0], Utf16JaA[1], $EE, $EE, $EE, $EE, $EE], 'WriteStringAsUnicode(max=1)');
+			TMarshal.WriteStringAsUnicode(pw2, 2, 'あか', 2);
+			Expect(pw2.ToPointer, [$EE, $EE, Utf16JaA[0], Utf16JaA[1], Utf16JaKa[0], Utf16JaKa[1], $EE, $EE, $EE], 'WriteStringAsUnicode(max=2)');
+			FillChar(pw2.ToPointer^, 8, $EE);
+			TMarshal.WriteStringAsUnicode(pw2, 2, 'あか', -1);
+			Expect(pw2.ToPointer, [$EE, $EE, Utf16JaA[0], Utf16JaA[1], Utf16JaKa[0], Utf16JaKa[1], 0, 0, $EE], 'WriteStringAsUnicode(max=-1)');
+			TMarshal.WriteStringAsUnicode(pw2, 8, 'あか', 0);
+			Expect(pw2.ToPointer, [$EE, $EE, Utf16JaA[0], Utf16JaA[1], Utf16JaKa[0], Utf16JaKa[1], 0, 0, $EE], 'WriteStringAsUnicode(max=0)');
+
+			ExpectU(TMarshal.ReadStringAsUnicode(TPtrWrapper.Create(pw2.ToInteger + 2), -1), 'あか', 'ReadStringAsUnicode(Len = -1)');
+			ExpectU(TMarshal.ReadStringAsUnicode(TPtrWrapper.Create(pw2.ToInteger + 2), 1), 'あ', 'ReadStringAsUnicode(Len = 1)');
+
+			FillChar(pw2.ToPointer^, 10, $EE);
+		{$if defined(delphi) or defined(test_things_broken_in_fpc)}
+			TMarshal.WriteStringAsUtf8(pw2, 2, 'あか', 4);
+			Expect(pw2.ToPointer, [$EE, $EE, Utf8JaA[0], Utf8JaA[1], Utf8JaA[2], $EE, $EE, $EE, $EE, $EE], 'WriteStringAsUtf8(max=4)');
+		{$endif}
+			TMarshal.WriteStringAsUtf8(pw2, 2, 'あか', 6);
+			Expect(pw2.ToPointer, [$EE, $EE, Utf8JaA[0], Utf8JaA[1], Utf8JaA[2], Utf8JaKa[0], Utf8JaKa[1], Utf8JaKa[2], $EE, $EE], 'WriteStringAsUtf8(max=6)');
+			TMarshal.WriteStringAsUtf8(pw2, 2, 'あか', -1);
+			Expect(pw2.ToPointer, [$EE, $EE, Utf8JaA[0], Utf8JaA[1], Utf8JaA[2], Utf8JaKa[0], Utf8JaKa[1], Utf8JaKa[2], 0, $EE], 'WriteStringAsUtf8(max=-1)');
+
+			ExpectU(TMarshal.ReadStringAsUtf8(TPtrWrapper.Create(pw2.ToInteger + 2), -1), 'あか', 'ReadStringAsUtf8(Len = -1)');
+			// These things are buggy in Delphi XE3 due to wrong assumptions it makes about when MultiByteToWideChar result
+			// includes the null terminator and when it does not, didn't test newer versions.
+			// (Shift-JIS version works for me however, probably by chance...)
+		{$if defined(fpc) or defined(test_things_broken_in_xe3)}
+			ExpectU(TMarshal.ReadStringAsUtf8(TPtrWrapper.Create(pw2.ToInteger + 2), 3), 'あ', 'ReadStringAsUtf8(Len = 3)');
+		{$if defined(delphi) or defined(test_things_broken_in_fpc)}
+			ExpectU(TMarshal.ReadStringAsUtf8(TPtrWrapper.Create(pw2.ToInteger + 2), 4), 'あ', 'ReadStringAsUtf8(Len = 4)');
+		{$endif}
+		{$endif}
+
+		finally
+			TMarshal.UnfixString(pfs);
+			TMarshal.{$ifdef fpc} specialize {$endif} UnfixArray<longint>(pfa);
+			TMarshal.FreeMem(pw2);
+			TMarshal.FreeMem(pw);
+		end;
+	end;
+
+{$if defined(fpc) or defined(test_things_broken_in_xe3)}
+var
+	OrigMgr: TMemoryManager;
+	TrackedPointers: array[0 .. 1] of pointer;
+
+	function TrackedFreeMem(ptr: pointer): {$ifdef delphi} integer {$else} PtrUint {$endif};
+	var
+		i: NativeInt;
+	begin
+		for i := 0 to High(TrackedPointers) do
+			if TrackedPointers[i] = ptr then TrackedPointers[i] := nil;
+		result := OrigMgr.FreeMem(ptr);
+	end;
+{$endif}
+
+	procedure TestTMarshaller;
+
+	{$if defined(fpc) or defined(test_things_broken_in_xe3)} // *SIGH*
+		procedure TestRealloc;
+		var
+			m: TMarshaller;
+			c: TPtrWrapper;
+			oldcv: pointer;
+			csz: NativeInt;
+			newMgr: TMemoryManager;
+		begin
+			m.AllocMem(5);
+			m.AllocMem(6);
+			csz := 7;
+			c := m.AllocMem(csz);
+			oldcv := c.ToPointer;
+			repeat
+				csz := 2 * csz;
+				c := m.ReallocMem(c, csz);
+			until c.ToPointer <> oldcv;
+
+			newMgr.FreeMem := nil; // suppress warning
+			GetMemoryManager(newMgr);
+			OrigMgr := newMgr;
+			newMgr.FreeMem := @TrackedFreeMem;
+			SetMemoryManager(newMgr);
+			try
+				TrackedPointers[0] := oldcv;
+				TrackedPointers[1] := c.ToPointer;
+				m.Flush;
+				if TrackedPointers[0] = nil then Fail('TMarshaller freed the old pointer supplied to ReallocMem.');
+				if TrackedPointers[1] <> nil then Fail('TMarshaller did not free the new pointer got from ReallocMem.');
+			finally
+				SetMemoryManager(OrigMgr);
+			end;
+		end;
+	{$endif}
+
+		procedure TestAllocString;
+		var
+			m: TMarshaller;
+		begin
+			Expect(m.AllocStringAsAnsi('あか', ShiftJIS).ToPointer, Concat(Concat(SjJaA, SjJaKa), [0]), 'AllocStringAsAnsi');
+			Expect(m.AllocStringAsUnicode('あか').ToPointer, Concat(Concat(Utf16JaA, Utf16JaKa), [0, 0]), 'AllocStringAsUnicode');
+		end;
+
+		procedure TestInOutString;
+		var
+			m: TMarshaller;
+			sba, sbb: TUnicodeStringBuilder;
+		begin
+			sba := nil; sbb := nil;
+			try
+				sba := TUnicodeStringBuilder.Create('ikai wa');
+				sbb := TUnicodeStringBuilder.Create('fukashin atorakushon');
+
+				TMarshal.WriteStringAsUnicode(m.InString(sba, 10), 'IKAI', -1);
+				TMarshal.WriteStringAsUnicode(m.InOutString(sbb, 10), 'FUKASHIN', -1);
+
+				ExpectU(sba.ToString, 'ikai wa', 'InString (pending)');
+				ExpectU(sbb.ToString, 'fukashin atorakushon', 'InOutString (pending)');
+
+				m.Flush;
+
+				ExpectU(sba.ToString, 'IKAI', 'InString');
+				ExpectU(sbb.ToString, 'FUKASHIN', 'InOutString');
+			finally
+				sba.Free; sbb.Free;
+			end;
+		end;
+
+	var
+		heapUsed: NativeUint;
+	begin
+		heapUsed := GetHeapStatus.TotalAllocated;
+	{$if defined(fpc) or defined(test_things_broken_in_xe3)}
+		TestRealloc;
+	{$endif}
+		TestAllocString;
+		TestInOutString;
+		if GetHeapStatus.TotalAllocated <> heapUsed then
+			Fail(unicodestring('TMarshaller leaked: heap used before = ' + IntToStr(heapUsed) + ', after = ' + IntToStr(GetHeapStatus.TotalAllocated) + '.'));
+	end;
+
+begin
+	TestTMarshal;
+	if anythingFailed then halt(1);
+	TestTMarshaller;
+	if anythingFailed then halt(2);
+	if not anythingFailed then writeln('...ok?');
+end.