From 4db2ccf52a4ab7339be832f61afa40cd5fdf614e Mon Sep 17 00:00:00 2001 From: Raymond Date: Wed, 7 Apr 2010 21:43:34 +0200 Subject: [PATCH] Updated PS.. --- Units/PascalScript/PascalScriptFPC.inc | 1 + Units/PascalScript/eDefines.inc | 51 +++++++++++++++++++++++++- Units/PascalScript/uPSCompiler.pas | 20 ++++++---- Units/PascalScript/uPSComponent.pas | 5 ++- Units/PascalScript/uPSR_dll.pas | 2 +- Units/PascalScript/uPSRuntime.pas | 46 +++++++++++++++-------- 6 files changed, 99 insertions(+), 26 deletions(-) diff --git a/Units/PascalScript/PascalScriptFPC.inc b/Units/PascalScript/PascalScriptFPC.inc index f73780a..7857ae9 100644 --- a/Units/PascalScript/PascalScriptFPC.inc +++ b/Units/PascalScript/PascalScriptFPC.inc @@ -9,6 +9,7 @@ {$UNDEF PS_FPCSTRINGWORKAROUND} {$DEFINE PS_RESBEFOREPARAMETERS} {$DEFINE x64_string_result_as_varparameter} + {$DEFINE PS_RESULTFIRST} {FreePascal 2.3.1 and above has much Delphi compatibility bugs fixed} {$else} {$DEFINE FPC_OLD_FIX} diff --git a/Units/PascalScript/eDefines.inc b/Units/PascalScript/eDefines.inc index 2f2e25f..80dcdde 100644 --- a/Units/PascalScript/eDefines.inc +++ b/Units/PascalScript/eDefines.inc @@ -407,9 +407,48 @@ {$DEFINE 32BIT} {$DEFINE CPU32} {$ENDIF} - {$ENDIF MSWINDOWS} +{ defines for Delphi 2011 } +{$IFDEF VER220} + {$DEFINE VER140UP} + {$DEFINE DELPHI} + + {$DEFINE DELPHI15} + {$DEFINE DELPHI1UP} + {$DEFINE DELPHI2UP} + {$DEFINE DELPHI3UP} + {$DEFINE DELPHI4UP} + {$DEFINE DELPHI5UP} + {$DEFINE DELPHI6UP} + {$DEFINE DELPHI7UP} + {$DEFINE DELPHI9UP} + {$DEFINE DELPHI10UP} + {$DEFINE DELPHI11UP} + {$DEFINE DELPHI12UP} + {$DEFINE DELPHI14UP} + {$DEFINE DELPHI15UP} + + {$DEFINE DELPHI2011} + {$DEFINE DELPHI2005UP} + {$DEFINE DELPHI2006UP} + {$DEFINE DELPHI2007UP} + {$DEFINE DELPHI2009UP} + {$DEFINE DELPHI2010UP} + {$DEFINE DELPHI2011UP} + {$DEFINE BDS} + {$DEFINE BDS8} + {$DEFINE BDS3UP} + {$DEFINE BDS4UP} + {$DEFINE BDS5UP} + {$DEFINE BDS6UP} + {$DEFINE BDS7UP} + {$DEFINE BDS8UP} + {$DEFINE 32BIT} + {$DEFINE CPU32} +{$ENDIF} + + { defines for "Delphi for .NET" } {$IFDEF CLR} {$DEFINE DOTNET} @@ -490,4 +529,14 @@ {$DEFINE DARWIN64} {$ENDIF} {$ENDIF} +{$ELSE} + {$DEFINE ENDIAN_LITTLE} // To have endianness symbol defined in Delphi too +{$ENDIF} + +{$IFDEF DELPHI} + {$DEFINE DELPHI_or_MSWINDOWS} +{$ENDIF} + +{$IFDEF MSWINDOWS} + {$DEFINE DELPHI_or_MSWINDOWS} {$ENDIF} \ No newline at end of file diff --git a/Units/PascalScript/uPSCompiler.pas b/Units/PascalScript/uPSCompiler.pas index bf47630..36cb3d4 100644 --- a/Units/PascalScript/uPSCompiler.pas +++ b/Units/PascalScript/uPSCompiler.pas @@ -2654,9 +2654,10 @@ begin end; procedure FinalizeA(var s: tbtString); overload; begin s := ''; end; +{$IFNDEF PS_NOWIDESTRING} procedure FinalizeW(var s: tbtwidestring); overload; begin s := ''; end; procedure FinalizeU(var s: tbtunicodestring); overload; begin s := ''; end; - +{$ENDIF} procedure FinalizeVariant(var p: TIfRVariant); begin if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then @@ -5187,15 +5188,19 @@ begin begin Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val); if PType <> nil then - if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString, btWideString, btUnicodeString, btChar, btWideChar]) then begin + if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString, + {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, btWideChar,{$ENDIF} + btChar]) then begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; if Params[c].ExpectedType.BaseType = btChar then Params[c].ExpectedType := FindBaseType(btString) else +{$IFNDEF PS_NOWIDESTRING} if Params[c].ExpectedType.BaseType = btWideChar then Params[c].ExpectedType := FindBaseType(btUnicodeString); +{$ENDIF} end else if (PType.BaseType = btArray) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray) then begin if TPSArrayType(GetTypeNo(BlockInfo, Params[c].Val)).ArrayTypeNo <> TPSArrayType(PType).ArrayTypeNo then @@ -5366,7 +5371,7 @@ function TPSPascalCompiler.ReadString: PIfRVariant; temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI6UP}System.{$IFDEF DELPHI2009UP}UTF8ToWidestring{$ELSE}UTF8Decode{$ENDIF}{$ENDIF}{$ENDIF}(PString(FParser.GetToken)); {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF} end else - temp3 := temp3 + tbtUnicodestring(PString(FParser.GetToken)); + temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}tbtUnicodestring{$ENDIF}(PString(FParser.GetToken)); FParser.Next; if FParser.CurrTokenId = CSTI_String then @@ -5562,7 +5567,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; Temp.ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result; if (Temp.ResultType <> nil) and (Temp.ResultType = FAnyString) then begin // workaround to make the result type match for i := 0 to Par.Count -1 do begin - if Par[i].ExpectedType.BaseType in [btString, btWideString] then + if Par[i].ExpectedType.BaseType in [btString{$IFNDEF PS_NOWIDESTRING}, btWideString{$ENDIF}] then Temp.ResultType := Par[i].ExpectedType; end; end; @@ -11172,7 +11177,8 @@ var TPSProcedure(FProcs[I]).Free; FProcs.Free; FProcs := nil; - for I := 0 to FTypes.Count - 1 do + //reverse free types: a custom type's attribute value type may point to a base type + for I := FTypes.Count - 1 downto 0 do begin PT := FTypes[I]; pt.Free; @@ -13919,9 +13925,9 @@ begin begin case FValue.FType.BaseType of btChar: FValue.tchar := (Val+#0)[1]; - btWideChar: FValue.twidechar := WideChar((Val+#0)[1]); btString: tbtString(FValue.tstring) := val; {$IFNDEF PS_NOWIDESTRING} + btWideChar: FValue.twidechar := WideChar((Val+#0)[1]); btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val); btUnicodeString: tbtunicodestring(FValue.tunistring) := tbtunicodestring(val); {$ENDIF} @@ -14840,7 +14846,7 @@ begin GetPropInfos(fclass.ClassInfo, p); for i := Count -1 downto 0 do begin - if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod{$IFNDEF PS_NOWIDESTRING}, tkWString{$ENDIF}] then + if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod{$IFNDEF PS_NOWIDESTRING}, tkWString{$ENDIF}{$IFDEF DELPHI2009UP}, tkUString{$ENDIF}] then begin if (p^[i]^.GetProc <> nil) then begin diff --git a/Units/PascalScript/uPSComponent.pas b/Units/PascalScript/uPSComponent.pas index 44cfb54..f302c29 100644 --- a/Units/PascalScript/uPSComponent.pas +++ b/Units/PascalScript/uPSComponent.pas @@ -64,7 +64,7 @@ type TIFPS3CEPluginItem = class(TPSPluginItem); - + TPSPlugins = class(TCollection) private FCompExec: TPSScript; @@ -310,7 +310,7 @@ type public property FileName: tbtstring read FFileName write SetFileName; - + property FileNameHash: Longint read FFileNameHash; property Line: Longint read FLine write FLine; @@ -1006,6 +1006,7 @@ begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (aComponent is TPSPlugin) then begin + if Plugins <> nil then for i := Plugins.Count -1 downto 0 do begin if (Plugins.Items[i] as TPSPluginItem).Plugin = aComponent then diff --git a/Units/PascalScript/uPSR_dll.pas b/Units/PascalScript/uPSR_dll.pas index e2c9d3d..f3453e6 100644 --- a/Units/PascalScript/uPSR_dll.pas +++ b/Units/PascalScript/uPSR_dll.pas @@ -15,7 +15,7 @@ function UnloadProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSSt implementation uses {$IFDEF UNIX} - LCLIntf, Unix, baseunix, dynlibs, termio, sockets; + Unix, baseunix, dynlibs, termio, sockets; {$ELSE} Windows; {$ENDIF} diff --git a/Units/PascalScript/uPSRuntime.pas b/Units/PascalScript/uPSRuntime.pas index 53f9c7b..49d96a6 100644 --- a/Units/PascalScript/uPSRuntime.pas +++ b/Units/PascalScript/uPSRuntime.pas @@ -1537,7 +1537,11 @@ begin tkVariant: begin Result := '[Variant]'; exit; end; {$IFDEF DELPHI6UP} {$IFNDEF PS_NOWIDESTRING} - tkWString: begin Result := ''''+tbtString(GetWideStrProp(Instance, pp))+''; end; {$ENDIF} + tkWString: begin Result := ''''+tbtString(GetWideStrProp(Instance, pp))+''; end; + {$IFDEF DELPHI2009UP} + tkUString: begin Result := ''''+tbtUnicodeString(GetUnicodeStrProp(Instance, pp))+''; end; + {$ENDIF} + {$ENDIF} {$ENDIF} else begin Result := '[Unknown]'; exit; end; end; @@ -1599,9 +1603,9 @@ begin btS16: str(tbts16(p.dta^), Result); btU32: str(tbtu32(p.dta^), Result); btS32: str(tbts32(p.dta^), Result); - btSingle: result := floattostr(tbtsingle(p.dta^)); - btDouble: result := floattostr(tbtdouble(p.dta^)); - btExtended: result := floattostr(tbtextended(p.dta^)); + btSingle: str(tbtsingle(p.dta^), Result); + btDouble: str(tbtdouble(p.dta^), Result); + btExtended: str(tbtextended(p.dta^), Result); btString: Result := makestring(tbtString(p.dta^)); btPChar: begin @@ -1975,7 +1979,7 @@ end; class function TPSExec.About: tbtString; begin - Result := 'RemObjects Pascal Script. Copyright (c) 2004-2009 by RemObjects Software'; + Result := 'RemObjects Pascal Script. Copyright (c) 2004-2010 by RemObjects Software'; end; procedure TPSExec.Cleanup; @@ -8674,24 +8678,26 @@ begin 1: Stack.SetInt(-1, StrToInt(Stack.GetAnsiString(-2))); // strtoint 2: Stack.SetInt(-1, StrToIntDef(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // strtointdef 3: +{$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetInt(-1, Pos(Stack.GetUnicodeString(-2), Stack.GetUnicodeString(-3)))// pos else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then Stack.SetInt(-1, Pos(Stack.GetWideString(-2), Stack.GetWideString(-3)))// pos - else + else{$ENDIF} Stack.SetInt(-1, Pos(Stack.GetAnsiString(-2), Stack.GetAnsiString(-3)));// pos 4: - if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then +{$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then Stack.SetWideString(-1, Copy(Stack.GetWideString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetUnicodeString(-1, Copy(Stack.GetUnicodeString(-2), Stack.GetInt(-3), Stack.GetInt(-4))) // copy - else + else{$ENDIF} Stack.SetAnsiString(-1, Copy(Stack.GetAnsiString(-2), Stack.GetInt(-3), Stack.GetInt(-4))); // copy 5: //delete begin temp := NewTPSVariantIFC(Stack[Stack.Count -1], True); +{$IFNDEF PS_NOWIDESTRING} if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then begin Delete(tbtUnicodeString(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3)); @@ -8699,7 +8705,7 @@ begin if (temp.Dta <> nil) and (temp.aType.BaseType = btWideString) then begin Delete(tbtwidestring(temp.Dta^), Stack.GetInt(-2), Stack.GetInt(-3)); - end else begin + end else {$ENDIF} begin if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then begin Result := False; @@ -8711,11 +8717,12 @@ begin 6: // insert begin temp := NewTPSVariantIFC(Stack[Stack.Count -2], True); +{$IFNDEF PS_NOWIDESTRING} if (temp.Dta <> nil) and (temp.aType.BaseType = btUnicodeString) then begin 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 begin + end else {$ENDIF} begin if (temp.Dta = nil) or (temp.aType.BaseType <> btString) then begin Result := False; @@ -8759,6 +8766,7 @@ begin tbtstring(temp.Dta^)[i] := tbtchar(Stack.GetInt(-1)); end; 10: +{$IFNDEF PS_NOWIDESTRING} {$IFDEF DELPHI2009UP} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetUnicodeString(-1, UpperCase(Stack.GetUnicodeString(-2))) // Uppercase @@ -8768,8 +8776,10 @@ begin (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then Stack.SetWideString(-1, WideUpperCase(Stack.GetWideString(-2))) // Uppercase else +{$ENDIF} Stack.SetAnsiString(-1, FastUppercase(Stack.GetAnsiString(-2))); // Uppercase 11: +{$IFNDEF PS_NOWIDESTRING} {$IFDEF DELPHI2009UP} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetUnicodeString(-1, LowerCase(Stack.GetUnicodeString(-2))) // Uppercase @@ -8779,14 +8789,17 @@ begin (Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString) then Stack.SetWideString(-1, WideLowerCase(Stack.GetWideString(-2))) // Uppercase else +{$ENDIF} Stack.SetAnsiString(-1, FastLowercase(Stack.GetAnsiString(-2)));// LowerCase 12: +{$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetUnicodeString(-1, SysUtils.Trim(Stack.GetUnicodestring(-2))) // Uppercase else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then Stack.SetWideString(-1, SysUtils.Trim(Stack.GetWideString(-2))) // Uppercase else - Stack.SetAnsiString(-1, Trim(Stack.GetAnsiString(-2)));// Trim +{$ENDIF} + Stack.SetAnsiString(-1, SysUtils.Trim(Stack.GetAnsiString(-2)));// Trim 13: Stack.SetInt(-1, Length(Stack.GetAnsiString(-2))); // Length 14: // SetLength begin @@ -8809,28 +8822,31 @@ begin 23: Stack.SetReal(-1, StrToFloat(Stack.GetAnsiString(-2))); // StrToFloat 24: Stack.SetAnsiString(-1, FloatToStr(Stack.GetReal(-2)));// FloatToStr 25: +{$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetUnicodeString(-1, upadL(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadL else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then Stack.SetWideString(-1, wPadL(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadL - else + else{$ENDIF} Stack.SetAnsiString(-1, PadL(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadL 26: +{$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetUnicodeString(-1, uPadR(Stack.GetUnicodeString(-2), Stack.GetInt(-3))) // PadR else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then Stack.SetWideString(-1, wPadR(Stack.GetWideString(-2), Stack.GetInt(-3))) // PadR - else + else{$ENDIF} Stack.SetAnsiString(-1, PadR(Stack.GetAnsiString(-2), Stack.GetInt(-3))); // PadR 27: +{$IFNDEF PS_NOWIDESTRING} if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btUnicodeString then Stack.SetUnicodeString(-1, uPadZ(Stack.GetUnicodeString(-2), Stack.GetInt(-3)))// PadZ else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then Stack.SetWideString(-1, wPadZ(Stack.GetWideString(-2), Stack.GetInt(-3)))// PadZ - else + else{$ENDIF} Stack.SetAnsiString(-1, PadZ(Stack.GetAnsiString(-2), Stack.GetInt(-3)));// PadZ 28: Stack.SetAnsiString(-1, StringOfChar(tbtChar(Stack.GetInt(-2)), Stack.GetInt(-3))); // Replicate/StrOfChar 29: // Assigned @@ -12105,6 +12121,7 @@ begin Result := PSGetUInt(@PPSVariantData(val).Data, val.FType); end; +{$IFNDEF PS_NOWIDESTRING} function TPSStack.GetUnicodeString(ItemNo: Integer): tbtunicodestring; var val: PPSVariant; @@ -12116,7 +12133,6 @@ begin Result := PSGetUnicodeString(@PPSVariantData(val).Data, val.FType); end; -{$IFNDEF PS_NOWIDESTRING} function TPSStack.GetWideString(ItemNo: Longint): tbtWideString; var val: PPSVariant;