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

Fixed error #44 (by using the latest PS) and updated the rev-version in Testunit.

Browse Source 
git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@399 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2010-01-12 15:20:54 +00:00
parent f8787a9e1d
commit 464be3215c
5 changed files with 496 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Projects/SAMufasaGUI/testunit.pas
View File

@ -42,7 +42,7 @@ uses
ocr, updateform, simbasettings; ocr, updateform, simbasettings;
const const
SimbaVersion = 394; SimbaVersion = 399;
type type

6
Units/PascalScript/PascalScript.inc
View File

@ -48,7 +48,11 @@
{ {
Defines: Defines:
IFPS3_NOSMARTLIST - Don't use the smart list option PS_NOSMARTLIST - Don't use the smart list option
PS_NOIDISPATCH
PS_NOWIDESTRING
PS_NOINT64
PS_DELPHIDIV
} }
{$UNDEF DEBUG} {$UNDEF DEBUG}

397
Units/PascalScript/uPSCompiler.pas
View File

@ -758,7 +758,8 @@ type
ecInvalidnumberOfParameters ecInvalidnumberOfParameters
{$IFDEF PS_USESSUPPORT} {$IFDEF PS_USESSUPPORT}
, ecNotAllowed, , ecNotAllowed,
ecUnitNotFoundOrContainsErrors ecUnitNotFoundOrContainsErrors,
ecCrossReference
{$ENDIF} {$ENDIF}
); );
@ -873,7 +874,7 @@ type
TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs, TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs, otIntDiv,
otGreaterEqual, otLessEqual, otGreater, otLess, otEqual, otGreaterEqual, otLessEqual, otGreater, otLess, otEqual,
otNotEqual, otIs, otIn); otNotEqual, otIs, otIn);
@ -945,7 +946,9 @@ type
{$IFDEF PS_USESSUPPORT} {$IFDEF PS_USESSUPPORT}
FUnitInits : TPSList; //nvds FUnitInits : TPSList; //nvds
FUnitFinits: TPSList; //nvds FUnitFinits: TPSList; //nvds
FUses : TIFStringList; FUses : TPSStringList;
fUnits : TPSUnitList;
fUnit : TPSUnit;
fModule : tbtString; fModule : tbtString;
{$ENDIF} {$ENDIF}
fInCompile : Integer; fInCompile : Integer;
@ -1017,6 +1020,9 @@ type
function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean; function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean;
function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean; function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean;
{$IFDEF PS_USESSUPPORT}
function IsInLocalUnitList(s: tbtString): Boolean;
{$ENDIF}
function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure; function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure;
@ -1599,6 +1605,8 @@ type
function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean; function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean;
function RegisterMethodEx(const Declaration: tbtString; const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
procedure RegisterDummyMethod; procedure RegisterDummyMethod;
function IsCompatibleWith(aType: TPSType): Boolean; function IsCompatibleWith(aType: TPSType): Boolean;
@ -1703,6 +1711,7 @@ type
function PS_mi2s(i: Cardinal): tbtString; function PS_mi2s(i: Cardinal): tbtString;
function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
function DeclToBits(const Decl: TPSParametersDecl): tbtString; function DeclToBits(const Decl: TPSParametersDecl): tbtString;
@ -1775,6 +1784,7 @@ const
{$IFDEF PS_USESSUPPORT} {$IFDEF PS_USESSUPPORT}
RPS_NotAllowed = '%s is not allowed at this position'; RPS_NotAllowed = '%s is not allowed at this position';
RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors'; RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors';
RPS_CrossReference = 'Cross-Reference error of ''%s''';
{$ENDIF} {$ENDIF}
@ -1969,8 +1979,12 @@ begin
end; end;
end; end;
function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean;
begin
Result := ParseMethodEx(Owner, FClassName, Decl, OrgName, DestDecl, Func, nil);
end;
function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean;
var var
Parser: TPSPascalParser; Parser: TPSPascalParser;
FuncType: Byte; FuncType: Byte;
@ -1980,8 +1994,11 @@ var
ERow, EPos, ECol: Integer; ERow, EPos, ECol: Integer;
begin begin
Parser := TPSPascalParser.Create; if CustomParser = nil then begin
Parser.SetText(Decl); Parser := TPSPascalParser.Create;
Parser.SetText(Decl);
end else
Parser := CustomParser;
if Parser.CurrTokenId = CSTII_Function then if Parser.CurrTokenId = CSTII_Function then
FuncType:= 0 FuncType:= 0
else if Parser.CurrTokenId = CSTII_Procedure then else if Parser.CurrTokenId = CSTII_Procedure then
@ -1990,14 +2007,18 @@ begin
FuncType := 2 FuncType := 2
else else
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free;
Result := False; Result := False;
exit; exit;
end; end;
Parser.Next; Parser.Next;
if Parser.CurrTokenId <> CSTI_Identifier then if Parser.CurrTokenId <> CSTI_Identifier then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecIdentifierExpected, '');
Result := False; Result := False;
exit; exit;
end; {if} end; {if}
@ -2031,7 +2052,10 @@ begin
modifier := pmIn; modifier := pmIn;
if Parser.CurrTokenId <> CSTI_Identifier then if Parser.CurrTokenId <> CSTI_Identifier then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecIdentifierExpected, '');
Result := False; Result := False;
exit; exit;
end; end;
@ -2046,7 +2070,10 @@ begin
Parser.Next; Parser.Next;
if Parser.CurrTokenId <> CSTI_Identifier then if Parser.CurrTokenId <> CSTI_Identifier then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecIdentifierExpected, '');
Result := False; Result := False;
exit; exit;
end; end;
@ -2055,7 +2082,10 @@ begin
end; end;
if Parser.CurrTokenId <> CSTI_Colon then if Parser.CurrTokenId <> CSTI_Colon then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecColonExpected, '');
Result := False; Result := False;
exit; exit;
end; end;
@ -2065,7 +2095,10 @@ begin
Parser.nExt; Parser.nExt;
if Parser.CurrTokenId <> CSTII_Of then if Parser.CurrTokenId <> CSTII_Of then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecOfExpected, '');
Result := False; Result := False;
exit; exit;
end; end;
@ -2078,7 +2111,10 @@ begin
VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken)); VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken));
if VCType = nil then if VCType = nil then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecUnknownType, Parser.GetToken);
Result := False; Result := False;
exit; exit;
end; end;
@ -2106,7 +2142,8 @@ begin
btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken)); btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken));
else else
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free;
Result := False; Result := False;
exit; exit;
end; end;
@ -2118,7 +2155,10 @@ begin
VCType := Owner.FindType(Parser.GetToken); VCType := Owner.FindType(Parser.GetToken);
if VCType = nil then if VCType = nil then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecUnknownType, Parser.GetToken);
Result := False; Result := False;
exit; exit;
end; end;
@ -2144,7 +2184,10 @@ begin
break; break;
if Parser.CurrTokenId <> CSTI_Semicolon then if Parser.CurrTokenId <> CSTI_Semicolon then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecSemiColonExpected, '');
Result := False; Result := False;
exit; exit;
end; end;
@ -2157,7 +2200,10 @@ begin
begin begin
if Parser.CurrTokenId <> CSTI_Colon then if Parser.CurrTokenId <> CSTI_Colon then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecColonExpected, '');
Result := False; Result := False;
exit; exit;
end; end;
@ -2166,10 +2212,14 @@ begin
VCType := Owner.FindType(Parser.GetToken); VCType := Owner.FindType(Parser.GetToken);
if VCType = nil then if VCType = nil then
begin begin
Parser.Free; if Parser <> CustomParser then
Parser.Free
else
Owner.MakeError('', ecUnknownType, Parser.GetToken);
Result := False; Result := False;
exit; exit;
end; end;
Parser.Next;
end end
else if FuncType = 2 then {constructor} else if FuncType = 2 then {constructor}
begin begin
@ -2177,7 +2227,8 @@ begin
end else end else
VCType := nil; VCType := nil;
DestDecl.Result := VCType; DestDecl.Result := VCType;
Parser.Free; if Parser <> CustomParser then
Parser.Free;
if FuncType = 2 then if FuncType = 2 then
Func := mftConstructor Func := mftConstructor
else else
@ -2218,7 +2269,8 @@ begin
else else
begin begin
if (TPSExternalProcedure(x).RegProc.NameHash = h) and if (TPSExternalProcedure(x).RegProc.NameHash = h) and
(TPSExternalProcedure(x).RegProc.Name = Name) then (TPSExternalProcedure(x).RegProc.Name = Name) {$IFDEF PS_USESSUPPORT} and
(IsInLocalUnitList(TPSInternalProcedure(x).DeclareUnit)){$ENDIF} then
begin begin
Result := l; Result := l;
exit; exit;
@ -3171,7 +3223,34 @@ begin
else Result := False; else Result := False;
end; end;
end; end;
{$IFDEF PS_DELPHIDIV}
otDiv: otDiv:
begin { / }
if IsIntType(var1.FType.BaseType) then
ConvertToFloat(self, FUseUsedTypes, var1, Self.FindType('EXTENDED'));
case Var1.FType.BaseType of
btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result);
btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result);
btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result);
btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result);
else Result := False;
end;
end;
otIntDiv:
begin { / }
case Var1.FType.BaseType of
btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result);
btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result);
btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result);
btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result);
btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result);
{$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF}
else Result := False;
end;
end;
{$ELSE}
otDiv, otIntDiv:
begin { / } begin { / }
case Var1.FType.BaseType of case Var1.FType.BaseType of
btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result); btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result);
@ -3188,6 +3267,7 @@ begin
else Result := False; else Result := False;
end; end;
end; end;
{$ENDIF}
otMod: otMod:
begin { MOD } begin { MOD }
case Var1.FType.BaseType of case Var1.FType.BaseType of
@ -3719,7 +3799,11 @@ var
rvv: PIFPSRecordFieldTypeDef; rvv: PIFPSRecordFieldTypeDef;
p, p2: TPSType; p, p2: TPSType;
tempf: PIfRVariant; tempf: PIfRVariant;
{$IFNDEF PS_NOINTERFACES}
InheritedFrom: tbtString;
Guid: TGUID;
Intf: TPSInterface;
{$ENDIF}
begin begin
if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then
begin begin
@ -4059,6 +4143,94 @@ begin
FTypes.Add(p); FTypes.Add(p);
Result := p; Result := p;
Exit; Exit;
{$IFNDEF PS_NOINTERFACES}
end else if FParser.CurrTokenId = CSTII_Interface then
begin
FParser.Next;
if FParser.CurrTokenId <> CSTI_OpenRound then
begin
MakeError('', ecOpenRoundExpected, '');
Result := nil;
Exit;
end;
FParser.Next;
if FParser.CurrTokenID <> CSTI_Identifier then
begin
MakeError('', ecIdentifierExpected, '');
Result := nil;
exit;
end;
InheritedFrom := FParser.GetToken;
TypeNo := FindType(InheritedFrom);
if TypeNo = nil then
begin
MakeError('', ecUnknownType, FParser.GetToken);
Result := nil;
exit;
end;
if TypeNo.BaseType <> btInterface then
begin
MakeError('', ecTypeMismatch, '');
Result := nil;
Exit;
end;
FParser.Next;
if FParser.CurrTokenId <> CSTI_CloseRound then
begin
MakeError('', ecCloseRoundExpected, '');
Result := nil;
Exit;
end;
{$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
FParser.Next;
if FParser.CurrTokenId <> CSTI_OpenBlock then
begin
MakeError('', ecOpenBlockExpected, '');
Result := nil;
Exit;
end;
{$ENDIF}
FParser.Next;
if FParser.CurrTokenId <> CSTI_String then
begin
MakeError('', ecStringExpected, '');
Result := nil;
Exit;
end;
s := FParser.GetToken;
try
Guid := StringToGuid(String(Copy(s, 2, Length(s)-2)));
except
on e: Exception do
begin
MakeError('', ecCustomError, tbtstring(e.Message));
Result := nil;
Exit;
end;
end;
{$IFNDEF PS_NOINTERFACEGUIDBRACKETS}
FParser.Next;
if FParser.CurrTokenId <> CSTI_CloseBlock then
begin
MakeError('', ecCloseBlockExpected, '');
Result := nil;
Exit;
end;
{$ENDIF}
Intf := AddInterface(FindInterface(InheritedFrom), Guid, Name);
FParser.Next;
repeat
if not Intf.RegisterMethodEx('', cdStdCall, FParser) then begin
MakeError('', ecCustomError, 'Invalid method');
Result := nil;
Exit;
end;
FParser.Next;
until FParser.CurrTokenId = CSTII_End;
FParser.Next; // skip CSTII_End
Result := Intf.FType;
Exit;
{$ENDIF}
end else if FParser.CurrTokenId = CSTI_Identifier then end else if FParser.CurrTokenId = CSTI_Identifier then
begin begin
s := FParser.GetToken; s := FParser.GetToken;
@ -5655,6 +5827,16 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
BVal.Val2 := tmpp; BVal.Val2 := tmpp;
end; end;
end else begin end else begin
if (BVal.aType <> nil) and (BVal.aType <> GetTypeNo(BlockInfo, Output)) then begin
tmpp := AllocStackReg(BVal.aType);
PreWriteOutrec(tmpp, nil);
DoBinCalc(BVal, tmpp);
afterwriteoutrec(tmpp);
result := WriteCalculation(tmpp, output);
tmpp.Free;
exit;
end;
if not PreWriteOutRec(Output, nil) then if not PreWriteOutRec(Output, nil) then
begin begin
Result := False; Result := False;
@ -5700,7 +5882,10 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
exit; exit;
end; end;
BlockWriteByte(BlockInfo, Cm_CA); BlockWriteByte(BlockInfo, Cm_CA);
BlockWriteByte(BlockInfo, Ord(BVal.Operator)); if BVAL.Operator = otIntDiv then
BlockWriteByte(BlockInfo, Ord(otDiv))
else
BlockWriteByte(BlockInfo, Ord(BVal.Operator));
if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then
begin begin
Result := False; Result := False;
@ -6232,15 +6417,6 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
end; end;
end; end;
function GetIdentifier(const FType: Byte): TPSValue;
{
FType:
0 = Anything
1 = Only variables
2 = Not constants
}
procedure CheckProcCall(var x: TPSValue); procedure CheckProcCall(var x: TPSValue);
var var
aType: TPSType; aType: TPSType;
@ -7193,6 +7369,15 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
end; end;
end; end;
function GetIdentifier(const FType: Byte): TPSValue;
{
FType:
0 = Anything
1 = Only variables
2 = Not constants
}
var var
vt: TPSVariableType; vt: TPSVariableType;
vno: Cardinal; vno: Cardinal;
@ -7351,7 +7536,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
for l := 0 to FVars.Count - 1 do for l := 0 to FVars.Count - 1 do
begin begin
if (TPSVar(FVars[l]).NameHash = h) and if (TPSVar(FVars[l]).NameHash = h) and
(TPSVar(FVars[l]).Name = s) then (TPSVar(FVars[l]).Name = s) {$IFDEF PS_USESSUPPORT} and
(IsInLocalUnitList(TPSVar(FVars[l]).FDeclareUnit)){$ENDIF} then
begin begin
TPSVar(FVars[l]).Use; TPSVar(FVars[l]).Use;
Result := TPSValueGlobalVar.Create; Result := TPSValueGlobalVar.Create;
@ -7438,7 +7624,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
for l := 0 to FConstants.Count -1 do for l := 0 to FConstants.Count -1 do
begin begin
t := TPSConstant(FConstants[l]); t := TPSConstant(FConstants[l]);
if (t.NameHash = h) and (t.Name = s) then if (t.NameHash = h) and (t.Name = s) {$IFDEF PS_USESSUPPORT} and
(IsInLocalUnitList(t.FDeclareUnit)) {$ENDIF} then
begin begin
if FType <> 0 then if FType <> 0 then
begin begin
@ -7986,7 +8173,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
else else
Result := nil; Result := nil;
end; end;
otSub, otMul, otDiv: { - * / }
otSub, otMul, otIntDiv, otDiv: { - * / }
begin begin
if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and (
((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or
@ -8003,15 +8191,23 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or
(isIntRealType(t1.BaseType))) then (isIntRealType(t1.BaseType))) then
Result := t2 Result := t2
else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then begin
Result := t1 Result := t1;
else if IsIntRealType(t1.BaseType) and {$IFDEF PS_DELPHIDIV}
if Cmd = otDiv then
result := FindBaseType(btExtended);
{$ENDIF}
end else if IsIntRealType(t1.BaseType) and
IsIntRealType(t2.BaseType) then IsIntRealType(t2.BaseType) then
begin begin
if IsRealType(t1.BaseType) then if IsRealType(t1.BaseType) then
Result := t1 Result := t1
else else
Result := t2; Result := t2;
{$IFDEF PS_DELPHIDIV}
if Cmd = otIntDiv then //intdiv only works
result := nil;
{$ENDIF}
end end
else else
Result := nil; Result := nil;
@ -8208,6 +8404,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
Result := FDefaultBoolType Result := FDefaultBoolType
else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then
Result := FDefaultBoolType Result := FDefaultBoolType
else if (t1 = t2) then
Result := FDefaultBoolType
else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then
Result := FDefaultBoolType Result := FDefaultBoolType
else Result := nil; else Result := nil;
@ -8247,6 +8445,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
function ReadTerm: TPSValue; function ReadTerm: TPSValue;
var var
F1, F2: TPSValue; F1, F2: TPSValue;
fType: TPSType;
F: TPSBinValueOp; F: TPSBinValueOp;
Token: TPSPasToken; Token: TPSPasToken;
Op: TPSBinOperatorType; Op: TPSBinOperatorType;
@ -8270,7 +8469,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
end; end;
case Token of case Token of
CSTI_Multiply: Op := otMul; CSTI_Multiply: Op := otMul;
CSTII_div, CSTI_Divide: Op := otDiv; CSTI_Divide: Op := otDiv;
CSTII_div: Op := otIntDiv;
CSTII_mod: Op := otMod; CSTII_mod: Op := otMod;
CSTII_and: Op := otAnd; CSTII_and: Op := otAnd;
CSTII_shl: Op := otShl; CSTII_shl: Op := otShl;
@ -8279,19 +8479,30 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
else else
Op := otAdd; Op := otAdd;
end; end;
F := TPSBinValueOp.Create; if (Op = otAs) and (f2 is TPSValueData) and (TPSValueData(f2).Data.FType.BaseType = btType) then begin
f.Val1 := F1; fType := TPSValueData(f2).Data.ttype;
f.Val2 := F2; f2.Free;
f.Operator := Op; f2 := TPSUnValueOp.Create;
f.aType := GetResultType(F1, F2, Op); TPSUnValueOp(F2).Val1 := f1;
if f.aType = nil then TPSUnValueOp(F2).SetParserPos(FParser);
begin TPSUnValueOp(f2).FType := fType;
MakeError('', ecTypeMismatch, ''); TPSUnValueOp(f2).Operator := otCast;
f.Free; f1 := f2;
Result := nil; end else begin
exit; F := TPSBinValueOp.Create;
f.Val1 := F1;
f.Val2 := F2;
f.Operator := Op;
f.aType := GetResultType(F1, F2, Op);
if f.aType = nil then
begin
MakeError('', ecTypeMismatch, '');
f.Free;
Result := nil;
exit;
end;
f1 := f;
end; end;
f1 := f;
end; end;
Result := F1; Result := F1;
end; // ReadTerm end; // ReadTerm
@ -8727,7 +8938,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
end; end;
var var
Val: TPSValue; Temp, Val: TPSValue;
vt: TPSVariableType;
begin begin
Val := ReadExpression; Val := ReadExpression;
@ -8736,6 +8948,17 @@ begin
Result := nil; Result := nil;
exit; exit;
end; end;
vt := ivtGlobal;
repeat
Temp := Val;
if Val <> nil then CheckFurther(Val, False);
if Val <> nil then CheckClass(Val, vt, InvalidVal, False);
if Val <> nil then CheckExtClass(Val, vt, InvalidVal, False);
{$IFNDEF PS_NOIDISPATCH}if Val <> nil then CheckIntf(Val, vt, InvalidVal, False);{$ENDIF}
if Val <> nil then CheckProcCall(Val);
if Val<> nil then CheckClassArrayProperty(Val, vt, InvalidVal);
until (Val = nil) or (Temp = Val);
if not TryEvalConst(Val) then if not TryEvalConst(Val) then
begin begin
Val.Free; Val.Free;
@ -9113,6 +9336,18 @@ begin
begin begin
Res := ProcCall.ResultType; Res := ProcCall.ResultType;
if ProcCall.ResultType = FAnyString then
begin
for l := ProcCall.Parameters.Count - 1 downto 0 do
begin
Tmp := ProcCall.Parameters[l];
if (Tmp.ParamMode <> pmOut) and (Tmp.ExpectedType = FAnyString) then
begin
Res := GetTypeNo(BlockInfo, tmp.Val);
Break;
end;
end;
end;
Result := False; Result := False;
if (res = nil) and (ResultRegister <> nil) then if (res = nil) and (ResultRegister <> nil) then
begin begin
@ -9196,7 +9431,7 @@ begin
end end
else else
begin begin
if Tmp.ExpectedType = nil then if (Tmp.ExpectedType = nil) or (Tmp.ExpectedType = FAnyString) then
Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val); Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val);
if Tmp.ExpectedType.BaseType = btPChar then if Tmp.ExpectedType.BaseType = btPChar then
begin begin
@ -9391,7 +9626,7 @@ begin
exit; exit;
end; end;
case lType.BaseType of case lType.BaseType of
btVariant, btU8, btS8, btU16, btS16, btU32, btS32: ; btVariant, btU8, btS8, btU16, btS16, btU32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btS32: ;
else else
begin begin
MakeError('', ecTypeMismatch, ''); MakeError('', ecTypeMismatch, '');
@ -9953,7 +10188,7 @@ begin
begin begin
Result := False; Result := False;
Debug_WriteLine(BlockInfo); Debug_WriteLine(BlockInfo);
vin := GetIdentifier(2); vin := Calc(CSTI_Assignment);//GetIdentifier(2);
if vin <> nil then if vin <> nil then
begin begin
if vin is TPSValueVar then if vin is TPSValueVar then
@ -10638,6 +10873,7 @@ begin
if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then
break; break;
end; end;
CSTI_OpenRound,
CSTI_Identifier: CSTI_Identifier:
begin begin
case _ProcessLabel of case _ProcessLabel of
@ -10878,6 +11114,7 @@ var
OldFileName: tbtString; OldFileName: tbtString;
OldParser : TPSPascalParser; OldParser : TPSPascalParser;
OldIsUnit : Boolean; OldIsUnit : Boolean;
OldUnit : TPSUnit;
{$ENDIF} {$ENDIF}
procedure Cleanup; procedure Cleanup;
@ -10955,8 +11192,8 @@ var
FUnitFinits.Free; // FUnitFinits.Free; //
FUnitFinits := nil; // FUnitFinits := nil; //
FUses.Free; FreeAndNil(fUnits);
FUses:=nil; FreeAndNil(FUses);
fInCompile:=0; fInCompile:=0;
{$ENDIF} {$ENDIF}
end; end;
@ -11516,7 +11753,16 @@ var
{$ENDIF} {$ENDIF}
end; end;
end; end;
{$IFDEF PS_USESSUPPORT} {$IFDEF PS_USESSUPPORT}
if fUnits.GetUnit(S).HasUses(fModule) then
begin
MakeError('', ecCrossReference, s);
Result := False;
exit;
end;
fUnit.AddUses(S);
if Parse then if Parse then
begin begin
{$ENDIF} {$ENDIF}
@ -11612,6 +11858,7 @@ begin
FUnitFinits:= TPSList.Create; //nvds FUnitFinits:= TPSList.Create; //nvds
FUses:=TIFStringList.Create; FUses:=TIFStringList.Create;
FUnits:=TPSUnitList.Create;
{$ENDIF} {$ENDIF}
{$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF} {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF}
@ -11650,16 +11897,20 @@ begin
{$IFDEF PS_USESSUPPORT} {$IFDEF PS_USESSUPPORT}
fModule:=OldFileName; fModule:=OldFileName;
OldParser:=nil; OldParser:=nil;
OldUnit:=nil;
OldIsUnit:=false; // defaults OldIsUnit:=false; // defaults
end end
else else
begin begin
OldParser:=FParser; OldParser:=FParser;
OldIsUnit:=FIsUnit; OldIsUnit:=FIsUnit;
OldUnit:=fUnit;
FParser:=TPSPascalParser.Create; FParser:=TPSPascalParser.Create;
FParser.SetText(s); FParser.SetText(s);
end; end;
fUnit:=fUnits.GetUnit(fModule);
inc(fInCompile); inc(fInCompile);
{$ENDIF} {$ENDIF}
@ -11956,6 +12207,7 @@ begin
fParser.Free; fParser.Free;
fParser:=OldParser; fParser:=OldParser;
fIsUnit:=OldIsUnit; fIsUnit:=OldIsUnit;
fUnit:=OldUnit;
result:=true; result:=true;
end; end;
{$ENDIF} {$ENDIF}
@ -12428,7 +12680,8 @@ function TPSPascalCompiler.ReadConstant(FParser: TPSPascalParser; StopOn: TPSPas
end; end;
case Token of case Token of
CSTI_Multiply: Op := otMul; CSTI_Multiply: Op := otMul;
CSTII_div, CSTI_Divide: Op := otDiv; CSTI_Divide: Op := otDiv;
CSTII_Div: Op := otIntDiv;
CSTII_mod: Op := otMod; CSTII_mod: Op := otMod;
CSTII_and: Op := otAnd; CSTII_and: Op := otAnd;
CSTII_shl: Op := otShl; CSTII_shl: Op := otShl;
@ -12903,12 +13156,16 @@ end;
function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar; function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar;
var var
P: TPSVar; P: TPSVar;
s:tbtString;
begin begin
if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]); if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]);
s := Fastuppercase(Name);
if IsDuplicate(s,[dcVars]) then raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
p := TPSVar.Create; p := TPSVar.Create;
p.OrgName := Name; p.OrgName := Name;
p.Name := Fastuppercase(Name); p.Name := s;
p.FType := AT2UT(FType); p.FType := AT2UT(FType);
p.exportname := p.Name; p.exportname := p.Name;
FVars.Add(p); FVars.Add(p);
@ -13340,6 +13597,19 @@ begin
result := nil; result := nil;
end; end;
{$IFDEF PS_USESSUPPORT}
function TPSPascalCompiler.IsInLocalUnitList(s: tbtstring): Boolean;
begin
s:=FastUpperCase(s);
if (s=FastUpperCase(fModule)) or (s='SYSTEM') then
begin
result:=true;
exit;
end;
result:=fUnit.HasUses(S);
end;
{$ENDIF}
{ TPSType } { TPSType }
constructor TPSType.Create; constructor TPSType.Create;
@ -13765,6 +14035,7 @@ begin
{$IFDEF PS_USESSUPPORT} {$IFDEF PS_USESSUPPORT}
ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param])); ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));
ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param])); ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));
ecCrossReference: Result:=Format(RPS_CrossReference,[Param]);
{$ENDIF} {$ENDIF}
else else
Result := tbtstring(RPS_UnknownError); Result := tbtstring(RPS_UnknownError);
@ -15214,13 +15485,19 @@ end;
function TPSInterface.RegisterMethod(const Declaration: tbtString; function TPSInterface.RegisterMethod(const Declaration: tbtString;
const cc: TPSCallingConvention): Boolean; const cc: TPSCallingConvention): Boolean;
begin
Result := RegisterMethodEx(Declaration, cc, nil);
end;
function TPSInterface.RegisterMethodEx(const Declaration: tbtString;
const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean;
var var
M: TPSInterfaceMethod; M: TPSInterfaceMethod;
DOrgName: tbtString; DOrgName: tbtString;
Func: TPMFuncType; Func: TPMFuncType;
begin begin
M := TPSInterfaceMethod.Create(Self); M := TPSInterfaceMethod.Create(Self);
if not ParseMethod(FOwner, '', Declaration, DOrgname, m.Decl, Func) then if not ParseMethodEx(FOwner, '', Declaration, DOrgname, m.Decl, Func, CustomParser) then
begin begin
FItems.Add(m); // in any case, add a dummy item FItems.Add(m); // in any case, add a dummy item
Result := False; Result := False;

21
Units/PascalScript/uPSRuntime.pas
View File

@ -5042,6 +5042,15 @@ begin
b := not b; b := not b;
end else result := False; end else result := False;
end; end;
btRecord:
begin
if var1Type = var2Type then
begin
Set_Equal(var1, var2, TPSTypeRec_Record(var1Type).RealSize, b);
b := not b;
end else result := False;
end
else begin else begin
CMD_Err(erTypeMismatch); CMD_Err(erTypeMismatch);
exit; exit;
@ -5142,6 +5151,13 @@ begin
Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b); Set_Equal(var1, var2, TPSTypeRec_Set(var1Type).aByteSize, b);
end else result := False; end else result := False;
end; end;
btRecord:
begin
if var1Type = var2Type then
begin
Set_Equal(var1, var2, TPSTypeRec_Record(var1Type).RealSize, b);
end else result := False;
end
else begin else begin
CMD_Err(erTypeMismatch); CMD_Err(erTypeMismatch);
exit; exit;
@ -8854,7 +8870,7 @@ begin
38: Stack.SetAnsiString(-1, tbtString(AnsiLowercase(string(Stack.GetAnsiString(-2))))); // AnsiLowerCase 38: Stack.SetAnsiString(-1, tbtString(AnsiLowercase(string(Stack.GetAnsiString(-2))))); // AnsiLowerCase
{$IFNDEF PS_NOINT64} {$IFNDEF PS_NOINT64}
39: Stack.SetInt64(-1, StrToInt64(string(Stack.GetAnsiString(-2)))); // StrToInt64 39: Stack.SetInt64(-1, StrToInt64(string(Stack.GetAnsiString(-2)))); // StrToInt64
40: Stack.SetAnsiString(-1, SysUtils.IntToStr(Stack.GetInt64(-2)));// Int64ToStr 40: Stack.SetAnsiString(-1, tbtstring(SysUtils.IntToStr(Stack.GetInt64(-2))));// Int64ToStr
{$ENDIF} {$ENDIF}
41: // sizeof 41: // sizeof
begin begin
@ -12098,9 +12114,6 @@ begin
end; end;
function TPSStack.PushType(aType: TPSTypeRec): PPSVariant; function TPSStack.PushType(aType: TPSTypeRec): PPSVariant;
var
o: Cardinal;
p: Pointer;
begin begin
Result := Push(aType.RealSize + Sizeof(Pointer)); Result := Push(aType.RealSize + Sizeof(Pointer));
Result.FType := aType; Result.FType := aType;

