diff --git a/Source/InvokeCall.inc b/Source/InvokeCall.inc index 5251d075..d168b62a 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>; @@ -49,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 @@ -67,6 +72,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 +174,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 +240,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 + [[]]; @@ -272,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; @@ -281,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)]; @@ -290,8 +351,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)]; @@ -313,6 +375,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: @@ -386,6 +453,8 @@ var SysCalConv : TCallConv; ctx: TRTTIContext; RttiType : TRttiType; ResValue : TValue; + ArrTypeInfo: PTypeInfo; + BorrowList: TPSPCharBorrowList; begin Result := False; IsStatic := _Self = nil; @@ -418,11 +487,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; @@ -443,6 +518,7 @@ begin {$ENDIF CPUX86} IsConstr := (Integer(CallingConv) and 64) <> 0; + try if not assigned(res) then begin Invoke(Address, Args, SysCalConv, nil); { ignore return } @@ -463,6 +539,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: @@ -478,16 +557,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); @@ -529,6 +634,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: @@ -606,6 +718,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/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/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]; 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/uPSCompiler.pas b/Source/uPSCompiler.pas index f13307e2..a13afe37 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 @@ -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; @@ -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; @@ -1168,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; @@ -1761,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; @@ -1773,7 +1795,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 +1809,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'; @@ -1883,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); @@ -1945,7 +1969,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)); @@ -1968,7 +1992,8 @@ 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)); + btAnsiChar: BlockWriteData(BlockInfo, p^.tchar, 1); btSet: begin BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); @@ -1977,7 +2002,13 @@ 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; + 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 @@ -2237,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)); @@ -2477,6 +2516,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; + @@ -2726,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); @@ -2774,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 @@ -2816,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; @@ -2825,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; @@ -2914,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} @@ -2940,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} @@ -2964,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} @@ -2988,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} @@ -3015,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} @@ -3034,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)); @@ -3053,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); @@ -3068,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); @@ -3182,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; @@ -3279,18 +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 (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 (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 @@ -3360,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; @@ -3571,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); @@ -3606,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); @@ -3641,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); @@ -3669,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); @@ -3698,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); @@ -3735,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); @@ -3756,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; @@ -4080,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; @@ -5017,7 +5111,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; @@ -6854,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 @@ -6936,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; @@ -8078,7 +8172,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, btAnsiChar: 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, 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; + + function MakeOrdConst(aType: TPSType; v: Longint): TPSValue; + begin + Result := TPSValueData.Create; + Result.SetParserPos(FParser); + TPSValueData(Result).Data := NewVariant(aType); + case aType.BaseType of + btChar, btAnsiChar: 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 +8249,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 @@ -8332,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 @@ -8583,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 @@ -8794,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 @@ -8827,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 @@ -8849,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; @@ -9146,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} @@ -9172,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} @@ -9198,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} @@ -9224,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} @@ -9250,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} @@ -9276,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} @@ -9303,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} @@ -9327,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} @@ -9349,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} @@ -9379,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); @@ -10214,9 +10407,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 +10425,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 +10459,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); @@ -10971,6 +11175,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 +11982,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; @@ -11942,7 +12253,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); @@ -12001,7 +12312,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)); @@ -12024,7 +12335,8 @@ 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)); + btAnsiChar: WriteData(p^.tchar, 1); btSet: begin WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); @@ -12033,7 +12345,13 @@ 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; + 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 @@ -12069,7 +12387,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 @@ -12142,13 +12460,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 @@ -12171,7 +12489,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; @@ -12207,7 +12525,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; @@ -12235,10 +12553,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 @@ -12249,16 +12567,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 @@ -12281,7 +12599,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 @@ -12299,14 +12617,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); @@ -12332,7 +12650,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} @@ -12593,8 +12911,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; @@ -13041,7 +13365,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 @@ -13081,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); @@ -13130,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]); @@ -13952,6 +14297,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;'); @@ -14137,6 +14484,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; @@ -14653,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); @@ -14780,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); @@ -14825,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; @@ -14841,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 @@ -14855,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 @@ -15252,7 +15878,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; @@ -15678,7 +16304,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 @@ -15802,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/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..15584bb4 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; @@ -184,8 +184,8 @@ function IFPS3DataToText(const Input: tbtstring; var Output: string): Boolean; 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: tbtstring; var Output: string): Boolean; 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: tbtstring; var Output: string): Boolean; 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/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); diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..43d07a33 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; @@ -741,7 +748,7 @@ TPSExec = class(TObject) function RunScript: Boolean; - function LoadData(const s: tbtstring): Boolean; virtual; + function LoadData(const s: tbtAnsiString): Boolean; virtual; procedure Clear; Virtual; @@ -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; @@ -1112,7 +1137,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 +1156,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} @@ -1630,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])); @@ -1661,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^)); @@ -1718,6 +1757,460 @@ 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'; + {$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'; + 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^))); + 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 + 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; + 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)^); + 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(string(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); + 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); + 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 + // 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 + 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; @@ -1764,12 +2257,13 @@ procedure TPSTypeRec.CalcSize; begin case BaseType of btVariant: FRealSize := sizeof(Variant); - btChar, bts8, btU8: 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, {$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); @@ -1827,11 +2321,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 @@ -1878,7 +2372,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 @@ -1945,9 +2439,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 @@ -2035,6 +2531,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; @@ -2369,7 +2927,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; @@ -2406,7 +2964,7 @@ function TPSExec.LoadData(const s: tbtString): 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; @@ -2441,13 +2999,29 @@ function TPSExec.LoadData(const s: tbtString): Boolean; exit; end; end; - bts8, btchar, btU8: 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; 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; @@ -2505,13 +3079,14 @@ function TPSExec.LoadData(const s: tbtString): 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; end; end; {$IFNDEF PS_NOWIDESTRING} + btPWideChar, btWidestring: begin if not read(NameLen, 4) then @@ -2623,8 +3198,9 @@ function TPSExec.LoadData(const s: tbtString): 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); @@ -2640,7 +3216,7 @@ function TPSExec.LoadData(const s: tbtString): 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); @@ -2661,7 +3237,7 @@ function TPSExec.LoadData(const s: tbtString): 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); @@ -2833,7 +3409,7 @@ function TPSExec.LoadData(const s: tbtString): 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; @@ -2878,7 +3454,7 @@ function TPSExec.LoadData(const s: tbtString): 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; @@ -2895,7 +3471,7 @@ function TPSExec.LoadData(const s: tbtString): 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 @@ -2945,7 +3521,7 @@ function TPSExec.LoadData(const s: tbtString): 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; @@ -2964,7 +3540,7 @@ function TPSExec.LoadData(const s: tbtString): 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; @@ -3022,7 +3598,7 @@ function TPSExec.LoadData(const s: tbtString): 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); @@ -3063,16 +3639,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 @@ -3449,6 +4031,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 @@ -3519,12 +4102,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; @@ -3547,6 +4134,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} @@ -3635,6 +4223,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); @@ -3663,12 +4252,18 @@ 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^)); 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; @@ -3686,6 +4281,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^); @@ -3708,6 +4307,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^); @@ -3745,6 +4348,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; @@ -3782,6 +4386,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} @@ -3822,6 +4427,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} @@ -3924,6 +4530,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; @@ -3953,7 +4560,9 @@ 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]); + 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)); @@ -3984,6 +4593,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: @@ -4011,6 +4622,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: @@ -4095,7 +4708,14 @@ function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): begin try case aType.BaseType of - btU8, btS8, btChar: + 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^); @@ -4186,8 +4806,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^); @@ -4516,6 +5143,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; @@ -4579,10 +5290,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); @@ -4608,10 +5321,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} @@ -4637,6 +5352,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} @@ -4664,6 +5380,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} @@ -4725,6 +5442,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; @@ -4753,6 +5474,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; @@ -4761,7 +5486,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)); @@ -4850,7 +5611,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 +5631,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} @@ -5064,10 +5838,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: @@ -5144,10 +5921,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: @@ -5224,10 +6004,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: @@ -5297,10 +6080,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: @@ -5391,6 +6177,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); @@ -5399,6 +6187,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: @@ -5506,6 +6295,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); @@ -5514,6 +6305,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: @@ -5841,10 +6633,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: @@ -6877,7 +7671,7 @@ function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boo exit; end; end; - bts8, btchar, btU8: + bts8, btU8, btAnsiChar{$IF SizeOf(tbtChar) = 1}, btchar{$IFEND}: begin if FCurrentPosition >= FDataLength then begin @@ -6889,7 +7683,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 @@ -7056,17 +7851,46 @@ 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; + 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; + PAnsiChar(dest.p^)[Param] := #0; end; end; {$IFNDEF PS_NOWIDESTRING} + btPWideChar, btWidestring: begin if FCurrentPosition + 3 >= FDataLength then @@ -9159,7 +9983,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); @@ -9192,7 +10017,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); @@ -9507,6 +10333,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 @@ -9524,6 +10353,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 @@ -9563,6 +10395,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 @@ -9602,6 +10445,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 @@ -9649,6 +10503,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; @@ -9714,9 +10574,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 @@ -9752,10 +10614,12 @@ 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 + 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); @@ -9923,7 +10787,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; @@ -9969,6 +10838,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 @@ -9993,7 +10867,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 @@ -10018,6 +10892,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 @@ -10026,7 +10901,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; @@ -10129,6 +11004,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); @@ -10223,6 +11100,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 @@ -10282,6 +11166,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^); @@ -10292,6 +11179,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^); @@ -10390,8 +11278,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 @@ -10412,6 +11305,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^); @@ -10466,8 +11363,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 @@ -10542,7 +11456,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 @@ -10594,9 +11512,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 @@ -11259,7 +12192,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 +12206,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 +12236,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 @@ -11489,6 +12422,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} @@ -12473,6 +13407,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} @@ -12617,53 +13601,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} - 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 @@ -12686,6 +13623,7 @@ function SupportsRegister(b: TPSTypeRec): Boolean; {$ENDIF} btPChar, {$IFNDEF PS_NOWIDESTRING} + btPWideChar, btwidestring, btUnicodeString, btWideChar, @@ -13820,12 +14758,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 +14798,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 +14871,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 diff --git a/Source/uPSUtils.pas b/Source/uPSUtils.pas index f3d3ce30..cee10ffc 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; @@ -590,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; @@ -657,6 +682,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 } @@ -1071,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; @@ -1087,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; @@ -1180,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; @@ -1220,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; @@ -1229,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; @@ -1242,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 @@ -1255,6 +1311,7 @@ procedure TPSPascalParser.Next; Dec(Byte(p^), 32); inc(p); end; + {$ifend} if not CheckReserved(FLastUpToken, CurrTokenId) then begin CurrTokenId := CSTI_Identifier; @@ -1264,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; @@ -1275,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 @@ -1285,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 @@ -1335,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 @@ -1344,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; @@ -1519,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 @@ -1596,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 @@ -1753,6 +1824,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. diff --git a/Source/x64.inc b/Source/x64.inc index d06ba115..d0fd8cb4 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 @@ -760,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, @@ -834,7 +843,8 @@ _XMM0: Double; btChar, btU8, - btS8: begin + btS8, + btAnsiChar: begin StoreReg(IPointer(byte(fVar^.dta^))); end; {$IFNDEF PS_NOWIDESTRING} btWideChar, {$ENDIF} @@ -851,7 +861,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 +975,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 +997,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 +1048,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 +1065,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 +1093,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];