diff --git a/trunk/Projects/SAMufasaGUI/testunit.pas b/trunk/Projects/SAMufasaGUI/testunit.pas index 65d71a2..a223f88 100644 --- a/trunk/Projects/SAMufasaGUI/testunit.pas +++ b/trunk/Projects/SAMufasaGUI/testunit.pas @@ -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 diff --git a/trunk/Units/MMLAddon/mmlpsthread.pas b/trunk/Units/MMLAddon/mmlpsthread.pas index fe14217..2994c3d 100644 --- a/trunk/Units/MMLAddon/mmlpsthread.pas +++ b/trunk/Units/MMLAddon/mmlpsthread.pas @@ -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 diff --git a/trunk/Units/PascalScript/uPSCompiler.pas b/trunk/Units/PascalScript/uPSCompiler.pas index 4ec5d8e..bf47630 100644 --- a/trunk/Units/PascalScript/uPSCompiler.pas +++ b/trunk/Units/PascalScript/uPSCompiler.pas @@ -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;'); diff --git a/trunk/Units/PascalScript/uPSR_dll.pas b/trunk/Units/PascalScript/uPSR_dll.pas index 00dd22c..e2c9d3d 100644 --- a/trunk/Units/PascalScript/uPSR_dll.pas +++ b/trunk/Units/PascalScript/uPSR_dll.pas @@ -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 diff --git a/trunk/Units/PascalScript/uPSRuntime.pas b/trunk/Units/PascalScript/uPSRuntime.pas index 01e5097..53f9c7b 100644 --- a/trunk/Units/PascalScript/uPSRuntime.pas +++ b/trunk/Units/PascalScript/uPSRuntime.pas @@ -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; diff --git a/trunk/Units/PascalScript/uPSUtils.pas b/trunk/Units/PascalScript/uPSUtils.pas index 30873c2..883316d 100644 --- a/trunk/Units/PascalScript/uPSUtils.pas +++ b/trunk/Units/PascalScript/uPSUtils.pas @@ -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