131
Units/PascalScript/uPSUtils.pas
View File

@ -405,6 +405,40 @@ type
end; end;
TIFStringList = TPsStringList; TIFStringList = TPsStringList;
TPSUnitList = class;
TPSUnit = class(TObject)
private
fList : TPSUnitList;
fUnits : TPSList;
fUnitName : TbtString;
procedure SetUnitName(const Value: TbtString);
public
constructor Create(List: TPSUnitList);
destructor Destroy; override;
procedure AddUses(pUnitName: TbtString);
function HasUses(pUnitName: TbtString): Boolean;
property UnitName: TbtString read fUnitName write SetUnitName;
end;
TPSUnitList = class
private
fList: TPSList;
function Add: TPSUnit;
public
constructor Create;
function GetUnit(UnitName: TbtString): TPSUnit;
destructor Destroy; override;
end;
type type
@ -1587,6 +1621,103 @@ begin
result := -1; result := -1;
end; end;
{ TPSUnitList }
function TPSUnitList.Add: TPSUnit;
begin
result:=TPSUnit.Create(Self);
fList.Add(result);
end;
constructor TPSUnitList.Create;
begin
fList:=TPSList.Create;
end;
destructor TPSUnitList.Destroy;
var
Dummy: Integer;
begin
for Dummy:=0 to fList.Count-1 do
TObject(fList[Dummy]).Free;
FreeAndNil(fList);
inherited;
end;
function TPSUnitList.GetUnit(UnitName: TbtString): TPSUnit;
var
Dummy: Integer;
begin
UnitName:=FastUpperCase(UnitName);
for Dummy:=0 to fList.Count-1 do
begin
if TPSUnit(fList[Dummy]).UnitName=UnitName then
begin
result:=TPSUnit(fList[Dummy]);
exit;
end;
end;
result:=Add;
result.UnitName:=UnitName;
end;
{ TPSUnit }
procedure TPSUnit.AddUses(pUnitName: TbtString);
var
UsesUnit: TPSUnit;
begin
UsesUnit:=fList.GetUnit(pUnitName);
fUnits.Add(UsesUnit);
end;
constructor TPSUnit.Create(List: TPSUnitList);
begin
fUnits:=TPSList.Create;
fList:=List;
end;
destructor TPSUnit.Destroy;
begin
FreeAndNIl(fUnits);
inherited;
end;
function TPSUnit.HasUses(pUnitName: TbtString): Boolean;
var
Dummy: Integer;
begin
pUnitName:=FastUpperCase(pUnitName);
if fUnitName=pUnitName then
begin
result:=true;
exit;
end;
result:=false;
for Dummy:=0 to fUnits.Count-1 do
begin
result:=TPSUnit(fUnits[Dummy]).HasUses(pUnitName);
if result then
exit;
end;
end;
procedure TPSUnit.SetUnitName(const Value: TbtString);
begin
fUnitName := FastUpperCase(Value);
end;
end. end.