From 23bdb06ba885dd5b6839cf1a62beee4893156512 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 10:51:36 +0200 Subject: [PATCH 01/28] Fix compiler state corruption after an exception in the OnUses handler With PS_USESSUPPORT, ProcessUses sets fModule to the name of the unit being imported before invoking the OnUses callback. The regular failure path (OnUses returning False) restores fModule and FParser afterwards, but the exception handler did not. The stale fModule survives Cleanup: Compile saves it as OldFileName on entry and restores it after the System import, so every following Compile on the same instance treats the main module as the previously failed unit and rejects any 'uses ;' with a bogus cross-reference error. Reproduction (one compiler instance): 1. Compile a script whose OnUses handler raises (e.g. a failing AddTypeS registration) -> correct error is reported. 2. Compile any script with 'uses ;' again -> before: 'Cross-Reference error of ' -> after: compiles normally (or reports the real error again). The exception handler now restores FParser and fModule exactly like the regular failure path. MakeError stays first so the error keeps being attributed to the failed unit. Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..6a915dc3 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -12593,8 +12593,14 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; except on e: Exception do begin - MakeError('', ecCustomError, tbtstring(e.Message)); - {$IFNDEF PS_USESSUPPORT} + MakeError('', ecCustomError, tbtstring(e.Message)); // still attributed to the used unit + {$IFDEF PS_USESSUPPORT} + // restore what the regular failure path above restores: a stale + // fModule survives Cleanup and makes every following Compile of + // this instance fail with a bogus cross-reference error + FParser:=ParserPos; + fModule:=OldFileName; + {$ELSE} FUses.Free; {$ENDIF} Result := False; From c8454f32bd966fb5f3083d4721d77afa6f80ae17 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:13:13 +0200 Subject: [PATCH 02/28] Fix dynamic array parameters and results on the Rtti.Invoke call path Imported (host) functions called through the Rtti.Invoke path (the default since XE2; PS_USECLASSICINVOKE was not affected) mishandled dynamic arrays in two ways: 1. By-value dynamic array parameters passed the address of the script's variable slot instead of the array pointer stored in it. The callee then interpreted the slot address as an array reference and crashed with an access violation (reproducible on Win32 and Win64). 2. Dynamic array results were only retrieved when a host RTTI type could be located whose name ends with the script type's exported name. Script types are usually not name-exported, so the lookup found nothing - and because the Invoke call sat inside the search loop, the imported function was then never called at all: the script silently received an empty array (and none of the function's side effects). The empty-result path additionally corrupted the result IFC record by setting res.dta to nil. The parameter case now passes the dereferenced array pointer. The result case selects a type info matching the managed kind of the element type (Invoke only needs it for the - universally identical - dynamic array result ABI and for releasing the TValue's reference; the element-wise transfer into the script slot goes through the script's own type record). The host-type name lookup remains as the path for nested container elements, and a failed lookup now fails the call instead of faking an empty result. Empty results clear the script slot properly via CopyArrayContents. Related: #198 (the FPC report covers the classic x86 path, but the same symptom class exists here on the default path). Co-Authored-By: Claude Fable 5 --- Source/InvokeCall.inc | 52 +++++++++++++++++++++++++++++++++---------- 1 file changed, 40 insertions(+), 12 deletions(-) diff --git a/Source/InvokeCall.inc b/Source/InvokeCall.inc index 5251d075..0f45464c 100644 --- a/Source/InvokeCall.inc +++ b/Source/InvokeCall.inc @@ -290,8 +290,9 @@ begin exit; end; end - else //dynarray = just push pointer - aValues := aValues + [TValue.From(aValue^.dta)]; + else //dynamic array by value: pass the array pointer itself, not + //the address of the slot holding it (that crashed the callee) + aValues := aValues + [TValue.From(PPointer(aValue^.dta)^)]; end; //13 btPointer: aValues := aValues + [TValue.From(aValue^.dta)]; @@ -386,6 +387,7 @@ var SysCalConv : TCallConv; ctx: TRTTIContext; RttiType : TRttiType; ResValue : TValue; + ArrTypeInfo: PTypeInfo; begin Result := False; IsStatic := _Self = nil; @@ -478,16 +480,42 @@ begin //12 btArray: //need to check with open arrays begin - for RttiType in ctx.GetTypes do - if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkDynArray) then - begin - ResValue := Invoke(Address,Args,SysCalConv,RttiType.Handle,IsStatic); - if ResValue.GetArrayLength > 0 then - CopyArrayContents(res.dta, ResValue.GetReferenceToRawData, 1, res.aType) - else - res.dta := nil; - Break; - end; + // Invoke needs a dynamic array type info only for the result ABI + // (identical for all dynamic arrays) and to release the TValue's + // reference afterwards. The element-wise handling below uses the + // script's own type record, so for the TValue any type info with the + // right managed kind of element suffices. + ArrTypeInfo := nil; + case TPSTypeRec_Array(res.aType).ArrayType.BaseType of + btString: ArrTypeInfo := TypeInfo(TArray); + {$IFNDEF PS_NOWIDESTRING} + btWideString: ArrTypeInfo := TypeInfo(TArray); + btUnicodeString: ArrTypeInfo := TypeInfo(TArray); + {$ENDIF} + btVariant: ArrTypeInfo := TypeInfo(TArray); + btInterface: ArrTypeInfo := TypeInfo(TArray); + btArray, btRecord, btStaticArray: + // nested containers: prefer the host's own array type (exact + // element layout), located by the exported type name + for RttiType in ctx.GetTypes do + if (RttiType.TypeKind = tkDynArray) and (res.aType.FExportName <> '') and + (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) then + begin + ArrTypeInfo := RttiType.Handle; + Break; + end; + else + // unmanaged elements: releasing the reference is a plain block + // free, any element type will do + ArrTypeInfo := TypeInfo(TArray); + end; + if ArrTypeInfo = nil then + Exit; // fail the call instead of silently returning an empty array + ResValue := Invoke(Address, Args, SysCalConv, ArrTypeInfo, IsStatic); + // reference-assign into the script slot using the script's own type + // record; this also clears the slot correctly for empty results (the + // old code corrupted the IFC record by setting res.dta to nil) + CopyArrayContents(res.dta, ResValue.GetReferenceToRawData, 1, res.aType); end; //13 btPointer: res.dta := Pointer(Invoke(Address,Args,SysCalConv,TypeInfo(Pointer),IsStatic).AsType); From 8762b2edbd223ddadd4408a41711a9686b893632 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:14:49 +0200 Subject: [PATCH 03/28] Fix operator precedence hole in IsCompatibleType One line of the big compatibility expression was missing parentheses: (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString) or (p2.BaseType = btUnicodeString)) or 'and' binds stronger than 'or', so the (p2 = btUnicodeString) term stood alone: ANY destination type was considered assignment-compatible with a UnicodeString source. Since script 'string' is btUnicodeString nowadays, these all compiled without error and only failed at runtime (or corrupted data): var i: Integer; s: string; ... i := s; var b: Boolean; s: string; ... b := s; var d: Double; s: string; ... d := s; With the added parentheses the term applies - as clearly intended - only to btPchar/btString destinations. String-to-string, WideString and Char conversions keep compiling as before. Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..89b704f1 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -3287,7 +3287,10 @@ function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boo ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or - (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)or (p2.BaseType = btUnicodeString)) or + (((p1.basetype = btPchar) or (p1.BaseType = btString)) and + // the second/third term used to dangle outside the p1 check, which + // made EVERY destination type compatible with UnicodeString sources + ((p2.BaseType = btWideString) or (p2.BaseType = btUnicodeString))) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or {$ENDIF} From 6ae339b2fe6107d56dd1c762721cab0fed962b4e Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:16:22 +0200 Subject: [PATCH 04/28] Make failing interface/object casts catchable by script try/except The cast import (SpecImport's CastProc) reported failed interface and 'as' casts via CMD_Err2 and then returned False. CMD_Err2 already dispatches the error to the script's active exception handler and resets the pending-error state - so when the external proc afterwards returned False, the interpreter raised a second erCouldNotCallProc for which the handler was already consumed. Net effect: a failing cast could never be caught by try/except in a script, and the descriptive 'Cannot cast an interface/object' message was replaced by a generic 'Could not call proc'. Return True after CMD_Err2 instead, exactly like the DefProc builtins handle their reported errors (e.g. the string index checks). A failing cast now surfaces as a regular catchable runtime error with its proper message: try f := IMyFoo(u); // u does not implement IMyFoo except // reached now; previously the script died with 'Could not call proc' end; Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..c82a96b0 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -11259,7 +11259,7 @@ function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStac if (IUnknown(invar.Dta^) = nil) or (IUnknown(invar.Dta^).QueryInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^)) <> 0) then begin Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface)); - Result := False; + Result := True; // error already dispatched by CMD_Err2 exit; end; {$IFDEF Delphi3UP} @@ -11273,7 +11273,7 @@ function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStac if (TObject(invar.Dta^)= nil) or (not TObject(invar.dta^).GetInterface(TPSTypeRec_Interface(ResVar.aType).Guid, IUnknown(resvar.Dta^))) then begin Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastInterface)); - Result := False; + Result := True; // error already dispatched by CMD_Err2 exit; end; {$ENDIF} @@ -11303,8 +11303,8 @@ function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStac try TObject(ResVar.Dta^) := TObject(InVar.Dta^) as FSelf; except - Result := False; Caller.CMD_Err2(erCustomError, tbtString(RPS_CannotCastObject)); + Result := True; // error already dispatched by CMD_Err2 exit; end; end else From 69a90199f213e66262908b0f6c7ea7520b4fa9eb Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:21:40 +0200 Subject: [PATCH 05/28] IDispatchInvoke: pass IDispatch arguments as VT_DISPATCH Variant parameters holding an IDispatch reference were marshaled like every other variant: wrapped as VT_VARIANT or VT_BYREF pointing at a copy of the variant. Lenient automation servers (e.g. the Scripting.* classes) accept that form, but strict marshalers - most prominently .NET COM interop - reject it, and assigning an object to an IDispatch property only works with a plain dispatch argument. Such arguments are now passed as VT_DISPATCH with the interface pointer itself (deliberately WITHOUT VT_BYREF, which is known to crash several COM servers). The variant in Par keeps the reference alive for the duration of the Invoke call, so no AddRef is needed. Also replaces the repeated rgvarg[i] indexing with a PVariantArg local (FPC needs rgvarg^[i]) and the cleanup check with a VT_BYREF mask test so VT_DISPATCH entries are skipped correctly. Originally found and fixed in the TetzkatLipHoka fork during .NET interop testing. Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 61 +++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 28 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..a4acffc8 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -13820,12 +13820,14 @@ procedure TPSStack.SetWideString(ItemNo: Longint; function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant; var Param: Word; - i, ArgErr: Longint; + i, ArgErr, aSize: Longint; DispatchId: Longint; DispParam: TDispParams; ExceptInfo: TExcepInfo; aName: PWideChar; WSFreeList: TPSList; + ArgType: Word; + DispArg: PVariantArg; begin if Self = nil then begin raise EPSException.Create('Variant is null, cannot invoke', nil, 0, 0); @@ -13858,44 +13860,46 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS WSFreeList := TPSList.Create; try - GetMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1)); - FillCHar(DispParam.rgvarg^, sizeof(TVariantArg) * (High(Par) + 1), 0); + aSize := SizeOf(TVariantArg) * (High(Par) + 1); + GetMem(DispParam.rgvarg, aSize); + FillChar(DispParam.rgvarg^, aSize, 0); try for i := 0 to High(Par) do begin - if PVarData(@Par[High(Par)-i]).VType = varString then + ArgType := PVarData(@Par[High(Par)-i]).VType; + DispArg := @(DispParam.rgvarg{$IFDEF FPC}^{$ENDIF}[i]); + if ArgType = varString then begin - DispParam.rgvarg[i].vt := VT_BSTR; - DispParam.rgvarg[i].bstrVal := StringToOleStr(AnsiString(Par[High(Par)-i])); - WSFreeList.Add(DispParam.rgvarg[i].bstrVal); + DispArg.vt := VT_BSTR; + DispArg.bstrVal := StringToOleStr(AnsiString(Par[High(Par)-i])); + WSFreeList.Add(DispArg.bstrVal); {$IFDEF UNICODE} - end else if (PVarData(@Par[High(Par)-i]).VType = varOleStr) or (PVarData(@Par[High(Par)-i]).VType = varUString) then + end else if (ArgType = varOleStr) or (ArgType = varUString) then begin - DispParam.rgvarg[i].vt := VT_BSTR; - DispParam.rgvarg[i].bstrVal := StringToOleStr(UnicodeString(Par[High(Par)-i])); - WSFreeList.Add(DispParam.rgvarg[i].bstrVal); + DispArg.vt := VT_BSTR; + DispArg.bstrVal := StringToOleStr(UnicodeString(Par[High(Par)-i])); + WSFreeList.Add(DispArg.bstrVal); {$ENDIF} + end else if ArgType = varDispatch then + begin + // pass COM objects as plain VT_DISPATCH instead of a by-ref + // variant: strict marshalers (e.g. .NET COM interop) reject the + // wrapped form, and property assignments of IDispatch values only + // work this way. Deliberately without VT_BYREF, which is known to + // crash several COM servers. + DispArg.vt := VT_DISPATCH; + DispArg.dispVal := PVarData(@Par[High(Par)-i]).VDispatch; end else begin - DispParam.rgvarg[i].vt := VT_VARIANT or VT_BYREF; + DispArg.vt := VT_VARIANT or VT_BYREF; New( {$IFDEF DELPHI4UP} POleVariant {$ELSE} PVariant{$ENDIF} - (DispParam.rgvarg[i].pvarVal)); - - (* - {$IFDEF DELPHI4UP} - POleVariant - {$ELSE} - PVariant - {$ENDIF} - (DispParam.rgvarg[i].pvarVal)^ := Par[High(Par)-i]; - *) - Move(Par[High(Par)-i],Pointer(DispParam.rgvarg[i].pvarVal)^, + (DispArg.pvarVal)); + Move(Par[High(Par)-i],Pointer(DispArg.pvarVal)^, Sizeof({$IFDEF DELPHI4UP}OleVariant{$ELSE}Variant{$ENDIF})); - end; end; i :=Self.Invoke(DispatchId, GUID_NULL, LOCALE_SYSTEM_DEFAULT, Param, DispParam, @Result, @ExceptInfo, @ArgErr); @@ -13929,20 +13933,21 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS finally for i := 0 to High(Par) do begin - if DispParam.rgvarg[i].vt = (VT_VARIANT or VT_BYREF) then + DispArg := @(DispParam.rgvarg{$IFDEF FPC}^{$ENDIF}[i]); + if (DispArg.vt and VT_BYREF) = VT_BYREF then begin if{$IFDEF DELPHI4UP}POleVariant{$ELSE}PVariant{$ENDIF} - (DispParam.rgvarg[i].pvarVal) <> nil then + (DispArg.pvarVal) <> nil then Dispose( {$IFDEF DELPHI4UP} POleVariant {$ELSE} PVariant {$ENDIF} - (DispParam.rgvarg[i].pvarVal)); + (DispArg.pvarVal)); end; end; - FreeMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1)); + FreeMem(DispParam.rgvarg, aSize); end; finally for i := WSFreeList.Count -1 downto 0 do From ec630909e38d08563548907a7a4a4340485de7cc Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:24:47 +0200 Subject: [PATCH 06/28] Support assigning Variants and cross-typed interfaces to interface variables Assigning a Variant that holds an interface reference to a script variable of an interface type only worked when the destination was exactly IDispatch; every other interface destination failed with a plain 'Type Mismatch'. Assignments between differently declared interface types blindly copied the reference without ever consulting QueryInterface. SetVariantValue's btInterface branch now: - accepts Variants holding varUnknown/varDispatch values (including by-ref variants) for ANY interface destination, casting via QueryInterface on the destination's GUID; empty/nil Variants assign nil. Destinations declared as IUnknown (or without a GUID) receive the reference as-is, preserving existing behaviour. - performs interface-to-interface assignments of differently declared types via QueryInterface as well; same-GUID (and nil) assignments stay plain reference copies. Failed casts raise a descriptive, script-catchable error that names the destination type (or its GUID when the type is unnamed) instead of the generic type mismatch. Pre-Delphi3 builds keep their previous paths. Note: the companion fix 'Make failing interface/object casts catchable' covers the explicit cast-import path (CastProc); together they make all interface conversion failures catchable with descriptive messages. Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 103 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 100 insertions(+), 3 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..5d13f491 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -4516,6 +4516,90 @@ procedure AssignIDispatchFromVariant(var Dest: IDispatch; const Src: Variant); end; {$ENDIF} +{$IFNDEF PS_NOINTERFACES} +const + GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}'; + IUnknown_GUID: TGUID = '{00000000-0000-0000-C000-000000000046}'; + +// variant payload as IUnknown, no conversion (varAny/CORBA not supported) +function VarToIInterface(const Value: TVarData; out Obj): Boolean; +var + Intf: IUnknown absolute Obj; +begin + Pointer(Obj) := nil; + case Value.VType of + varUnknown, varDispatch: + if Assigned(Value.VUnknown) then + Intf := IUnknown(Value.VUnknown); + varUnknown + varByRef, varDispatch + varByRef: + if Assigned(Value.VPointer) then + Intf := IUnknown(PPointer(Value.VPointer)^); + end; + Result := Assigned(Intf); +end; + +// assign a Variant to an interface slot, casting to the destination GUID via +// QueryInterface; empty/nil variants assign nil when AllowEmptyAssign +function AssignIInterfaceFromVariant(var Dest: IUnknown; const Src: Variant; + const DestGuid: TGUID; AllowEmptyAssign: Boolean = True): Boolean; +var + iObj: IUnknown; +begin + Dest := nil; + case TVarData(Src).VType of + varEmpty, varNull: + begin + Result := AllowEmptyAssign; + Exit; + end; + varDispatch, varUnknown: + if TVarData(Src).VUnknown = nil then + begin + Result := AllowEmptyAssign; + Exit; + end; + end; + if VarToIInterface(TVarData(Src), iObj) then + begin + // GUID-less destinations (IUnknown or script interfaces declared without + // a GUID) get the reference as-is, everything else must support the GUID + if IsEqualGUID(DestGuid, IUnknown_GUID) or IsEqualGUID(DestGuid, GUID_NULL) then + Dest := iObj + else if iObj.QueryInterface(DestGuid, Dest) <> 0 then + Dest := nil; + end; + Result := Dest <> nil; +end; + +// assign between interface slots of different declared types (cast via +// QueryInterface); same GUID-less fallback as above +function AssignIntfFromIntf(var Dest: IUnknown; const Src: IUnknown; + const DestGuid: TGUID; AllowNilAssign: Boolean = True): Boolean; +begin + Dest := nil; + if Src = nil then + begin + Result := AllowNilAssign; + Exit; + end; + if IsEqualGUID(DestGuid, IUnknown_GUID) or IsEqualGUID(DestGuid, GUID_NULL) then + Dest := Src + else if Src.QueryInterface(DestGuid, Dest) <> 0 then + Dest := nil; + Result := Dest <> nil; +end; + +// 'Cannot cast an interface' plus the target's name (or GUID when unnamed) +function PSIntfCastErrorMsg(const BaseMsg: TbtString; DestType: TPSTypeRec): TbtString; +begin + Result := BaseMsg; + if DestType.ExportName <> '' then + Result := Result + TbtString(' ') + DestType.ExportName + else + Result := Result + TbtString(' ') + TbtString(GUIDToString(TPSTypeRec_Interface(DestType).Guid)); +end; +{$ENDIF !PS_NOINTERFACES} + function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean; var Tmp: TObject; @@ -4850,7 +4934,13 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR AssignIDispatchFromVariant(IDispatch(Dest^), Variant(Src^)); {$ENDIF} end else + {$IFDEF Delphi3UP} + if not AssignIInterfaceFromVariant(IUnknown(Dest^), Variant(Src^), + TPSTypeRec_Interface(desttype).Guid) then + raise Exception.Create(string(PSIntfCastErrorMsg(TbtString(RPS_CannotCastInterface), desttype))); + {$ELSE} Result := False; + {$ENDIF} {$IFDEF Delphi3UP} end else if srctype.BaseType = btClass then @@ -4864,15 +4954,22 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR {$ENDIF} end else if srctype.BaseType = btInterface then begin - {$IFNDEF Delphi3UP} + {$IFDEF Delphi3UP} + // same declared type (or nil source): plain assignment, otherwise + // cast to the destination interface via QueryInterface + if (Pointer(Src^) = nil) or + IsEqualGUID(TPSTypeRec_Interface(srctype).Guid, TPSTypeRec_Interface(desttype).Guid) then + IUnknown(Dest^) := IUnknown(Src^) + else if not AssignIntfFromIntf(IUnknown(Dest^), IUnknown(Src^), + TPSTypeRec_Interface(desttype).Guid) then + raise Exception.Create(string(PSIntfCastErrorMsg(TbtString(RPS_CannotCastInterface), desttype))); + {$ELSE} if IUnknown(Dest^) <> nil then begin IUnknown(Dest^).Release; IUnknown(Dest^) := nil; end; - {$ENDIF} IUnknown(Dest^) := IUnknown(Src^); - {$IFNDEF Delphi3UP} if IUnknown(Dest^) <> nil then IUnknown(Dest^).AddRef; {$ENDIF} From 21ce4b3cf6ba5f1f545319f46b02fd2018e4df98 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:26:31 +0200 Subject: [PATCH 07/28] Report which LoadData stage failed instead of failing silently Several failure paths inside LoadTypes/LoadProcs/LoadVars only return False without calling CMD_Err. LoadData then cleared the instance and returned False with ExceptionCode still erNoError, so hosts printing TIFErrorToString(ExceptionCode, ExceptionString) showed 'No Error' for a failed load. Each stage now reports a stage-specific erCustomError - but only when no more specific error is pending (ExEx = erNoError), so existing detailed errors like 'Out Of Range' or 'Unexpected End Of File' are preserved. Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..24bf94f4 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -3063,16 +3063,22 @@ function TPSExec.LoadData(const s: tbtString): Boolean; if not LoadTypes then begin Clear; + if ExEx = erNoError then + CMD_Err2(erCustomError, TbtString('Failed to load types')); exit; end; if not LoadProcs then begin Clear; + if ExEx = erNoError then + CMD_Err2(erCustomError, TbtString('Failed to load procedures')); exit; end; if not LoadVars then begin Clear; + if ExEx = erNoError then + CMD_Err2(erCustomError, TbtString('Failed to load variables')); exit; end; if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> InvalidVal)then begin From 740dbc746c1efe6981963748e1e59c893dee92e4 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:27:42 +0200 Subject: [PATCH 08/28] Raise instead of silently dropping a property with an unresolved type TPSCompileTimeClass.RegisterProperty freed the half-built property and returned silently when its type string referenced a type that was not (yet) registered. Scripts using the property then failed with a bare 'Unknown identifier' - very hard to trace back to a wrong registration order in an import unit. This is the actual root cause behind reports like issue #255 ('Delphi 11 case sensitive'). Raise EPSCompilerException naming the property and its type string instead, matching how AddTypeS and the other registration APIs report bad input. Inside OnUses the exception surfaces as a regular compiler error message. Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..784bf1a6 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -15678,7 +15678,10 @@ procedure TPSCompileTimeClass.RegisterProperty(const PropertyName, if FType = nil then begin p.Free; - Exit; + // dropping the property silently leads to hard-to-diagnose 'Unknown + // identifier' errors in scripts; report the unresolved type instead + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, + [PropertyName + ': ' + PropertyType]); end; if p.Decl.Result = nil then p.Decl.Result := FType else begin From ad34e3aaf243e680ab79314fc93ea2eb707270ba Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:44:13 +0200 Subject: [PATCH 09/28] Restore Delphi 7 compatibility Recent changes made the core units unbuildable on old Delphi versions (reported for Delphi 7 in issue #286). Three categories of fixes, all behavior-neutral on current compilers: - Exit(Value) needs Delphi 2009+: expanded to 'Result := ...; Exit;' in the for-loop code generation (EmitForEntryCheck/EmitForExitCheck). - High(UInt64)/High(tbtU64) is not evaluable as a constant expression on Delphi 7 (its UInt64 is a crippled signed alias): replaced with 'not UInt64(0)', which yields the same all-ones value everywhere. - 'tbtDouble(p^.textended)' is an invalid typecast on Delphi 7 (Extended -> Double must be a conversion): assign without the cast, which is the intended float conversion on every compiler. - SysUtils.StrToUInt64/StrToUInt64Def (XE4+) and SysUtils.UIntToStr (2009+) do not exist on old RTLs: uPSUtils now provides fallbacks, compiled only when SysUtils lacks them (checked via {$IF NOT DECLARED(...)}, so this adapts to any compiler and to FPC). The two qualified SysUtils.UIntToStr calls in uPSRuntime were unqualified so they resolve to whichever implementation exists. Note: pre-2010 compilers format UInt64 values above High(Int64) with a sign - an inherent limitation of their signed UInt64 alias. With this, all uPS* units (including the import units) compile on Delphi 7 again; Delphi 12 Win32/Win64 builds are unchanged. Fixes #286 (the current sources can be used on Delphi 7 again). Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 31 ++++++++++++++++++--------- Source/uPSRuntime.pas | 6 +++--- Source/uPSUtils.pas | 48 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 72 insertions(+), 13 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..73036203 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -1945,7 +1945,7 @@ function BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant{$IFNDEF PS_NO if ExecIs64Bit then begin {$IFNDEF CPU64} { On 64-bit Exec, Extended is an alias for Double, so write a Double instead } - TempDouble := tbtDouble(p^.textended); + TempDouble := p^.textended; { conversion; a tbtDouble() cast fails on Delphi 7 } BlockWriteData(BlockInfo, TempDouble, sizeof(tbtDouble)); {$ELSE} BlockWriteData(BlockInfo, p^.textended, sizeof(tbtExtended)); @@ -10214,9 +10214,9 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; TPSValueData(Result).Data^.ts64 := High(tbtS64); btU64: if Backwards then - TPSValueData(Result).Data^.tu64 := Low(tbtU64) - else - TPSValueData(Result).Data^.tu64 := High(tbtU64); + TPSValueData(Result).Data^.tu64 := 0 + else // all-ones = High(tbtU64); D7 cannot evaluate that as a constant + TPSValueData(Result).Data^.tu64 := not tbtU64(0); {$ENDIF} else begin @@ -10232,14 +10232,20 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Does not free finVal. See also EmitForExitCheck. } begin if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(finVal, nil)) then - Exit(False); + begin + Result := False; + Exit; + end; BlockWriteByte(BlockInfo, CM_CO); if Backwards then BlockWriteByte(BlockInfo, 0) { >= } else BlockWriteByte(BlockInfo, 1); { <= } if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then - Exit(False); + begin + Result := False; + Exit; + end; AfterWriteOutRec(finVal); AfterWriteOutRec(VariableVar); BlockWriteByte(BlockInfo, Cm_CNG); @@ -10260,18 +10266,23 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; BoundaryValue := CreateForBoundaryValue; ExitCheckEmitted := BoundaryValue <> nil; if BoundaryValue = nil then - Exit(True); + begin + Result := True; + Exit; + end; if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(BoundaryValue, nil)) then begin BoundaryValue.Free; - Exit(False); + Result := False; + Exit; end; BlockWriteByte(BlockInfo, CM_CO); BlockWriteByte(BlockInfo, 5); { = } if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(BoundaryValue, True)) then begin BoundaryValue.Free; - Exit(False); + Result := False; + Exit; end; AfterWriteOutRec(BoundaryValue); AfterWriteOutRec(VariableVar); @@ -12001,7 +12012,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; if FExecIs64Bit then begin {$IFNDEF CPU64} { On 64-bit Exec, Extended is an alias for Double, so write a Double instead } - TempDouble := tbtDouble(p^.textended); + TempDouble := p^.textended; { conversion; a tbtDouble() cast fails on Delphi 7 } WriteData(TempDouble, sizeof(tbtDouble)); {$ELSE} WriteData(p^.textended, sizeof(tbtExtended)); diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..78923981 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -9752,10 +9752,10 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack 40: Stack.SetAnsiString(-1, tbtstring(SysUtils.IntToStr(Stack.GetInt64(-2))));// Int64ToStr 41: Stack.SetInt64(-1, StrToInt64Def(string(Stack.GetAnsiString(-2)), Stack.GetInt64(-3))); // StrToInt64Def 45: Stack.SetUInt64(-1, StrToUInt64(string(Stack.GetAnsiString(-2)))); // StrToUInt64 - 46: Stack.SetAnsiString(-1, tbtstring(SysUtils.UIntToStr(Stack.GetUInt64(-2))));// UInt64ToStr + 46: Stack.SetAnsiString(-1, tbtstring(UIntToStr(Stack.GetUInt64(-2))));// UInt64ToStr 47: Stack.SetUInt64(-1, StrToUInt64Def(string(Stack.GetAnsiString(-2)), Stack.GetUInt64(-3))); // StrToUInt64Def {$ENDIF} - 48: Stack.SetAnsiString(-1, tbtstring(SysUtils.UIntToStr({$IFNDEF PS_NOINT64}Stack.GetUInt64(-2){$ELSE}Stack.GetUInt(-2){$ENDIF}))); // UIntToStr + 48: Stack.SetAnsiString(-1, tbtstring(UIntToStr({$IFNDEF PS_NOINT64}Stack.GetUInt64(-2){$ELSE}Stack.GetUInt(-2){$ENDIF}))); // UIntToStr 42: // sizeof begin temp := NewTPSVariantIFC(Stack[Stack.Count -2], False); @@ -10026,7 +10026,7 @@ function High_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): btS32 : Stack.SetInt(-1,High(Integer)); //Integer/LongInt: 2147483647 {$IFNDEF PS_NOINT64} btS64 : Stack.SetInt64(-1,High(Int64)); //Int64: 9223372036854775807 - btU64 : Stack.SetUInt64(-1,High(UInt64)); //UInt64: 18446744073709551615 + btU64 : Stack.SetUInt64(-1,not UInt64(0)); //UInt64: 18446744073709551615 (High(UInt64); D7 cannot evaluate that as a constant) {$ENDIF} else Result:=false; end; diff --git a/Source/uPSUtils.pas b/Source/uPSUtils.pas index f3d3ce30..80fe0674 100644 --- a/Source/uPSUtils.pas +++ b/Source/uPSUtils.pas @@ -657,6 +657,27 @@ function GRLW(var s: TbtString): TbtString; function WideUpperCase(const S: WideString): WideString; function WideLowerCase(const S: WideString): WideString; {$ENDIF} + +{ SysUtils fallbacks for compilers that lack the UInt64 conversion helpers + (the StrToUInt64 family appeared in XE4, UIntToStr in 2009). Note that + pre-2010 compilers treat UInt64 as a signed alias, so values above + High(Int64) are formatted with a sign there - an inherent limit of those + RTLs. } +{$IFNDEF PS_NOINT64} +{$IF NOT DECLARED(StrToUInt64)} + {$DEFINE PS_NEED_STRTOUINT64} +{$IFEND} +{$IF NOT DECLARED(UIntToStr)} + {$DEFINE PS_NEED_UINTTOSTR} +{$IFEND} +{$ENDIF} +{$IFDEF PS_NEED_STRTOUINT64} +function StrToUInt64(const S: string): UInt64; +function StrToUInt64Def(const S: string; const Default: UInt64): UInt64; +{$ENDIF} +{$IFDEF PS_NEED_UINTTOSTR} +function UIntToStr(Value: UInt64): string; +{$ENDIF} implementation {$IFDEF DELPHI3UP } @@ -1753,6 +1774,33 @@ procedure TPSUnit.SetUnitName(const Value: TbtString); fUnitName := FastUpperCase(Value); end; +{$IFDEF PS_NEED_STRTOUINT64} +function StrToUInt64(const S: string): UInt64; +var + Err: Integer; +begin + Val(S, Result, Err); + if Err <> 0 then + raise EConvertError.CreateFmt('''%s'' is not a valid UInt64 value', [S]); +end; + +function StrToUInt64Def(const S: string; const Default: UInt64): UInt64; +var + Err: Integer; +begin + Val(S, Result, Err); + if Err <> 0 then + Result := Default; +end; +{$ENDIF} + +{$IFDEF PS_NEED_UINTTOSTR} +function UIntToStr(Value: UInt64): string; +begin + Str(Value, Result); +end; +{$ENDIF} + end. From 18fa493abcb73cf933788532da66550dfc3bbc67 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:49:56 +0200 Subject: [PATCH 10/28] Support constant ranges in set literals: ['0'..'9'] Set/array literals only accepted single elements; the common Pascal notation with ranges failed to parse ('Closing square bracket expected'): if c in ['0'..'9'] then ... if b in [1..5, 250..255] then ... if f in [frBanana..frDate] then ... ReadArray now expands constant '..' ranges into individual constant elements while parsing. Rules match Delphi where applicable: - both bounds must be compile-time ordinal constants of the same family (char/char, integer/integer, or values of the identical enum type), - ranges can be mixed freely with single elements, - an inverted range ('z'..'a') contributes no elements, - a range spanning 256 or more values is rejected (a set cannot hold more), reported as a type mismatch. Dynamic bounds stay unsupported (they would require runtime set construction); the bounds must be constants, mirroring the previous all-constant behaviour of set literals. Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 95 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 93 insertions(+), 2 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..1a2aec8e 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -8078,7 +8078,60 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Proc: TPSProcedure; function ReadArray: Boolean; var - tmp: TPSValue; + tmp, tmp2: TPSValue; + RStart, RStop, RVal: Longint; + RType: TPSType; + + // constant ordinal value of a set/array literal element ('a', 5, enum) + function OrdValueOf(P: TPSValue; var v: Longint): Boolean; + begin + Result := P is TPSValueData; + if not Result then Exit; + case TPSValueData(P).Data.FType.BaseType of + btChar: v := Ord(TPSValueData(P).Data.tchar); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: v := Ord(TPSValueData(P).Data.twidechar); + {$ENDIF} + btU8: v := TPSValueData(P).Data.tu8; + btS8: v := TPSValueData(P).Data.ts8; + btU16: v := TPSValueData(P).Data.tu16; + btS16: v := TPSValueData(P).Data.ts16; + btEnum, btU32: v := Longint(TPSValueData(P).Data.tu32); + btS32: v := TPSValueData(P).Data.ts32; + else + Result := False; + end; + end; + + function SameOrdFamily(a, b: TPSType): Boolean; + begin + if a.BaseType = btEnum then + Result := a = b + else if a.BaseType in [btChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}] then + Result := b.BaseType in [btChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}] + else + Result := IsIntType(a.BaseType) and IsIntType(b.BaseType); + end; + + function MakeOrdConst(aType: TPSType; v: Longint): TPSValue; + begin + Result := TPSValueData.Create; + Result.SetParserPos(FParser); + TPSValueData(Result).Data := NewVariant(aType); + case aType.BaseType of + btChar: TPSValueData(Result).Data.tchar := TbtChar(v); + {$IFNDEF PS_NOWIDESTRING} + btWideChar: TPSValueData(Result).Data.twidechar := TbtWideChar(v); + {$ENDIF} + btU8: TPSValueData(Result).Data.tu8 := TbtU8(v); + btS8: TPSValueData(Result).Data.ts8 := TbtS8(v); + btU16: TPSValueData(Result).Data.tu16 := TbtU16(v); + btS16: TPSValueData(Result).Data.ts16 := TbtS16(v); + btEnum, btU32: TPSValueData(Result).Data.tu32 := TbtU32(v); + btS32: TPSValueData(Result).Data.ts32 := TbtS32(v); + end; + end; + begin FParser.Next; NewVar := TPSValueArray.Create; @@ -8102,7 +8155,45 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Result := False; exit; end; - TPSValueArray(NewVar).Add(tmp); + if FParser.CurrTokenID = CSTI_TwoDots then + begin + // range like ['0'..'9']: expand into individual constant + // elements; both bounds must be constant ordinals of the same + // family (char/char, int/int or the identical enum) + FParser.Next; + tmp2 := ReadExpression(); + if tmp2 = nil then + begin + tmp.Free; + NewVar.Free; + Result := False; + exit; + end; + if (not TryEvalConst(tmp2)) or (not OrdValueOf(tmp, RStart)) or + (not OrdValueOf(tmp2, RStop)) or + (not SameOrdFamily(TPSValueData(tmp).Data.FType, TPSValueData(tmp2).Data.FType)) or + (RStop - RStart >= 256) then // a set holds at most 256 elements + begin + MakeError('', ecTypeMismatch, ''); + tmp.Free; + tmp2.Free; + NewVar.Free; + Result := False; + exit; + end; + tmp2.Free; + if RStop >= RStart then + begin + RType := TPSValueData(tmp).Data.FType; + TPSValueArray(NewVar).Add(tmp); + for RVal := RStart + 1 to RStop do + TPSValueArray(NewVar).Add(MakeOrdConst(RType, RVal)); + end + else // like Delphi: an inverted range yields no elements + tmp.Free; + end + else + TPSValueArray(NewVar).Add(tmp); if FParser.CurrTokenID = CSTI_CloseBlock then Break; if FParser.CurrTokenID <> CSTI_Comma then begin From 23338d4c2497fa5649f72b1198ad86779db17ca3 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:52:47 +0200 Subject: [PATCH 11/28] Add a 'raise' statement and the ParamCount/ParamStr builtins raise: scripts could report custom errors only through the RaiseException builtin and could not re-raise inside except blocks with the usual Pascal syntax. The identifier RAISE is now handled as a statement in ProcessSub: raise; // re-raise: RaiseLastException raise Exception.Create('message'); // RaiseException(erCustomError, msg) The class name is parsed but not evaluated (scripts have no exception objects), the message may be any string expression, and the strict .Create() grammar keeps the single-token-lookahead parser deterministic. Both forms work as if/then one-liners and interact with try/except/finally as expected; ExceptionType/ExceptionParam report erCustomError and the message. ParamCount/ParamStr: the host process' command line was not reachable from scripts. Registered as DefProc indices 49/50 (45-48 are taken by the StrToUInt64 family and UIntToStr), kept in sync in DefineStandardProcedures, DefProc and RegisterStandardProcs. Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 109 +++++++++++++++++++++++++++++++++++++++++ Source/uPSRuntime.pas | 4 ++ 2 files changed, 113 insertions(+) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..c54f41c9 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -10971,6 +10971,107 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Result := True; end; {ProcessIdentifier} + function ProcessRaise: Boolean; + { 'raise;' re-raises the current exception (compiled as a call to + RaiseLastException); 'raise .Create();' compiles to + RaiseException(erCustomError, ). The class name is parsed but + not evaluated - scripts have no exception objects; the strict grammar + keeps the parser deterministic. } + var + L: Cardinal; + Decl: TPSParametersDecl; + Call: TPSValueProcNo; + Msg: TPSValue; + ExData: TPSValueData; + Con: TPSConstant; + begin + Result := False; + Debug_WriteLine(BlockInfo); + FParser.Next; // skip RAISE + if (FParser.CurrTokenId = CSTI_Semicolon) or (FParser.CurrTokenId = CSTII_End) or + (FParser.CurrTokenId = CSTII_Else) or (FParser.CurrTokenId = CSTII_Except) or + (FParser.CurrTokenId = CSTII_Finally) or (FParser.CurrTokenId = CSTII_until) then + begin // bare 'raise': re-raise the current exception + L := FindProc('RaiseLastException'); + if L = InvalidVal then + begin + MakeError('', ecUnknownIdentifier, 'RaiseLastException'); + exit; + end; + Call := TPSValueProcNo.Create; + Call.SetParserPos(FParser); + Call.ProcNo := L; + Call.ResultType := nil; + Call.Parameters := TPSParameters.Create; + Result := _ProcessFunction(Call, nil); + Call.Free; + exit; + end; + if FParser.CurrTokenId <> CSTI_Identifier then + begin + MakeError('', ecIdentifierExpected, ''); + exit; + end; + FParser.Next; + if FParser.CurrTokenId <> CSTI_Period then + begin + MakeError('', ecPeriodExpected, ''); + exit; + end; + FParser.Next; + if (FParser.CurrTokenId <> CSTI_Identifier) or (FParser.GetToken <> 'CREATE') then + begin + MakeError('', ecIdentifierExpected, FParser.OriginalToken); + exit; + end; + FParser.Next; + if FParser.CurrTokenId <> CSTI_OpenRound then + begin + MakeError('', ecOpenRoundExpected, ''); + exit; + end; + FParser.Next; + L := FindProc('RaiseException'); + Con := GetConstant('erCustomError'); + if (L = InvalidVal) or (Con = nil) then + begin + MakeError('', ecUnknownIdentifier, 'RaiseException'); + exit; + end; + Msg := Calc(CSTI_CloseRound); + if Msg = nil then + exit; + if FParser.CurrTokenId <> CSTI_CloseRound then + begin + MakeError('', ecCloseRoundExpected, ''); + Msg.Free; + exit; + end; + FParser.Next; + if TPSProcedure(FProcs[L]).ClassType = TPSInternalProcedure then + Decl := TPSInternalProcedure(FProcs[L]).Decl + else + Decl := TPSExternalProcedure(FProcs[L]).RegProc.Decl; + ExData := TPSValueData.Create; + ExData.SetParserPos(FParser); + ExData.Data := NewVariant(at2ut(Con.Value.FType)); + ExData.Data.tu32 := Con.Value.tu32; + Call := TPSValueProcNo.Create; + Call.SetParserPos(FParser); + Call.ProcNo := L; + Call.ResultType := Decl.Result; + Call.Parameters := TPSParameters.Create; + Call.Parameters.Add.Val := ExData; + Call.Parameters.Add.Val := Msg; + if not ValidateParameters(BlockInfo, Call.Parameters, Decl) then + begin + Call.Free; + exit; + end; + Result := _ProcessFunction(Call, nil); + Call.Free; + end; {ProcessRaise} + function ProcessCase: Boolean; var V1, V2, TempRec, Val, CalcItem: TPSValue; @@ -11677,6 +11778,12 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; FParser.Next; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; + end else if FParser.GetToken = 'RAISE' then + begin + if not ProcessRaise then + exit; + if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then + break; end else if not ProcessIdentifier then exit; @@ -13952,6 +14059,8 @@ procedure TPSPascalCompiler.DefineStandardProcedures; AddFunction('function ExceptionProc: Cardinal;'); AddFunction('function ExceptionPos: Cardinal;'); AddFunction('function ExceptionToString(er: TIFException; Param: string): string;'); + AddFunction('function ParamCount: Integer;'); + AddFunction('function ParamStr(Index: Integer): string;'); {$IFNDEF PS_NOINT64} AddFunction('function StrToInt64(S: string): Int64;'); AddFunction('function Int64ToStr(I: Int64): string;'); diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..19a4e723 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -9756,6 +9756,8 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack 47: Stack.SetUInt64(-1, StrToUInt64Def(string(Stack.GetAnsiString(-2)), Stack.GetUInt64(-3))); // StrToUInt64Def {$ENDIF} 48: Stack.SetAnsiString(-1, tbtstring(SysUtils.UIntToStr({$IFNDEF PS_NOINT64}Stack.GetUInt64(-2){$ELSE}Stack.GetUInt(-2){$ENDIF}))); // UIntToStr + 49: Stack.SetInt(-1, ParamCount); // ParamCount + 50: {$IFNDEF PS_NOWIDESTRING}Stack.SetUnicodeString(-1, tbtunicodestring(ParamStr(Stack.GetInt(-2)))){$ELSE}Stack.SetAnsiString(-1, tbtstring(ParamStr(Stack.GetInt(-2)))){$ENDIF}; // ParamStr 42: // sizeof begin temp := NewTPSVariantIFC(Stack[Stack.Count -2], False); @@ -10129,6 +10131,8 @@ procedure TPSExec.RegisterStandardProcs; RegisterFunctionName('IntToStr', DefProc, Pointer(0), nil); RegisterFunctionName('UIntToStr', DefProc, Pointer(48), nil); + RegisterFunctionName('ParamCount', DefProc, Pointer(49), nil); + RegisterFunctionName('ParamStr', DefProc, Pointer(50), nil); RegisterFunctionName('StrToInt', DefProc, Pointer(1), nil); RegisterFunctionName('StrToIntDef', DefProc, Pointer(2), nil); RegisterFunctionName('Pos', DefProc, Pointer(3), nil); From 9895fb5992d426f2192f710f69d7cf467545df1a Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 12:04:17 +0200 Subject: [PATCH 12/28] Register host types directly from RTTI: AddType(PTypeInfo) and AddRecordWithRTTI Importing host types previously meant hand-writing AddTypeS declarations that had to be kept in sync with the Delphi type. The compiler can now derive them from RTTI: Sender.AddType(TypeInfo(TFruits)); // set of TFruit Sender.AddType(TypeInfo(TIntArr)); // array of Integer Sender.AddType(TypeInfo(TMyEvent)); // procedure(...) of object Sender.AddType(TypeInfo(TFull)); // packed record (Delphi 2010+) AddType(PTypeInfo) covers the classic RTTI kinds - integers (all ord sizes), chars, all string kinds, floats, enums, Variant, Int64/UInt64 (UInt64 detected via its inverted MinInt64Value/MaxInt64Value pattern), sets, dynamic arrays and method pointers (signature reconstructed from the ParamList RTTI). Element types of sets/arrays are registered recursively; sets/dynarrays/methods are excluded under FPC where the TTypeData layouts differ. On Delphi 2010+ extended RTTI adds tkRecord via AddRecordWithRTTI and named static array types. Records must be packed: field offsets are verified one by one (including tail padding) and a padded layout is rejected with a clear error, because script records are packed and a mismatched layout would corrupt data on host interop. Fields with anonymous types (inline 'array[0..7] of X') have no RTTI and are rejected with a message naming the field; generic names such as TArray are sanitized to valid script identifiers. TypInfo moves to the interface uses for PTypeInfo in the public signatures; the Rtti unit stays implementation-only (the protected helpers take untyped pointers). Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 303 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 300 insertions(+), 3 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..fbdd5f5c 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -3,7 +3,7 @@ interface uses {$IFNDEF DELPHI3UP}{$IFNDEF PS_NOINTERFACES}{$IFNDEF LINUX}Windows, Ole2,{$ENDIF} - {$ENDIF}{$ENDIF}SysUtils, uPSUtils; + {$ENDIF}{$ENDIF}SysUtils, TypInfo, uPSUtils; type @@ -992,6 +992,12 @@ TPSPascalCompiler = class FCurrUsedTypeNo: Cardinal; FGlobalBlock: TPSBlockInfo; + {$IFDEF DELPHI2010UP} + // ARttiType is a TRttiType (typed as Pointer so the Rtti unit stays out + // of the interface uses); unknown types are registered recursively + function RttiTypeName(ARttiType: Pointer): TbtString; + function RttiFieldTypeDecl(ARttiType: Pointer): TbtString; + {$ENDIF} function IsBoolean(aType: TPSType): Boolean; {$IFNDEF PS_NOWIDESTRING} @@ -1138,7 +1144,14 @@ TPSPascalCompiler = class function AddDelphiFunction(const Decl: tbtString): TPSRegProc; - function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType; + function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType; overload; + + { registers a host type by its classic RTTI: ordinal, char, string, float, + enum, set, dynamic array, method pointer and Int64/UInt64 kinds - plus + records and named static arrays via extended RTTI on Delphi 2010+ } + function AddType(const Name: TbtString; TypeInfo: PTypeInfo): TPSType; overload; + + function AddType(TypeInfo: PTypeInfo): TPSType; overload; function AddTypeS(const Name, Decl: tbtString): TPSType; @@ -1146,6 +1159,14 @@ TPSPascalCompiler = class function AddTypeCopyN(const Name, FType: tbtString): TPSType; + {$IFDEF DELPHI2010UP} + { registers a packed host record via extended RTTI; every field type is + registered recursively as needed } + function AddRecordWithRTTI(const ATypeInfo: PTypeInfo): TPSType; overload; + + function AddRecordWithRTTI(const Name: TbtString; const ATypeInfo: PTypeInfo): TPSType; overload; + {$ENDIF} + function AddConstant(const Name: tbtString; FType: TPSType): TPSConstant; function AddConstantN(const Name, FType: tbtString): TPSConstant; @@ -1773,7 +1794,7 @@ procedure DisposeVariant(p: PIfRVariant); implementation -uses {$IFDEF DELPHI5}ComObj, {$ENDIF}{$IFDEF PS_FPC_HAS_COM}ComObj, {$ENDIF}Classes, typInfo; +uses {$IFDEF DELPHI5}ComObj, {$ENDIF}{$IFDEF PS_FPC_HAS_COM}ComObj, {$ENDIF}{$IFDEF DELPHI2010UP}Rtti, {$ENDIF}Classes; {$IFDEF DELPHI3UP} resourceString @@ -1787,6 +1808,8 @@ implementation RPS_InvalidTypeForVar = 'Invalid type for variable %s'; RPS_InvalidType = 'Invalid Type'; RPS_UnableToRegisterType = 'Unable to register type %s'; + RPS_RecordNotPacked = 'Record %s must be packed (padding-free) to be registered via RTTI'; + RPS_RecordFieldNoRTTI = 'Record %s: field %s has an anonymous type without RTTI (declare and use a named type)'; RPS_UnknownInterface = 'Unknown interface: %s'; RPS_ConstantValueMismatch = 'Constant Value Type Mismatch'; RPS_ConstantValueNotAssigned = 'Constant Value is not assigned'; @@ -14137,6 +14160,280 @@ function TPSPascalCompiler.AddTypeCopyN(const Name, Result := AddTypeCopy(Name, FindType(FType)); end; +function TPSPascalCompiler.AddType(const Name: TbtString; TypeInfo: PTypeInfo): TPSType; +var + TypeName, s, s2: TbtString; + TypeData: PTypeData; + i: Longint; + el: PTypeInfo; + {$IFNDEF FPC} + pp: PAnsiChar; + Flags: TParamFlags; + {$ENDIF} + {$IFDEF DELPHI2010UP} + ctx: TRttiContext; + {$ENDIF} + + function TypeInfoName(ti: PTypeInfo): TbtString; + begin + Result := TbtString(string(ti^.Name)); + end; + +begin + if FProcs = nil then + raise EPSCompilerException.Create(RPS_OnUseEventOnly); + if TypeInfo = nil then + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, ['nil']); + if Name = '' then + TypeName := TypeInfoName(TypeInfo) + else + TypeName := Name; + TypeData := GetTypeData(TypeInfo); + case TypeInfo^.Kind of + tkInteger: + case TypeData^.OrdType of + otSByte: Result := AddType(TypeName, btS8); + otUByte: Result := AddType(TypeName, btU8); + otSWord: Result := AddType(TypeName, btS16); + otUWord: Result := AddType(TypeName, btU16); + otULong: Result := AddType(TypeName, btU32); + else + Result := AddType(TypeName, btS32); // otSLong + end; + tkChar: Result := AddType(TypeName, btChar); + {$IFNDEF PS_NOWIDESTRING} + tkWChar: Result := AddType(TypeName, btWideChar); + {$ENDIF} + tkEnumeration: + begin + s := '('; + for i := TypeData^.MinValue to TypeData^.MaxValue do + s := s + TbtString(GetEnumName(TypeInfo, i)) + ','; + s[Length(s)] := ')'; // replace the trailing comma + Result := AddTypeS(TypeName, s); + end; + tkFloat: + case TypeData^.FloatType of + ftSingle: Result := AddType(TypeName, btSingle); + ftDouble: Result := AddType(TypeName, btDouble); + ftExtended: Result := AddType(TypeName, btExtended); + ftCurr: Result := AddType(TypeName, btCurrency); + else // ftComp has no script equivalent + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [TypeName]); + end; + tkString, // ShortString: mapped to AnsiString (no length-limit semantics) + tkLString: Result := AddType(TypeName, btString); + {$IFNDEF PS_NOWIDESTRING} + tkWString: Result := AddType(TypeName, btWideString); + {$if declared(tkUString)} + tkUString: Result := AddType(TypeName, btUnicodeString); + {$ifend} + {$ENDIF} + tkVariant: Result := AddType(TypeName, btVariant); + {$IFNDEF PS_NOINT64} + {$if declared(tkInt64)} + tkInt64: + // UInt64 type infos have MaxInt64Value < MinInt64Value (0..-1 pattern) + if TypeData^.MaxInt64Value < TypeData^.MinInt64Value then + Result := AddType(TypeName, btU64) + else + Result := AddType(TypeName, btS64); + {$ifend} + {$ENDIF} + {$IFNDEF FPC} // FPC's TTypeData layouts differ for the kinds below + tkSet: + begin + if TypeData^.CompType = nil then + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [TypeName]); + el := TypeData^.CompType^; + s2 := TypeInfoName(el); + if FindType(FastUpperCase(s2)) = nil then + AddType('', el); // register the element type first + Result := AddTypeS(TypeName, 'set of ' + s2); + end; + tkDynArray: + begin + el := nil; + if TypeData^.elType2 <> nil then + el := TypeData^.elType2^ + else if TypeData^.elType <> nil then + el := TypeData^.elType^; + if el = nil then + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [TypeName]); + s2 := TypeInfoName(el); + if FindType(FastUpperCase(s2)) = nil then + AddType('', el); // register the element type first + Result := AddTypeS(TypeName, 'array of ' + s2); + end; + tkMethod: + begin + case TypeData^.MethodKind of + mkProcedure: s := 'procedure('; + mkFunction: s := 'function('; + else // constructors/class methods have no script proc-type equivalent + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [TypeName]); + end; + // ParamList layout (stable since Delphi 2): per parameter + // TParamFlags + name: ShortString + type name: ShortString, + // afterwards the result type name for mkFunction + pp := PAnsiChar(@TypeData^.ParamList); + for i := 1 to TypeData^.ParamCount do + begin + if i > 1 then + s := s + '; '; + Flags := TParamFlags(Pointer(pp)^); + Inc(pp, SizeOf(TParamFlags)); + if pfVar in Flags then + s := s + 'var ' + else if pfOut in Flags then + s := s + 'out ' + else if pfConst in Flags then + s := s + 'const '; + s := s + TbtString(PShortString(pp)^) + ': '; + Inc(pp, Length(PShortString(pp)^) + 1); + if pfArray in Flags then + s := s + 'array of '; + s := s + TbtString(PShortString(pp)^); + Inc(pp, Length(PShortString(pp)^) + 1); + end; + s := s + ')'; + if TypeData^.MethodKind = mkFunction then + s := s + ': ' + TbtString(PShortString(pp)^); + Result := AddTypeS(TypeName, s); + end; + {$ENDIF !FPC} + {$IFDEF DELPHI2010UP} + tkRecord{$if declared(tkMRecord)}, tkMRecord{$ifend}: + Result := AddRecordWithRTTI(TypeName, TypeInfo); + tkArray: // named static array types ('TBuf = array[0..7] of X') + begin + ctx := TRttiContext.Create; + try + Result := AddTypeS(TypeName, RttiFieldTypeDecl(ctx.GetType(TypeInfo))); + finally + ctx.Free; + end; + end; + {$ENDIF} + // not mappable automatically: tkClass/tkInterface (use the class/interface + // importers), tkPointer, tkClassRef, tkProcedure + // (tkRecord/tkArray need the extended RTTI and are Delphi-2010+ only) + else + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [TypeName]); + end; +end; + +function TPSPascalCompiler.AddType(TypeInfo: PTypeInfo): TPSType; +begin + Result := AddType('', TypeInfo); +end; + +{$IFDEF DELPHI2010UP} +// script identifier for a type; unknown types are registered recursively, +// non-identifier characters in RTTI names ('TArray') sanitized +function TPSPascalCompiler.RttiTypeName(ARttiType: Pointer): TbtString; +var + t: TRttiType; + j: Integer; +begin + t := TRttiType(ARttiType); + Result := TbtString(t.Name); + // 'string' and 'Char' can be redeclared aliases in Pascal Script (e.g. + // with PS_PANSICHAR) -- map them by their exact RTTI kind instead + {$IFNDEF PS_NOWIDESTRING} + {$if declared(tkUString)} + if (t.TypeKind = tkUString) and SameText(string(Result), 'string') then + Result := 'UnicodeString' + else + {$ifend} + if (t.TypeKind = tkWChar) and SameText(string(Result), 'Char') then + Result := 'WideChar'; + {$ENDIF} + for j := 1 to Length(Result) do + if not (Result[j] in ['A'..'Z', 'a'..'z', '0'..'9', '_']) then + Result[j] := '_'; + if (Result = '') or (Result[1] in ['0'..'9']) then + Result := '_' + Result; + if FindType(FastUpperCase(Result)) = nil then + begin + if t.TypeKind in [tkRecord{$if declared(tkMRecord)}, tkMRecord{$ifend}] then + AddRecordWithRTTI(Result, t.Handle) + else + AddType(Result, t.Handle); + end; +end; + +// declaration text for a field/element type; static arrays become inline +// 'array[0..n-1] of El' (works for anonymous element chains as well) +function TPSPascalCompiler.RttiFieldTypeDecl(ARttiType: Pointer): TbtString; +var + t: TRttiType; +begin + t := TRttiType(ARttiType); + if t is TRttiArrayType then + begin + if TRttiArrayType(t).DimensionCount <> 1 then + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [TbtString(t.Name)]); + Result := 'array[0..' + TbtString(SysUtils.IntToStr(TRttiArrayType(t).TotalElementCount - 1)) + + '] of ' + RttiFieldTypeDecl(TRttiArrayType(t).ElementType); + end + else + Result := RttiTypeName(t); +end; + +function TPSPascalCompiler.AddRecordWithRTTI(const ATypeInfo: PTypeInfo): TPSType; +begin + Result := AddRecordWithRTTI('', ATypeInfo); +end; + +function TPSPascalCompiler.AddRecordWithRTTI(const Name: TbtString; const ATypeInfo: PTypeInfo): TPSType; +var + ctx: TRttiContext; + rt, ft: TRttiType; + fields: TArray; + i: Integer; + TypeName, Decl: TbtString; + PackedOfs: Integer; +begin + if FProcs = nil then + raise EPSCompilerException.Create(RPS_OnUseEventOnly); + if (ATypeInfo = nil) or + not (ATypeInfo^.Kind in [tkRecord{$if declared(tkMRecord)}, tkMRecord{$ifend}]) then + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, ['nil']); + if Name = '' then + TypeName := TbtString(string(ATypeInfo^.Name)) + else + TypeName := Name; + ctx := TRttiContext.Create; + try + rt := ctx.GetType(ATypeInfo); + fields := rt.GetFields; + if Length(fields) = 0 then + raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [TypeName]); + Decl := 'record '; + PackedOfs := 0; + for i := 0 to High(fields) do + begin + ft := fields[i].FieldType; + if ft = nil then // anonymous types (e.g. 'array[0..7] of X' inline) have no RTTI + raise EPSCompilerException.CreateFmt(RPS_RecordFieldNoRTTI, [TypeName, TbtString(fields[i].Name)]); + // Pascal Script records are packed; refuse layouts with padding, the + // field offsets would not match and host interop would corrupt data + if fields[i].Offset <> PackedOfs then + raise EPSCompilerException.CreateFmt(RPS_RecordNotPacked, [TypeName]); + Decl := Decl + TbtString(fields[i].Name) + ': ' + RttiFieldTypeDecl(ft) + '; '; + Inc(PackedOfs, ft.TypeSize); + end; + if PackedOfs <> rt.TypeSize then // tail padding + raise EPSCompilerException.CreateFmt(RPS_RecordNotPacked, [TypeName]); + Decl := Decl + 'end;'; + Result := AddTypeS(TypeName, Decl); + finally + ctx.Free; + end; +end; +{$ENDIF} + function TPSPascalCompiler.AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar; From 4737b9e324b20f8e611a9262ddc60b2d2508628a Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 12:21:42 +0200 Subject: [PATCH 13/28] Add debug/watch helpers: PSVariantToString overload, StringToPSVariant, PSBaseTypeToStr Hosts that embed a script debugger (watch windows, tooltips, REPL-style inspection) all end up writing the same code: turn an arbitrary script value into readable text and parse an edited value back. This adds the helpers used by the TetzkatLipHoka fork's debugger frame: - PSVariantToString(IFC, AppendType, NoQuotes): renders every base type including sets (element list), records (field list), static/dynamic arrays (element list, capped with '..' after 50 chars), variants (with their VarType), nested pointers and classes (via TStrings.Text or a published Caption/Title/Text/Lines/Strings property). AppendType prefixes the Delphi-style type name; NoQuotes returns string values raw instead of quoted. - StringToPSVariant: the reverse direction for editable watches - parses text into ordinal/float/string/char/variant slots and into class instances via the same published properties. btPChar slots are deliberately not written: they hold raw pointers to memory the engine does not own. - PSBaseTypeToStr(TPSBaseType/PIFTypeRec): base type names, optionally as Delphi names ('Integer' instead of 'S32'); the PIFTypeRec overload renders composed types (record field lists, array element types, class names). - VarTypeToString: readable names for TVarType values. Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 426 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 425 insertions(+), 1 deletion(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..a64dfce5 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -1112,7 +1112,13 @@ procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Lo function GetPSArrayLength(Arr: PIFVariant): Longint; procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint); -function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtstring): tbtstring; +function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtstring): tbtstring; overload; +{ debug/watch helpers: render any script value as text and parse it back } +function PSVariantToString(const V: TPSVariantIFC; AppendType: Boolean; NoQuotes: Boolean = False): string; overload; +function VarTypeToString(BaseType: TVarType): string; +procedure StringToPSVariant(const V: TPSVariantIFC; const Value: string); +function PSBaseTypeToStr(BaseType: TPSBaseType; DelphiNames: Boolean = False): string; overload; +function PSBaseTypeToStr(P: PIFTypeRec; DelphiNames: Boolean = False): string; overload; function MakeString(const s: tbtstring): tbtstring; {$IFNDEF PS_NOWIDESTRING} function MakeWString(const s: tbtunicodestring): tbtstring; @@ -1125,6 +1131,7 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS implementation uses + Classes, // TStrings access in PSVariantToString/StringToPSVariant TypInfo {$IFDEF DELPHI3UP} {$IFNDEF FPC}{$IFDEF MSWINDOWS} , ComObj {$ENDIF}{$ENDIF}{$ENDIF} {$IFDEF PS_FPC_HAS_COM}, ComObj{$ENDIF} @@ -1718,6 +1725,423 @@ function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtStr end; end; +function PSBaseTypeToStr(BaseType: TPSBaseType; DelphiNames: Boolean = False): string; +begin + case BaseType of + btReturnAddress : Result := 'ReturnAddress'; + btU8 : if DelphiNames then Result := 'Byte' else Result := 'U8'; + btS8 : if DelphiNames then Result := 'ShortInt' else Result := 'S8'; + btU16 : if DelphiNames then Result := 'Word' else Result := 'U16'; + btS16 : if DelphiNames then Result := 'SmallInt' else Result := 'S16'; + btU32 : if DelphiNames then Result := 'Cardinal' else Result := 'U32'; + btS32 : if DelphiNames then Result := 'Integer' else Result := 'S32'; + {$IFNDEF PS_NOINT64} + btS64 : if DelphiNames then Result := 'Int64' else Result := 'S64'; + {$ENDIF} + btSingle : Result := 'Single'; + btDouble : Result := 'Double'; + btExtended : Result := 'Extended'; + // names follow the width of the base type on this build + btString : Result := {$if SizeOf(tbtChar)=2}'UnicodeString'{$ELSE}'AnsiString'{$IFEND}; + btRecord : Result := 'Record'; + btArray : Result := 'Array'; + btPointer : Result := 'Pointer'; + btPChar : Result := {$if SizeOf(tbtChar)=2}'PWideChar'{$ELSE}'PAnsiChar'{$IFEND}; + btResourcePointer : Result := 'ResourcePointer'; + btVariant : Result := 'Variant'; + btChar : Result := {$if SizeOf(tbtChar)=2}'WideChar'{$ELSE}'AnsiChar'{$IFEND}; + {$IFNDEF PS_NOWIDESTRING} + btWideString : Result := 'WideString'; + btWideChar : Result := 'WideChar'; + {$ENDIF} + btProcPtr : Result := 'ProcPtr'; + btStaticArray : Result := 'StaticArray'; + btSet : Result := 'Set'; + btCurrency : Result := 'Currency'; + btClass : Result := 'Class'; + btInterface : Result := 'Interface'; + btNotificationVariant : Result := 'NotificationVariant'; + btUnicodeString : Result := 'UnicodeString'; + btType : Result := 'Type'; + btEnum : Result := 'Enum'; + btExtClass : Result := 'ExtClass'; + else + Result := 'Unknown ' + SysUtils.IntToStr(BaseType); + end; +end; + +function PSBaseTypeToStr(P: PIFTypeRec; DelphiNames: Boolean = False): string; +var + i: Longint; +begin + case p.BaseType of + btRecord : begin + Result := 'Record('; + for i := 0 to TPSTypeRec_Record(P).FieldTypes.Count-1 do + begin + if i <> 0 then Result := Result+','; + Result := Result + PSBaseTypeToStr(PIFTypeRec(TPSTypeRec_Record(P).FieldTypes[i]), DelphiNames); + end; + Result := Result + ')'; + end; + btArray : Result := 'Array of ' + PSBaseTypeToStr(TPSTypeRec_Array(P).ArrayType, DelphiNames); + btStaticArray : Result := 'StaticArray['+IntToStr(TPSTypeRec_StaticArray(P).StartOffset)+'..'+IntToStr(TPSTypeRec_StaticArray(P).StartOffset+TPSTypeRec_StaticArray(P).Size-1)+'] of '+PSBaseTypeToStr(TPSTypeRec_Array(P).ArrayType, DelphiNames); + btClass : Result := 'Class :' + TPSTypeRec_Class(P).CN; + else + Result := PSBaseTypeToStr(p.BaseType, DelphiNames); + end; +end; + +function VarTypeToString(BaseType: TVarType): string; +var + IsArr: Boolean; +begin + IsArr := (BaseType and varArray) <> 0; + BaseType := BaseType and varTypeMask; + case BaseType of + varEmpty : Result := 'Empty'; + varNull : Result := 'Null'; + varSmallint : Result := 'Smallint'; + varInteger : Result := 'Integer'; + varSingle : Result := 'Single'; + varDouble : Result := 'Double'; + varCurrency : Result := 'Currency'; + varDate : Result := 'Date'; + varOleStr : Result := 'OleStr'; + varDispatch : Result := 'Dispatch'; + varError : Result := 'Error'; + varBoolean : Result := 'Boolean'; + varVariant : Result := 'Variant'; + varUnknown : Result := 'Unknown'; + {$if declared(varShortInt)} + varShortInt : Result := 'ShortInt'; + {$ifend} + varByte : Result := 'Byte'; + {$if declared(varWord)} + varWord : Result := 'Word'; + varLongWord : Result := 'LongWord'; // = varUInt32 + varInt64 : Result := 'Int64'; + {$ifend} + {$if declared(varUInt64)} + varUInt64 : Result := 'UInt64'; + {$ifend} + {$if declared(varRecord)} + varRecord : Result := 'Record'; + {$ifend} + {$if declared(varObject)} + varObject : Result := 'Object'; + {$ifend} + {$if declared(varUString)} + varUString : Result := 'UnicodeString'; + {$ifend} + varStrArg : Result := 'StrArg'; + {$if declared(varUStrArg)} + varUStrArg : Result := 'UStrArg'; + {$ifend} + varString : Result := 'String'; + varAny : Result := 'Any'; + else + Result := 'VarType(' + SysUtils.IntToStr(BaseType) + ')'; + end; + if IsArr then + Result := 'Array of ' + Result; +end; + +function PSVariantToString(const V: TPSVariantIFC; AppendType: Boolean; NoQuotes: Boolean = False): string; +const + MAX_LEN = 50; + + function WithType(const VV: TPSVariantIFC; const val: string): string; + begin + case VV.aType.BaseType of + btPointer: + if (VV.Dta <> nil) and (TPSTypeRec(Pointer(IPointer(VV.Dta)+PointerSize)^) <> nil) then + Result := PSBaseTypeToStr(VV.aType.BaseType, True) + ' (' + + PSBaseTypeToStr(TPSTypeRec(Pointer(IPointer(VV.Dta)+PointerSize)^).BaseType, True) + ') = ' + val + else + Result := PSBaseTypeToStr(VV.aType.BaseType, True) + ' = ' + val; + btVariant: + Result := PSBaseTypeToStr(VV.aType.BaseType, True) + ' (' + + VarTypeToString(TVarData(VV.Dta^).VType) + ') = ' + val; + btRecord, btStaticArray, btArray: Result := val; + else + Result := PSBaseTypeToStr(VV.aType.BaseType, True) + ' = ' + val; + end; + end; + +var + i, lo, hi: Integer; + S: string; + V2: TPSVariantIFC; + StrL: TStrings; + Obj: TObject; +begin + Result := ''; + if (V.Dta = nil) or (V.aType = nil) then + Exit; + case V.aType.BaseType of + btU8 : Result := {$if declared(UIntToStr)}UIntToStr{$else}SysUtils.IntToStr{$ifend}(tbtU8(V.Dta^)); + btS8 : Result := SysUtils.IntToStr(tbtS8(V.Dta^)); + btU16 : Result := {$if declared(UIntToStr)}UIntToStr{$else}SysUtils.IntToStr{$ifend}(tbtU16(V.Dta^)); + btS16 : Result := SysUtils.IntToStr(tbtS16(V.Dta^)); + btU32 : Result := {$if declared(UIntToStr)}UIntToStr{$else}SysUtils.IntToStr{$ifend}(tbtU32(V.Dta^)); + btS32 : Result := SysUtils.IntToStr(tbtS32(V.Dta^)); + {$IFNDEF PS_NOINT64} + btS64 : Result := SysUtils.IntToStr(tbtS64(V.Dta^)); + {$ENDIF} + btSingle : Result := FloatToStr(tbtSingle(V.Dta^)); + btDouble : Result := FloatToStr(tbtDouble(V.Dta^)); + btExtended : Result := FloatToStr(tbtExtended(V.Dta^)); + btCurrency : Result := CurrToStr(tbtCurrency(V.Dta^)); + btString : if NoQuotes then + Result := string(tbtstring(V.Dta^)) + else + Result := string(MakeString(tbtstring(V.Dta^))); + btChar : if NoQuotes then + Result := string(tbtChar(V.Dta^)) + else + Result := string(MakeString(tbtstring(tbtChar(V.Dta^)))); + {$IFNDEF PS_NOWIDESTRING} + btWideChar : if NoQuotes then + Result := string(tbtWideChar(V.Dta^)) + else + Result := string(MakeWString(tbtWideChar(V.Dta^))); + btWideString : if NoQuotes then + Result := string(tbtWideString(V.Dta^)) + else + Result := string(MakeWString(tbtWideString(V.Dta^))); + btUnicodeString : if NoQuotes then + Result := string(tbtUnicodeString(V.Dta^)) + else + Result := string(MakeWString(tbtUnicodeString(V.Dta^))); + {$ENDIF} + btPChar : if tbtPChar(V.Dta^) <> nil then + begin + if NoQuotes then + Result := string(tbtPChar(V.Dta^)) + else + Result := string(MakeString(tbtPChar(V.Dta^))); + end; + btPointer : begin + V2.Dta := Pointer(V.Dta^); + V2.aType := TPSTypeRec(Pointer(IPointer(V.Dta)+PointerSize)^); + V2.VarParam := False; + if (V2.Dta = nil) or (V2.aType = nil) then + Result := 'nil' + else + Result := PSVariantToString(V2, False, NoQuotes); + end; + btProcPtr : Result := 'ProcPtr(' + SysUtils.IntToStr(tbtU32(V.Dta^)) + ')'; + btSet : begin + for i := 0 to TPSTypeRec_Set(V.aType).aBitSize - 1 do + if (PByteArray(V.Dta)^[i shr 3] and (1 shl (i and 7))) <> 0 then + begin + if Result <> '' then + Result := Result + ', '; + if Length(Result) > MAX_LEN then + begin + Result := Result + '..'; + Break; + end; + Result := Result + SysUtils.IntToStr(i); + end; + Result := '[' + Result + ']'; + end; + btRecord : begin + Result := 'Record = ('; + for i := 0 to TPSTypeRec_Record(V.aType).FieldTypes.Count - 1 do + begin + V2 := PSGetRecField(V, i); + S := PSVariantToString(V2, False, NoQuotes); + if (S <> '') and AppendType then + S := WithType(V2, S); + Result := Result + S; + if i < TPSTypeRec_Record(V.aType).FieldTypes.Count - 1 then + begin + if Length(Result) > MAX_LEN then + begin + Result := Result + '..'; + Break; + end; + Result := Result + ', '; + end; + end; + Result := Result + ')'; + end; + btStaticArray, + btArray : begin + if V.aType.BaseType = btStaticArray then + hi := TPSTypeRec_StaticArray(V.aType).Size + else + hi := PSDynArrayGetLength(Pointer(V.Dta^), V.aType); + if hi > 0 then + begin + for i := 0 to hi - 1 do + begin + if Result <> '' then + Result := Result + ', '; + if Length(Result) > MAX_LEN then + begin + Result := Result + '..'; + Break; + end; + V2 := PSGetArrayField(V, i); + if i = 0 then + Result := 'Array of ' + PSBaseTypeToStr(V2.aType.BaseType, True) + ' = [ ' + Result; + Result := Result + PSVariantToString(V2, False, NoQuotes); + end; + Result := Result + ' ]'; + end + else + Result := 'Array (empty)'; + end; + btVariant : begin + try + if TVarData(V.Dta^).VType = varDispatch then + Result := 'Variant(IDispatch)' + else if TVarData(V.Dta^).VType = varNull then + Result := 'Null' + else if (TVarData(V.Dta^).VType = varOleStr) and not NoQuotes then + {$IFDEF PS_NOWIDESTRING} + Result := string(MakeString(Variant(V.Dta^))) + {$ELSE} + Result := string(MakeWString(Variant(V.Dta^))) + {$ENDIF} + else if (TVarData(V.Dta^).VType = varString) and not NoQuotes then + Result := string(MakeString(tbtstring(Variant(V.Dta^)))) + {$if declared(varUString)} + else if (TVarData(V.Dta^).VType = varUString) and not NoQuotes then + Result := string(MakeWString(Variant(V.Dta^))) + {$ifend} + else if VarIsArray(Variant(V.Dta^)) then + begin + // one generic loop covers every element type (and + // non-zero low bounds) + lo := VarArrayLowBound(Variant(V.Dta^), 1); + hi := VarArrayHighBound(Variant(V.Dta^), 1); + for i := lo to hi do + begin + if Result <> '' then + Result := Result + ', '; + if Length(Result) > MAX_LEN then + begin + Result := Result + '..'; + Break; + end; + Result := Result + VarToStr(Variant(V.Dta^)[i]); + end; + Result := VarTypeToString(TVarData(V.Dta^).VType) + ' = [ ' + Result + ' ]'; + end + else + Result := VarToStr(Variant(V.Dta^)); + except + Result := ''; + Exit; + end; + end; + btClass : begin + Obj := TObject(V.Dta^); + if Obj = nil then + Result := 'nil' + else + try + if Obj is TStrings then + Result := TStrings(Obj).Text + else if IsPublishedProp(Obj, 'Caption') then + Result := GetPropValue(Obj, 'Caption') + else if IsPublishedProp(Obj, 'Title') then + Result := GetPropValue(Obj, 'Title') + else if IsPublishedProp(Obj, 'Text') then + Result := GetPropValue(Obj, 'Text') + else if IsPublishedProp(Obj, 'Lines') then + begin + StrL := TStrings(GetObjectProp(Obj, 'Lines')); + if StrL <> nil then + Result := StrL.Text; + end + else if IsPublishedProp(Obj, 'Strings') then + begin + StrL := TStrings(GetObjectProp(Obj, 'Strings')); + if StrL <> nil then + Result := StrL.Text; + end + else + Result := Obj.ClassName; + except + Result := Obj.ClassName; + end; + end; + btInterface : Result := string(PSVariantToString(V, '')); + else + Result := ''; + end; + if (Result <> '') and AppendType then + Result := WithType(V, Result); +end; + +procedure StringToPSVariant(const V: TPSVariantIFC; const Value: string); +var + StrL: TStrings; + Obj: TObject; +begin + if (V.Dta = nil) or (V.aType = nil) then + Exit; + case V.aType.BaseType of + btU8 : tbtU8(V.Dta^) := {$if declared(StrToUIntDef)}StrToUIntDef{$else}StrToIntDef{$ifend}(Value, 0); + btS8 : tbtS8(V.Dta^) := StrToIntDef(Value, 0); + btU16 : tbtU16(V.Dta^) := {$if declared(StrToUIntDef)}StrToUIntDef{$else}StrToIntDef{$ifend}(Value, 0); + btS16 : tbtS16(V.Dta^) := StrToIntDef(Value, 0); + btU32 : tbtU32(V.Dta^) := {$if declared(StrToUIntDef)}StrToUIntDef{$else}StrToIntDef{$ifend}(Value, 0); + btS32 : tbtS32(V.Dta^) := StrToIntDef(Value, 0); + {$IFNDEF PS_NOINT64} + btS64 : tbtS64(V.Dta^) := StrToInt64Def(Value, 0); + {$ENDIF} + btSingle : tbtSingle(V.Dta^) := StrToFloatDef(Value, 0); + btDouble : tbtDouble(V.Dta^) := StrToFloatDef(Value, 0); + btExtended : tbtExtended(V.Dta^) := StrToFloatDef(Value, 0); + btCurrency : tbtCurrency(V.Dta^) := StrToFloatDef(Value, 0); + btString : tbtstring(V.Dta^) := tbtstring(Value); + btChar : if Value <> '' then tbtChar(V.Dta^) := tbtChar(tbtstring(Value)[1]); + {$IFNDEF PS_NOWIDESTRING} + btWideChar : if Value <> '' then tbtWideChar(V.Dta^) := tbtWideChar(Value[1]); + btWideString : tbtWideString(V.Dta^) := tbtWideString(Value); + btUnicodeString : tbtUnicodeString(V.Dta^) := tbtUnicodeString(Value); + {$ENDIF} + // btPChar is not written: the slot holds a raw pointer to memory that + // is not owned by the script engine + btVariant : try + Variant(V.Dta^) := Value; + except + end; + btClass : begin + Obj := TObject(V.Dta^); + if Obj = nil then + Exit; + try + if Obj is TStrings then + TStrings(Obj).Text := Value + else if IsPublishedProp(Obj, 'Caption') then + SetPropValue(Obj, 'Caption', Value) + else if IsPublishedProp(Obj, 'Text') then + SetPropValue(Obj, 'Text', Value) + else if IsPublishedProp(Obj, 'Lines') then + begin + StrL := TStrings(GetObjectProp(Obj, 'Lines')); + if StrL <> nil then + StrL.Text := Value; + end + else if IsPublishedProp(Obj, 'Strings') then + begin + StrL := TStrings(GetObjectProp(Obj, 'Strings')); + if StrL <> nil then + StrL.Text := Value; + end; + except + end; + end; + end; +end; + function TIFErrorToString(x: TPSError; const Param: tbtString): tbtString; From 38273d42b679d219cadc0970ffeb962030e07b28 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 12:36:27 +0200 Subject: [PATCH 14/28] PS_NATIVESTRINGS foundation: native tbt-string types and Ansi base types First step of the opt-in PS_NATIVESTRINGS mode (default: OFF, nothing changes without the define). With PS_NATIVESTRINGS, tbtChar/tbtPChar/tbtString follow the host compiler's native types (Unicode on Delphi 2009+). The practical win: host functions registered with tbtString/tbtChar parameters receive exactly the width the engine passes - the silent width mismatch that breaks legacy registrations against today's unicode script strings (see issue #296) disappears, because tbtString is the correct signature type again on every compiler version. This commit adds the type switch, the always-Ansi companion types (tbtAnsiChar/tbtAnsiString/tbtPAnsiChar) and four new base type ids: btPWideChar = 30 (PChar maps here under PS_NATIVESTRINGS) btAnsiChar = 31 \ real Ansi script types, needed because btAnsiString = 32 ) btChar/btString/btPChar follow the native btPAnsiChar = 33 / (wide) width under PS_NATIVESTRINGS Compiler and runtime support for the new base types follows in the next commits; until then the define is declared but not yet functional. Co-Authored-By: Claude Fable 5 --- Source/PascalScript.inc | 9 +++++++++ Source/uPSUtils.pas | 25 +++++++++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/Source/PascalScript.inc b/Source/PascalScript.inc index 6ed5c1b8..a383f5bd 100644 --- a/Source/PascalScript.inc +++ b/Source/PascalScript.inc @@ -53,8 +53,17 @@ Defines: PS_NOWIDESTRING PS_NOINT64 PS_DELPHIDIV + PS_NATIVESTRINGS - tbtChar/tbtPChar/tbtString follow the host compiler's + native string types (Unicode on Delphi 2009+): host + functions registered with tbtString parameters match the + width the engine passes, and the script types + PChar/AnsiChar/AnsiString/PAnsiChar become fully usable + (btPWideChar and the always-Ansi base types). + Default: not defined - behavior is unchanged. } +{.$DEFINE PS_NATIVESTRINGS} + {$UNDEF DEBUG} {$IFDEF CLX} diff --git a/Source/uPSUtils.pas b/Source/uPSUtils.pas index 80fe0674..c6bc1e68 100644 --- a/Source/uPSUtils.pas +++ b/Source/uPSUtils.pas @@ -23,6 +23,15 @@ interface PSAddrNegativeStackStart = 1073741824; type + { PS_NATIVESTRINGS: tbtChar/tbtPChar/tbtString follow the host compiler's + native types (Unicode on Delphi 2009+). Host functions registered with + tbtString/tbtChar parameters then match the width the engine passes. + Without the define everything stays exactly as before. } + {$IFDEF PS_NATIVESTRINGS} + tbtString = {$IFDEF FPC}type {$ENDIF}string; + tbtPChar = PChar; + tbtChar = Char; + {$ELSE !PS_NATIVESTRINGS} {$IFDEF FPC} {$IFDEF FPC_UNICODE} tbtString = AnsiString; @@ -38,6 +47,13 @@ interface tbtPChar = {$IFDEF DELPHI2009UP}PAnsiChar{$ELSE}PChar{$ENDIF}; tbtChar = {$IFDEF DELPHI4UP}AnsiChar{$ELSE}CHAR{$ENDIF}; {$ENDIF} + {$ENDIF !PS_NATIVESTRINGS} + + { always-Ansi companions, independent of PS_NATIVESTRINGS; used by the + btAnsiChar/btAnsiString/btPAnsiChar base types and for byte buffers } + tbtAnsiChar = {$IFDEF DELPHI4UP}AnsiChar{$ELSE}Char{$ENDIF}; + tbtAnsiString = AnsiString; + tbtPAnsiChar = PAnsiChar; TPSBaseType = Byte; @@ -111,6 +127,15 @@ interface btU64 = 29; {$ENDIF} + btPWideChar = 30; + + { always-Ansi base types: with PS_NATIVESTRINGS the btChar/btString/btPChar + base types follow the compiler's native (wide) types, so the script types + AnsiChar/AnsiString/PAnsiChar need their own base types } + btAnsiChar = 31; + btAnsiString = 32; + btPAnsiChar = 33; + btType = 130; btEnum = 129; From 7a0f6553e86ebdf1efa9fb761a4eaebe62388844 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 12:44:00 +0200 Subject: [PATCH 15/28] PS_NATIVESTRINGS: width-neutral char handling in PSSetAnsiString and array-of-const Three spots assumed tbtchar is always a single byte: - PSSetAnsiString widened an AnsiChar into a possibly-wide char slot without a conversion (E2010 with PS_NATIVESTRINGS), - the array-of-const builder stored wide chars through TVarRec.VChar (vtChar), truncating them; wide builds now pass vtWideChar/VWideChar, - the var-param readback mirrored the same assumption. All three compile to the previous code when PS_NATIVESTRINGS is off. Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index f644866c..15a16152 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -4383,7 +4383,7 @@ procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; cons end; case aType.BaseType of btString: tbtstring(src^) := val; - btChar: if AnsiString(val) <> '' then tbtchar(src^) := AnsiString(val)[1]; + btChar: if AnsiString(val) <> '' then tbtchar(src^) := tbtchar(AnsiString(val)[1]); {$IFNDEF PS_NOWIDESTRING} btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val)); btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val)); @@ -10921,8 +10921,13 @@ function CreateOpenArray(VarParam: Boolean; Sender: TPSExec; val: PPSVariantIFC) tvarrec(p^).VVariant := cp; end; btchar: begin + {$if SizeOf(tbtchar)=2} + tvarrec(p^).VType := vtWideChar; + tvarrec(p^).VWideChar := tbtchar(cp^); + {$else} tvarrec(p^).VType := vtChar; - tvarrec(p^).VChar := tbtChar(tbtchar(cp^)); + tvarrec(p^).VChar := tbtchar(cp^); + {$ifend} end; btSingle: begin @@ -11073,7 +11078,11 @@ procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray); end; btChar: begin if v^.VarParam then - tbtchar(cp^) := tbtChar(tvarrec(p^).VChar) + {$if SizeOf(tbtchar)=2} + tbtchar(cp^) := tvarrec(p^).VWideChar + {$else} + tbtchar(cp^) := tbtchar(tvarrec(p^).VChar) + {$ifend} end; btSingle: begin if v^.VarParam then From bc9a46e50fc662c85f3a0ae9b5ef144be11afcc8 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 12:56:49 +0200 Subject: [PATCH 16/28] PS_NATIVESTRINGS: bytecode buffers are always byte strings Migrate all compiled-data containers from tbtString to tbtAnsiString so the bytecode stream stays a raw byte buffer when tbtString becomes a wide string under PS_NATIVESTRINGS: - TPSPascalCompiler.FOutput / GetOutput, TPSInternalProcedure.FData / Data - TPSExec.LoadData, TPSDebugExec.LoadData override - TPSScript.GetCompiled / SetCompiled / LoadExec (separate wide local for debug data, which stays tbtString) - IFPS3DataToText input - opcode appends use tbtAnsiChar casts (WriteByte, BlockWriteByte, FindMainProc master proc, empty-proc CM_R, CM_PO append); building these in a wide string and converting afterwards would turn bytes >127 into '?' - new PS_mi2d: PS_mi2s variant returning a byte string for binary buffers No behavior change when PS_NATIVESTRINGS is undefined (tbtAnsiString = tbtString = AnsiString there). Both modes compile warning-identical on Delphi 12 (DCC32). Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 33 ++++++++++++++++++++------------- Source/uPSComponent.pas | 15 ++++++++------- Source/uPSDebugger.pas | 4 ++-- Source/uPSDisassembly.pas | 4 ++-- Source/uPSRuntime.pas | 4 ++-- 5 files changed, 34 insertions(+), 26 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index 8ff372bb..caf2e60a 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -550,7 +550,7 @@ TPSExternalProcedure = class(TPSProcedure) TPSInternalProcedure = class(TPSProcedure) private FForwarded: Boolean; - FData: tbtString; + FData: tbtAnsiString; // compiled bytecode: always a byte string FNameHash: Longint; FName: tbtString; FDecl: TPSParametersDecl; @@ -578,7 +578,7 @@ TPSInternalProcedure = class(TPSProcedure) property Forwarded: Boolean read FForwarded write FForwarded; - property Data: tbtString read FData write FData; + property Data: tbtAnsiString read FData write FData; property Decl: TPSParametersDecl read FDecl; @@ -940,7 +940,7 @@ TPSPascalCompiler = class FTypes: TPSList; FAttributeTypes: TPSList; FVars: TPSList; - FOutput: tbtString; + FOutput: tbtAnsiString; // compiled bytecode: always a byte string FParser: TPSPascalParser; FParserHadError: Boolean; FMessages: TPSList; @@ -1189,7 +1189,7 @@ TPSPascalCompiler = class function Compile(const s: tbtString): Boolean; - function GetOutput(var s: tbtString): Boolean; + function GetOutput(var s: tbtAnsiString): Boolean; function GetDebugOutput(var s: tbtString): Boolean; @@ -1782,6 +1782,7 @@ function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarT function PS_mi2s(i: Cardinal): tbtString; +function PS_mi2d(i: Cardinal): tbtAnsiString; // PS_mi2s for binary (byte string) buffers function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean; @@ -1906,7 +1907,7 @@ function DeclToBits(const Decl: TPSParametersDecl): tbtString; procedure BlockWriteByte(BlockInfo: TPSBlockInfo; b: Byte); begin - BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtChar(b); + BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtAnsiChar(b); end; procedure BlockWriteData(BlockInfo: TPSBlockInfo; const Data; Len: Longint); @@ -2500,6 +2501,12 @@ function PS_mi2s(i: Cardinal): tbtString; Cardinal((@Result[1])^) := i; end; +function PS_mi2d(i: Cardinal): tbtAnsiString; +begin + SetLength(Result, 4); + Cardinal((@Result[1])^) := i; +end; + @@ -5043,7 +5050,7 @@ procedure WriteProcVars(Func:TPSInternalProcedure; t: TPSList); for l := 0 to t.Count - 1 do begin v := t[l]; - Func.Data := Func.Data + chr(cm_pt)+ PS_mi2s(v.AType.FinalTypeNo); + Func.Data := Func.Data + tbtAnsiChar(cm_pt)+ PS_mi2d(v.AType.FinalTypeNo); end; end; @@ -12177,7 +12184,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; procedure WriteByte(b: Byte); begin - FOutput := FOutput + tbtChar(b); + FOutput := FOutput + tbtAnsiChar(b); end; procedure WriteData(const Data; Len: Longint); @@ -12516,7 +12523,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; if x.ClassType = TPSInternalProcedure then begin if TPSInternalProcedure(x).Data = '' then - TPSInternalProcedure(x).Data := Chr(Cm_R); + TPSInternalProcedure(x).Data := tbtAnsiChar(Cm_R); L2 := Length(FOutput); Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 2], 4); // write position @@ -12534,14 +12541,14 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; var l: Longint; Proc : TPSInternalProcedure; - ProcData : tbtString; + ProcData : tbtAnsiString; // bytecode buffer: must stay a byte string Calls : Integer; procedure WriteProc(const aData: Longint); var l: Longint; begin - ProcData := ProcData + Chr(cm_c); + ProcData := ProcData + tbtAnsiChar(cm_c); l := Length(ProcData); SetLength(ProcData, l + 4); Move(aData, ProcData[l + 1], 4); @@ -12567,7 +12574,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; begin Proc := NewProc('Master proc', '!MASTERPROC'); Result := FindProc('!MASTERPROC'); - Proc.data := Procdata + Chr(cm_R); + Proc.data := Procdata + tbtAnsiChar(cm_R); end; end; {$ELSE} @@ -13282,7 +13289,7 @@ destructor TPSPascalCompiler.Destroy; inherited Destroy; end; -function TPSPascalCompiler.GetOutput(var s: tbtString): Boolean; +function TPSPascalCompiler.GetOutput(var s: tbtAnsiString): Boolean; begin if Length(FOutput) <> 0 then begin @@ -15769,7 +15776,7 @@ destructor TPSValueAllocatedStackVar.Destroy; pv := Proc.ProcVars[Proc.ProcVars.Count -1]; Proc.ProcVars.Delete(Proc.ProcVars.Count -1); pv.Free; - Proc.Data := Proc.Data + tbtChar(CM_PO); + Proc.Data := Proc.Data + tbtAnsiChar(CM_PO); end; inherited Destroy; end; diff --git a/Source/uPSComponent.pas b/Source/uPSComponent.pas index bdeddd64..6769304a 100644 --- a/Source/uPSComponent.pas +++ b/Source/uPSComponent.pas @@ -198,9 +198,9 @@ TPSScript = class(TComponent) property Running: Boolean read GetRunning; - procedure GetCompiled(var data: tbtstring); + procedure GetCompiled(var data: tbtAnsiString); - procedure SetCompiled(const Data: tbtstring); + procedure SetCompiled(const Data: tbtAnsiString); property Comp: TPSPascalCompiler read FComp; @@ -688,7 +688,7 @@ function TPSScript.GetAbout: tbtstring; Result := TPSExec.About; end; -procedure TPSScript.GetCompiled(var data: tbtstring); +procedure TPSScript.GetCompiled(var data: tbtAnsiString); begin if not FComp.GetOutput(Data) then raise Exception.Create(RPS_ScriptNotCompiled); @@ -741,7 +741,8 @@ function TPSScript.GetVariable(const Name: tbtstring): PIFVariant; function TPSScript.LoadExec: Boolean; var - s: tbtstring; + s: tbtAnsiString; + d: tbtstring; begin if (not FComp.GetOutput(s)) or (not FExec.LoadData(s)) then begin @@ -750,8 +751,8 @@ function TPSScript.LoadExec: Boolean; end; if FUseDebugInfo then begin - FComp.GetDebugOutput(s); - FExec.LoadDebugData(s); + FComp.GetDebugOutput(d); + FExec.LoadDebugData(d); end; Result := True; end; @@ -796,7 +797,7 @@ function TPSScript.ScriptUses(Sender: TPSPascalCompiler; end; end; -procedure TPSScript.SetCompiled(const Data: tbtstring); +procedure TPSScript.SetCompiled(const Data: tbtAnsiString); var i: Integer; begin diff --git a/Source/uPSDebugger.pas b/Source/uPSDebugger.pas index 2c40d503..e190727c 100644 --- a/Source/uPSDebugger.pas +++ b/Source/uPSDebugger.pas @@ -85,7 +85,7 @@ TPSDebugExec = class(TPSCustomDebugExec) public constructor Create; - function LoadData(const s: tbtstring): Boolean; override; + function LoadData(const s: tbtAnsiString): Boolean; override; procedure Pause; override; @@ -585,7 +585,7 @@ procedure TPSDebugExec.ClearDebug; FDebugMode := dmRun; end; -function TPSDebugExec.LoadData(const s: tbtstring): Boolean; +function TPSDebugExec.LoadData(const s: tbtAnsiString): Boolean; begin Result := inherited LoadData(s); FDebugMode := dmRun; diff --git a/Source/uPSDisassembly.pas b/Source/uPSDisassembly.pas index fee71aab..95c89644 100644 --- a/Source/uPSDisassembly.pas +++ b/Source/uPSDisassembly.pas @@ -7,7 +7,7 @@ interface uses uPSRuntime, uPSUtils, sysutils; -function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean; +function IFPS3DataToText(const Input: tbtAnsiString; var Output: string): Boolean; implementation type @@ -44,7 +44,7 @@ function FloatToStr(Value: Extended): string; end; -function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean; +function IFPS3DataToText(const Input: tbtAnsiString; var Output: string): Boolean; var I: TMyPSExec; diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index 15a16152..19d857e1 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -741,7 +741,7 @@ TPSExec = class(TObject) function RunScript: Boolean; - function LoadData(const s: tbtstring): Boolean; virtual; + function LoadData(const s: tbtAnsiString): Boolean; virtual; procedure Clear; Virtual; @@ -2793,7 +2793,7 @@ function TPSExec.RegisterFunctionName(const Name: tbtString; ProcPtr: TPSProcPtr Result := P; end; -function TPSExec.LoadData(const s: tbtString): Boolean; +function TPSExec.LoadData(const s: tbtAnsiString): Boolean; var HDR: TPSHeader; Pos: Cardinal; From aac2783b49064212167bd30fc21ba0b82d382dc9 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 13:07:13 +0200 Subject: [PATCH 17/28] PS_NATIVESTRINGS: width-aware string payload I/O in bytecode stream Names, export declarations and string constants embedded in the bytecode are tbtString values; their stream payload is Length(s) characters. Multiply all raw reads/writes of such payloads by SizeOf(tbtChar) so they stay correct when tbtChar is 2 bytes: - compiler writers (MakeOutput/BlockWriteVariant): btChar constants, btString constant payloads, attribute type names, class names, proc-ptr decl bits, type/var export names, internal proc name + export decl, external proc name + import decl - runtime readers: attribute type name and btString/btPchar attribute values, class FCN, proc-ptr FParamInfo, type/proc/var export names and decls, ReadVariable inline string constants (terminator via tbtpchar) - btChar constants take SizeOf(tbtChar) bytes; readers dispatch btchar into the 1-byte or 2-byte group via {$IF SizeOf(tbtChar)} - uPSDisassembly: string/char constant readers width-aware (s, c are now tbt types) btSet payloads keep byte semantics (Set_* operators address the string container as PByteArray). No change with PS_NATIVESTRINGS undefined; both modes compile on Delphi 12 and the OFF-mode probe suite passes. Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 28 ++++++++++++++-------------- Source/uPSDisassembly.pas | 8 ++++---- Source/uPSRuntime.pas | 34 ++++++++++++++++++---------------- 3 files changed, 36 insertions(+), 34 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index caf2e60a..4ea89fc6 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -1992,7 +1992,7 @@ function BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant{$IFNDEF PS_NO {$ENDIF} end; btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency)); - btChar: BlockWriteData(BlockInfo, p^.tchar, 1); + btChar: BlockWriteData(BlockInfo, p^.tchar, SizeOf(tbtChar)); btSet: begin BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); @@ -2001,7 +2001,7 @@ function BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant{$IFNDEF PS_NO begin BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring))); if Length(tbtString(p^.tstring)) > 0 then - BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); + BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))*SizeOf(tbtChar)); end; btenum: begin @@ -12266,7 +12266,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; {$ENDIF} end; btCurrency: WriteData(p^.tcurrency, sizeof(tbtCurrency)); - btChar: WriteData(p^.tchar, 1); + btChar: WriteData(p^.tchar, SizeOf(tbtChar)); btSet: begin WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); @@ -12275,7 +12275,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; begin WriteLong(Length(tbtString(p^.tstring))); if Length(tbtString(p^.tstring)) > 0 then - WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); + WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))*SizeOf(tbtChar)); end; btenum: begin @@ -12311,7 +12311,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; begin j := Length(attr[i].FAttribType.Name); WriteLong(j); - WriteData(Attr[i].FAttribType.Name[1], j); + WriteData(Attr[i].FAttribType.Name[1], j*SizeOf(tbtChar)); WriteLong(Attr[i].Count); for j := 0 to Attr[i].Count -1 do begin @@ -12384,13 +12384,13 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; end else {$ENDIF} if x.BaseType = btClass then begin WriteLong(Length(TPSClassType(X).Cl.FClassName)); - WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName)); + WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName)*SizeOf(tbtChar)); end else if (x.BaseType = btProcPtr) then begin s := DeclToBits(TPSProceduralType(x).ProcDef); WriteLong(Length(s)); - WriteData(s[1], Length(s)); + WriteData(s[1], Length(s)*SizeOf(tbtChar)); end else if (x.BaseType = btSet) then begin @@ -12413,7 +12413,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; if FExportName <> '' then begin WriteLong(Length(FExportName)); - WriteData(FExportName[1], length(FExportName)); + WriteData(FExportName[1], length(FExportName)*SizeOf(tbtChar)); end; if not WriteAttributes(x.Attributes) then begin Result := False; @@ -12449,7 +12449,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; begin WriteByte( 1); WriteLong(Length(X.ExportName)); - WriteData( X.ExportName[1], length(X.ExportName)); + WriteData( X.ExportName[1], length(X.ExportName)*SizeOf(tbtChar)); end else WriteByte( 0); end; @@ -12477,10 +12477,10 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; WriteLong(0); // offset is unknown at this time WriteLong(0); // length is also unknown at this time WriteLong(Length(xo.Name)); - WriteData( xo.Name[1], length(xo.Name)); + WriteData( xo.Name[1], length(xo.Name)*SizeOf(tbtChar)); s := MakeExportDecl(xo.Decl); WriteLong(Length(s)); - WriteData( s[1], length(S)); + WriteData( s[1], length(S)*SizeOf(tbtChar)); end else begin @@ -12491,16 +12491,16 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; if xe.RegProc.FExportName then begin WriteByte(Length(xe.RegProc.Name)); - WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF); + WriteData(xe.RegProc.Name[1], (Length(xe.RegProc.Name) and $FF)*SizeOf(tbtChar)); end else begin WriteByte(0); end; WriteLong(Length(xe.RegProc.ImportDecl)); - WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl)); + WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl)*SizeOf(tbtChar)); end else begin WriteByte(att or 1); // imported WriteByte(Length(xe.RegProc.Name)); - WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF); + WriteData(xe.RegProc.Name[1], (Length(xe.RegProc.Name) and $FF)*SizeOf(tbtChar)); end; end; if xp.Attributes.Count <> 0 then diff --git a/Source/uPSDisassembly.pas b/Source/uPSDisassembly.pas index 95c89644..15584bb4 100644 --- a/Source/uPSDisassembly.pas +++ b/Source/uPSDisassembly.pas @@ -184,8 +184,8 @@ function IFPS3DataToText(const Input: tbtAnsiString; var Output: string): Boolea e: extended; ss: single; d: double; - s: ansistring; - c: char; + s: tbtstring; + c: tbtchar; {$IFNDEF PS_NOWIDESTRING} wc: WideChar; ws: WideString; @@ -207,7 +207,7 @@ function IFPS3DataToText(const Input: tbtAnsiString; var Output: string): Boolea btSingle: begin if not ReadData(ss, Sizeof(tbtsingle)) then exit; Result := FloatToStr(ss); end; btDouble: begin if not ReadData(d, Sizeof(tbtdouble)) then exit; Result := FloatToStr(d); end; btExtended: begin if not ReadData(e, Sizeof(tbtextended)) then exit; Result := FloatToStr(e); end; - btPChar, btString: begin if not ReadData(l, 4) then exit; SetLength(s, l); if not readData(s[1], l) then exit; Result := MakeString(s); end; + btPChar, btString: begin if not ReadData(l, 4) then exit; SetLength(s, l); if not readData(s[1], l*SizeOf(tbtChar)) then exit; Result := MakeString(s); end; btSet: begin SetLength(s, TPSTypeRec_Set(f).aByteSize); @@ -215,7 +215,7 @@ function IFPS3DataToText(const Input: tbtAnsiString; var Output: string): Boolea result := MakeString(s); end; - btChar: begin if not ReadData(c, 1) then exit; Result := '#'+IntToStr(ord(c)); end; + btChar: begin if not ReadData(c, SizeOf(tbtChar)) then exit; Result := '#'+IntToStr(ord(c)); end; {$IFNDEF PS_NOWIDESTRING} btWideChar: begin if not ReadData(wc, 2) then exit; Result := '#'+IntToStr(ord(wc)); end; btWideString: begin if not ReadData(l, 4) then exit; SetLength(ws, l); if not readData(ws[1], l*2) then exit; Result := MakeWString(ws); end; diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index 19d857e1..c65278c9 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -2830,7 +2830,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; SetLength(Name, NameLen); - if not Read(Name[1], NameLen) then + if not Read(Name[1], NameLen*SizeOf(tbtChar)) then begin CMD_Err(ErOutOfRange); Result := false; @@ -2865,13 +2865,14 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; end; - bts8, btchar, btU8: if not read(PPSVariantU8(VarP)^.data, SizeOf(tbtu8)) then + bts8, btU8{$IF SizeOf(tbtChar) = 1}, btchar{$IFEND}: if not read(PPSVariantU8(VarP)^.data, SizeOf(tbtu8)) then begin CMD_Err(erOutOfRange); Result := False; exit; end; - bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16: if not read(PPSVariantU16(Varp)^.Data, SizeOf(TbtU16)) then begin + bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} + {$IF SizeOf(tbtChar) = 2}btchar,{$IFEND} btU16: if not read(PPSVariantU16(Varp)^.Data, SizeOf(TbtU16)) then begin CMD_Err(ErOutOfRange); Result := False; exit; @@ -2929,7 +2930,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; SetLength(PPSVariantAString(varp)^.Data, NameLen); - if not read(PPSVariantAString(varp)^.Data[1], NameLen) then begin + if not read(PPSVariantAString(varp)^.Data[1], NameLen*SizeOf(tbtChar)) then begin CMD_Err(erOutOfRange); Result := False; exit; @@ -3064,7 +3065,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; setlength(TPSTypeRec_Class(Curr).FCN, d); - if not Read(TPSTypeRec_Class(Curr).FCN[1], d) then + if not Read(TPSTypeRec_Class(Curr).FCN[1], d*SizeOf(tbtChar)) then begin curr.Free; cmd_err(erUnexpectedEof); @@ -3085,7 +3086,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; setlength(TPSTypeRec_ProcPtr(Curr).FParamInfo, d); - if not Read(TPSTypeRec_ProcPtr(Curr).FParamInfo[1], d) then + if not Read(TPSTypeRec_ProcPtr(Curr).FParamInfo[1], d*SizeOf(tbtChar)) then begin curr.Free; cmd_err(erUnexpectedEof); @@ -3257,7 +3258,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; SetLength(Curr.FExportName, d); - if not read(Curr.fExportName[1], d) then + if not read(Curr.fExportName[1], d*SizeOf(tbtChar)) then begin cmd_err(erUnexpectedEof); LoadTypes := False; @@ -3302,7 +3303,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; SetLength(n, b); - if not read(n[1], b) then begin + if not read(n[1], b*SizeOf(tbtChar)) then begin Curr.Free; cmd_err(erUnexpectedEof); LoadProcs := False; @@ -3319,7 +3320,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; SetLength(n, L2); - Read(n[1], L2); // no check is needed + Read(n[1], L2*SizeOf(tbtChar)); // no check is needed TPSExternalProcRec(Curr).FDecl := n; end; if not ImportProc(TPSExternalProcRec(Curr).Name, TPSExternalProcRec(Curr)) then begin @@ -3369,7 +3370,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; SetLength(TPSInternalProcRec(Curr).FExportName, L3); - if not read(TPSInternalProcRec(Curr).FExportName[1], L3) then begin + if not read(TPSInternalProcRec(Curr).FExportName[1], L3*SizeOf(tbtChar)) then begin Curr.Free; cmd_err(erUnexpectedEof); LoadProcs := False; @@ -3388,7 +3389,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; SetLength(TPSInternalProcRec(Curr).FExportDecl, L3); - if not read(TPSInternalProcRec(Curr).FExportDecl[1], L3) then begin + if not read(TPSInternalProcRec(Curr).FExportDecl[1], L3*SizeOf(tbtChar)) then begin Curr.Free; cmd_err(erUnexpectedEof); LoadProcs := False; @@ -3446,7 +3447,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; new(e); try SetLength(e^.FName, n); - if not Read(e^.FName[1], n) then + if not Read(e^.FName[1], n*SizeOf(tbtChar)) then begin dispose(e); cmd_err(erUnexpectedEof); @@ -7404,7 +7405,7 @@ function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boo exit; end; end; - bts8, btchar, btU8: + bts8, btU8{$IF SizeOf(tbtChar) = 1}, btchar{$IFEND}: begin if FCurrentPosition >= FDataLength then begin @@ -7416,7 +7417,8 @@ function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boo tbtu8(dest.p^) := FData^[FCurrentPosition]; Inc(FCurrentPosition); end; - bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} btU16: + bts16, {$IFNDEF PS_NOWIDESTRING}btwidechar,{$ENDIF} + {$IF SizeOf(tbtChar) = 2}btchar,{$IFEND} btU16: begin if FCurrentPosition + 1>= FDataLength then begin @@ -7583,14 +7585,14 @@ function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boo Pointer(Dest.P^) := nil; SetLength(tbtstring(Dest.P^), Param); if Param <> 0 then begin - if not ReadData(tbtstring(Dest.P^)[1], Param) then + if not ReadData(tbtstring(Dest.P^)[1], Param*SizeOf(tbtChar)) then begin CMD_Err(erOutOfRange); FTempVars.Pop; Result := False; exit; end; - pansichar(dest.p^)[Param] := #0; + tbtpchar(dest.p^)[Param] := #0; end; end; {$IFNDEF PS_NOWIDESTRING} From 665ad05233485663073d56a45b661e84d905243b Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 14:04:17 +0200 Subject: [PATCH 18/28] PS_NATIVESTRINGS: width-aware tokenizer TPSPascalParser assumed 1-byte characters: FText was hard-typed PAnsiChar, token extraction moved Length bytes, and the keyword uppercaser walked the token as a byte string. With a wide tbtString the parser returned garbage tokens (every script failed with 'Unable to register type Boolean' from the very first AddTypeS). - FText: TbtPChar; all token/raw-text extractions move Length*SizeOf(tbtChar) - CheckReserved takes TbtString (keyword names no longer truncated through ShortString) - identifier uppercasing uses UpperCase for 2-byte tbtChar, the byte walk otherwise - char-class tests use CharInSet when available (silences WideChar-in-set warnings; same code on old compilers), incl. FastUpperCase/FastLowerCase No change with PS_NATIVESTRINGS undefined (SizeOf(tbtChar)=1 keeps all arithmetic identical). Co-Authored-By: Claude Fable 5 --- Source/uPSUtils.pas | 63 +++++++++++++++++++++++++++++++-------------- 1 file changed, 44 insertions(+), 19 deletions(-) diff --git a/Source/uPSUtils.pas b/Source/uPSUtils.pas index c6bc1e68..cee10ffc 100644 --- a/Source/uPSUtils.pas +++ b/Source/uPSUtils.pas @@ -615,7 +615,7 @@ TPSUnitList = class TPSPascalParser = class(TObject) protected FData: TbtString; - FText: {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}PChar{$ENDIF}; + FText: TbtPChar; FLastEnterPos, FRow, FRealPosition, FTokenLength: Cardinal; FTokenId: TPSPasToken; FToken: TbtString; @@ -1117,7 +1117,7 @@ function FastUpperCase(const s: TbtString): TbtString; while I > 0 do begin C := Result[I]; - if c in [#97..#122] then + if {$if declared(CharInSet)}CharInSet(c, [#97..#122]){$else}(c in [#97..#122]){$ifend} then Result[I] := tbtchar(Ord(Result[I]) -32); Dec(I); end; @@ -1133,7 +1133,7 @@ function FastLowerCase(const s: TbtString): TbtString; while I > 0 do begin C := Result[I]; - if C in [#65..#90] then + if {$if declared(CharInSet)}CharInSet(C, [#65..#90]){$else}(C in [#65..#90]){$ifend} then Result[I] := tbtchar(Ord(Result[I]) + 32); Dec(I); end; @@ -1226,7 +1226,7 @@ procedure TPSPascalParser.Next; var Err: TPSParserErrorKind; FLastUpToken: TbtString; - function CheckReserved(Const S: ShortString; var CurrTokenId: TPSPasToken): Boolean; + function CheckReserved(Const S: TbtString; var CurrTokenId: TPSPasToken): Boolean; var L, H, I: LongInt; J: SmallInt; @@ -1266,7 +1266,7 @@ procedure TPSPascalParser.Next; s: tbtString; begin SetLength(s, CurrTokenLen); - Move(FText[CurrTokenPos], S[1], CurrtokenLen); + Move(FText[CurrTokenPos], S[1], CurrtokenLen*SizeOf(TbtChar)); Result := s; end; @@ -1275,7 +1275,9 @@ procedure TPSPascalParser.Next; var ct, ci: Cardinal; hs: Boolean; + {$if SizeOf(TbtChar) <> 2} p: {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}PChar{$ENDIF}; + {$ifend} begin ParseToken := iNoError; ct := CurrTokenPos; @@ -1288,12 +1290,20 @@ procedure TPSPascalParser.Next; 'A'..'Z', 'a'..'z', '_': begin ci := ct + 1; - while (FText[ci] in ['_', '0'..'9', 'a'..'z', 'A'..'Z']) do begin + while {$if declared(CharInSet)} + CharInSet(FText[ci], ['_', '0'..'9', 'a'..'z', 'A'..'Z']) + {$else} + (FText[ci] in ['_', '0'..'9', 'a'..'z', 'A'..'Z']) + {$ifend} + do begin Inc(ci); end; CurrTokenLen := ci - ct; FLastUpToken := _GetToken(CurrTokenPos, CurrtokenLen); + {$if SizeOf(TbtChar) = 2} + FLastUpToken := UpperCase(FLastUpToken); + {$else} p := {$IFDEF DELPHI4UP}PAnsiChar{$ELSE}pchar{$ENDIF}(FLastUpToken); while p^<>#0 do begin @@ -1301,6 +1311,7 @@ procedure TPSPascalParser.Next; Dec(Byte(p^), 32); inc(p); end; + {$ifend} if not CheckReserved(FLastUpToken, CurrTokenId) then begin CurrTokenId := CSTI_Identifier; @@ -1310,7 +1321,11 @@ procedure TPSPascalParser.Next; begin ci := ct + 1; - while (FText[ci] in ['0'..'9', 'a'..'f', 'A'..'F']) + while {$if declared(CharInSet)} + CharInSet(FText[ci], ['0'..'9', 'a'..'f', 'A'..'F']) + {$else} + (FText[ci] in ['0'..'9', 'a'..'f', 'A'..'F']) + {$ifend} do Inc(ci); CurrTokenId := CSTI_HexInt; @@ -1321,7 +1336,7 @@ procedure TPSPascalParser.Next; begin hs := False; ci := ct; - while (FText[ci] in ['0'..'9']) do + while {$if declared(CharInSet)}CharInSet(FText[ci], ['0'..'9']){$else}(FText[ci] in ['0'..'9']){$ifend} do begin Inc(ci); if (FText[ci] = '.') and (not hs) then @@ -1331,16 +1346,21 @@ procedure TPSPascalParser.Next; Inc(ci); end; end; - if (FText[ci] in ['E','e']) and ((FText[ci+1] in ['0'..'9']) + if {$if declared(CharInSet)} + CharInSet(FText[ci], ['E','e']) and (CharInSet(FText[ci+1], ['0'..'9']) + or (CharInSet(FText[ci+1], ['+','-']) and CharInSet(FText[ci+2], ['0'..'9']))) then + {$else} + (FText[ci] in ['E','e']) and ((FText[ci+1] in ['0'..'9']) or ((FText[ci+1] in ['+','-']) and (FText[ci+2] in ['0'..'9']))) then + {$ifend} begin hs := True; Inc(ci); - if FText[ci] in ['+','-'] then + if {$if declared(CharInSet)}CharInSet(FText[ci], ['+','-']){$else}(FText[ci] in ['+','-']){$ifend} then Inc(ci); repeat Inc(ci); - until not (FText[ci] in ['0'..'9']); + until not {$if declared(CharInSet)}CharInSet(FText[ci], ['0'..'9']){$else}(FText[ci] in ['0'..'9']){$ifend}; end; if hs @@ -1381,7 +1401,12 @@ procedure TPSPascalParser.Next; if FText[ci] = '$' then begin inc(ci); - while (FText[ci] in ['A'..'F', 'a'..'f', '0'..'9']) do begin + while {$if declared(CharInSet)} + CharInSet(FText[ci], ['A'..'F', 'a'..'f', '0'..'9']) + {$else} + (FText[ci] in ['A'..'F', 'a'..'f', '0'..'9']) + {$ifend} + do begin Inc(ci); end; if ci = ct + 2 then @@ -1390,10 +1415,10 @@ procedure TPSPascalParser.Next; CurrTokenLen := ci - ct; end else begin - while (FText[ci] in ['0'..'9']) do begin + while {$if declared(CharInSet)}CharInSet(FText[ci], ['0'..'9']){$else}(FText[ci] in ['0'..'9']){$ifend} do begin Inc(ci); end; - if (ci = ct + 1) or (FText[ci] in ['A'..'Z', 'a'..'z', '_']) then + if (ci = ct + 1) or {$if declared(CharInSet)}CharInSet(FText[ci], ['A'..'Z', 'a'..'z', '_']){$else}(FText[ci] in ['A'..'Z', 'a'..'z', '_']){$ifend} then ParseToken := iCharError; CurrTokenId := CSTI_Char; CurrTokenLen := ci - ct; @@ -1565,7 +1590,7 @@ procedure TPSPascalParser.Next; #32, #9, #13, #10: begin ci := ct; - while (FText[ci] in [#32, #9, #13, #10]) do + while {$if declared(CharInSet)}CharInSet(FText[ci], [#32, #9, #13, #10]){$else}(FText[ci] in [#32, #9, #13, #10]){$ifend} do begin if FText[ci] = #13 then begin @@ -1642,25 +1667,25 @@ procedure TPSPascalParser.Next; CSTIINT_Comment: if not FEnableComments then Continue else begin SetLength(FOriginalToken, FTokenLength); - Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength*SizeOf(TbtChar)); FToken := FOriginalToken; end; CSTIINT_WhiteSpace: if not FEnableWhitespaces then Continue else begin SetLength(FOriginalToken, FTokenLength); - Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength*SizeOf(TbtChar)); FToken := FOriginalToken; end; CSTI_Integer, CSTI_Real, CSTI_String, CSTI_Char, CSTI_HexInt: begin SetLength(FOriginalToken, FTokenLength); - Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength*SizeOf(TbtChar)); FToken := FOriginalToken; end; CSTI_Identifier: begin SetLength(FOriginalToken, FTokenLength); - Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength); + Move(FText[CurrTokenPos], FOriginalToken[1], FTokenLength*SizeOf(TbtChar)); FToken := FLastUpToken; end; else From 6f8806295e73e7e794e4345ce407b313b1982b60 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 14:04:17 +0200 Subject: [PATCH 19/28] PS_NATIVESTRINGS: real Ansi script types and PWideChar support With native (wide) tbtString, the script types AnsiChar/AnsiString/PAnsiChar would silently lose their Ansi semantics. Give them their own always-Ansi base types (btAnsiChar=31, btAnsiString=32, btPAnsiChar=33) and map script PChar to the new btPWideChar=30. Only active under PS_NATIVESTRINGS+UNICODE; otherwise DefineStandardTypes registers exactly the same types as before and the new base types are never emitted. Compiler: type registration incl. PWideChar and open arrays, IsCharType/ IsStringType, IsCompatibleType rules (PWideChar mirrors UnicodeString, Ansi family assignable across all string types), GetResultType (all-Ansi concat stays btAnsiString; comparisons; otIn accepts any char type against char sets and int against byte sets), const getters/setters, variant copy/finalize, ConvertToAnsiString + PreCalc folding (concat, all six comparisons, otIn), BlockWriteVariant/WriteVariant (btAnsiChar = 1 byte, btAnsiString = length x 1), set-of-AnsiChar, string indexing, Ord(), const cast folding. Runtime: LoadTypes/CalcSize/InitializeVariant/FinalizeVariant/ NeedFinalization for the four new types, attribute + inline-constant readers, PSGet*/PSSet*, CopyArrayContents (missing types here silently zero record fields!), SetVariantValue sources and destinations, comparison/concat operators, string builtins (Length/SetLength/StrGet/ StrSet/Copy/Delete/Insert/Low/High), IntPIFVariantToVariant, debug helpers, TVarRec builder, RTTI property stores. P-char ownership: btPAnsiChar/btPWideChar slots own their content as a managed string (the payload pointer IS the p-char value); they are finalized like strings and all writers assign managed strings. PSBorrowPCharOwnership/PSReownPCharOwnership are included for the call-marshaling layer. btPChar (14) deliberately stays the upstream raw pointer type - unchanged semantics for existing host code; under PS_NATIVESTRINGS scripts cannot create btPChar values (PChar maps to btPWideChar). Both modes compile on Delphi 12; OFF-mode probe suite unchanged-green; ON-mode script smoke tests (string/char/AnsiString/AnsiChar consts, concat, StrSet indexing, Ord) pass. Co-Authored-By: Claude Fable 5 --- Source/uPSCompiler.pas | 208 ++++++++++++++++------ Source/uPSRuntime.pas | 382 +++++++++++++++++++++++++++++++++++++++-- 2 files changed, 522 insertions(+), 68 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index 4ea89fc6..a13afe37 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -1993,6 +1993,7 @@ function BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant{$IFNDEF PS_NO end; btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency)); btChar: BlockWriteData(BlockInfo, p^.tchar, SizeOf(tbtChar)); + btAnsiChar: BlockWriteData(BlockInfo, p^.tchar, 1); btSet: begin BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); @@ -2003,6 +2004,12 @@ function BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant{$IFNDEF PS_NO if Length(tbtString(p^.tstring)) > 0 then BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))*SizeOf(tbtChar)); end; + btAnsiString: + begin + BlockWriteLong(BlockInfo, Length(tbtAnsiString(p^.tstring))); + if Length(tbtAnsiString(p^.tstring)) > 0 then + BlockWriteData(BlockInfo, tbtAnsiString(p^.tstring)[1], Length(tbtAnsiString(p^.tstring))); + end; btenum: begin if TPSEnumType(p^.FType).HighValue <=255 then @@ -2261,10 +2268,18 @@ function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; De {$IFNDEF PS_NOINT64}btS64: VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64'); btU64: VCType := FindAndAddType(Owner, '!OPENARRAYOFU64', 'array of UInt64');{$ENDIF} btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char'); + {$IF DEFINED(PS_NATIVESTRINGS) AND DEFINED(UNICODE) AND NOT DEFINED(PS_NOWIDESTRING)} + btAnsiChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFANSICHAR', 'array of AnsiChar'); + btAnsiString: VCType := FindAndAddType(Owner, '!OPENARRAYOFANSISTRING', 'array of AnsiString'); + btPAnsiChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPANSICHAR', 'array of PAnsiChar'); + {$IFEND} {$IFNDEF PS_NOWIDESTRING} btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString'); btUnicodeString: VCType := FindAndAddType(Owner, '!OPENARRAYOFUNICODESTRING', 'array of UnicodeString'); btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar'); + {$IF DEFINED(PS_NATIVESTRINGS) AND DEFINED(UNICODE)} + btPWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPWIDECHAR', 'array of PWideChar'); + {$IFEND} {$ENDIF} btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject'); btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken)); @@ -2756,12 +2771,13 @@ procedure CopyVariantContents(Src, Dest: PIfRVariant); btdouble: Dest^.tdouble := src^.tdouble; btextended: Dest^.textended := src^.textended; btCurrency: Dest^.tcurrency := Src^.tcurrency; - btchar: Dest^.tchar := src^.tchar; + btchar, btAnsiChar: Dest^.tchar := src^.tchar; {$IFNDEF PS_NOINT64} bts64: dest^.ts64 := src^.ts64; btU64: dest^.tu64 := src^.tu64; {$ENDIF} btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring); + btAnsiString: tbtAnsiString(dest^.tstring) := tbtAnsiString(src^.tstring); {$IFNDEF PS_NOWIDESTRING} btunicodestring: tbtunicodestring(dest^.tunistring) := tbtunicodestring(src^.tunistring); btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring); @@ -2804,6 +2820,8 @@ procedure FinalizeVariant(var p: TIfRVariant); begin if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then finalizeA(tbtstring(p.tstring)) + else if p.FType.BaseType = btAnsiString then + tbtAnsiString(p.tstring) := '' {$IFNDEF PS_NOWIDESTRING} else if p.FType.BaseType = btWideString then finalizeW(tbtWideString(p.twidestring)) // tbtwidestring @@ -2846,7 +2864,7 @@ function IsIntType(b: TPSBaseType): Boolean; function IsCharType(b: TPSBaseType): Boolean; begin case b of - btChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}: Result := True; + btChar, btAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}: Result := True; else Result := False; end; @@ -2855,7 +2873,7 @@ function IsCharType(b: TPSBaseType): Boolean; function IsStringType(b: TPSBaseType): Boolean; begin case b of - btString{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: Result := True; + btString, btAnsiString{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: Result := True; else Result := False; end; @@ -2944,7 +2962,7 @@ function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal; bts64: Result := src^.ts64; btU64: Result := src^.tu64; {$ENDIF} - btChar: Result := ord(Src^.tchar); + btChar, btAnsiChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} @@ -2970,7 +2988,7 @@ function GetInt(Src: PIfRVariant; var s: Boolean): Longint; bts64: Result := src^.ts64; btU64: Result := src^.tu64; {$ENDIF} - btChar: Result := ord(Src^.tchar); + btChar, btAnsiChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} @@ -2994,7 +3012,7 @@ function GetInt64(Src: PIfRVariant; var s: Boolean): Int64; btS32: Result := Src^.ts32; bts64: Result := src^.ts64; btU64: Result := src^.tu64; - btChar: Result := ord(Src^.tchar); + btChar, btAnsiChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} @@ -3018,7 +3036,7 @@ function GetUInt64(Src: PIfRVariant; var s: Boolean): UInt64; btS32: Result := Src^.ts32; bts64: Result := src^.ts64; btU64: Result := src^.tu64; - btChar: Result := ord(Src^.tchar); + btChar, btAnsiChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} @@ -3045,7 +3063,7 @@ function GetReal(Src: PIfRVariant; var s: Boolean): Extended; bts64: Result := src^.ts64; btU64: Result := src^.tu64; {$ENDIF} - btChar: Result := ord(Src^.tchar); + btChar, btAnsiChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} @@ -3064,8 +3082,9 @@ function GetReal(Src: PIfRVariant; var s: Boolean): Extended; function GetString(Src: PIfRVariant; var s: Boolean): tbtString; begin case Src.FType.BaseType of - btChar: Result := Src^.tchar; + btChar, btAnsiChar: Result := Src^.tchar; btString: Result := tbtstring(src^.tstring); + btAnsiString: Result := tbtstring(tbtAnsiString(src^.tstring)); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtstring(src^.twidechar); btWideString: Result := tbtstring(tbtWideString(src^.twidestring)); @@ -3083,8 +3102,9 @@ function GetString(Src: PIfRVariant; var s: Boolean): tbtString; function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring; begin case Src.FType.BaseType of - btChar: Result := tbtWidestring(Src^.tchar); + btChar, btAnsiChar: Result := tbtWidestring(Src^.tchar); btString: Result := tbtWidestring(tbtstring(src^.tstring)); + btAnsiString: Result := tbtWidestring(tbtAnsiString(src^.tstring)); btWideChar: Result := src^.twidechar; btWideString: Result := tbtWideString(src^.twidestring); btUnicodeString: result := tbtUnicodeString(src^.tunistring); @@ -3098,8 +3118,9 @@ function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtw function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring; begin case Src.FType.BaseType of - btChar: Result := tbtunicodestring(Src^.tchar); + btChar, btAnsiChar: Result := tbtunicodestring(Src^.tchar); btString: Result := tbtunicodestring(tbtstring(src^.tstring)); + btAnsiString: Result := tbtunicodestring(tbtAnsiString(src^.tstring)); btWideChar: Result := src^.twidechar; btWideString: Result := tbtWideString(src^.twidestring); btUnicodeString: result := tbtUnicodeString(src^.tunistring); @@ -3212,6 +3233,18 @@ procedure ConvertToUnicodeString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; tbtunicodestring(var1^.tunistring) := s; end; {$ENDIF} +procedure ConvertToAnsiString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtAnsiString); +var + atype: TPSType; +begin + FinalizeVariant(var1^); + atype := se.FindBaseType(btAnsiString); + if FUseUsedTypes then + InitializeVariant(var1, se.at2ut(atype)) + else + InitializeVariant(var1, atype); + tbtAnsiString(var1^.tstring) := s; +end; procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType); var vartemp: PIfRVariant; @@ -3309,21 +3342,28 @@ function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boo ((p1.BaseType = btChar) and (p2.BaseType = btWideChar)) or ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or - ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or - ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or - ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or + (((p1.basetype = btPwidechar) or (p1.BaseType = btWidestring)) and (p2.BaseType = btChar)) or + (((p1.basetype = btPwidechar) or (p1.BaseType = btWidestring)) and (p2.BaseType = btWideChar)) or + (((p1.basetype = btPwidechar) or (p1.BaseType = btWidestring)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.basetype = btPwidechar) or (p2.BaseType = btUnicodeString))) or ((p1.BaseType = btWidestring) and ((p2.BaseType = btWidestring))) or ((p1.BaseType = btUnicodeString) and (p2.BaseType = btChar)) or ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or - ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or + (((p1.basetype = btPwidechar) or (p1.BaseType = btUnicodeString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.basetype = btPwidechar) or (p2.basetype = btWideString) or (p2.BaseType = btUnicodeString))) or ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and // the second/third term used to dangle outside the p1 check, which // made EVERY destination type compatible with UnicodeString sources - ((p2.BaseType = btWideString) or (p2.BaseType = btUnicodeString))) or + ((p2.BaseType = btWideString) or (p2.BaseType = btUnicodeString) or (p2.basetype = btPwidechar))) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or {$ENDIF} + // always-Ansi types (PS_NATIVESTRINGS): behave like btChar/btString/btPChar + ((p1.BaseType = btAnsiChar) and ((p2.BaseType in [btAnsiChar, btChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}]) or IsIntType(p2.BaseType))) or + ((p1.BaseType in [btChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}]) and (p2.BaseType = btAnsiChar)) or + ((p1.BaseType in [btAnsiString, btPAnsiChar]) and (p2.BaseType in [btAnsiString, btPAnsiChar, btAnsiChar, + btString, btPchar, btChar{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString, btWideChar, btPwidechar{$ENDIF}])) or + ((p1.BaseType in [btString, btPchar{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString, btPwidechar{$ENDIF}]) and + (p2.BaseType in [btAnsiString, btPAnsiChar, btAnsiChar])) or ((p1.BaseType = btRecord) and (p2.BaseType = btrecord) and (not IsVarInCompatible(p1, p2))) or ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or @@ -3393,10 +3433,20 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, Result)+getstring(Var2, Result)); end; btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result); + btAnsiString: tbtAnsiString(var1^.tstring) := tbtAnsiString(var1^.tstring) + tbtAnsiString(GetString(Var2, Result)); + btAnsiChar, btPAnsiChar: + if Var2.FType.BaseType in [btAnsiChar, btAnsiString, btPAnsiChar] then + ConvertToAnsiString(Self, FUseUsedTypes, var1, tbtAnsiString(getstring(Var1, Result)) + tbtAnsiString(getstring(Var2, Result))) + else + {$IFNDEF PS_NOWIDESTRING} + ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, b)+GetUnicodeString(Var2, b)); + {$ELSE} + ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, Result)+getstring(Var2, Result)); + {$ENDIF} {$IFNDEF PS_NOWIDESTRING} btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result); btUnicodeString: tbtunicodestring(var1^.tunistring) := tbtunicodestring(var1^.tunistring) + GetUnicodeString(Var2, Result); - btWidechar: + btWidechar, btPWideChar: begin ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, Result)+GetUnicodeString(Var2, Result)); end; @@ -3604,7 +3654,8 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: btExtended: b := var1^.textended >= GetReal( Var2, Result); btCurrency: b := var1^.tcurrency >= GetReal( Var2, Result); btString: b := tbtstring(var1^.tstring) >= GetString(var2, Result); - btChar: b := var1^.tchar >= GetString(var2, Result); + btAnsiString: b := tbtstring(tbtAnsiString(var1^.tstring)) >= GetString(var2, Result); + btChar, btAnsiChar: b := var1^.tchar >= GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) >= GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.tunistring) >= GetUnicodeString(var2, Result); @@ -3639,7 +3690,8 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: btExtended: b := var1^.textended <= GetReal( Var2, Result); btCurrency: b := var1^.tcurrency <= GetReal( Var2, Result); btString: b := tbtstring(var1^.tstring) <= GetString(var2, Result); - btChar: b := var1^.tchar <= GetString(var2, Result); + btAnsiString: b := tbtstring(tbtAnsiString(var1^.tstring)) <= GetString(var2, Result); + btChar, btAnsiChar: b := var1^.tchar <= GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) <= GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <= GetUnicodeString(var2, Result); @@ -3674,7 +3726,8 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: btExtended: b := var1^.textended > GetReal( Var2, Result); btCurrency: b := var1^.tcurrency > GetReal( Var2, Result); btString: b := tbtstring(var1^.tstring) > GetString(var2, Result); - btChar: b := var1^.tchar > GetString(var2, Result); + btAnsiString: b := tbtstring(tbtAnsiString(var1^.tstring)) > GetString(var2, Result); + btChar, btAnsiChar: b := var1^.tchar > GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) > GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.tunistring) > GetUnicodeString(var2, Result); @@ -3702,7 +3755,8 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: btExtended: b := var1^.textended < GetReal( Var2, Result); btCurrency: b := var1^.tcurrency < GetReal( Var2, Result); btString: b := tbtstring(var1^.tstring) < GetString(var2, Result); - btChar: b := var1^.tchar < GetString(var2, Result); + btAnsiString: b := tbtstring(tbtAnsiString(var1^.tstring)) < GetString(var2, Result); + btChar, btAnsiChar: b := var1^.tchar < GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) < GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.tunistring) < GetUnicodeString(var2, Result); @@ -3731,7 +3785,8 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: btCurrency: b := var1^.tcurrency <> GetReal( Var2, Result); btEnum: b := var1^.ts32 <> Getint(Var2, Result); btString: b := tbtstring(var1^.tstring) <> GetString(var2, Result); - btChar: b := var1^.tchar <> GetString(var2, Result); + btAnsiString: b := tbtstring(tbtAnsiString(var1^.tstring)) <> GetString(var2, Result); + btChar, btAnsiChar: b := var1^.tchar <> GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) <> GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <> GetUnicodeString(var2, Result); @@ -3768,7 +3823,8 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: btCurrency: b := var1^.tcurrency = GetReal( Var2, Result); btEnum: b := var1^.ts32 = Getint(Var2, Result); btString: b := tbtstring(var1^.tstring) = GetString(var2, Result); - btChar: b := var1^.tchar = GetString(var2, Result); + btAnsiString: b := tbtstring(tbtAnsiString(var1^.tstring)) = GetString(var2, Result); + btChar, btAnsiChar: b := var1^.tchar = GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.tunistring) = GetUnicodeString(var2, Result); @@ -3789,7 +3845,12 @@ function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: end; otIn: begin - if (var2.Ftype.BaseType = btset) and (TPSSetType(var2.Ftype).SetType = Var1.FType) then + if (var2.Ftype.BaseType = btset) and ((TPSSetType(var2.Ftype).SetType = Var1.FType) or + // consistent with GetResultType: any char against a char set, + // any int against a byte set (ord-based) + ((Var1.FType.BaseType in [btChar, btAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}]) and + (TPSSetType(var2.Ftype).SetType.BaseType in [btChar, btAnsiChar])) or + (IsIntType(Var1.FType.BaseType) and (TPSSetType(var2.Ftype).SetType.BaseType = btU8))) then begin Set_membership(GetUint(var1, result), var2.tstring, b); end else Result := False; @@ -4113,7 +4174,7 @@ function TPSPascalCompiler.ReadType(const Name: tbtString; FParser: TPSPascalPar Result := nil; exit; end; - if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btU8) then + if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btAnsiChar) or (TypeNo.BaseType = btU8) then begin FParser.Next; p2 := TPSSetType.Create; @@ -6887,7 +6948,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit; if FParser.CurrTokenId = CSTI_OpenBlock then begin - if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or + if (u.BaseType = btString) or (u.BaseType = btAnsiString) {$IFNDEF PS_NOWIDESTRING} or (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF} {$IFDEF PS_HAVEVARIANT}or (u.BaseType = btVariant){$ENDIF} then begin @@ -6969,7 +7030,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; end; {$IFDEF PS_HAVEVARIANT}if (u.BaseType <> btVariant) then {$ENDIF} begin - if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar) + if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar) and (GetTypeNo(BlockInfo, Tmp).BaseType <> btAnsiChar) {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then begin x.Free; @@ -8121,7 +8182,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Result := P is TPSValueData; if not Result then Exit; case TPSValueData(P).Data.FType.BaseType of - btChar: v := Ord(TPSValueData(P).Data.tchar); + btChar, btAnsiChar: v := Ord(TPSValueData(P).Data.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: v := Ord(TPSValueData(P).Data.twidechar); {$ENDIF} @@ -8140,8 +8201,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; begin if a.BaseType = btEnum then Result := a = b - else if a.BaseType in [btChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}] then - Result := b.BaseType in [btChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}] + else if a.BaseType in [btChar, btAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}] then + Result := b.BaseType in [btChar, btAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}] else Result := IsIntType(a.BaseType) and IsIntType(b.BaseType); end; @@ -8152,7 +8213,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Result.SetParserPos(FParser); TPSValueData(Result).Data := NewVariant(aType); case aType.BaseType of - btChar: TPSValueData(Result).Data.tchar := TbtChar(v); + btChar, btAnsiChar: TPSValueData(Result).Data.tchar := TbtChar(v); {$IFNDEF PS_NOWIDESTRING} btWideChar: TPSValueData(Result).Data.twidechar := TbtWideChar(v); {$ENDIF} @@ -8456,7 +8517,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; MakeError('', ecCloseRoundExpected, ''); exit; end; - if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or + if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or (GetTypeNo(BlockInfo, NewVar).BaseType = btAnsiChar) or {$IFNDEF PS_NOWIDESTRING} (GetTypeNo(BlockInfo, NewVar).BaseType = btWideChar) or{$ENDIF} (GetTypeNo(BlockInfo, NewVar).BaseType = btEnum) or (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType))) then begin @@ -8707,11 +8768,14 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Result := t1 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then Result := t2 + else if (t1.BaseType in [btAnsiString, btAnsiChar, btPAnsiChar]) and + (t2.BaseType in [btAnsiString, btAnsiChar, btPAnsiChar]) then + Result := at2ut(FindBaseType(btAnsiString)) else if ((t1.BaseType = btPchar) or(t1.BaseType = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btPchar) or(t2.BaseType = btString) or (t2.BaseType = btChar)) then Result := at2ut(FindBaseType(btString)) {$IFNDEF PS_NOWIDESTRING} - else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btPchar)or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodeString)) and - ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then + else if (t1.BaseType in [btString, btChar, btPchar, btPWideChar, btWideString, btWideChar, btUnicodeString, btAnsiString, btAnsiChar, btPAnsiChar]) and + (t2.BaseType in [btString, btChar, btPchar, btPWideChar, btWideString, btWideChar, btUnicodeString, btAnsiString, btAnsiChar, btPAnsiChar]) then Result := at2ut(FindBaseType(btUnicodeString)) {$ENDIF} else @@ -8918,8 +8982,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; IsIntRealType(t2.BaseType) then Result := FDefaultBoolType else if - ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and - ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then + (t1.BaseType in [btString, btChar, btAnsiString, btAnsiChar, btPAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideString, btWideChar, btUnicodestring, btPWideChar{$ENDIF}]) and + (t2.BaseType in [btString, btChar, btAnsiString, btAnsiChar, btPAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideString, btWideChar, btUnicodestring, btPWideChar{$ENDIF}]) then Result := FDefaultBoolType else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then Result := FDefaultBoolType @@ -8951,8 +9015,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; IsIntRealType(t2.BaseType) then Result := FDefaultBoolType else if - ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and - ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then + (t1.BaseType in [btString, btChar, btAnsiString, btAnsiChar, btPAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideString, btWideChar, btUnicodestring, btPWideChar{$ENDIF}]) and + (t2.BaseType in [btString, btChar, btAnsiString, btAnsiChar, btPAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideString, btWideChar, btUnicodestring, btPWideChar{$ENDIF}]) then Result := FDefaultBoolType else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then Result := FDefaultBoolType @@ -8973,7 +9037,12 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; if (t2.Name = 'TVARIANTARRAY') then Result := FDefaultBoolType else - if (t2.BaseType = btSet) and (TPSSetType(t2).SetType = t1) then + if (t2.BaseType = btSet) and ((TPSSetType(t2).SetType = t1) or + // any char type may be tested against a char set (ord-based at runtime) + ((t1.BaseType in [btChar, btAnsiChar{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}]) and + (TPSSetType(t2).SetType.BaseType in [btChar, btAnsiChar])) or + // and any int type against a byte set + (IsIntType(t1.BaseType) and (TPSSetType(t2).SetType.BaseType = btU8))) then Result := FDefaultBoolType else Result := nil; @@ -9270,7 +9339,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btU8: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9296,7 +9365,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btS8: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9322,7 +9391,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btU16: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9348,7 +9417,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; bts16: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9374,7 +9443,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btEnum, btU32: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9400,7 +9469,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btS32: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9427,7 +9496,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btS64: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9451,7 +9520,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btU64: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.tu64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.tu64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tu64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9473,10 +9542,10 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; end; end; {$ENDIF} - btChar: + btChar, btAnsiChar: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar; + btchar, btAnsiChar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar; {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} @@ -9503,7 +9572,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; btWideChar: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of - btchar: TPSValueData(preplace).Data.twidechar := tbtwidechar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); + btchar, btAnsiChar: TPSValueData(preplace).Data.twidechar := tbtwidechar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); btwidechar: TPSValueData(preplace).Data.twidechar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar; btU8: TPSValueData(preplace).Data.twidechar := tbtwidechar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8); btS8: TPSValueData(preplace).Data.twidechar := tbtwidechar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8); @@ -12267,6 +12336,7 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; end; btCurrency: WriteData(p^.tcurrency, sizeof(tbtCurrency)); btChar: WriteData(p^.tchar, SizeOf(tbtChar)); + btAnsiChar: WriteData(p^.tchar, 1); btSet: begin WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); @@ -12277,6 +12347,12 @@ function TPSPascalCompiler.Compile(const s: tbtString): Boolean; if Length(tbtString(p^.tstring)) > 0 then WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))*SizeOf(tbtChar)); end; + btAnsiString: + begin + WriteLong(Length(tbtAnsiString(p^.tstring))); + if Length(tbtAnsiString(p^.tstring)) > 0 then + WriteData(tbtAnsiString(p^.tstring)[1], Length(tbtAnsiString(p^.tstring))); + end; btenum: begin if TPSEnumType(p^.FType).HighValue <=255 then @@ -13329,17 +13405,31 @@ procedure TPSPascalCompiler.DefineStandardTypes; begin HighValue := 255; // make sure it's gonna be a 1 byte var end; + {$IF DEFINED(PS_NATIVESTRINGS) AND DEFINED(UNICODE) AND NOT DEFINED(PS_NOWIDESTRING)} + { btChar/btString/btPChar are native (wide) here; the Ansi script types get + their own always-Ansi base types } + AddType('Char', btChar); + AddType('AnsiChar', btAnsiChar); + {$ELSE} //following 2 IFDEFs should actually be UNICODE IFDEFs... AddType({$IFDEF PS_PANSICHAR}'AnsiChar'{$ELSE}'Char'{$ENDIF}, btChar); {$IFDEF PS_PANSICHAR} AddType('Char', btWideChar); {$ENDIF} + {$IFEND} {$IFNDEF PS_NOWIDESTRING} AddType('WideChar', btWideChar); AddType('WideString', btWideString); AddType('UnicodeString', btUnicodeString); + {$IF DEFINED(PS_NATIVESTRINGS) AND DEFINED(UNICODE)} + AddType('PWideChar', btPWideChar); + {$IFEND} {$ENDIF} + {$IF DEFINED(PS_NATIVESTRINGS) AND DEFINED(UNICODE) AND NOT DEFINED(PS_NOWIDESTRING)} + AddType('AnsiString', btAnsiString); + {$ELSE} AddType('AnsiString', btString); + {$IFEND} {$IFNDEF PS_NOWIDESTRING} {$IFDEF DELPHI2009UP} AddType('string', btUnicodeString); @@ -13378,7 +13468,14 @@ procedure TPSPascalCompiler.DefineStandardTypes; AddType('Double', btDouble); AddType('Extended', btExtended); AddType('Currency', btCurrency); + {$IF DEFINED(PS_NATIVESTRINGS) AND DEFINED(UNICODE) AND NOT DEFINED(PS_NOWIDESTRING)} + { script PChar values live in owned btPWideChar slots; btPChar (14) stays a + raw pointer type reachable only through host declarations } + AddType('PChar', btPWideChar); + AddType('PAnsiChar', btPAnsiChar); + {$ELSE} AddType({$IFDEF PS_PANSICHAR}'PAnsiChar'{$ELSE}'PChar'{$ENDIF}, btPChar); + {$IFEND} AddType('Variant', btVariant); AddType('!NotificationVariant', btNotificationVariant); for i := FTypes.Count -1 downto 0 do AT2UT(FTypes[i]); @@ -15177,8 +15274,9 @@ procedure TPSConstant.SetChar(c: tbtChar); if (FValue <> nil) then begin case FValue.FType.BaseType of - btChar: FValue.tchar := c; + btChar, btAnsiChar: FValue.tchar := c; btString: tbtString(FValue.tstring) := c; + btAnsiString: tbtAnsiString(FValue.tstring) := tbtAnsiString(c); {$IFNDEF PS_NOWIDESTRING} btWideString: tbtwidestring(FValue.twidestring) := tbtWidestring(c); btUnicodeString: tbtUnicodestring(FValue.tunistring) := tbtUnicodestring(c); @@ -15304,8 +15402,9 @@ procedure TPSConstant.SetString(const Val: tbtString); if (FValue <> nil) then begin case FValue.FType.BaseType of - btChar: FValue.tchar := (Val+#0)[1]; + btChar, btAnsiChar: FValue.tchar := (Val+#0)[1]; btString: tbtString(FValue.tstring) := val; + btAnsiString: tbtAnsiString(FValue.tstring) := tbtAnsiString(val); {$IFNDEF PS_NOWIDESTRING} btWideChar: FValue.twidechar := WideChar((Val+#0)[1]); btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val); @@ -15349,6 +15448,7 @@ procedure TPSConstant.SetWideChar(const val: WideChar); begin case FValue.FType.BaseType of btString: tbtString(FValue.tstring) := tbtstring(val); + btAnsiString: tbtAnsiString(FValue.tstring) := tbtAnsiString(val); btWideChar: FValue.twidechar := val; btWideString: tbtwidestring(FValue.twidestring) := val; btUnicodeString: tbtUnicodestring(FValue.tUniString) := val; @@ -15365,6 +15465,7 @@ procedure TPSConstant.SetWideString(const val: tbtwidestring); begin case FValue.FType.BaseType of btString: tbtString(FValue.tstring) := tbtstring(val); + btAnsiString: tbtAnsiString(FValue.tstring) := tbtAnsiString(val); btWideString: tbtwidestring(FValue.twidestring) := val; btUnicodeString: tbtunicodestring(FValue.tunistring) := val; else @@ -15379,6 +15480,7 @@ procedure TPSConstant.SetUnicodeString(const val: tbtunicodestring); begin case FValue.FType.BaseType of btString: tbtString(FValue.tstring) := tbtstring(val); + btAnsiString: tbtAnsiString(FValue.tstring) := tbtAnsiString(val); btWideString: tbtwidestring(FValue.twidestring) := val; btUnicodeString: tbtunicodestring(FValue.tunistring) := val; else @@ -16329,7 +16431,7 @@ function TPSSetType.GetBitSize: Longint; begin case SetType.BaseType of btEnum: begin Result := TPSEnumType(setType).HighValue+1; end; - btChar, btU8: Result := 256; + btChar, btAnsiChar, btU8: Result := 256; else Result := 0; end; diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index c65278c9..ca37394c 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -333,6 +333,13 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbtString; end; + PPSVariantAnsiString = ^TPSVariantAnsiString; + + TPSVariantAnsiString = packed record + VI: TPSVariant; + Data: tbtAnsiString; + end; + {$IFNDEF PS_NOWIDESTRING} PPSVariantWString = ^TPSVariantWString; @@ -893,6 +900,23 @@ function ResultAsRegister(b: TPSTypeRec): Boolean; function PSGetRecField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC; function PSGetArrayField(const avar: TPSVariantIFC; Fieldno: Longint): TPSVariantIFC; + +type + { P-Char slots (btPAnsiChar/btPWideChar) own their content as managed strings. + When a slot is passed by reference to external code, the callee may + overwrite the raw pointer. These helpers move the slot's ownership into a + holder before the call (the slot keeps its raw pointer value for the callee) + and afterwards either give the reference back (untouched) or copy the + foreign data into an owned string. } + TPSPCharBorrowEntry = record + Slot: Pointer; // address of the P-Char slot + BaseType: TPSBaseType; + Holder: Pointer; // borrowed string reference (owned while borrowed) + end; + TPSPCharBorrowList = array of TPSPCharBorrowEntry; + +procedure PSBorrowPCharOwnership(aType: TPSTypeRec; Dta: Pointer; var List: TPSPCharBorrowList); +procedure PSReownPCharOwnership(var List: TPSPCharBorrowList); function NewTPSVariantRecordIFC(avar: PPSVariant; Fieldno: Longint): TPSVariantIFC; function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC; @@ -914,6 +938,7 @@ function PSGetReal(Src: Pointer; aType: TPSTypeRec): Extended; function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency; function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint; function PSGetString(Src: Pointer; aType: TPSTypeRec): string; +function PSGetAnsiChar(Src: Pointer; aType: TPSTypeRec): tbtchar; function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; {$IFNDEF PS_NOWIDESTRING} function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString; @@ -1668,6 +1693,13 @@ function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtStr end; btchar: Result := MakeString(tbtchar(p.dta^)); {$IFNDEF PS_NOWIDESTRING} + btPWideChar: + begin + if PWideChar(p.dta^) = nil then + Result := 'nil' + else + Result := MakeWString(PWideChar(p.dta^)); + end; btwidechar: Result := MakeWString(tbtwidechar(p.dta^)); btWideString: Result := MakeWString(tbtwidestring(p.dta^)); btUnicodeString: Result := MakeWString(tbtUnicodeString(p.dta^)); @@ -1762,6 +1794,12 @@ function PSBaseTypeToStr(BaseType: TPSBaseType; DelphiNames: Boolean = False): s btInterface : Result := 'Interface'; btNotificationVariant : Result := 'NotificationVariant'; btUnicodeString : Result := 'UnicodeString'; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar : Result := 'PWideChar'; + {$ENDIF} + btAnsiChar : Result := 'AnsiChar'; + btAnsiString : Result := 'AnsiString'; + btPAnsiChar : Result := 'PAnsiChar'; btType : Result := 'Type'; btEnum : Result := 'Enum'; btExtClass : Result := 'ExtClass'; @@ -1897,6 +1935,14 @@ function PSVariantToString(const V: TPSVariantIFC; AppendType: Boolean; NoQuotes Result := string(tbtstring(V.Dta^)) else Result := string(MakeString(tbtstring(V.Dta^))); + btAnsiString : if NoQuotes then + Result := string(tbtAnsiString(V.Dta^)) + else + Result := string(MakeString(tbtstring(tbtAnsiString(V.Dta^)))); + btAnsiChar : if NoQuotes then + Result := string(tbtAnsiChar(V.Dta^)) + else + Result := string(MakeString(tbtstring(tbtAnsiChar(V.Dta^)))); btChar : if NoQuotes then Result := string(tbtChar(V.Dta^)) else @@ -1922,6 +1968,22 @@ function PSVariantToString(const V: TPSVariantIFC; AppendType: Boolean; NoQuotes else Result := string(MakeString(tbtPChar(V.Dta^))); end; + btPAnsiChar : if PAnsiChar(V.Dta^) <> nil then + begin + if NoQuotes then + Result := string(tbtAnsiString(PAnsiChar(V.Dta^))) + else + Result := string(MakeString(tbtstring(tbtAnsiString(PAnsiChar(V.Dta^))))); + end; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar : if PWideChar(V.Dta^) <> nil then + begin + if NoQuotes then + Result := PWideChar(V.Dta^) + else + Result := string(MakeWString(PWideChar(V.Dta^))); + end; + {$ENDIF} btPointer : begin V2.Dta := Pointer(V.Dta^); V2.aType := TPSTypeRec(Pointer(IPointer(V.Dta)+PointerSize)^); @@ -2101,7 +2163,9 @@ procedure StringToPSVariant(const V: TPSVariantIFC; const Value: string); btExtended : tbtExtended(V.Dta^) := StrToFloatDef(Value, 0); btCurrency : tbtCurrency(V.Dta^) := StrToFloatDef(Value, 0); btString : tbtstring(V.Dta^) := tbtstring(Value); + btAnsiString : tbtAnsiString(V.Dta^) := tbtAnsiString(Value); btChar : if Value <> '' then tbtChar(V.Dta^) := tbtChar(tbtstring(Value)[1]); + btAnsiChar : if Value <> '' then tbtAnsiChar(V.Dta^) := tbtAnsiString(Value)[1]; {$IFNDEF PS_NOWIDESTRING} btWideChar : if Value <> '' then tbtWideChar(V.Dta^) := tbtWideChar(Value[1]); btWideString : tbtWideString(V.Dta^) := tbtWideString(Value); @@ -2109,6 +2173,11 @@ procedure StringToPSVariant(const V: TPSVariantIFC; const Value: string); {$ENDIF} // btPChar is not written: the slot holds a raw pointer to memory that // is not owned by the script engine + // btPAnsiChar/btPWideChar slots own their content as a managed string + btPAnsiChar : tbtAnsiString(V.Dta^) := tbtAnsiString(Value); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar : tbtUnicodeString(V.Dta^) := tbtUnicodeString(Value); + {$ENDIF} btVariant : try Variant(V.Dta^) := Value; except @@ -2188,12 +2257,12 @@ procedure TPSTypeRec.CalcSize; begin case BaseType of btVariant: FRealSize := sizeof(Variant); - btChar, bts8, btU8: FrealSize := 1 ; + btChar, bts8, btU8, btAnsiChar: FrealSize := 1 ; {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: FrealSize := 2; {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF} - btclass, btPChar, btString: FrealSize := PointerSize; + btclass, btPChar, btString, btAnsiString, btPAnsiChar {$IFNDEF PS_NOWIDESTRING}, btPWideChar{$ENDIF}: FrealSize := PointerSize; btSingle, bts32, btU32: FRealSize := 4; btProcPtr: FRealSize := 3 * sizeof(Pointer); btCurrency: FrealSize := Sizeof(Currency); @@ -2251,11 +2320,11 @@ procedure InitializeVariant(p: Pointer; aType: TPSTypeRec); i: Longint; begin case aType.BaseType of - btChar, bts8, btU8: tbtu8(p^) := 0; + btChar, bts8, btU8, btAnsiChar: tbtu8(p^) := 0; {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: tbtu16(p^) := 0; btSingle: TbtSingle(P^) := 0; bts32, btU32: TbtU32(P^) := 0; - btPChar, btString, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF}btClass, + btPChar, btString, btAnsiString, btPAnsiChar, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, btPWideChar, {$ENDIF}btClass, btInterface, btArray: Pointer(P^) := nil; btPointer: begin @@ -2302,7 +2371,7 @@ procedure InitializeVariant(p: Pointer; aType: TPSTypeRec); procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); forward; const - NeedFinalization = [btStaticArray, btRecord, btArray, btPointer, btVariant {$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}, btString {$IFNDEF PS_NOWIDESTRING}, btUnicodestring,btWideString{$ENDIF}]; + NeedFinalization = [btStaticArray, btRecord, btArray, btPointer, btVariant {$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}, btString, btAnsiString, btPAnsiChar {$IFNDEF PS_NOWIDESTRING}, btUnicodestring,btWideString, btPWideChar{$ENDIF}]; type TDynArrayRecHeader = packed record @@ -2369,9 +2438,11 @@ procedure FinalizeVariant(p: Pointer; aType: TPSTypeRec); begin case aType.BaseType of btString: tbtString(p^) := ''; + btAnsiString, btPAnsiChar: tbtAnsiString(p^) := ''; {$IFNDEF PS_NOWIDESTRING} btWideString: tbtwidestring(p^) := ''; btUnicodeString: tbtunicodestring(p^) := ''; + btPWideChar: tbtunicodestring(p^) := ''; {$ENDIF} {$IFNDEF PS_NOINTERFACES}btInterface: begin @@ -2459,6 +2530,68 @@ function CreateHeapVariant2(aType: TPSTypeRec): Pointer; InitializeVariant(Result, aType); end; +procedure PSBorrowPCharOwnership(aType: TPSTypeRec; Dta: Pointer; var List: TPSPCharBorrowList); +var + i, n: Longint; +begin + if (aType = nil) or (Dta = nil) then + Exit; + case aType.BaseType of + btPAnsiChar{$IFNDEF PS_NOWIDESTRING}, btPWideChar{$ENDIF}: + begin + n := Length(List); + SetLength(List, n + 1); + List[n].Slot := Dta; + List[n].BaseType := aType.BaseType; + List[n].Holder := Pointer(Dta^); // steal the reference; the slot keeps the raw pointer + end; + btRecord: + for i := 0 to TPSTypeRec_Record(aType).FieldTypes.Count - 1 do + PSBorrowPCharOwnership(TPSTypeRec_Record(aType).FieldTypes[i], + Pointer(IPointer(Dta) + IPointer(TPSTypeRec_Record(aType).RealFieldOffsets[i])), List); + btStaticArray: + for i := 0 to TPSTypeRec_StaticArray(aType).Size - 1 do + PSBorrowPCharOwnership(TPSTypeRec_StaticArray(aType).ArrayType, + Pointer(IPointer(Dta) + IPointer(Cardinal(i) * TPSTypeRec_StaticArray(aType).ArrayType.RealSize)), List); + end; +end; + +procedure PSReownPCharOwnership(var List: TPSPCharBorrowList); +var + i: Longint; + s: Pointer; +begin + for i := 0 to Length(List) - 1 do + with List[i] do + begin + if Pointer(Slot^) = Holder then + // untouched by the callee: the slot silently keeps its reference + Holder := nil + else + begin + // the callee stored a foreign pointer: copy its data into an owned + // string and release the original (still owned via the holder) + s := nil; + case BaseType of + btPAnsiChar: + begin + tbtAnsiString(s) := tbtAnsiString(PAnsiChar(Slot^)); + tbtAnsiString(Holder) := ''; + end; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: + begin + tbtunicodestring(s) := tbtunicodestring(PWideChar(Slot^)); + tbtunicodestring(Holder) := ''; + end; + {$ENDIF} + end; + Pointer(Slot^) := s; // transfer ownership of the copy into the slot + end; + end; + SetLength(List, 0); +end; + procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); begin if v = nil then exit; @@ -2865,7 +2998,22 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; exit; end; end; - bts8, btU8{$IF SizeOf(tbtChar) = 1}, btchar{$IFEND}: if not read(PPSVariantU8(VarP)^.data, SizeOf(tbtu8)) then + btAnsiString: + begin + if not read(NameLen, 4) then + begin + Cmd_Err(erOutOfRange); + Result := False; + exit; + end; + SetLength(PPSVariantAnsiString(varp)^.Data, NameLen); + if (NameLen > 0) and not read(PPSVariantAnsiString(varp)^.Data[1], NameLen) then begin + CMD_Err(erOutOfRange); + Result := False; + exit; + end; + end; + bts8, btU8, btAnsiChar{$IF SizeOf(tbtChar) = 1}, btchar{$IFEND}: if not read(PPSVariantU8(VarP)^.data, SizeOf(tbtu8)) then begin CMD_Err(erOutOfRange); Result := False; @@ -2937,6 +3085,7 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; end; end; {$IFNDEF PS_NOWIDESTRING} + btPWideChar, btWidestring: begin if not read(NameLen, 4) then @@ -3048,8 +3197,9 @@ function TPSExec.LoadData(const s: tbtAnsiString): Boolean; case currf.BaseType of {$IFNDEF PS_NOINT64}bts64, btU64, {$ENDIF} btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btCurrency, - btExtended, btString, btPointer, btPChar, - btVariant, btChar{$IFNDEF PS_NOWIDESTRING}, btUnicodeString, btWideString, btWideChar{$ENDIF}: begin + btExtended, btString, btPointer, + btAnsiChar, btAnsiString, btPAnsiChar, btPChar, + btVariant, btChar{$IFNDEF PS_NOWIDESTRING}, btUnicodeString, btWideString, btWideChar, btPWideChar{$ENDIF}: begin curr := TPSTypeRec.Create(self); Curr.BaseType := currf.BaseType; FTypes.Add(Curr); @@ -3880,6 +4030,7 @@ function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal; btU64: Result := tbtu64(src^); {$ENDIF} btChar: Result := Ord(tbtchar(Src^)); + btAnsiChar: Result := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF} btVariant: case VarType(Variant(Src^)) of @@ -3950,12 +4101,16 @@ function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64; btS64: Result := tbts64(src^); btU64: Result := tbtu64(src^); btChar: Result := Ord(tbtchar(Src^)); + btAnsiChar: Result := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^)); {$ENDIF} {$IFDEF DELPHI6UP} btVariant: Result := Variant(src^); {$ENDIF} + {$IFDEF CPUX64}{$IFNDEF PS_NOWIDESTRING} + btPWideChar: Result := tbtS64(Src^); + {$ENDIF}{$ENDIF CPUX64} else raise Exception.Create(RPS_TypeMismatch); end; end; @@ -3978,6 +4133,7 @@ function PSGetUInt64(Src: Pointer; aType: TPSTypeRec): UInt64; btS64: Result := tbts64(src^); btU64: Result := tbtu64(src^); btChar: Result := Ord(tbtchar(Src^)); + btAnsiChar: Result := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^)); {$ENDIF} @@ -4066,6 +4222,7 @@ function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint; btU64: Result := tbtu64(src^); {$ENDIF} btChar: Result := Ord(tbtchar(Src^)); + btAnsiChar: Result := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := Ord(tbtwidechar(Src^));{$ENDIF} btVariant: Result := Variant(src^); else raise Exception.Create(RPS_TypeMismatch); @@ -4094,7 +4251,13 @@ function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; btU8: Result := tbtchar(tbtu8(src^)); btChar: Result := tbtchar(Src^); btPchar: Result := pansichar(src^); -{$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtString(tbtwidechar(Src^));{$ENDIF} + btAnsiChar: Result := tbtString(tbtAnsiChar(Src^)); + btPAnsiChar: Result := tbtString(tbtAnsiString(PAnsiChar(Src^))); + btAnsiString: Result := tbtString(tbtAnsiString(src^)); +{$IFNDEF PS_NOWIDESTRING} + btWideChar: Result := tbtString(tbtwidechar(Src^)); + btPWideChar: Result := tbtString(WideString(PWideChar(Src^))); +{$ENDIF} btString: Result := tbtstring(src^); {$IFNDEF PS_NOWIDESTRING} btUnicodeString: result := tbtString(tbtUnicodestring(src^)); @@ -4117,6 +4280,10 @@ function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString; btU16: Result := widechar(src^); btChar: Result := tbtwidestring(tbtchar(Src^)); btPchar: Result := tbtwidestring(pansichar(src^)); + btAnsiChar: Result := tbtwidestring(tbtAnsiChar(Src^)); + btPAnsiChar: Result := tbtwidestring(tbtAnsiString(PAnsiChar(Src^))); + btAnsiString: Result := tbtwidestring(tbtAnsiString(Src^)); + btPWideChar: Result := tbtWideString(WideString(PWideChar(Src^))); btWideChar: Result := tbtwidechar(Src^); btString: Result := tbtwidestring(tbtstring(src^)); btWideString: Result := tbtwidestring(src^); @@ -4139,6 +4306,10 @@ function PSGetUnicodeString(Src: Pointer; aType: TPSTypeRec): tbtunicodestring; btU16: Result := widechar(src^); btChar: Result := tbtunicodestring(tbtchar(Src^)); btPchar: Result := tbtunicodestring(pansichar(src^)); + btAnsiChar: Result := tbtunicodestring(tbtAnsiChar(Src^)); + btPAnsiChar: Result := tbtunicodestring(tbtAnsiString(PAnsiChar(Src^))); + btAnsiString: Result := tbtunicodestring(tbtAnsiString(Src^)); + btPWideChar: Result := tbtUnicodeString(WideString(PWideChar(src^))); btWideChar: Result := tbtwidechar(Src^); btString: Result := tbtunicodestring(tbtstring(src^)); btWideString: Result := tbtwidestring(src^); @@ -4176,6 +4347,7 @@ procedure PSSetUInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: btU64: tbtu64(src^) := Val; {$ENDIF} btChar: tbtchar(Src^) := tbtChar(Val); + btAnsiChar: tbtAnsiChar(Src^) := tbtAnsiChar(Val); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF} btSingle: tbtSingle(src^) := Val; btDouble: tbtDouble(src^) := Val; @@ -4213,6 +4385,7 @@ procedure PSSetInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val btS64: tbts64(src^) := Val; btU64: tbtu64(src^) := Val; btChar: tbtchar(Src^) := tbtChar(Val); + btAnsiChar: tbtAnsiChar(Src^) := tbtAnsiChar(Val); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val); {$ENDIF} @@ -4253,6 +4426,7 @@ procedure PSSetUInt64(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Va btS64: tbts64(Src^) := Val; btU64: tbtu64(Src^) := Val; btChar: tbtchar(Src^) := tbtChar(Val); + btAnsiChar: tbtAnsiChar(Src^) := tbtAnsiChar(Val); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val); {$ENDIF} @@ -4355,6 +4529,7 @@ procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: btU64: tbtu64(src^) := Val; {$ENDIF} btChar: tbtchar(Src^) := tbtChar(Val); + btAnsiChar: tbtAnsiChar(Src^) := tbtAnsiChar(Val); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(Src^) := tbtwidechar(Val);{$ENDIF} btSingle: tbtSingle(src^) := Val; btDouble: tbtDouble(src^) := Val; @@ -4385,6 +4560,8 @@ procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; cons case aType.BaseType of btString: tbtstring(src^) := val; btChar: if AnsiString(val) <> '' then tbtchar(src^) := tbtchar(AnsiString(val)[1]); + btAnsiString: tbtAnsiString(src^) := tbtAnsiString(val); + btAnsiChar: if val <> '' then tbtAnsiChar(Src^) := tbtAnsiChar(Val[1]); {$IFNDEF PS_NOWIDESTRING} btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val)); btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val)); @@ -4415,6 +4592,8 @@ procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; cons btChar: if val <> '' then tbtchar(src^) := tbtChar(val[1]); btWideChar: if val <> '' then tbtwidechar(src^) := val[1]; btString: tbtstring(src^) := tbtString(val); + btAnsiString: tbtAnsiString(src^) := tbtAnsiString(val); + btAnsiChar: if val <> '' then tbtAnsiChar(src^) := tbtAnsiChar(val[1]); btWideString: tbtwidestring(src^) := val; btUnicodeString: tbtunicodestring(src^) := val; btVariant: @@ -4442,6 +4621,8 @@ procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; c btChar: if val <> '' then tbtchar(src^) := tbtChar(val[1]); btWideChar: if val <> '' then tbtwidechar(src^) := val[1]; btString: tbtstring(src^) := tbtString(val); + btAnsiString: tbtAnsiString(src^) := tbtAnsiString(val); + btAnsiChar: if val <> '' then tbtAnsiChar(src^) := tbtAnsiChar(val[1]); btWideString: tbtwidestring(src^) := val; btUnicodeString: tbtunicodestring(src^) := val; btVariant: @@ -4526,7 +4707,7 @@ function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): begin try case aType.BaseType of - btU8, btS8, btChar: + btU8, btS8, btChar, btAnsiChar: for i := 0 to Len -1 do begin tbtU8(Dest^) := tbtU8(Src^); @@ -4617,8 +4798,15 @@ function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Dest := Pointer(IPointer(Dest) + PointerSize); Src := Pointer(IPointer(Src) + PointerSize); end; + btAnsiString, btPAnsiChar: + for i := 0 to Len -1 do + begin + tbtAnsiString(Dest^) := tbtAnsiString(Src^); + Dest := Pointer(IPointer(Dest) + PointerSize); + Src := Pointer(IPointer(Src) + PointerSize); + end; {$IFNDEF PS_NOWIDESTRING} - btUnicodeString: + btUnicodeString, btPWideChar: for i := 0 to Len -1 do begin tbtunicodestring(Dest^) := tbtunicodestring(Src^); @@ -5094,10 +5282,12 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR btU64: tbtu32(Dest^) := tbtu64(src^); {$ENDIF} btChar: tbtu32(Dest^) := Ord(tbtchar(Src^)); + btAnsiChar: tbtu32(Dest^) := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtu32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF} btVariant: tbtu32(Dest^) := Variant(src^); {$IFNDEF CPU64} // see below + {$IFNDEF PS_NOWIDESTRING}btPWideChar,{$ENDIF} btClass: tbtu32(Dest^) := tbtu32(src^); {$ENDIF} else raise Exception.Create(RPS_TypeMismatch); @@ -5123,10 +5313,12 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR btU64: tbts32(Dest^) := tbtu64(src^); {$ENDIF} btChar: tbts32(Dest^) := Ord(tbtchar(Src^)); + btAnsiChar: tbts32(Dest^) := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts32(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF} btVariant: tbts32(Dest^) := Variant(src^); {$IFNDEF CPU64} // nx change start - allow assignment of class + {$IFNDEF PS_NOWIDESTRING}btPWideChar,{$ENDIF} btClass: tbts32(Dest^) := tbts32(src^); // nx change end {$ENDIF} @@ -5152,6 +5344,7 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR btS64: tbts64(Dest^) := tbts64(src^); btU64: tbts64(Dest^) := tbtu64(src^); btChar: tbts64(Dest^) := Ord(tbtchar(Src^)); + btAnsiChar: tbts64(Dest^) := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbts64(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF} btVariant: tbts64(Dest^) := Variant(src^); {$IFDEF CPU64} @@ -5179,6 +5372,7 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR btS64: tbtu64(Dest^) := tbts64(src^); btU64: tbtu64(Dest^) := tbtu64(src^); btChar: tbtu64(Dest^) := Ord(tbtchar(Src^)); + btAnsiChar: tbtu64(Dest^) := Ord(tbtAnsiChar(Src^)); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtu64(Dest^) := Ord(tbtwidechar(Src^));{$ENDIF} btVariant: tbtu64(Dest^) := Variant(src^); {$IFDEF CPU64} @@ -5240,6 +5434,10 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR btExtended: tbtdouble(Dest^) := tbtextended(Src^); btCurrency: tbtdouble(Dest^) := tbtcurrency(Src^); btVariant: tbtdouble(Dest^) := Variant(src^); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: + tbtdouble(Dest^) := {$IFDEF CPU64}NativeUInt(Pointer(Src^)){$ELSE}tbtu32(Src^){$ENDIF}; + {$ENDIF} else raise Exception.Create(RPS_TypeMismatch); end; @@ -5268,6 +5466,10 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR btExtended: tbtextended(Dest^) := tbtextended(Src^); btCurrency: tbtextended(Dest^) := tbtcurrency(Src^); btVariant: tbtextended(Dest^) := Variant(src^); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: + tbtextended(Dest^) := {$IFDEF CPU64}NativeUInt(Pointer(Src^)){$ELSE}tbtu32(Src^){$ENDIF}; + {$ENDIF} else raise Exception.Create(RPS_TypeMismatch); end; end; @@ -5276,7 +5478,43 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR btString: tbtstring(dest^) := PSGetAnsiString(Src, srctype); btChar: tbtchar(dest^) := PSGetAnsiChar(Src, srctype); + btAnsiChar: tbtAnsiChar(dest^) := tbtAnsiChar(PSGetAnsiChar(Src, srctype)); + btAnsiString: + begin + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btAnsiString: tbtAnsiString(dest^) := tbtAnsiString(Src^); + btAnsiChar: tbtAnsiString(dest^) := tbtAnsiChar(Src^); + btPAnsiChar: tbtAnsiString(dest^) := tbtAnsiString(PAnsiChar(Src^)); + else tbtAnsiString(dest^) := tbtAnsiString( + {$IFNDEF PS_NOWIDESTRING}PSGetUnicodeString(Src, srctype){$ELSE}PSGetAnsiString(Src, srctype){$ENDIF}); + end; + end; + btPAnsiChar: begin + // the slot owns a managed Ansi string; payload pointer IS the P-Char value + if srctype.BaseType = btPointer then + begin + srctype := PIFTypeRec(Pointer(IPointer(Src)+PointerSize)^); + Src := Pointer(Src^); + if (src = nil) or (srctype = nil) then raise Exception.Create(RPS_TypeMismatch); + end; + case srctype.BaseType of + btAnsiString: tbtAnsiString(Dest^) := tbtAnsiString(Src^); + btAnsiChar: tbtAnsiString(Dest^) := tbtAnsiChar(Src^); + btPAnsiChar: tbtAnsiString(Dest^) := tbtAnsiString(PAnsiChar(Src^)); + else tbtAnsiString(Dest^) := tbtAnsiString( + {$IFNDEF PS_NOWIDESTRING}PSGetUnicodeString(Src, srctype){$ELSE}PSGetAnsiString(Src, srctype){$ENDIF}); + end; + end; {$IFNDEF PS_NOWIDESTRING} + btPWideChar: + // the slot owns a managed string; its payload pointer IS the P-Char value + tbtunicodestring(dest^) := PSGetUnicodeString(Src, srcType); btWideString: tbtwidestring(dest^) := PSGetWideString(Src, srctype); btUnicodeString: tbtUnicodeString(dest^) := PSGetUnicodeString(Src, srctype); btWideChar: tbtwidechar(dest^) := widechar(PSGetUInt(Src, srctype)); @@ -5592,10 +5830,13 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in btU64: b := tbtu64(var1^) >= PSGetUInt64(Var2, var2type); {$ENDIF} btPChar,btString: b := tbtstring(var1^) >= PSGetAnsiString(Var2, var2type); + btAnsiChar: b := tbtAnsiChar(var1^) >= tbtAnsiString(PSGetAnsiString(Var2, var2type)); + btPAnsiChar, btAnsiString: b := tbtAnsiString(var1^) >= tbtAnsiString(PSGetAnsiString(Var2, var2type)); btChar: b := tbtchar(var1^) >= PSGetAnsiString(Var2, var2type); {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbtwidechar(var1^) >= PSGetWideString(Var2, var2type); btWideString: b := tbtwidestring(var1^) >= PSGetWideString(Var2, var2type); + btPWideChar, // slot owns a tbtunicodestring btUnicodeString: b := tbtUnicodestring(var1^) >= PSGetUnicodeString(Var2, var2type); {$ENDIF} btVariant: @@ -5672,10 +5913,13 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in btU64: b := tbtu64(var1^) <= PSGetUInt64(Var2, var2type); {$ENDIF} btPChar,btString: b := tbtstring(var1^) <= PSGetAnsiString(Var2, var2type); + btAnsiChar: b := tbtAnsiChar(var1^) <= tbtAnsiString(PSGetAnsiString(Var2, var2type)); + btPAnsiChar, btAnsiString: b := tbtAnsiString(var1^) <= tbtAnsiString(PSGetAnsiString(Var2, var2type)); btChar: b := tbtchar(var1^) <= PSGetAnsiString(Var2, var2type); {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbtwidechar(var1^) <= PSGetWideString(Var2, var2type); btWideString: b := tbtwidestring(var1^) <= PSGetWideString(Var2, var2type); + btPWideChar, // slot owns a tbtunicodestring btUnicodeString: b := tbtUnicodestring(var1^) <= PSGetUnicodeString(Var2, var2type); {$ENDIF} btVariant: @@ -5752,10 +5996,13 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in btU64: b := tbtu64(var1^) > PSGetUInt64(Var2, var2type); {$ENDIF} btPChar,btString: b := tbtstring(var1^) > PSGetAnsiString(Var2, var2type); + btAnsiChar: b := tbtAnsiChar(var1^) > tbtAnsiString(PSGetAnsiString(Var2, var2type)); + btPAnsiChar, btAnsiString: b := tbtAnsiString(var1^) > tbtAnsiString(PSGetAnsiString(Var2, var2type)); btChar: b := tbtchar(var1^) > PSGetAnsiString(Var2, var2type); {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbtwidechar(var1^) > PSGetWideString(Var2, var2type); btWideString: b := tbtwidestring(var1^) > PSGetWideString(Var2, var2type); + btPWideChar, // slot owns a tbtunicodestring btUnicodeString: b := tbtUnicodestring(var1^) > PSGetUnicodeString(Var2, var2type); {$ENDIF} btVariant: @@ -5825,10 +6072,13 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in btU64: b := tbtu64(var1^) < PSGetUInt64(Var2, var2type); {$ENDIF} btPChar,btString: b := tbtstring(var1^) < PSGetAnsiString(Var2, var2type); + btAnsiChar: b := tbtAnsiChar(var1^) < tbtAnsiString(PSGetAnsiString(Var2, var2type)); + btPAnsiChar, btAnsiString: b := tbtAnsiString(var1^) < tbtAnsiString(PSGetAnsiString(Var2, var2type)); btChar: b := tbtchar(var1^) < PSGetAnsiString(Var2, var2type); {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbtwidechar(var1^) < PSGetWideString(Var2, var2type); btWideString: b := tbtwidestring(var1^) < PSGetWideString(Var2, var2type); + btPWideChar, // slot owns a tbtunicodestring btUnicodeString: b := tbtUnicodestring(var1^) < PSGetUnicodeString(Var2, var2type); {$ENDIF} btVariant: @@ -5919,6 +6169,8 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in btExtended: b := tbtextended(var1^) <> PSGetReal(Var2, var2type); btCurrency: b := tbtcurrency(var1^) <> PSGetCurrency(Var2, var2type); btPChar,btString: b := tbtstring(var1^) <> PSGetAnsiString(Var2, var2type); + btAnsiChar: b := tbtAnsiChar(var1^) <> tbtAnsiString(PSGetAnsiString(Var2, var2type)); + btPAnsiChar, btAnsiString: b := tbtAnsiString(var1^) <> tbtAnsiString(PSGetAnsiString(Var2, var2type)); {$IFNDEF PS_NOINT64} btS64: b := tbts64(var1^) <> PSGetInt64(Var2, var2type); btU64: b := tbtu64(var1^) <> PSGetUInt64(Var2, var2type); @@ -5927,6 +6179,7 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbtwidechar(var1^) <> PSGetWideString(Var2, var2type); btWideString: b := tbtwidestring(var1^) <> PSGetWideString(Var2, var2type); + btPWideChar, // slot owns a tbtunicodestring btUnicodeString: b := tbtUnicodeString(var1^) <> PSGetUnicodeString(Var2, var2type); {$ENDIF} btVariant: @@ -6034,6 +6287,8 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in btExtended: b := tbtextended(var1^) = PSGetReal(Var2, var2type); btCurrency: b := tbtcurrency(var1^) = PSGetCurrency(Var2, var2type); btPchar, btString: b := tbtstring(var1^) = PSGetAnsiString(Var2, var2type); + btAnsiChar: b := tbtAnsiChar(var1^) = tbtAnsiString(PSGetAnsiString(Var2, var2type)); + btPAnsiChar, btAnsiString: b := tbtAnsiString(var1^) = tbtAnsiString(PSGetAnsiString(Var2, var2type)); {$IFNDEF PS_NOINT64} btS64: b := tbts64(var1^) = PSGetInt64(Var2, var2type); btU64: b := tbtu64(var1^) = PSGetUInt64(Var2, var2type); @@ -6042,6 +6297,7 @@ function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, in {$IFNDEF PS_NOWIDESTRING} btWideChar: b := tbtwidechar(var1^) = PSGetWideString(Var2, var2type); btWideString: b := tbtwidestring(var1^) = PSGetWideString(Var2, var2type); + btPWideChar, // slot owns a tbtunicodestring btUnicodeString: b := tbtUnicodestring(var1^) = PSGetUnicodeString(Var2, var2type); {$ENDIF} btVariant: @@ -6369,10 +6625,12 @@ function TPSExec.DoCalc(var1, Var2: Pointer; var1Type, var2type: TPSTypeRec; Cal end; end; btPchar, btString: tbtstring(var1^) := tbtstring(var1^) + PSGetAnsiString(Var2, var2type); + btAnsiString: tbtAnsiString(var1^) := tbtAnsiString(var1^) + tbtAnsiString(PSGetAnsiString(Var2, var2type)); btChar: tbtchar(var1^) := tbtchar(ord(tbtchar(var1^)) + PSGetUInt(Var2, var2type)); {$IFNDEF PS_NOWIDESTRING} btWideChar: tbtwidechar(var1^) := widechar(ord(tbtwidechar(var1^)) + PSGetUInt(Var2, var2type)); btWideString: tbtwidestring(var1^) := tbtwidestring(var1^) + PSGetWideString(Var2, var2type); + btPWideChar, // slot owns a tbtunicodestring btUnicodeString: tbtUnicodestring(var1^) := tbtUnicodestring(var1^) + PSGetUnicodeString(Var2, var2type); {$ENDIF} btVariant: @@ -7405,7 +7663,7 @@ function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boo exit; end; end; - bts8, btU8{$IF SizeOf(tbtChar) = 1}, btchar{$IFEND}: + bts8, btU8, btAnsiChar{$IF SizeOf(tbtChar) = 1}, btchar{$IFEND}: begin if FCurrentPosition >= FDataLength then begin @@ -7595,7 +7853,36 @@ function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boo tbtpchar(dest.p^)[Param] := #0; end; end; + btPAnsiChar, btAnsiString: + begin + if FCurrentPosition + 3 >= FDataLength then + begin + Cmd_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + Param := unaligned(Cardinal((@FData^[FCurrentPosition])^)); + {$else} + Param := Cardinal((@FData^[FCurrentPosition])^); + {$endif} + Inc(FCurrentPosition, 4); + Pointer(Dest.P^) := nil; + SetLength(tbtAnsiString(Dest.P^), Param); + if Param <> 0 then begin + if not ReadData(tbtAnsiString(Dest.P^)[1], Param) then + begin + CMD_Err(erOutOfRange); + FTempVars.Pop; + Result := False; + exit; + end; + PAnsiChar(dest.p^)[Param] := #0; + end; + end; {$IFNDEF PS_NOWIDESTRING} + btPWideChar, btWidestring: begin if FCurrentPosition + 3 >= FDataLength then @@ -10036,6 +10323,9 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then begin Delete(tbtwidestring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3)); + end else if (temp.Dta <> nil) and (temp.aType.BaseType = btAnsiString) then + begin + Delete(tbtAnsiString(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3)); end else {$ENDIF} begin if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then begin @@ -10053,6 +10343,9 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack Insert(Stack.GetUnicodeString(-1), tbtUnicodeString(temp.Dta^), Stack.GetInt(-3)); end else if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then begin Insert(Stack.GetWideString(-1), tbtwidestring(temp.Dta^), Stack.GetInt(-3)); + end else if (temp.Dta <> nil) and (temp.aType.BaseType = btAnsiString) then + begin + Insert(tbtAnsiString(Stack.GetAnsiString(-1)), tbtAnsiString(temp.Dta^), Stack.GetInt(-3)); end else {$ENDIF} begin if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then begin @@ -10092,6 +10385,17 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack end; Stack.SetInt(-1,Ord(tbtUnicodeString(temp.Dta^)[i])); end; + btAnsiString: + begin + I := Stack.GetInt(-3); + if (i<1) or (i>length(tbtAnsiString(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := True; + exit; + end; + Stack.SetInt(-1,Ord(tbtAnsiString(temp.Dta^)[i])); + end; else begin @@ -10131,6 +10435,17 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack end; tbtUnicodeString(temp.Dta^)[i] := WideChar(Stack.GetInt(-1)); end; + btAnsiString: + begin + I := Stack.GetInt(-2); + if (i<1) or (i>length(tbtAnsiString(temp.Dta^))) then + begin + Caller.CMD_Err2(erCustomError, tbtString(RPS_OutOfStringRange)); + Result := True; + exit; + end; + tbtAnsiString(temp.Dta^)[i] := tbtAnsiChar(Stack.GetInt(-1)); + end; else begin @@ -10178,6 +10493,12 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack 14: // SetLength begin temp := NewTPSVariantIFC(Stack[Stack.Count -1], True); + if (temp.Dta <> nil) and (temp.aType.BaseType = btAnsiString) then + begin + SetLength(tbtAnsiString(temp.Dta^), Stack.GetInt(-2)); + Result := True; + exit; + end; if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then begin Result := False; @@ -10243,9 +10564,11 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack btU16, btS16: b := tbtu16(temp.dta^) <> 0; btU32, btS32: b := tbtu32(temp.dta^) <> 0; btString, btPChar: b := tbtstring(temp.dta^) <> ''; + btAnsiString, btPAnsiChar: b := tbtAnsiString(temp.dta^) <> ''; + btAnsiChar: b := tbtAnsiChar(temp.dta^) <> #0; {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtwidestring(temp.dta^)<> ''; - btUnicodeString: b := tbtUnicodeString(temp.dta^)<> ''; + btUnicodeString, btPWideChar: b := tbtUnicodeString(temp.dta^)<> ''; {$ENDIF} btArray, btClass{$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}: b := Pointer(temp.dta^) <> nil; else @@ -10454,7 +10777,12 @@ function Length_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack Stack.SetInt(-1,length(tbtstring(arr.Dta^))); Result:=true; end; - btChar: + btAnsiString: + begin + Stack.SetInt(-1,length(tbtAnsiString(arr.Dta^))); + Result:=true; + end; + btChar, btAnsiChar: begin Stack.SetInt(-1, 1); Result:=true; @@ -10500,6 +10828,11 @@ function SetLength_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSSt begin SetLength(tbtstring(arr.Dta^),STack.GetInt(-2)); Result:=true; + end else + if arr.aType.BaseType=btAnsiString then + begin + SetLength(tbtAnsiString(arr.Dta^),STack.GetInt(-2)); + Result:=true; {$IFNDEF PS_NOWIDESTRING} end else if arr.aType.BaseType=btWideString then @@ -10524,7 +10857,7 @@ function Low_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): case arr.aType.BaseType of btArray : Stack.SetInt(-1,0); btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset); - btString : Stack.SetInt(-1,1); + btString, btAnsiString: Stack.SetInt(-1,1); btU8 : Stack.SetInt(-1,Low(Byte)); //Byte: 0 btS8 : Stack.SetInt(-1,Low(ShortInt)); //ShortInt: -128 btU16 : Stack.SetInt(-1,Low(Word)); //Word: 0 @@ -10549,6 +10882,7 @@ function High_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): btArray : Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType)-1); btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset+TPSTypeRec_StaticArray(arr.aType).Size-1); btString : Stack.SetInt(-1,Length(tbtstring(arr.Dta^))); + btAnsiString : Stack.SetInt(-1,Length(tbtAnsiString(arr.Dta^))); btU8 : Stack.SetInt(-1,High(Byte)); //Byte: 255 btS8 : Stack.SetInt(-1,High(ShortInt)); //ShortInt: 127 btU16 : Stack.SetInt(-1,High(Word)); //Word: 65535 @@ -10756,6 +11090,13 @@ function ToString(p: PansiChar): tbtString; {$IF NOT DEFINED (NEXTGEN) AND NOT DEFINED (MACOS) AND DEFINED (DELPHI_TOKYO_UP)}AnsiStrings.StrLen(p){$ELSE}Length(p){$IFEND}); end; +{$IFNDEF PS_NOWIDESTRING} +function ToWideString(p: PWideChar): tbtWideString; +begin + Result := p; +end; +{$ENDIF} + function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; function BuildArray(P: Pointer; aType: TPSTypeRec; Len: Longint): Boolean; var @@ -10815,6 +11156,9 @@ function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Varia btExtended: Dest := tbtExtended(Src^); btString: Dest := tbtString(Src^); btPChar: Dest := ToString(PansiChar(Src^)); + btAnsiString: Dest := tbtAnsiString(Src^); + btAnsiChar: Dest := tbtAnsiString(tbtAnsiChar(src^)); + btPAnsiChar: Dest := tbtAnsiString(PAnsiChar(Src^)); {$IFNDEF PS_NOINT64} {$IFDEF DELPHI6UP} btS64: Dest := tbts64(Src^); @@ -10825,6 +11169,7 @@ function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Varia {$ENDIF} btChar: Dest := tbtString(tbtchar(src^)); {$IFNDEF PS_NOWIDESTRING} + btPWideChar: Dest := ToWideString(PWideChar(Src^)); btWideString: Dest := tbtWideString(src^); btWideChar: Dest := tbtwidestring(tbtwidechar(src^)); btUnicodeString: Dest := tbtUnicodeString(src^); @@ -10950,6 +11295,10 @@ function CreateOpenArray(VarParam: Boolean; Sender: TPSExec; val: PPSVariantIFC) tvarrec(p^).VExtended^ := tbtdouble(cp^); end; {$IFNDEF PS_NOWIDESTRING} + btPWideChar: begin + TVarRec(p^).VType := vtPWideChar; + TVarRec(p^).VPWideChar := Pointer(cp^); + end; btwidechar: begin tvarrec(p^).VType := vtWideChar; tvarrec(p^).VWideChar := tbtwidechar(cp^); @@ -12031,6 +12380,7 @@ function ClassCallProcProperty(Caller: TPSExec; p: TPSExternalProcRec; Global, S btClass: SetOrdProp(TObject(FSelf), P.Ext1, IPointer(n.Dta^)); {$IFDEF DELPHI6UP} {$IFNDEF PS_NOWIDESTRING} + btPWideChar: SetWideStrProp(TObject(FSelf), P.Ext1, WideString(PWideChar(n.Dta^))); {$IFNDEF DELPHI2009UP}btUnicodeString,{$ENDIF} btWideString: SetWideStrProp(TObject(FSelf), P.Ext1, tbtWidestring(n.dta^)); {$IFDEF DELPHI2009UP} @@ -13181,6 +13531,7 @@ function ResultAsRegister(b: TPSTypeRec): Boolean; {$ENDIF} btPChar, {$IFNDEF PS_NOWIDESTRING} + btPWideChar, btWideChar, {$ENDIF} btChar, @@ -13228,6 +13579,7 @@ function SupportsRegister(b: TPSTypeRec): Boolean; {$ENDIF} btPChar, {$IFNDEF PS_NOWIDESTRING} + btPWideChar, btwidestring, btUnicodeString, btWideChar, From 320221d6d831b3da51a223890aa26baf4b099720 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 14:16:24 +0200 Subject: [PATCH 20/28] PS_NATIVESTRINGS: call marshaling for the Ansi and PWideChar types Marshal the new base types across all Delphi invoke paths: - InvokeCall.inc (Rtti, XE2+): TValue construction for by-value btAnsiChar/btAnsiString/btPAnsiChar/btPWideChar (nil p-char slots pass an empty terminated buffer), open-array element cases, managed result stores (a p-char result is copied into the slot as its managed string type), and var-param ownership handling: PSBorrowPCharOwnership before the call, PSReownPCharOwnership in a try..finally after it, so external code may overwrite the pointer or write through it without corrupting the slot's managed string. - x86.inc / x64.inc (classic paths): same by-value/var/result coverage, borrow/reown around the call, btAnsiString in the string-pointer and hidden-result groups. The x86 GetPtr 'tempstr' buffer is now explicitly TbtAnsiString - it is a raw byte buffer concatenated into the byte-string call stack and must never become wide (identical in OFF mode). btChar by-value reads SizeOf(tbtChar) bytes. EmptyPchar widened to two #0 chars since it also serves as the PWideChar nil replacement. - btPChar keeps its upstream raw-pointer marshaling everywhere. All 8 combos compile (DCC32/DCC64 x default/classic x on/off). Native-mode functional tests pass on all four ON combos: TestWideUp (29 checks: PWideChar/PAnsiChar/AnsiString params + results, stack spills), TestPChar (25 checks: ownership, aliasing, external reassignment, leak delta), TestRec (host record interop with AnsiChar fields and set of AnsiChar). OFF-mode probe suite unchanged-green on 32/64 bit, default and classic paths. Co-Authored-By: Claude Fable 5 --- Source/InvokeCall.inc | 72 +++++++++++++++++++++++++++++++++++- Source/x64.inc | 45 +++++++++++++++++----- Source/x86.inc | 86 +++++++++++++++++++++++++++++++++++-------- 3 files changed, 176 insertions(+), 27 deletions(-) diff --git a/Source/InvokeCall.inc b/Source/InvokeCall.inc index 0f45464c..1b803c3d 100644 --- a/Source/InvokeCall.inc +++ b/Source/InvokeCall.inc @@ -1,5 +1,6 @@ type ptbtChar = ^tbtchar; + ptbtAnsiChar = ^tbtAnsiChar; PtbtPChar = ^tbtPChar; ptbtWideChar = ^tbtwidechar; ptbtString = ^TbtString; @@ -19,12 +20,15 @@ type DataString: TArray>; DataPointer: TArray>; DataPChar: TArray>; + DataPAnsiChar: TArray>; + DataPWideChar: TArray>; DataVariant: TArray>; {$IFNDEF PS_NOINT64} DataS64: TArray>; DataU64: TArray>; {$ENDIF} DataChar: TArray>; + DataAnsiChar: TArray>; {$IFNDEF PS_NOWIDESTRING} DataWideString: TArray>; DataWideChar: TArray>; @@ -67,6 +71,14 @@ begin btExtended: aValues := aValues + [TValue.From(PExtended(aValue^.dta)^)]; //10 btString: aValues := aValues + [TValue.From(pTbtString(aValue^.dta)^)]; + //32 + btAnsiString: aValues := aValues + [TValue.From(PAnsiString(aValue^.dta)^)]; + //31 + btAnsiChar: aValues := aValues + [TValue.From(PAnsiChar(aValue^.dta)^)]; + //33 - nil is passed as pointer to #0, matching the asm paths + btPAnsiChar: if Pointer(aValue^.dta^) = nil + then aValues := aValues + [TValue.From(PAnsiChar(''))] + else aValues := aValues + [TValue.From(PPAnsiChar(aValue^.dta)^)]; //11 btRecord: aValues := aValues + [TValue.From(aValue^.dta)]; //12 @@ -161,6 +173,26 @@ begin aValues := aValues + [TValue.From(@aOpenArrayData^.DataPChar[High(aOpenArrayData^.DataPChar)][0])]; aValues := aValues + [TValue.From(l_high)]; end; + btPAnsiChar: begin + aOpenArrayData^.DataPAnsiChar := aOpenArrayData^.DataPAnsiChar + [[]]; + SetLength(aOpenArrayData^.DataPAnsiChar[High(aOpenArrayData^.DataPAnsiChar)], l_high + 1); + for i := 0 to l_high do begin + elemIFC := PSGetArrayField(aValue^, i); + aOpenArrayData^.DataPAnsiChar[High(aOpenArrayData^.DataPAnsiChar)][i] := PPAnsiChar(elemIFC.Dta)^; + end; + aValues := aValues + [TValue.From(@aOpenArrayData^.DataPAnsiChar[High(aOpenArrayData^.DataPAnsiChar)][0])]; + aValues := aValues + [TValue.From(l_high)]; + end; + btPWideChar: begin + aOpenArrayData^.DataPWideChar := aOpenArrayData^.DataPWideChar + [[]]; + SetLength(aOpenArrayData^.DataPWideChar[High(aOpenArrayData^.DataPWideChar)], l_high + 1); + for i := 0 to l_high do begin + elemIFC := PSGetArrayField(aValue^, i); + aOpenArrayData^.DataPWideChar[High(aOpenArrayData^.DataPWideChar)][i] := PPWideChar(elemIFC.Dta)^; + end; + aValues := aValues + [TValue.From(@aOpenArrayData^.DataPWideChar[High(aOpenArrayData^.DataPWideChar)][0])]; + aValues := aValues + [TValue.From(l_high)]; + end; btVariant, btNotificationVariant: begin //For array of variant we need IntPIFVariantToVariant to get actual Variant values aOpenArrayData^.DataVariant := aOpenArrayData^.DataVariant + [[]]; @@ -207,6 +239,16 @@ begin aValues := aValues + [TValue.From(@aOpenArrayData^.DataChar[High(aOpenArrayData^.DataChar)][0])]; aValues := aValues + [TValue.From(l_high)]; end; + btAnsiChar: begin + aOpenArrayData^.DataAnsiChar := aOpenArrayData^.DataAnsiChar + [[]]; + SetLength(aOpenArrayData^.DataAnsiChar[High(aOpenArrayData^.DataAnsiChar)], l_high + 1); + for i := 0 to l_high do begin + elemIFC := PSGetArrayField(aValue^, i); + aOpenArrayData^.DataAnsiChar[High(aOpenArrayData^.DataAnsiChar)][i] := ptbtAnsiChar(elemIFC.Dta)^; + end; + aValues := aValues + [TValue.From(@aOpenArrayData^.DataAnsiChar[High(aOpenArrayData^.DataAnsiChar)][0])]; + aValues := aValues + [TValue.From(l_high)]; + end; {$IFNDEF PS_NOWIDESTRING} btWideString: begin aOpenArrayData^.DataWideString := aOpenArrayData^.DataWideString + [[]]; @@ -314,6 +356,11 @@ begin btWideString: aValues := aValues + [TValue.From(ptbtWideString(aValue^.dta)^)]; //20 btWideChar: aValues := aValues + [TValue.From(ptbtWideChar(aValue^.dta)^)]; + //30 + // nil is passed as pointer to #0, matching the asm paths (EmptyPchar in x86.inc/x64.inc) + btPWideChar: if Pointer(aValue^.dta^) = nil + then aValues := aValues + [TValue.From(PWideChar(''))] + else aValues := aValues + [TValue.From(pPWideChar(aValue^.dta)^)]; {$ENDIF} //21 btProcPtr: @@ -388,6 +435,7 @@ var SysCalConv : TCallConv; RttiType : TRttiType; ResValue : TValue; ArrTypeInfo: PTypeInfo; + BorrowList: TPSPCharBorrowList; begin Result := False; IsStatic := _Self = nil; @@ -420,11 +468,17 @@ begin if fvar.varparam then begin { var param } case fvar.aType.BaseType of - btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF} + btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, btPWideChar, {$ENDIF} + btAnsiString, btAnsiChar, btPAnsiChar, btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency, btUnicodeString {$IFNDEF PS_NOINT64}, bts64, btU64{$ENDIF}: - Arg := TValue.From( Pointer(fvar.dta) ); + begin + // the callee may overwrite P-Char slots (directly or inside + // records/static arrays); borrow their ownership around the call + PSBorrowPCharOwnership(fvar.aType, fvar.dta, BorrowList); + Arg := TValue.From( Pointer(fvar.dta) ); + end; else begin Exit; @@ -445,6 +499,7 @@ begin {$ENDIF CPUX86} IsConstr := (Integer(CallingConv) and 64) <> 0; + try if not assigned(res) then begin Invoke(Address, Args, SysCalConv, nil); { ignore return } @@ -465,6 +520,9 @@ begin btExtended: PExtended(res.dta)^ := Extended(Invoke(Address,Args,SysCalConv,TypeInfo(Extended),IsStatic).AsExtended); //10 btString: tbtString(res.dta^) := tbtString(Invoke(Address,Args,SysCalConv,TypeInfo(tbtString),IsStatic).AsString); + btAnsiString: AnsiString(res.dta^) := AnsiString(Invoke(Address,Args,SysCalConv,TypeInfo(AnsiString),IsStatic).AsType()); + btAnsiChar: PAnsiChar(res.dta)^ := AnsiChar(Invoke(Address,Args,SysCalConv,TypeInfo(AnsiChar),IsStatic).AsType()); + btPAnsiChar: TbtAnsiString(res.dta^) := TbtAnsiString(PAnsiChar(Invoke(Address,Args,SysCalConv,TypeInfo(PAnsiChar),IsStatic).AsType())); {$IFNDEF FPC} //11 btRecord: @@ -557,6 +615,13 @@ begin {$ELSE} ptbtWideChar(res.dta)^ := tbtWideChar(Invoke(Address,Args,SysCalConv,TypeInfo(tbtWideChar),IsStatic).AsType()); {$ENDIF} + //30 + btPWideChar: + {$IFDEF FPC} + tbtunicodestring(res.dta^) := tbtunicodestring(PWideChar(Invoke(Address,Args,SysCalConv,TypeInfo(PWideChar),IsStatic).AsOrdinal)); + {$ELSE} + tbtunicodestring(res.dta^) := tbtunicodestring(PWideChar(Invoke(Address,Args,SysCalConv,TypeInfo(PWideChar),IsStatic).AsType())); + {$ENDIF} {$ENDIF} //21 btProcPtr: @@ -634,6 +699,9 @@ begin Exit; end; { case } end; //assigned(res) + finally + PSReownPCharOwnership(BorrowList); + end; SetLength(Args, 0); SetLength(old_Args, 0); SetLength(old_Args2, 0); diff --git a/Source/x64.inc b/Source/x64.inc index d06ba115..5a42884f 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -6,7 +6,7 @@ { implementation of x64 abi } //procedure DebugBreak; external 'Kernel32.dll'; const - EmptyPchar: array[0..0] of char = #0; + EmptyPchar: array[0..1] of char = (#0, #0); {$IFDEF FPC} {$ASMMODE INTEL} {$ENDIF} @@ -522,6 +522,7 @@ _XMM0: Double; I: Integer; pp: ^Byte; IsSafeCall: Boolean; + BorrowList: TPSPCharBorrowList; function rp(p: PPSVariantIFC): PPSVariantIFC; begin @@ -731,10 +732,15 @@ _XMM0: Double; btRecord, btInterface, btClass, - {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, + {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, btPWideChar,{$ENDIF} + btAnsiString, btAnsiChar, btPAnsiChar, + btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency {$IFNDEF PS_NOINT64}, bts64, btU64{$ENDIF}: begin + // the callee may overwrite P-Char slots (directly or inside + // records/static arrays); borrow their ownership around the call + PSBorrowPCharOwnership(fvar.aType, fvar.Dta, BorrowList); Varptr := fvar.Dta; end; else begin @@ -834,7 +840,8 @@ _XMM0: Double; btChar, btU8, - btS8: begin + btS8, + btAnsiChar: begin StoreReg(IPointer(byte(fVar^.dta^))); end; {$IFNDEF PS_NOWIDESTRING} btWideChar, {$ENDIF} @@ -851,7 +858,22 @@ _XMM0: Double; else StoreReg(IPointer(fvar^.dta^)); end; - btclass, btinterface, btString: + btPAnsiChar: + begin + if pointer(fvar^.dta^) = nil then + StoreReg(IPointer(@EmptyPchar)) + else + StoreReg(IPointer(fvar^.dta^)); + end; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: begin + if Pointer(fVar^.Dta^) = nil then + StoreReg(IPointer(@EmptyPchar)) + else + StoreReg(IPointer(fVar^.Dta^)); + end; + {$ENDIF} + btclass, btinterface, btString, btAnsiString: begin StoreReg(IPointer(fvar^.dta^)); end; @@ -950,7 +972,7 @@ begin if assigned(res) and not IsSafeCall then begin case res^.aType.BaseType of {$IFDEF x64_string_result_as_varparameter} - btstring, btWideString, btUnicodeString, + btstring, btWideString, btUnicodeString, btAnsiString, {$ENDIF} btInterface, btArray, btVariant{$IFNDEF DELPHI_and_WINDOWS}, btStaticArray{$ENDIF}: GetPtr(res); @@ -972,7 +994,7 @@ begin {$IFNDEF PS_RESBEFOREPARAMETERS} case res^.aType.BaseType of {$IFDEF x64_string_result_as_varparameter} - btstring, btWideString, btUnicodeString, + btstring, btWideString, btUnicodeString, btAnsiString, {$ENDIF} btInterface, btArray, btVariant{$IFNDEF DELPHI_and_WINDOWS}, btStaticArray{$ENDIF}: GetPtr(res); @@ -1023,11 +1045,15 @@ begin btSingle: tbtsingle(res.Dta^) := _XMM0; btDouble: tbtdouble(res.Dta^) := _XMM0; btExtended: tbtextended(res.Dta^) := _XMM0; - btchar,btU8, btS8: tbtu8(res.dta^) := _RAX; + btchar,btU8, btS8, btAnsiChar: tbtu8(res.dta^) := _RAX; {$IFNDEF PS_NOWIDESTRING} btWideChar, {$ENDIF} btu16, bts16: tbtu16(res.dta^) := _RAX; btClass : IPointer(res.dta^) := _RAX; btu32,bts32: tbtu32(res.dta^) := _RAX; btPChar: pansichar(res.dta^) := Pansichar(_RAX); + btPAnsiChar: TbtAnsiString(res.dta^) := TbtAnsiString(PAnsiChar(_RAX)); +{$IFNDEF PS_NOWIDESTRING} + btPWideChar: tbtunicodestring(res.dta^) := tbtunicodestring(PWideChar(_RAX)); +{$ENDIF} {$IFNDEF PS_NOINT64} bts64: tbts64(res.dta^) := Int64(_RAX); btU64: tbtu64(res.dta^) := UInt64(_RAX); @@ -1036,11 +1062,11 @@ begin btInterface, btVariant, {$IFDEF x64_string_result_as_varparameter} - btWidestring,btUnicodestring, btstring , + btWidestring,btUnicodestring, btstring, btAnsiString, {$ENDIF} {$IFNDEF DELPHI_and_WINDOWS}btStaticArray, {$ENDIF}btArray:; {$IFNDEF x64_string_result_as_varparameter} - btUnicodeString, btWideString, btstring: Int64(res.dta^) := _RAX; + btUnicodeString, btWideString, btstring, btAnsiString: Int64(res.dta^) := _RAX; {$ENDIF} else exit; @@ -1064,6 +1090,7 @@ begin end; Result := True; finally + PSReownPCharOwnership(BorrowList); if CallData <> nil then begin for i := CallData.Count -1 downto 0 do begin diff --git a/Source/x86.inc b/Source/x86.inc index 8982d82c..f40dff9e 100644 --- a/Source/x86.inc +++ b/Source/x86.inc @@ -242,7 +242,7 @@ begin end; const - EmptyPchar: array[0..0] of char = #0; + EmptyPchar: array[0..1] of char = (#0, #0); {$IFDEF DELPHI}{$IFDEF MSWINDOWS}{$DEFINE DELPHI_and_MSWINDOWS}{$ENDIF}{$ENDIF} @@ -270,6 +270,7 @@ var {$ENDIF} EAX, EDX, ECX: Longint; + BorrowList: TPSPCharBorrowList; function rp(p: PPSVariantIFC): PPSVariantIFC; begin @@ -313,7 +314,7 @@ var var varPtr: Pointer; UseReg: Boolean; - tempstr: tbtstring; + tempstr: TbtAnsiString; // raw byte buffer: MUST stay Ansi (see Stack) p: Pointer; DataSize: Cardinal; begin @@ -363,10 +364,15 @@ var btRecord, btInterface, btClass, - {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, + {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, btPWideChar, {$ENDIF} + btAnsiString, btAnsiChar, btPAnsiChar, + btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency {$IFNDEF PS_NOINT64}, bts64, btU64{$ENDIF}: begin + // the callee may overwrite P-Char slots (directly or inside + // records/static arrays); borrow their ownership around the call + PSBorrowPCharOwnership(fvar.aType, fvar.Dta, BorrowList); Varptr := fvar.Dta; end; else begin @@ -538,10 +544,18 @@ var TempStr:= StringOfChar(AnsiChar(#0),12); Extended((@TempStr[1])^) := extended(fvar.dta^); end; - btChar, + btChar: begin + TempStr := StringOfChar(AnsiChar(#0),4); + {$if SizeOf(TbtChar) = 2} + Word((@TempStr[1])^) := Word(fVar^.dta^); + {$else} + Byte((@TempStr[1])^) := Byte(fVar^.dta^); + {$ifend} + end; btU8, btS8: begin - TempStr := tbtchar(fVar^.dta^) + tbtstring(StringOfChar(AnsiChar(#0),3)); + TempStr := StringOfChar(AnsiChar(#0),4); + Byte((@TempStr[1])^) := Byte(fVar^.dta^); end; {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF} btu16, btS16: begin @@ -560,7 +574,30 @@ var else Pointer((@TempStr[1])^) := pointer(fvar^.dta^); end; - btclass, btinterface, btString: + btPAnsiChar: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + if pointer(fvar^.dta^) = nil then + Pointer((@TempStr[1])^) := @EmptyPchar + else + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + end; + btAnsiChar: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + Byte((@TempStr[1])^) := Byte(fVar^.dta^); + end; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + if Pointer(fvar^.Dta^) = nil then + Pointer((@TempStr[1])^) := @EmptyPChar + else + Pointer((@TempStr[1])^) := Pointer(fvar^.Dta^); + end; + {$ENDIF !PS_NOWIDESTRING} + btclass, btinterface, btString, btAnsiString: begin TempStr := StringOfChar(AnsiChar(#0),4); Pointer((@TempStr[1])^) := pointer(fvar^.dta^); @@ -679,7 +716,7 @@ begin if assigned(res) then begin case res^.aType.BaseType of {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF} - btInterface, {$IFNDEF FPC} btArray, {$ENDIF}{$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant{$IFNDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: GetPtr(res); + btInterface, {$IFNDEF FPC} btArray, {$ENDIF}{$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btAnsiString, btVariant{$IFNDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: GetPtr(res); btRecord{$IFDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: begin if ResultUsesResultPointer(res) then GetPtr(res); @@ -711,7 +748,7 @@ begin btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); - btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + btchar,btU8, btS8, btAnsiChar: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); btClass : begin @@ -727,6 +764,10 @@ begin btu32,bts32{$IFDEF FPC},btArray{$ENDIF}: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); btPChar: pansichar(res.dta^) := Pansichar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + btPAnsiChar: TbtAnsiString(res.dta^) := TbtAnsiString(PAnsiChar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: tbtunicodestring(res.Dta^) := tbtunicodestring(PWideChar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$ENDIF !PS_NOWIDESTRING} {$IFNDEF PS_NOINT64}bts64, btU64: begin EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); @@ -739,7 +780,7 @@ begin btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000; btInterface, {$IFNDEF PS_NOWIDESTRING}btWidestring,btUnicodestring, {$ENDIF} - btVariant{$IFNDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}{$IFNDEF FPC}, btArray{$ENDIF}{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring{$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + btVariant{$IFNDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}{$IFNDEF FPC}, btArray{$ENDIF}{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring{$ENDIF}, btAnsiString: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); btRecord{$IFDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: begin if not ResultUsesResultPointer(res) then @@ -778,7 +819,7 @@ begin end; if assigned(res) then begin case res^.aType.BaseType of - {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btString, btVariant: GetPtr(res); + {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btString, btAnsiString, btVariant: GetPtr(res); btRecord{$IFDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: begin if ResultUsesResultPointer(res) then GetPtr(res); @@ -806,10 +847,14 @@ begin btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); btCurrency: tbtCurrency(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000; - btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + btChar, btU8, btS8, btAnsiChar: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + btPAnsiChar: TbtAnsiString(res^.dta^) := TbtAnsiString(PAnsiChar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: tbtunicodestring(res^.Dta^) := tbtunicodestring(PWideChar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$ENDIF !PS_NOWIDESTRING} {$IFNDEF PS_NOINT64}bts64, btU64: begin EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); @@ -820,7 +865,7 @@ begin end; {$ENDIF} btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} - btInterface, btArray, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + btInterface, btArray, btstring, btAnsiString: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); btRecord{$IFDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: begin if not ResultUsesResultPointer(res) then @@ -896,10 +941,14 @@ begin btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); btCurrency: tbtCurrency(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000; - btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + btCHar, btU8, btS8, btAnsiChar: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + btPAnsiChar: TbtAnsiString(res^.dta^) := TbtAnsiString(PAnsiChar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: tbtunicodestring(res^.Dta^) := tbtunicodestring(PWideChar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$ENDIF !PS_NOWIDESTRING} {$IFNDEF PS_NOINT64}bts64, btU64: begin EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); @@ -910,7 +959,7 @@ begin end; {$ENDIF} btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} - btInterface, btArray, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; + btInterface, btArray, btstring, btAnsiString: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; btRecord{$IFDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: begin if ResultUsesResultPointer(res) then @@ -967,10 +1016,14 @@ begin btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); btCurrency: tbtCurrency(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000; - btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + btChar, btU8, btS8, btAnsiChar: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + btPAnsiChar: TbtAnsiString(res^.dta^) := TbtAnsiString(PAnsiChar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: tbtunicodestring(res^.Dta^) := tbtunicodestring(PWideChar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil))); + {$ENDIF !PS_NOWIDESTRING} {$IFNDEF PS_NOINT64}bts64, btU64: begin EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); @@ -981,7 +1034,7 @@ begin end; {$ENDIF} btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} - btInterface, btArray, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; + btInterface, btArray, btstring, btAnsiString: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; btRecord{$IFDEF DELPHI_and_MSWINDOWS}, btStaticArray{$ENDIF}: begin if ResultUsesResultPointer(res) then @@ -1025,6 +1078,7 @@ begin end; end; finally + PSReownPCharOwnership(BorrowList); for i := CallData.Count -1 downto 0 do begin pp := CallData[i]; From 8179099f3cbf160f8c8adc6769891f968a636ebd Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 15:04:09 +0200 Subject: [PATCH 21/28] PS_NATIVESTRINGS: width-correct array-of-const marshaling CreateOpenArray tagged btString elements as vtAnsiString unconditionally. With a wide tbtString the callee then reinterpreted UTF-16 payloads as Ansi data, so Format('%s', [...]) received empty/garbled strings (visible with temporaries, e.g. [Trim(s)], on the classic invoke paths; the Rtti path has its own builder). btString now maps to vtUnicodeString when tbtChar is 2 bytes, incl. the matching var-param readback and finalization. Also add the missing element cases for the always-Ansi types: btAnsiString (vtAnsiString, managed), btAnsiChar (vtChar), btPAnsiChar (vtPChar) - previously they fell through the case and arrived as zeroed vtInteger. No change with PS_NATIVESTRINGS undefined. Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index ca37394c..f6c93a69 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -11353,8 +11353,25 @@ function CreateOpenArray(VarParam: Boolean; Sender: TPSExec; val: PPSVariantIFC) end; {$ENDIF} btString: begin + {$if SizeOf(tbtChar) = 2} + tvarrec(p^).VType := vtUnicodeString; + tbtunicodestring(TVarRec(p^).VUnicodeString) := tbtunicodestring(cp^); + {$else} tvarrec(p^).VType := vtAnsiString; tbtString(TVarRec(p^).VAnsiString) := tbtstring(cp^); + {$ifend} + end; + btAnsiString: begin + tvarrec(p^).VType := vtAnsiString; + tbtAnsiString(TVarRec(p^).VAnsiString) := tbtAnsiString(cp^); + end; + btAnsiChar: begin + tvarrec(p^).VType := vtChar; + tvarrec(p^).VChar := AnsiChar(tbtAnsiChar(cp^)); + end; + btPAnsiChar: begin + tvarrec(p^).VType := vtPchar; + TVarRec(p^).VPChar := pointer(cp^); end; btPChar: begin @@ -11485,9 +11502,24 @@ procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray); end; {$ENDIF} btString: begin + {$if SizeOf(tbtChar) = 2} + if v^.VarParam then + tbtstring(cp^) := tbtstring(tbtunicodestring(TVarRec(p^).VUnicodeString)); + finalize(tbtunicodestring(TVarRec(p^).VUnicodeString)); + {$else} if v^.VarParam then tbtstring(cp^) := tbtstring(TVarRec(p^).VString); finalize(tbtString(TVarRec(p^).VAnsiString)); + {$ifend} + end; + btAnsiString: begin + if v^.VarParam then + tbtAnsiString(cp^) := tbtAnsiString(TVarRec(p^).VAnsiString); + finalize(tbtAnsiString(TVarRec(p^).VAnsiString)); + end; + btAnsiChar: begin + if v^.VarParam then + tbtAnsiChar(cp^) := tbtAnsiChar(tvarrec(p^).VChar); end; btClass: begin if v^.VarParam then From 17d010789f458db2556ed631df5508257b07bb01 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 15:04:09 +0200 Subject: [PATCH 22/28] PS_NATIVESTRINGS: DLL import name handling GetProcAddress takes an ANSI name: convert explicitly via PAnsiChar(TbtAnsiString(s3)) instead of casting the tbtstring pointer - under PS_NATIVESTRINGS the raw cast reinterpreted UTF-16 data as an Ansi name (truncating it at the first high byte), and older compilers lack the PWideChar overload the old cast accidentally relied on. uPSC_dll locals follow tbtstring so DLL/function names survive without a wide->ansi->wide roundtrip. Verified with kernel32 calls (lstrlenA/W, lstrcmpW, MulDiv, delayload, UnloadDLL) on DCC32/DCC64, Rtti + classic invoke paths, PS_NATIVESTRINGS on; OFF mode and Delphi 7 unchanged. Co-Authored-By: Claude Fable 5 --- Source/uPSC_dll.pas | 2 +- Source/uPSR_dll.pas | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/Source/uPSC_dll.pas b/Source/uPSC_dll.pas index c03bb33d..df1e4108 100644 --- a/Source/uPSC_dll.pas +++ b/Source/uPSC_dll.pas @@ -49,7 +49,7 @@ function DllExternalProc(Sender: TPSPascalCompiler; Decl: TPSParametersDecl; con var FuncName, Name, - FuncCC, s, s2: AnsiString; + FuncCC, s, s2: tbtstring; // must follow tbtString: no wide->ansi->wide roundtrip for DLL names CC: TDllCallingConvention; DelayLoad, LoadWithAlteredSearchPath: Boolean; diff --git a/Source/uPSR_dll.pas b/Source/uPSR_dll.pas index 04eec992..04e972fc 100644 --- a/Source/uPSR_dll.pas +++ b/Source/uPSR_dll.pas @@ -159,7 +159,10 @@ function LoadDll(Caller: TPSExec; P: TPSExternalProcRec; var ErrorCode: LongInt) dllhandle := ph^.dllhandle; end; until dllhandle <> 0; - p.Ext1 := GetProcAddress(dllhandle, pansichar(s3)); + // GetProcAddress takes an ANSI name; do not pass TbtPChar here: under + // PS_NATIVESTRINGS the raw cast would reinterpret UTF-16 data as an + // Ansi name (and older compilers lack the PWideChar overload) + p.Ext1 := GetProcAddress(dllhandle, PAnsiChar(TbtAnsiString(s3))); if p.Ext1 = nil then begin p.Ext2 := Pointer(1); From 7fd89ec56b50389d9258c977bd2f406e9ad76fe9 Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 15:42:11 +0200 Subject: [PATCH 23/28] PS_NATIVESTRINGS: FPC ARM/AArch64/PowerPC call marshaling (review-based) Bring the FPC-only invoke paths in line with the x86/x64/Rtti paths: - var-param type lists, by-value marshaling and result stores for btAnsiChar/btAnsiString/btPAnsiChar/btPWideChar; managed result copies for the owned p-char types (btPChar keeps its raw upstream semantics) - PSBorrowPCharOwnership before the call / PSReownPCharOwnership after it (arm64: in the existing try..finally; arm/ppc: after the call block) - EmptyPchar as two #0 chars, used as nil replacement for by-value p-char arguments (arm/ppc previously dereferenced nil pointers here) - arm64 by-value btChar and btChar results are SizeOf(tbtChar) wide Also fill marshaling gaps these backends had for existing types: by-value btWideChar/btWideString/btUnicodeString/btCurrency/btVariant/ btClass/btInterface (arm/ppc), btExtended (arm), btWideChar and btCurrency results, ppc btS64/btU64/btCurrency results via rtINT64 (the asm stores r3 high / r4 low - directly readable as a big-endian int64), and hidden-result registration for AnsiString/WideString/ UnicodeString results. These files only compile for FPC ARM/AArch64/PowerPC targets, which are not available here - the port is review-based against a tested implementation of the same model; the known-open items (btArray result semantics on arm/ppc, btSet by-value on arm) are unchanged. Please double-check on a real target before relying on it. Co-Authored-By: Claude Fable 5 --- Source/arm.inc | 67 ++++++++++++++++++++++++++++++++++++++------ Source/arm64.inc | 44 +++++++++++++++++++++++------ Source/powerpc.inc | 69 ++++++++++++++++++++++++++++++++++++++++------ 3 files changed, 154 insertions(+), 26 deletions(-) diff --git a/Source/arm.inc b/Source/arm.inc index 454a74a2..0f14a214 100644 --- a/Source/arm.inc +++ b/Source/arm.inc @@ -37,6 +37,8 @@ const rtINT = 0; rtINT64 = 1; rtFLOAT = 2; + // two #0 so it also serves as an empty PWideChar + EmptyPchar: array[0..1] of char = (#0, #0); type Trint = array[1..4] of dword; @@ -256,6 +258,7 @@ var var tempdw : dword; tempqw : qword; + BorrowList: TPSPCharBorrowList; begin if (Integer(CallingConv) and 64) <> 0 then begin IsConstructor := true; @@ -277,7 +280,8 @@ begin if assigned(res) then begin case res.atype.basetype of - btStaticArray, btRecord,btString: addgen(dword(res.dta)); + btStaticArray, btRecord, btString, btAnsiString + {$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: addgen(dword(res.dta)); end; end; @@ -295,9 +299,16 @@ begin then begin { var param } case fvar.aType.BaseType of { add var params here } - btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} + btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, btPWideChar, {$ENDIF} + btAnsiString, btAnsiChar, btPAnsiChar, btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency - {$IFNDEF PS_NOINT64}, bts64, btU64{$ENDIF}: addgen(dword(fvar.dta)); + {$IFNDEF PS_NOINT64}, bts64, btU64{$ENDIF}: + begin + // the callee may overwrite P-Char slots (directly or inside + // records/static arrays); borrow their ownership around the call + PSBorrowPCharOwnership(fvar.aType, fvar.dta, BorrowList); + addgen(dword(fvar.dta)); + end; else begin writeln(stderr, 'Parameter type not recognised!'); Exit; @@ -312,14 +323,16 @@ begin { add normal params here } btString: addgen(dword(pstring(fvar.dta)^)); btU8, btS8: addgen(dword(pbyte(fvar.dta)^)); - btU16, BtS16: addgen(dword(pword(fvar.dta)^)); + btU16, BtS16 + {$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}: + addgen(dword(pword(fvar.dta)^)); btU32, btS32: addgen(dword(pdword(fvar.dta)^)); btSingle: {$if defined(FPUFPA) or defined(FPC_abi_eabihf)} addfloat(fvar.dta, 1); {$else} addgen(dword(psingle(fvar.dta)^)); {$endif} - btDouble{, btExtended}: {$if defined(FPUFPA) or defined(FPC_abi_eabihf)} + btDouble, btExtended: {$if defined(FPUFPA) or defined(FPC_abi_eabihf)} addfloat(fvar.dta, 2); {$else} begin @@ -331,8 +344,18 @@ begin {$ENDIF} end; {$endif} - btPChar: addgen(dword(ppchar(fvar.dta)^)); + btPChar, btPAnsiChar: if ppointer(fvar.dta)^ = nil + then addgen(dword(@EmptyPchar)) + else addgen(dword(ppointer(fvar.dta)^)); + btAnsiString: addgen(dword(ppointer(fvar.dta)^)); + btAnsiChar: addgen(dword(pbyte(fvar.dta)^)); btChar: addgen(dword(pchar(fvar.dta)^)); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: if ppointer(fvar.dta)^ = nil + then addgen(dword(@EmptyPchar)) + else addgen(dword(ppointer(fvar.dta)^)); + btWideString, btUnicodeString: addgen(dword(ppointer(fvar.dta)^)); + {$ENDIF} {$IFNDEF PS_NOINT64}bts64: begin {$IFDEF FPC_abi_eabi} addgend(qword(pint64(fvar.dta)^)); @@ -349,6 +372,16 @@ begin addgen(dword(puint64(fvar.dta)^ shr 32)); {$ENDIF} end;{$ENDIF} + btCurrency: begin + {$IFDEF FPC_abi_eabi} + addgend(qword(pint64(fvar.dta)^)); + {$ELSE} + addgen(dword(pint64(fvar.dta)^ and $ffffffff)); + addgen(dword(pint64(fvar.dta)^ shr 32)); + {$ENDIF} + end; + btVariant: addgen(dword(fvar.dta)); + btClass, btInterface: addgen(dword(ppointer(fvar.dta)^)); btStaticArray: addgen(dword(fvar.dta)); btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do addgen(pdword(fvar.dta + j*4)^); @@ -371,9 +404,21 @@ begin else begin case res.atype.basetype of { add result types here } - btU8, btS8, btChar: pbyte(res.dta)^ := lo(lo(lo(armasmcall(rint, rfloat, address, st, stindex, rtINT)))); - btU16, btS16: pword(res.dta)^ := lo(lo(armasmcall(rint, rfloat, address, st, stindex, rtINT))); + btU8, btS8, btChar, btAnsiChar: pbyte(res.dta)^ := lo(lo(lo(armasmcall(rint, rfloat, address, st, stindex, rtINT)))); + btU16, btS16{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}: + pword(res.dta)^ := lo(lo(armasmcall(rint, rfloat, address, st, stindex, rtINT))); btU32, btS32,btPChar: pdword(res.dta)^ := lo(armasmcall(rint, rfloat, address, st, stindex, rtINT)); + // the NEW p-char types own their content: copy the returned data + btPAnsiChar: begin + tempdw := lo(armasmcall(rint, rfloat, address, st, stindex, rtINT)); + TbtAnsiString(res.dta^) := TbtAnsiString(PAnsiChar(tempdw)); + end; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: begin + tempdw := lo(armasmcall(rint, rfloat, address, st, stindex, rtINT)); + tbtunicodestring(res.dta^) := tbtunicodestring(PWideChar(tempdw)); + end; + {$ENDIF} {$IFNDEF PS_NOINT64} btS64: pqword(res.dta)^ := armasmcall(rint, rfloat, address, st, stindex,rtINT); btU64: puint64(res.dta)^ := armasmcall(rint, rfloat, address, st, stindex,rtINT); @@ -392,7 +437,9 @@ begin pdword(res.dta)^:=tempdw; end; btDouble:pqword(res.dta)^ := armasmcall(rint, rfloat, address, st, stindex, rtFLOAT); - btStaticArray, btRecord,btString: armasmcall(rint, rfloat, address, st, stindex, rtINT); + btCurrency: pqword(res.dta)^ := armasmcall(rint, rfloat, address, st, stindex, rtINT); + btStaticArray, btRecord, btString, btAnsiString + {$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: armasmcall(rint, rfloat, address, st, stindex, rtINT); else begin writeln(stderr, 'Result type not implemented!'); exit; @@ -400,6 +447,8 @@ begin end; { case } end; + PSReownPCharOwnership(BorrowList); + { cook dynamic arrays - fpc stores size-1 at @array-4 } for i := 0 to Params.Count-1 do begin fvar := Params[i]; diff --git a/Source/arm64.inc b/Source/arm64.inc index dbcde3b3..ef4ccbb6 100644 --- a/Source/arm64.inc +++ b/Source/arm64.inc @@ -32,7 +32,8 @@ type end; const - EmptyPchar: array[0..0] of char = #0; + // two #0 so it also serves as an empty PWideChar + EmptyPchar: array[0..1] of char = (#0, #0); { arm64call performs the final ABI transition in arm64sysv.S: - preserves callee-saved registers @@ -62,6 +63,7 @@ var CallData: TPSList; I: Integer; pp: ^Byte; + BorrowList: TPSPCharBorrowList; {$IFDEF FPC} IsConstructor, IsVirtualCons: Boolean; {$ENDIF} @@ -167,11 +169,17 @@ var VarPtr := fvar.Dta; end; btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, - {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, btWideChar,{$ENDIF} + {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, btWideChar, btPWideChar,{$ENDIF} + btAnsiString, btAnsiChar, btPAnsiChar, btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency {$IFNDEF PS_NOINT64}, btS64, btU64{$ENDIF}: - VarPtr := fvar.Dta; + begin + // the callee may overwrite P-Char slots (directly or inside + // records/static arrays); borrow their ownership around the call + PSBorrowPCharOwnership(fvar.aType, fvar.Dta, BorrowList); + VarPtr := fvar.Dta; + end; else Exit; end; @@ -223,7 +231,13 @@ var StoreIntReg(IPointer(fvar.dta^)); btSingle: StoreFloatReg(Single(fvar.dta^), True); - btChar, btU8, btS8: + btChar: + {$if SizeOf(TbtChar) = 2} + StoreIntReg(IPointer(Word(fVar^.dta^))); + {$else} + StoreIntReg(IPointer(Byte(fVar^.dta^))); + {$ifend} + btU8, btS8, btAnsiChar: StoreIntReg(IPointer(Byte(fVar^.dta^))); {$IFNDEF PS_NOWIDESTRING} btWideChar, @@ -232,12 +246,12 @@ var StoreIntReg(IPointer(Word(FVar^.dta^))); btU32, btS32: StoreIntReg(IPointer(Cardinal(FVar^.dta^))); - btPChar: + btPChar, btPAnsiChar{$IFNDEF PS_NOWIDESTRING}, btPWideChar{$ENDIF}: if Pointer(fvar^.dta^) = nil then StoreIntReg(IPointer(@EmptyPChar)) else StoreIntReg(IPointer(fvar^.dta^)); - btClass, btInterface, btString{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: + btClass, btInterface, btString, btAnsiString{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: StoreIntReg(IPointer(fvar^.dta^)); btProcPtr: begin @@ -316,7 +330,7 @@ begin StoreIntReg(IPointer(res.Dta)); {$ENDIF} end; - btString, {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString,{$ENDIF} + btString, btAnsiString, {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString,{$ENDIF} btInterface, btArray, btVariant, btStaticArray: begin Registers.X8 := IPointer(res.Dta); @@ -363,7 +377,13 @@ begin btSingle: tbtsingle(res.Dta^) := _D0; btDouble: tbtdouble(res.Dta^) := _D0; btExtended: tbtextended(res.Dta^) := _D0; - btChar, btU8, btS8: tbtu8(res.dta^) := _X0; + btChar: + {$if SizeOf(TbtChar) = 2} + tbtu16(res.dta^) := _X0; + {$else} + tbtu8(res.dta^) := _X0; + {$ifend} + btU8, btS8, btAnsiChar: tbtu8(res.dta^) := _X0; {$IFNDEF PS_NOWIDESTRING} btWideChar, {$ENDIF} @@ -371,13 +391,18 @@ begin btClass: IPointer(res.dta^) := _X0; btU32, btS32: tbtu32(res.dta^) := _X0; btPChar: pansichar(res.dta^) := Pansichar(_X0); + // the NEW p-char types own their content: copy the returned data + btPAnsiChar: TbtAnsiString(res.dta^) := TbtAnsiString(PAnsiChar(_X0)); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: tbtunicodestring(res.dta^) := tbtunicodestring(PWideChar(_X0)); + {$ENDIF} {$IFNDEF PS_NOINT64} btS64: tbts64(res.dta^) := Int64(_X0); btU64: tbtu64(res.dta^) := UInt64(_X0); {$ENDIF} btCurrency: tbts64(res.Dta^) := Int64(_X0); btInterface, btVariant, btStaticArray, btArray, - btString{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: ; + btString, btAnsiString{$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: ; else Exit; end; @@ -385,6 +410,7 @@ begin Result := True; finally + PSReownPCharOwnership(BorrowList); for I := CallData.Count - 1 downto 0 do begin pp := CallData[I]; diff --git a/Source/powerpc.inc b/Source/powerpc.inc index 1e54e42b..c79dbed7 100644 --- a/Source/powerpc.inc +++ b/Source/powerpc.inc @@ -15,6 +15,8 @@ const rtINT = 0; rtINT64 = 1; rtFLOAT = 2; + // two #0 so it also serves as an empty PWideChar + EmptyPchar: array[0..1] of char = (#0, #0); type Trint = array[1..8] of dword; @@ -199,6 +201,8 @@ var IsConstructor: Boolean; fSetHelper: dword; fSetP1, fsetP2: PByte; + tempdw: dword; + BorrowList: TPSPCharBorrowList; { add a dword to stack } procedure addstackdword(value: dword); @@ -287,7 +291,8 @@ begin if assigned(res) then begin case res.atype.basetype of - btStaticArray, btRecord, btString: addgen(dword(res.dta)); + btStaticArray, btRecord, btString, btAnsiString + {$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: addgen(dword(res.dta)); end; end; @@ -305,9 +310,16 @@ begin then begin { var param } case fvar.aType.BaseType of { add var params here } - btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF} + btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, btPWideChar, {$ENDIF} + btAnsiString, btAnsiChar, btPAnsiChar, btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency - {$IFNDEF PS_NOINT64}, bts64, btU64{$ENDIF}: addgen(dword(fvar.dta)); { TODO: test all } + {$IFNDEF PS_NOINT64}, bts64, btU64{$ENDIF}: + begin + // the callee may overwrite P-Char slots (directly or inside + // records/static arrays); borrow their ownership around the call + PSBorrowPCharOwnership(fvar.aType, fvar.dta, BorrowList); + addgen(dword(fvar.dta)); { TODO: test all } + end; else begin writeln(stderr, 'Parameter type not recognised!'); Exit; @@ -322,12 +334,24 @@ begin { add normal params here } btString: addgen(dword(pstring(fvar.dta)^)); btU8, btS8: addgen(dword(pbyte(fvar.dta)^)); - btU16, BtS16: addgen(dword(pword(fvar.dta)^)); + btU16, BtS16 + {$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}: + addgen(dword(pword(fvar.dta)^)); btU32, btS32: addgen(dword(pdword(fvar.dta)^)); btSingle: addfloat(fvar.dta, 1); btDouble, btExtended: addfloat(fvar.dta, 2); - btPChar: addgen(dword(ppchar(fvar.dta)^)); + btPChar, btPAnsiChar: if ppointer(fvar.dta)^ = nil + then addgen(dword(@EmptyPchar)) + else addgen(dword(ppointer(fvar.dta)^)); + btAnsiString: addgen(dword(ppointer(fvar.dta)^)); + btAnsiChar: addgen(dword(pbyte(fvar.dta)^)); btChar: addgen(dword(pchar(fvar.dta)^)); + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: if ppointer(fvar.dta)^ = nil + then addgen(dword(@EmptyPchar)) + else addgen(dword(ppointer(fvar.dta)^)); + btWideString, btUnicodeString: addgen(dword(ppointer(fvar.dta)^)); + {$ENDIF} {$IFNDEF PS_NOINT64}bts64: begin addgen(dword(pint64(fvar.dta)^ shr 32)); addgen(dword(pint64(fvar.dta)^ and $ffffffff)); @@ -336,6 +360,12 @@ begin addgen(dword(puint64(fvar.dta)^ shr 32)); addgen(dword(puint64(fvar.dta)^ and $ffffffff)); end;{$ENDIF} + btCurrency: begin + addgen(dword(pint64(fvar.dta)^ shr 32)); + addgen(dword(pint64(fvar.dta)^ and $ffffffff)); + end; + btVariant: addgen(dword(fvar.dta)); + btClass, btInterface: addgen(dword(ppointer(fvar.dta)^)); btStaticArray: addgen(dword(fvar.dta)); btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do addgen(pdword(fvar.dta + j*4)^); @@ -385,14 +415,35 @@ begin else begin case res.atype.basetype of { add result types here } - btString: ppcasmcall(rint, rfloat, address, st, stindex, rtINT); - btU8, btS8: pbyte(res.dta)^ := byte(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); - btU16, btS16: pword(res.dta)^ := word(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btString, btAnsiString + {$IFNDEF PS_NOWIDESTRING}, btWideString, btUnicodeString{$ENDIF}: + ppcasmcall(rint, rfloat, address, st, stindex, rtINT); + btU8, btS8, btAnsiChar: pbyte(res.dta)^ := byte(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + btU16, btS16{$IFNDEF PS_NOWIDESTRING}, btWideChar{$ENDIF}: + pword(res.dta)^ := word(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); btU32, btS32: pdword(res.dta)^ := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^; btSingle: psingle(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^; btDouble, btExtended: pdouble(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^; btPChar: ppchar(res.dta)^ := pchar(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + // the NEW p-char types own their content: copy the returned data + btPAnsiChar: begin + tempdw := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^; + TbtAnsiString(res.dta^) := TbtAnsiString(PAnsiChar(tempdw)); + end; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: begin + tempdw := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^; + tbtunicodestring(res.dta^) := tbtunicodestring(PWideChar(tempdw)); + end; + {$ENDIF} btChar: pchar(res.dta)^ := char(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^); + {$IFNDEF PS_NOINT64} + { ppcasmcall stores r3 (high) at result+0 and r4 (low) at result+4: + on big-endian PPC that is a directly readable int64 } + btS64: pint64(res.dta)^ := pint64(ppcasmcall(rint, rfloat, address, st, stindex, rtINT64))^; + btU64: puint64(res.dta)^ := puint64(ppcasmcall(rint, rfloat, address, st, stindex, rtINT64))^; + {$ENDIF} + btCurrency: pint64(res.dta)^ := pint64(ppcasmcall(rint, rfloat, address, st, stindex, rtINT64))^; btStaticArray, btRecord: ppcasmcall(rint, rfloat, address, st, stindex, rtINT); btArray: res.dta := ppcasmcall(rint, rfloat, address, st, stindex, rtINT); @@ -405,6 +456,8 @@ begin end; { case } end; + PSReownPCharOwnership(BorrowList); + { cook dynamic arrays - fpc stores size-1 at @array-4 } for i := 0 to Params.Count-1 do begin fvar := Params[i]; From cb83f36acc78ae97037ab08d636fc359db661f4d Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 15:50:25 +0200 Subject: [PATCH 24/28] Fix FPC compilation of uPSRuntime Free Pascal 3.2.2 could not compile uPSRuntime.pas: - Inc()/Dec() on a Variant is a Delphi extension; FPC rejects it ('Operator is not overloaded'). Use := Variant +/- 1 instead, which is semantically identical and compiles on both. - ResultAsRegister was recently added to the interface section, but its implementation sits inside the {$else} region of empty_methods_handler. FPC on cpu64/arm/powerpc defines empty_methods_handler, so the whole region - including the implementation - disappeared and the unit failed with 'Forward declaration not solved'. Move the implementation in front of the region; it is plain Pascal with no dependency on the handlers. Repro: fpc 3.2.2 x86_64-linux fails on master with 4 errors + 1 fatal; with this change all uPS* core units compile and a script compile/run smoke test passes on Linux. No change for Delphi (verified DCC32/DCC64). Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 104 ++++++++++++++++++++++-------------------- 1 file changed, 54 insertions(+), 50 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index f6c93a69..8b692351 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -9975,7 +9975,8 @@ function TPSExec.RunScript: Boolean; bts64: dec(tbts64(vd.P^)); btU64: dec(tbtu64(vd.P^)); {$ENDIF} - btVariant: dec(Variant(vd.P^)); + // Inc/Dec on a Variant is Delphi-only; +/- 1 works on FPC too + btVariant: Variant(vd.P^) := Variant(vd.P^) - 1; else begin CMD_Err(ErTypeMismatch); @@ -10008,7 +10009,8 @@ function TPSExec.RunScript: Boolean; bts64: Inc(tbts64(vd.P^)); btU64: Inc(tbtu64(vd.P^)); {$ENDIF} - btVariant: Inc(Variant(vd.P^)); + // Inc/Dec on a Variant is Delphi-only; +/- 1 works on FPC too + btVariant: Variant(vd.P^) := Variant(vd.P^) + 1; else begin CMD_Err(ErTypeMismatch); @@ -13397,6 +13399,56 @@ function ParamAsVariable(const Modifier: tbtchar; aType: TPSTypeRec): Boolean; Result := (Modifier = '%') or (Modifier = '!') or AlwaysAsVariable(aType); end; +{ implementation must stay outside the empty_methods_handler region below: + the interface declares it unconditionally } +function ResultAsRegister(b: TPSTypeRec): Boolean; +begin + case b.BaseType of + btSingle, + btDouble, + btExtended, + btCurrency, + btU8, + bts8, + bts16, + btu16, + bts32, + btu32, +{$IFDEF PS_FPCSTRINGWORKAROUND} + btString, +{$ENDIF} +{$IFNDEF PS_NOINT64} + bts64, + btU64, +{$ENDIF} + btPChar, +{$IFNDEF PS_NOWIDESTRING} + btPWideChar, + btWideChar, +{$ENDIF} + btChar, + btclass, + btEnum: Result := true; +{$IFDEF DELPHI} + { The Delphi x64 ABI returns a record of 1, 2, or 4 bytes in RAX, and + the x86 ABI a record of 1 or 2 bytes in AL/AX (see System.Rtti's + UseResultPointer). Records of these sizes never contain a managed + field, so no managed check is needed. A record of pointer size is + also returned in RAX/EAX, but only when it contains no managed + field. Static arrays follow the same rule: UseResultPointer treats + tkArray like tkRecord. } + btRecord, btStaticArray: Result := (b.RealSize in [1, 2{$IFDEF CPU64}, 4{$ENDIF}]) or + ((b.RealSize = PointerSize) and not IsManagedType(b)); +{$ENDIF} + btSet: Result := b.RealSize <= PointerSize; +{$IFNDEF DELPHI} + btStaticArray: Result := b.RealSize <= PointerSize; +{$ENDIF} + else + Result := false; + end; +end; + {$ifdef fpc} {$if defined(cpupowerpc) or defined(cpuarm) or defined(cpu64)} {$define empty_methods_handler} @@ -13541,54 +13593,6 @@ procedure MyAllMethodsHandler; {$ENDIF} {$endif CPU64} -function ResultAsRegister(b: TPSTypeRec): Boolean; -begin - case b.BaseType of - btSingle, - btDouble, - btExtended, - btCurrency, - btU8, - bts8, - bts16, - btu16, - bts32, - btu32, -{$IFDEF PS_FPCSTRINGWORKAROUND} - btString, -{$ENDIF} -{$IFNDEF PS_NOINT64} - bts64, - btU64, -{$ENDIF} - btPChar, -{$IFNDEF PS_NOWIDESTRING} - btPWideChar, - btWideChar, -{$ENDIF} - btChar, - btclass, - btEnum: Result := true; -{$IFDEF DELPHI} - { The Delphi x64 ABI returns a record of 1, 2, or 4 bytes in RAX, and - the x86 ABI a record of 1 or 2 bytes in AL/AX (see System.Rtti's - UseResultPointer). Records of these sizes never contain a managed - field, so no managed check is needed. A record of pointer size is - also returned in RAX/EAX, but only when it contains no managed - field. Static arrays follow the same rule: UseResultPointer treats - tkArray like tkRecord. } - btRecord, btStaticArray: Result := (b.RealSize in [1, 2{$IFDEF CPU64}, 4{$ENDIF}]) or - ((b.RealSize = PointerSize) and not IsManagedType(b)); -{$ENDIF} - btSet: Result := b.RealSize <= PointerSize; -{$IFNDEF DELPHI} - btStaticArray: Result := b.RealSize <= PointerSize; -{$ENDIF} - else - Result := false; - end; -end; - function SupportsRegister(b: TPSTypeRec): Boolean; begin case b.BaseType of From 0b799fa4f11ea0b2315f8c4759af2fd6b1d41bfe Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 15:54:55 +0200 Subject: [PATCH 25/28] PS_NATIVESTRINGS: FPC-safe Variant-to-string conversions Under PS_NATIVESTRINGS on FPC, tbtString is a distinct string type (type string), and FPC rejects the direct hard cast tbtString(Variant) ('Illegal type conversion'). Convert through the plain string type first; the result is identical on Delphi. With this, all uPS* core units compile with FPC 3.2.2 (x86_64-linux) both without defines and with PS_NATIVESTRINGS, and the script probe suite passes on Linux in both modes. (FPC_UNICODE remains uncompilable - that mode already fails on upstream master with unrelated pre-existing errors.) Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index 8b692351..18338e09 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -1662,9 +1662,9 @@ function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtStr Result := MakeWString(variant(p.dta^)) {$ENDIF} else if TVarData(p.Dta^).VType = varString then - Result := MakeString(tbtstring(variant(p.Dta^))) + Result := MakeString(tbtstring(string(variant(p.Dta^)))) else - Result := tbtstring(Variant(p.Dta^)); + Result := tbtstring(string(Variant(p.Dta^))); except on e: Exception do Result := tbtstring(Format (RPS_Exception, [e.Message])); @@ -2070,7 +2070,7 @@ function PSVariantToString(const V: TPSVariantIFC; AppendType: Boolean; NoQuotes Result := string(MakeWString(Variant(V.Dta^))) {$ENDIF} else if (TVarData(V.Dta^).VType = varString) and not NoQuotes then - Result := string(MakeString(tbtstring(Variant(V.Dta^)))) + Result := string(MakeString(tbtstring(string(Variant(V.Dta^))))) {$if declared(varUString)} else if (TVarData(V.Dta^).VType = varUString) and not NoQuotes then Result := string(MakeWString(Variant(V.Dta^))) @@ -4262,7 +4262,7 @@ function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; {$IFNDEF PS_NOWIDESTRING} btUnicodeString: result := tbtString(tbtUnicodestring(src^)); btWideString: Result := tbtString(tbtwidestring(src^));{$ENDIF} - btVariant: Result := tbtString(Variant(src^)); + btVariant: Result := tbtString(string(Variant(src^))); else raise Exception.Create(RPS_TypeMismatch); end; end; From c76357fe6ac0c4728fb7f99f4c99d54d9e14e27f Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 16:36:30 +0200 Subject: [PATCH 26/28] PS_NATIVESTRINGS: p-char VTypes in Rtti-path array-of-const TValueArrayToArrayOfConst converts a TValue holding a PChar/PWideChar/ PAnsiChar into a plain vtPointer TVarRec, so p-char elements in an array-of-const arrived unusable (Format raised 'invalid or incompatible with argument'). The classic x86/x64 paths were unaffected. Track the element base types while building the TValue array and restore the proper VTypes (vtPChar/vtPWideChar; the data slot is shared, only the tag differs) after conversion. Repro: MyFormat('<%s>', [p]) with p: PChar under PS_NATIVESTRINGS on the Rtti invoke path; now passes on DCC32/DCC64, Rtti and classic, and the OFF-mode array-of-const test stays green. Co-Authored-By: Claude Fable 5 --- Source/InvokeCall.inc | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/Source/InvokeCall.inc b/Source/InvokeCall.inc index 1b803c3d..d168b62a 100644 --- a/Source/InvokeCall.inc +++ b/Source/InvokeCall.inc @@ -53,6 +53,7 @@ var methodValue: TValue; rttiType: TRttiType; elemIFC: TPSVariantIFC; + elemTypes: TArray; begin Result := Assigned(aValue^.aType) and (IPointer(aValue^.aType) > $FFFF); if Result then @@ -314,8 +315,10 @@ begin btPointer: begin //For array of const we need TValueArrayToArrayOfConst to get a TVarRec array SetLength(arr, 0); + SetLength(elemTypes, l_high + 1); for i := 0 to l_high do begin elemIFC := PSGetArrayField(aValue^, i); + elemTypes[i] := elemIFC.aType.BaseType; if not PSVariantIFCToTValue(@elemIFC, arr, aValues1, aValues2, aOpenArrayData, aSelf) then begin Result := False; Exit; @@ -323,6 +326,22 @@ begin end; aValues1 := aValues1 + arr; arr_varrec := TValueArrayToArrayOfConst(arr); + { TValueArrayToArrayOfConst turns p-char TValues into plain + vtPointer entries; consumers like Format need the proper + p-char VTypes (the data slot is shared, only VType differs) } + for i := 0 to High(arr_varrec) do + case elemTypes[i] of + btPChar: + {$if SizeOf(TbtChar) = 2} + arr_varrec[i].VType := vtPWideChar; + {$else} + arr_varrec[i].VType := vtPChar; + {$ifend} + btPAnsiChar: arr_varrec[i].VType := vtPChar; + {$IFNDEF PS_NOWIDESTRING} + btPWideChar: arr_varrec[i].VType := vtPWideChar; + {$ENDIF} + end; aValues2 := aValues2 + arr_varrec; aValues := aValues + [TValue.From(@arr_varrec[0])]; aValues := aValues + [TValue.From(l_high)]; From 5c10a6ffbc584bd84b895f42ab026cf63608ca4e Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 18:31:19 +0200 Subject: [PATCH 27/28] PS_NATIVESTRINGS: btChar values are SizeOf(TbtChar) wide in memory Two 1-byte leftovers clipped wide btChar values to their low byte (the high byte then carried heap garbage): - TPSTypeRec.CalcSize kept btChar in the 1-byte group; RealSize drives record field offsets and every size-based copy. - CopyArrayContents copied btChar elements 1 byte at a time; this is also the copy used when values are boxed for array-of-const elements, so Format('%s', ['x']) received a WideChar with a random high byte. Both now use SizeOf(TbtChar); identical code with PS_NATIVESTRINGS off. Found by the consolidated test suite (single-char literal element probe). Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index 18338e09..43d07a33 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -2257,7 +2257,8 @@ procedure TPSTypeRec.CalcSize; begin case BaseType of btVariant: FRealSize := sizeof(Variant); - btChar, bts8, btU8, btAnsiChar: FrealSize := 1 ; + btChar: FRealSize := SizeOf(TbtChar); + bts8, btU8, btAnsiChar: FrealSize := 1 ; {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}bts16, btU16: FrealSize := 2; {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, @@ -4707,7 +4708,14 @@ function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): begin try case aType.BaseType of - btU8, btS8, btChar, btAnsiChar: + btChar: + for i := 0 to Len -1 do + begin + tbtChar(Dest^) := tbtChar(Src^); + Dest := Pointer(IPointer(Dest) + SizeOf(tbtChar)); + Src := Pointer(IPointer(Src) + SizeOf(tbtChar)); + end; + btU8, btS8, btAnsiChar: for i := 0 to Len -1 do begin tbtU8(Dest^) := tbtU8(Src^); From 1c35f79f3c42a250ea771793273f673b65d29d4b Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 18:48:01 +0200 Subject: [PATCH 28/28] x64: pass by-value dynamic arrays as pointer value on FPC 3+ The classic x64 path passed by-value dynamic array parameters as the ADDRESS of the variable slot on FPC ({$IFDEF FPC} FVar.Dta instead of FVar.Dta^), a leftover from an FPC 2.4-era fix. On FPC 3.x x86_64-linux the callee then reads garbage instead of the array (Length() returns random values, element access crashes with an access violation). A dynamic array IS a pointer on every current target: pass its value, like the Delphi branch always did. The 2.4 behavior is kept behind {$IF FPC_VERSION < 3}. Repro (fails on master with the FPC-compilation fixes applied, passes with this change; fpc 3.2.2 x86_64-linux): host: function DynTake(const A: TArr): Integer; // TArr = array of string script: SetLength(a, 2); a[0] := 'x'; a[1] := 'y'; n := DynTake(a); Delphi Win64 classic path unchanged and re-verified. Co-Authored-By: Claude Fable 5 --- Source/x64.inc | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Source/x64.inc b/Source/x64.inc index 5a42884f..d0fd8cb4 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -766,11 +766,14 @@ _XMM0: Double; Result := True; exit; end else begin - {$IFDEF FPC} + {$IF DEFINED(FPC) AND (FPC_VERSION < 3)} + { kept for the old FPC 2.4 ABI this branch was written for } StoreReg(IPointer(FVar.Dta)); {$ELSE} + { a dynamic array is a pointer: pass its value, not the slot + address (FPC 3.x x86_64 crashed / read garbage here) } StoreReg(IPointer(FVar.Dta^)); - {$ENDIF} + {$IFEND} end; end; btSet,