Delphi/pascalscript
Delphi/pascalscript
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

1) fix of OPENARRAYOFU16 and OPENARRAYOFS16 declarations (#205)

Browse Source 
2) DynArray "out of range" errors extended, now included info about curr index and array length
3) uPSUtils - takilng ansi string length from 0 index - changed to correct Length() calling.
4) added names forming for dynarrays when compiling.
This commit is contained in:
Vizit0r 2019-08-20 08:24:22 +03:00 committed by Carlo Kok
parent 1f846a56c8
commit 51a015cbc5
3 changed files with 51 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
Source/uPSCompiler.pas
View File

@ -2153,8 +2153,8 @@ begin
case VCType.BaseType of
btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of Byte');
btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt');
btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt');
btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word');
btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of Word');
btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of SmallInt');
btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal');
btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of LongInt');
btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single');
@ -4077,8 +4077,19 @@ begin
p := TPSArrayType.Create;
p.BaseType := btArray;
end;
p.Name := FastUppercase(Name);
p.OriginalName := Name;
if Name <> '' then
begin
p.OriginalName := Name;
p.Name := FastUppercase(Name);
end
else
begin
if TypeNo.OriginalName = '' then
p.OriginalName := 'array of ' + TypeNo.Name
else
p.OriginalName := 'array of ' + TypeNo.OriginalName;
p.Name := FastUppercase(p.OriginalName);
end;
{$IFDEF PS_USESSUPPORT}
p.DeclareUnit:=fModule;
{$ENDIF}

32
Source/uPSRuntime.pas
View File

@ -3529,6 +3529,15 @@ begin
end;
end;
function PSGetAnsiChar(Src: Pointer; aType: TPSTypeRec): tbtchar;
var Res : tbtString;
begin
Res := PSGetAnsiString(Src,aType);
if Length(Res) > 0 then
Result := Res[Low(Res)]
else
Exit(#0);
end;
function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString;
begin
@ -4505,7 +4514,7 @@ begin
btPChar: pansichar(dest^) := pansichar(PSGetAnsiString(Src, srctype));
btString:
tbtstring(dest^) := PSGetAnsiString(Src, srctype);
btChar: tbtchar(dest^) := tbtchar(PSGetUInt(Src, srctype));
btChar: tbtchar(dest^) := PSGetAnsiChar(Src, srctype);
{$IFNDEF PS_NOWIDESTRING}
btWideString: tbtwidestring(dest^) := PSGetWideString(Src, srctype);
btUnicodeString: tbtUnicodeString(dest^) := PSGetUnicodeString(Src, srctype);
@ -4567,6 +4576,9 @@ begin
if srctype.BaseType = btClass then
TObject(Dest^) := TObject(Src^)
else
if srctype.BaseType = btVariant then
TbtU32(Dest^) := Variant(Src^)
else
// nx change start
if (srctype.BaseType in [btS32, btU32]) then
TbtU32(Dest^) := TbtU32(Src^)
@ -6764,7 +6776,9 @@ begin
begin
if Param >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
begin
CMD_Err(erOutOfRange);
CMD_Err2(erCustomError,
tbtstring(Format('Out Of Range! Element index is out of Array range: Element Index is %d, Array length = %d',
[Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)),Param])));
Result := False;
exit;
end;
@ -6775,7 +6789,9 @@ begin
begin
if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
begin
CMD_Err(erOutOfRange);
CMD_Err2(erCustomError,
tbtstring(Format('Out Of Range! Element index is out of Array range: Element Index is %d, Array length = %d',
[Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size),Param])));
Result := False;
exit;
end;
@ -6916,7 +6932,9 @@ begin
begin
if Cardinal(Param) >= Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)) then
begin
CMD_Err(erOutOfRange);
CMD_Err2(erCustomError,
tbtstring(Format('Out Of Range! Element index is out of Array range: Element Index is %d, Array length = %d',
[Cardinal(PSDynArrayGetLength(Pointer(Dest.P^), dest.aType)),Param])));
Result := False;
exit;
end;
@ -6927,7 +6945,9 @@ begin
begin
if Param >= Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size) then
begin
CMD_Err(erOutOfRange);
CMD_Err2(erCustomError,
tbtstring(Format('Out Of Range! Element index is out of Array range: Element Index is %d, Array length = %d',
[Cardinal(TPSTypeRec_StaticArray(Dest.aType).Size),Param])));
Result := False;
exit;
end;
@ -10290,7 +10310,7 @@ begin
v := NewPPSVariantIFC(Stack[CurrStack + 1], True);
end else v := nil;
try
Result := Caller.InnerfuseCall(FSelf, p.Ext1, {$IFDEF FPC}TPSCallingConvention(Integer(cc) or 64){$ELSE}cc{$ENDIF}, MyList, v);
Result := Caller.InnerfuseCall(FSelf, p.Ext1, TPSCallingConvention(Integer(cc) or 64), MyList, v);
finally
DisposePPSVariantIFC(v);
DisposePPSVariantIFCList(mylist);

16
Source/uPSUtils.pas
View File

@ -318,10 +318,14 @@ type
{$IFDEF FPC}
IPointer = PtrUInt;
{$ELSE}
{$IFDEF CPUX64}
IPointer = IntPtr;
{$IFDEF VER140UP}
IPointer = NativeInt;
{$ELSE}
{$IFDEF CPU64} IPointer = LongWord;{$ELSE} IPointer = Cardinal;{$ENDIF}{$ENDIF}
{$IFDEF CPUX64}
IPointer = IntPtr;
{$ELSE}
{$IFDEF CPU64} IPointer = LongWord;{$ELSE} IPointer = Cardinal;{$ENDIF}{$ENDIF}
{$ENDIF}
{$ENDIF}
TPSCallingConvention = (cdRegister, cdPascal, cdCdecl, cdStdCall, cdSafeCall);
@ -1152,17 +1156,17 @@ var
function CheckReserved(Const S: ShortString; var CurrTokenId: TPSPasToken): Boolean;
var
L, H, I: LongInt;
J: tbtChar;
J: SmallInt;
SName: ShortString;
begin
L := 0;
J := S[0];
J := Length(S);
H := KEYWORD_COUNT-1;
while L <= H do
begin
I := (L + H) shr 1;
SName := LookupTable[i].Name;
if J = SName[0] then
if J = Length(SName) then
begin
if S = SName then
begin