1
0
mirror of https://github.com/moparisthebest/Simba synced 2025-02-18 00:00:23 -05:00

Fixed the FloatToStr bug. + Updated the PascalScript st00f.

git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@559 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2010-02-26 18:25:42 +00:00
parent 4bd62c7237
commit 6c58941bc5
6 changed files with 125 additions and 51 deletions

View File

@ -1401,6 +1401,7 @@ end;
procedure TForm1.FormCreate(Sender: TObject); procedure TForm1.FormCreate(Sender: TObject);
begin begin
Randomize; Randomize;
DecimalSeparator := '.';
MainDir:= ExtractFileDir(Application.ExeName); MainDir:= ExtractFileDir(Application.ExeName);
SimbaSettingsFile := MainDir + DS + 'settings.xml'; SimbaSettingsFile := MainDir + DS + 'settings.xml';
if FileExists(SimbaSettingsFile) then if FileExists(SimbaSettingsFile) then

View File

@ -215,6 +215,9 @@ end;
function MakeString(data : TPSVariantIFC) : string; function MakeString(data : TPSVariantIFC) : string;
begin; begin;
if data.Dta = nil then
result := 'Nil'
else
if data.aType.basetype in [btString,btChar] then if data.aType.basetype in [btString,btChar] then
result := PSGetAnsiString(Data.Dta,data.aType) result := PSGetAnsiString(Data.Dta,data.aType)
else if data.aType.ExportName = 'BOOLEAN' then else if data.aType.ExportName = 'BOOLEAN' then

View File

