From e3c8f24d55d873d0c82e68fe85ab23331f0cfcc0 Mon Sep 17 00:00:00 2001 From: carlokok Date: Fri, 19 Jan 2007 14:48:53 +0000 Subject: [PATCH] Changes by Thomas Nitzschke to support Length/SetLength on arrays and low and high. git-svn-id: http://code.remobjects.com/svn/pascalscript@21 5c9d2617-0215-0410-a2ee-e80e04d1c6d8 --- Source/uPSCompiler.pas | 38 +++++++++-- Source/uPSRuntime.pas | 142 ++++++++++++++++++++++++++++++++++++++++- Source/uPSUtils.pas | 4 +- 3 files changed, 175 insertions(+), 9 deletions(-) diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index e8c83e0..d147b68 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -10556,8 +10556,10 @@ var if (x.BaseType = btArray) or (x.basetype = btStaticArray) then begin WriteLong(TPSArrayType(x).ArrayTypeNo.FinalTypeNo); - if (x.baseType = btstaticarray) then + if (x.baseType = btstaticarray) then begin WriteLong(TPSStaticArrayType(x).Length); + WriteLong(TPSStaticArrayType(x).StartOffset); //<-additional StartOffset + end; end else if x.BaseType = btRecord then begin n := TPSRecordType(x).RecValCount; @@ -12062,7 +12064,7 @@ procedure TPSPascalCompiler.DefineStandardProcedures; var p: TPSRegProc; begin - AddFunction('function inttostr(i: Longint): string;'); + AddFunction('function inttostr(i: Int64): string;'); AddFunction('function strtoint(s: string): Longint;'); AddFunction('function strtointdef(s: string; def: Longint): Longint;'); AddFunction('function copy(s: string; ifrom, icount: Longint): string;'); @@ -12094,8 +12096,36 @@ begin AddFunction('Function Uppercase(s : string) : string;'); AddFunction('Function Lowercase(s : string) : string;'); AddFunction('Function Trim(s : string) : string;'); - AddFunction('Function Length(s : String) : Longint;'); - AddFunction('procedure SetLength(var S: String; L: Longint);'); + AddFunction('function Length: Integer;').Decl.AddParam.OrgName:='s'; + with AddFunction('procedure SetLength;').Decl do + begin + with AddParam do + begin + OrgName:='s'; + Mode:=pmInOut; + end; + with AddParam do + begin + OrgName:='NewLength'; + aType:=FindBaseType(btS32); //Integer + end; + end; + AddFunction('function Low: Int64;').Decl.AddParam.OrgName:='x'; + AddFunction('function High: Int64;').Decl.AddParam.OrgName:='x'; + with AddFunction('procedure Dec;').Decl do begin + with AddParam do + begin + OrgName:='x'; + Mode:=pmInOut; + end; + end; + with AddFunction('procedure Inc;').Decl do begin + with AddParam do + begin + OrgName:='x'; + Mode:=pmInOut; + end; + end; AddFunction('Function Sin(e : Extended) : Extended;'); AddFunction('Function Cos(e : Extended) : Extended;'); AddFunction('Function Sqrt(e : Extended) : Extended;'); diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index bf2ade9..f7a89c2 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -191,9 +191,12 @@ type TPSTypeRec_StaticArray = class(TPSTypeRec_Array) private FSize: Longint; + FStartOffset: LongInt; public property Size: Longint read FSize write FSize; + property StartOffset: LongInt read FStartOffset write FStartOffset; + procedure CalcSize; override; end; @@ -2532,6 +2535,15 @@ var exit; end; TPSTypeRec_StaticArray(curr).Size := d; + if not Read(d,4) then //<-additional StartOffset + begin + curr.Free; + cmd_err(erUnexpectedEof); + LoadTypes:=false; + Exit; + end; + TPSTypeRec_StaticArray(curr).StartOffset:=d; + Curr.BaseType := currf.BaseType; FTypes.Add(Curr); end; @@ -8076,7 +8088,7 @@ var Tmp: TObject; begin case Longint(p.Ext1) of - 0: Stack.SetString(-1, IntToStr(Stack.GetInt(-2))); // inttostr + 0: Stack.SetString(-1, IntToStr(Stack.GetInt64(-2))); // inttostr 1: Stack.SetInt(-1, SysUtils.StrToInt(Stack.GetString(-2))); // strtoint 2: Stack.SetInt(-1, StrToIntDef(Stack.GetString(-2), Stack.GetInt(-3))); // strtointdef 3: Stack.SetInt(-1, Pos(Stack.GetString(-2), Stack.GetString(-3)));// pos @@ -8270,6 +8282,124 @@ begin Result := System.Unassigned; end; {$ENDIF} +function Length_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=false; + arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false); + if arr.aType.BaseType=btArray then + begin + Stack.SetInt(-1,PSDynArrayGetLength(Pointer(arr.Dta^),arr.aType)); + Result:=true; + end; + if arr.aType.BaseType=btStaticArray then + begin + Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).Size); + Result:=true; + end; + if arr.aType.BaseType=btString then + begin + Stack.SetInt(-1,length(tbtstring(arr.Dta^))); + Result:=true; + end; +end; + + +function SetLength_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=false; + arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true); + if arr.aType.BaseType=btArray then + begin + PSDynArraySetLength(Pointer(arr.Dta^),arr.aType,Stack.GetInt(-2)); + Result:=true; + end; + if arr.aType.BaseType=btString then + begin + SetLength(tbtstring(arr.Dta^),STack.GetInt(-2)); + Result:=true; + end; +end; + +function Low_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; + t: PIFTypeRec; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false); + case arr.aType.BaseType of + btArray : Stack.SetInt(-1,0); + btStaticArray: Stack.SetInt(-1,TPSTypeRec_StaticArray(arr.aType).StartOffset); + btString : Stack.SetInt64(-1,1); + btU8 : Stack.SetInt64(-1,Low(Byte)); //Byte: 0 + btS8 : Stack.SetInt64(-1,Low(ShortInt)); //ShortInt: -128 + btU16 : Stack.SetInt64(-1,Low(Word)); //Word: 0 + btS16 : Stack.SetInt64(-1,Low(SmallInt)); //SmallInt: -32768 + btU32 : Stack.SetInt64(-1,Low(Cardinal)); //Cardinal/LongWord: 0 + btS32 : Stack.SetInt64(-1,Low(Integer)); //Integer/LongInt: -2147483648 + else Result:=false; + end; +end; + +function High_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; + t: PIFTypeRec; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-2],false); + case arr.aType.BaseType of + 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^))); + btU8 : Stack.SetInt(-1,High(Byte)); //Byte: 255 + btS8 : Stack.SetInt(-1,High(ShortInt)); //ShortInt: 127 + btU16 : Stack.SetInt(-1,High(Word)); //Word: 65535 + btS16 : Stack.SetInt(-1,High(SmallInt)); //SmallInt: 32767 + btU32 : Stack.SetInt(-1,High(Cardinal)); //Cardinal/LongWord: 4294967295 + btS32 : Stack.SetInt(-1,High(Integer)); //Integer/LongInt: 2147483647 + else Result:=false; + end; +end; + +function Dec_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true); + case arr.aType.BaseType of + btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)-1); //Byte + btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)-1); //ShortInt + btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)-1); //Word + btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)-1); //SmallInt + btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)-1); //Cardinal/LongWord + btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)-1); //Integer/LongInt + else Result:=false; + end; +end; + +function Inc_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; +var + arr: TPSVariantIFC; +begin + Result:=true; + arr:=NewTPSVariantIFC(Stack[Stack.Count-1],true); + case arr.aType.BaseType of + btU8 : Stack.SetInt(-1,Tbtu8(arr.dta^)+1); //Byte + btS8 : Stack.SetInt(-1,Tbts8(arr.dta^)+1); //ShortInt + btU16 : Stack.SetInt(-1,Tbtu16(arr.dta^)+1); //Word + btS16 : Stack.SetInt(-1,Tbts16(arr.dta^)+1); //SmallInt + btU32 : Stack.SetInt(-1,Tbtu32(arr.dta^)+1); //Cardinal/LongWord + btS32 : Stack.SetInt(-1,Tbts32(arr.dta^)+1); //Integer/LongInt + else Result:=false; + end; +end; + procedure TPSExec.RegisterStandardProcs; begin @@ -8289,8 +8419,14 @@ begin RegisterFunctionName('UPPERCASE', DefProc, Pointer(10), nil); RegisterFunctionName('LOWERCASE', DefProc, Pointer(11), nil); RegisterFunctionName('TRIM', DefProc, Pointer(12), nil); - RegisterFunctionName('LENGTH', DefProc, Pointer(13), nil); - RegisterFunctionName('SETLENGTH', DefProc, Pointer(14), nil); + + RegisterFunctionName('LENGTH',Length_,nil,nil); + RegisterFunctionName('SETLENGTH',SetLength_,nil,nil); + RegisterFunctionName('LOW',Low_,nil,nil); + RegisterFunctionName('HIGH',High_,nil,nil); + RegisterFunctionName('DEC',Dec_,nil,nil); + RegisterFunctionName('INC',Inc_,nil,nil); + RegisterFunctionName('SIN', DefProc, Pointer(15), nil); RegisterFunctionName('COS', DefProc, Pointer(16), nil); RegisterFunctionName('SQRT', DefProc, Pointer(17), nil); diff --git a/Source/uPSUtils.pas b/Source/uPSUtils.pas index cac044f..b718e1c 100644 --- a/Source/uPSUtils.pas +++ b/Source/uPSUtils.pas @@ -12,9 +12,9 @@ const PSLowBuildSupport = 12; - PSCurrentBuildNo = 22; + PSCurrentBuildNo = 23; - PSCurrentversion = '1.30'; + PSCurrentversion = '1.31'; PSValidHeader = 1397769801;