moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-25 02:32:19 -05:00
Code Issues Releases Wiki Activity

Fixed the FloatToStr bug. + Updated the PascalScript st00f.

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
trunk/Projects/SAMufasaGUI/testunit.pas
View File

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

3
trunk/Units/MMLAddon/mmlpsthread.pas
View File

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

55
trunk/Units/PascalScript/uPSCompiler.pas
View File

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

2
trunk/Units/PascalScript/uPSR_dll.pas
View File

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

109
trunk/Units/PascalScript/uPSRuntime.pas
View File

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

6
trunk/Units/PascalScript/uPSUtils.pas
View File

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