@ -2269,8 +2269,7 @@ begin
else else
begin begin
if (TPSExternalProcedure(x).RegProc.NameHash = h) and if (TPSExternalProcedure(x).RegProc.NameHash = h) and
(TPSExternalProcedure(x).RegProc.Name = Name) {$IFDEF PS_USESSUPPORT} and (TPSExternalProcedure(x).RegProc.Name = Name)then
(IsInLocalUnitList(TPSInternalProcedure(x).DeclareUnit)){$ENDIF} then
begin begin
Result := l; Result := l;
exit; exit;
@ -6474,10 +6473,12 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
while True do while True do
begin begin
if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF} if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF}
{$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btVariant) or (u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit; {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit;
if FParser.CurrTokenId = CSTI_OpenBlock then if FParser.CurrTokenId = CSTI_OpenBlock then
begin begin
if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF} then if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or
(u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF}
{$IFDEF PS_HAVEVARIANT}or (u.BaseType = btVariant){$ENDIF} then
begin begin
FParser.Next; FParser.Next;
tmp := Calc(CSTI_CloseBlock); tmp := Calc(CSTI_CloseBlock);
@ -6505,12 +6506,15 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
x := nil; x := nil;
exit; exit;
end; end;
{$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
l := FindProc('VARARRAYSET') else
{$ENDIF}
{$IFNDEF PS_NOWIDESTRING} {$IFNDEF PS_NOWIDESTRING}
if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
l := FindProc('WSTRSET') l := FindProc('WSTRSET')
else else
{$ENDIF} {$ENDIF}
l := FindProc('STRSET'); l := FindProc('STRSET');
if l = -1 then if l = -1 then
begin begin
MakeError('', ecUnknownIdentifier, 'StrSet'); MakeError('', ecUnknownIdentifier, 'StrSet');
@ -6552,22 +6556,31 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
x := nil; x := nil;
exit; exit;
end; end;
if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar) {$IFDEF PS_HAVEVARIANT}if (u.BaseType <> btVariant) then {$ENDIF}
{$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then
begin begin
x.Free; if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar)
x := nil; {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then
Tmp.Free; begin
MakeError('', ecTypeMismatch, ''); x.Free;
exit; x := nil;
Tmp.Free;
MakeError('', ecTypeMismatch, '');
exit;
end;
end; end;
param.Val := tmp; param.Val := tmp;
{$IFDEF PS_HAVEVARIANT}
if u.BaseType = btVariant then
Param.ExpectedType := u else{$ENDIF}
Param.ExpectedType := GetTypeNo(BlockInfo, tmp); Param.ExpectedType := GetTypeNo(BlockInfo, tmp);
{$IFDEF DEBUG} {$IFDEF DEBUG}
if not Param.ExpectedType.Used then asm int 3; end; if not Param.ExpectedType.Used then asm int 3; end;
{$ENDIF} {$ENDIF}
end else begin end else begin
{$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
l := FindProc('VARARRAYGET') else
{$ENDIF}
{$IFNDEF PS_NOWIDESTRING} {$IFNDEF PS_NOWIDESTRING}
if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
l := FindProc('WSTRGET') l := FindProc('WSTRGET')
@ -6583,12 +6596,15 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
exit; exit;
end; end;
tmp3 := TPSValueProcNo.Create; tmp3 := TPSValueProcNo.Create;
{$IFDEF PS_HAVEVARIANT}if (u.BaseType = btVariant) then
tmp3.ResultType := FindBaseType(btVariant) else
{$ENDIF}
{$IFNDEF PS_NOWIDESTRING} {$IFNDEF PS_NOWIDESTRING}
if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then
tmp3.ResultType := FindBaseType(btWideChar) tmp3.ResultType := FindBaseType(btWideChar)
else else
{$ENDIF} {$ENDIF}
tmp3.ResultType := FindBaseType(btChar); tmp3.ResultType := FindBaseType(btChar);
tmp3.ProcNo := L; tmp3.ProcNo := L;
tmp3.SetParserPos(FParser); tmp3.SetParserPos(FParser);
tmp3.Parameters := TPSParameters.Create; tmp3.Parameters := TPSParameters.Create;
@ -6681,7 +6697,9 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
exit; exit;
end; end;
end end
else if (FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod) then else if ((FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod))
{$IFDEF PS_HAVEVARIANT}and not (u.BaseType = btVariant){$ENDIF}
then
begin begin
if not ImplicitPeriod then if not ImplicitPeriod then
FParser.Next; FParser.Next;
@ -6747,7 +6765,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
u := rr.aType; u := rr.aType;
end; end;
end end
else {$IFDEF PS_HAVEVARIANT}else if (u.BaseType = btVariant) then break else {$ENDIF}
begin begin
x.Free; x.Free;
MakeError('', ecSemicolonExpected, ''); MakeError('', ecSemicolonExpected, '');
@ -7054,10 +7073,10 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
if FType = nil then exit; if FType = nil then exit;
if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit; if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit;
CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock)and CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock) and
(Ftype.BaseType = BtVariant); (Ftype.BaseType = BtVariant);
while (FParser.CurrTokenID = CSTI_Period) while (FParser.CurrTokenID = CSTI_Period)
or (ImplicitPeriod)or (CheckArrayProperty) do begin or (ImplicitPeriod) do begin
HasArrayProperty:=CheckArrayProperty; HasArrayProperty:=CheckArrayProperty;
if CheckArrayProperty then begin if CheckArrayProperty then begin
@ -12961,6 +12980,8 @@ begin
AddFunction('Function WStrGet(var S : AnyString; I : Integer) : WideChar;'); AddFunction('Function WStrGet(var S : AnyString; I : Integer) : WideChar;');
AddFunction('procedure WStrSet(c : AnyString; I : Integer; var s : AnyString);'); AddFunction('procedure WStrSet(c : AnyString; I : Integer; var s : AnyString);');
{$ENDIF} {$ENDIF}
AddDelphiFunction('Function VarArrayGet(var S : Variant; I : Integer) : Variant;');
AddDelphiFunction('procedure VarArraySet(c : Variant; I : Integer; var s : Variant);');
AddFunction('Function AnsiUppercase(s : String) : String;'); AddFunction('Function AnsiUppercase(s : String) : String;');
AddFunction('Function AnsiLowercase(s : String) : String;'); AddFunction('Function AnsiLowercase(s : String) : String;');
AddFunction('Function Uppercase(s : AnyString) : AnyString;'); AddFunction('Function Uppercase(s : AnyString) : AnyString;');

View File

@ -188,7 +188,7 @@ begin
end else n := nil; end else n := nil;
try try
TMYExec(Caller).InnerfuseCall(nil, p.Ext1, cc, MyList, n); TMYExec(Caller).InnerfuseCall(nil, p.Ext1, cc, MyList, n);
{$IFNDEF LINUX} {$IFNDEF UNIX}
DLLSetLastError(Caller, GetLastError); DLLSetLastError(Caller, GetLastError);
{$ENDIF} {$ENDIF}
finally finally

View File

@ -1,5 +1,4 @@
unit uPSRuntime; unit uPSRuntime;
{$I PascalScript.inc} {$I PascalScript.inc}
{ {
@ -1600,9 +1599,9 @@ begin
btS16: str(tbts16(p.dta^), Result); btS16: str(tbts16(p.dta^), Result);
btU32: str(tbtu32(p.dta^), Result); btU32: str(tbtu32(p.dta^), Result);
btS32: str(tbts32(p.dta^), Result); btS32: str(tbts32(p.dta^), Result);
btSingle: str(tbtsingle(p.dta^), Result); btSingle: result := floattostr(tbtsingle(p.dta^));
btDouble: str(tbtdouble(p.dta^), Result); btDouble: result := floattostr(tbtdouble(p.dta^));
btExtended: str(tbtextended(p.dta^), Result); btExtended: result := floattostr(tbtextended(p.dta^));
btString: Result := makestring(tbtString(p.dta^)); btString: Result := makestring(tbtString(p.dta^));
btPChar: btPChar:
begin begin
@ -3725,6 +3724,7 @@ begin
end; end;
end; end;
procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString); procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString);
begin begin
if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
@ -3736,9 +3736,12 @@ begin
end; end;
case aType.BaseType of case aType.BaseType of
btString: tbtstring(src^) := val; btString: tbtstring(src^) := val;
btChar: if AnsiString(val) <> '' then tbtchar(src^) := AnsiString(val)[1];
{$IFNDEF PS_NOWIDESTRING} {$IFNDEF PS_NOWIDESTRING}
btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val)); btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val));
btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val));{$ENDIF} btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val));
btWideChar: if AnsiString(val) <> '' then tbtwidechar(src^) := tbtwidechar(AnsiString(val)[1]);
{$ENDIF}
btVariant: btVariant:
begin begin
try try
@ -3761,6 +3764,8 @@ begin
if (src = nil) or (aType = nil) then begin Ok := false; exit; end; if (src = nil) or (aType = nil) then begin Ok := false; exit; end;
end; end;
case aType.BaseType of case aType.BaseType of
btChar: if val <> '' then tbtchar(src^) := tbtChar(val[1]);
btWideChar: if val <> '' then tbtwidechar(src^) := val[1];
btString: tbtstring(src^) := tbtString(val); btString: tbtstring(src^) := tbtString(val);
btWideString: tbtwidestring(src^) := val; btWideString: tbtwidestring(src^) := val;
btUnicodeString: tbtunicodestring(src^) := val; btUnicodeString: tbtunicodestring(src^) := val;
@ -3775,6 +3780,7 @@ begin
else ok := false; else ok := false;
end; end;
end; end;
procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring); procedure PSSetUnicodeString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtunicodestring);
begin begin
if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; if (Src = nil) or (aType = nil) then begin Ok := false; exit; end;
@ -4564,19 +4570,19 @@ begin
if Tmp is EDivByZero then if Tmp is EDivByZero then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EZeroDivide then if Tmp is EZeroDivide then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EMathError then if Tmp is EMathError then
begin begin
Result := False; Result := False;
CMD_Err3(erMathError, '', Tmp); CMD_Err3(erMathError, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
end; end;
@ -5255,19 +5261,19 @@ begin
if Tmp is EDivByZero then if Tmp is EDivByZero then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EZeroDivide then if Tmp is EZeroDivide then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EMathError then if Tmp is EMathError then
begin begin
Result := False; Result := False;
CMD_Err3(erMathError, '', Tmp); CMD_Err3(erMathError, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
end; end;
@ -6273,19 +6279,19 @@ begin
if Tmp is EDivByZero then if Tmp is EDivByZero then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EZeroDivide then if Tmp is EZeroDivide then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EMathError then if Tmp is EMathError then
begin begin
Result := False; Result := False;
CMD_Err3(erMathError, '', Tmp); CMD_Err3(erMathError, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
end; end;
@ -6548,13 +6554,13 @@ begin
Pointer(Dest.P^) := nil; Pointer(Dest.P^) := nil;
SetLength(tbtstring(Dest.P^), Param); SetLength(tbtstring(Dest.P^), Param);
if Param <> 0 then begin if Param <> 0 then begin
if not ReadData(tbtstring(Dest.P^)[1], Param) then if not ReadData(tbtstring(Dest.P^)[1], Param) then
begin begin
CMD_Err(erOutOfRange); CMD_Err(erOutOfRange);
FTempVars.Pop; FTempVars.Pop;
Result := False; Result := False;
exit; exit;
end; end;
pansichar(dest.p^)[Param] := #0; pansichar(dest.p^)[Param] := #0;
end; end;
end; end;
@ -7171,19 +7177,19 @@ begin
if Tmp is EDivByZero then if Tmp is EDivByZero then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EZeroDivide then if Tmp is EZeroDivide then
begin begin
Result := False; Result := False;
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
if Tmp is EMathError then if Tmp is EMathError then
begin begin
Result := False; Result := False;
CMD_Err3(erMathError, '', Tmp); CMD_Err3(erMathError, Exception(Tmp).Message, Tmp);
Exit; Exit;
end; end;
end; end;
@ -7820,17 +7826,17 @@ begin
end else end else
if Tmp is EDivByZero then if Tmp is EDivByZero then
begin begin
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Break; Break;
end; end;
if Tmp is EZeroDivide then if Tmp is EZeroDivide then
begin begin
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
Break; Break;
end; end;
if Tmp is EMathError then if Tmp is EMathError then
begin begin
CMD_Err3(erMathError, '', Tmp); CMD_Err3(erMathError, Exception(Tmp).Message, Tmp);
Break; Break;
end; end;
end; end;
@ -8506,17 +8512,17 @@ begin
end else end else
if Tmp is EDivByZero then if Tmp is EDivByZero then
begin begin
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
break; break;
end; end;
if Tmp is EZeroDivide then if Tmp is EZeroDivide then
begin begin
CMD_Err3(erDivideByZero, '', Tmp); CMD_Err3(erDivideByZero, Exception(Tmp).Message, Tmp);
break; break;
end; end;
if Tmp is EMathError then if Tmp is EMathError then
begin begin
CMD_Err3(erMathError, '', Tmp); CMD_Err3(erMathError, Exception(Tmp).Message, Tmp);
break; break;
end; end;
end; end;
@ -9170,6 +9176,16 @@ begin
end; end;
end; end;
function _VarArrayGet(var S : Variant; I : Integer) : Variant;
begin
result := VarArrayGet(S, [I]);
end;
procedure _VarArraySet(const c : Variant; I : Integer; var s : Variant);
begin
VarArrayPut(s, c, [i]);
end;
procedure TPSExec.RegisterStandardProcs; procedure TPSExec.RegisterStandardProcs;
begin begin
@ -9247,6 +9263,8 @@ begin
RegisterFunctionName('WSTRGET', DefProc, Pointer(42), nil); RegisterFunctionName('WSTRGET', DefProc, Pointer(42), nil);
RegisterFunctionName('WSTRSET', DefProc, Pointer(43), nil); RegisterFunctionName('WSTRSET', DefProc, Pointer(43), nil);
{$ENDIF} {$ENDIF}
RegisterDelphiFunction(@_VarArrayGet, 'VARARRAYGET', cdRegister);
RegisterDelphiFunction(@_VarArraySet, 'VARARRAYSET', cdRegister);
RegisterInterfaceLibraryRuntime(Self); RegisterInterfaceLibraryRuntime(Self);
end; end;
@ -11092,18 +11110,40 @@ begin
end; end;
function TPSExec.LastExParam: tbtString; function TPSExec.LastExParam: tbtString;
var
pp: TPSExceptionHandler;
begin begin
result := ExParam; if FExceptionStack.Count = 0 then begin
result := ExParam;
exit;
end;
pp := fExceptionStack[fExceptionStack.Count-1];
result := pp.ExceptionParam;
end; end;
function TPSExec.LastExPos: Integer; function TPSExec.LastExPos: Integer;
var
pp: TPSExceptionHandler;
begin begin
result := ExPos; if FExceptionStack.Count = 0 then begin
result := ExPos;
exit;
end;
pp := fExceptionStack[fExceptionStack.Count-1];
result := pp.ExceptOffset;
end; end;
function TPSExec.LastExProc: Integer; function TPSExec.LastExProc: Integer;
var
pp: TPSExceptionHandler;
begin begin
result := exProc; if FExceptionStack.Count = 0 then begin
result := ExProc;
exit;
end;
pp := fExceptionStack[fExceptionStack.Count-1];
result := FProcs.IndexOf(pp.CurrProc);
end; end;
{ TPSRuntimeClass } { TPSRuntimeClass }
@ -12342,6 +12382,9 @@ var
aName: PWideChar; aName: PWideChar;
WSFreeList: TPSList; WSFreeList: TPSList;
begin begin
if Self = nil then begin
raise EPSException.Create('Variant is null, cannot invoke', nil, 0, 0);
end;
FillChar(ExceptInfo, SizeOf(ExceptInfo), 0); FillChar(ExceptInfo, SizeOf(ExceptInfo), 0);
if Name='' then begin if Name='' then begin
DispatchId:=0; DispatchId:=0;

View File

@ -733,12 +733,18 @@ end;
//------------------------------------------------------------------- //-------------------------------------------------------------------
function FloatToStr(E: Extended): TbtString; function FloatToStr(E: Extended): TbtString;
{$ifdef FPC}
begin
result := sysutils.floattostr(e);
end;
{$else}
var var
s: tbtstring; s: tbtstring;
begin begin
Str(e:0:12, s); Str(e:0:12, s);
result := s; result := s;
end; end;
{$endif}
function StrToInt(const S: TbtString): LongInt; function StrToInt(const S: TbtString): LongInt;
var var