if (r <> nil) and ((r^.Modifiers and 128)= 0) then
begin
if (r^.FType = CVAL_Array) then
begin
for l := 0 to r.ArrayItems.Count -1 do
begin
DisposePValue(R.ArrayItems.GetItem(l));
end;
r.ArrayItems.Free;
end else
if (r^.FType = CVAL_AllocatedStackReg) or (r^.FType = CVAL_Addr) or (r^.FType = CVAL_PushAddr) then
begin
FreeRecFields(R^.RecField);
end
else if r.FType = CVAL_Data then
DisposeVariant(r^.FData)
else if r.FType = CVAL_Eval then
begin
for l := 0 to r.SubItems.Count - 1 do
begin
p := r.SubItems.GetItem(l);
if not p^.C then
DisposePValue(p^.OutRec);
Dispose(p);
end;
r^.SubItems.Free;
end
else if (r.FType = CVAL_Proc) or (r.FType = CVAL_varProc)then
begin
for l := 0 to r^.Parameters.Count - 1 do
begin
P2 := r^.Parameters.GetItem(l);
if P2^.InReg <> nil then
DisposePValue(P2^.InReg);
Dispose(P2);
end;
r.Parameters.Free;
if r.FType = CVAL_VarProc then
DisposePValue(r._ProcNo);
end else if (r.FType = CVAL_ClassPropertyCallGet) or (r.FType = CVAL_ClassPropertyCallSet) or (r.FType = CVAL_ClassMethodCall) or (r.FType = CVAL_ClassProcCall) then
begin
DisposePValue(r.Self);
for l := 0 to r^.Params.Count - 1 do
begin
P2 := r^.Params.GetItem(l);
if P2^.InReg <> nil then
DisposePValue(P2^.InReg);
Dispose(P2);
end;
end;
Dispose(r);
end;
end;
function TIFPSPascalCompiler.GetTypeCopyLink(p: PIFPSType): PIFPSType;
function FindProc(const Name: string): Cardinal; forward;
function checkCompatType2(p1, p2: PIFPSType): Boolean;
begin
if
((p1^.BaseType = btProcPtr) and (p2 = p1)) or
(p1^.BaseType = btVariant) or
(p2^.baseType = btVariant) or
(IsIntType(p1^.BaseType) and IsIntType(P2^.BaseType)) or
(IsRealType(p1^.BaseType) and IsIntRealType(P2^.BaseType)) or
((p1^.BaseType = btString) and (P2^.BaseType = btString)) or
((p1^.BaseType = btString) and (P2^.BaseType = btChar)) or
((p1^.BaseType = btArray) and (p2^.BaseType = btArray)) or
((p1^.BaseType = btChar) and (p2^.BaseType = btChar)) or
((p1^.BaseType = btRecord) and (p2^.BaseType = btrecord)) or
((p1^.BaseType = btEnum) and (p2^.BaseType = btEnum))
then
Result := True
else if ((P1^.BaseType = btclass) and (p2^.Basetype = btClass)) then
begin
Result :=p1^.Ex.IsCompatibleWith(p2^.Ex);
end else
Result := False;
end;
function CheckCompatType(V1, v2: PIFPSValue): Boolean;
var
p1, P2: PIFPSType;
begin
if (v1^.Modifiers and 4) <> 0 then
begin
Result := True;
exit;
end;
p1 := FUsedTypes.GetItem(GetTypeNo(V1));
P2 := FUsedTypes.GetItem(GetTypeNo(v2));
if (p1^.BaseType = btChar) and (p2^.BaseType = btString) and (v2^.FType = CVAL_Data) and (length(V2^.FData^.Value) = 1) then
begin
v2^.FData^.FType := GetType(btChar);
P2 := FUsedTypes.GetItem(GetTypeNo(v2));
end;
Result := CheckCompatType2(p1, p2);
end;
function ProcessFunction(ResModifiers: Byte; ProcNo: Cardinal; InData: TIfList;
ResultRegister:
PIFPSValue): Boolean; forward;
function ProcessVarFunction(ResModifiers: Byte; ProcNo: PIFPSValue; InData: TIfList;
ResultRegister:
PIFPSValue): Boolean; forward;
function MakeNil(NilPos: Cardinal;ivar: PIFPSValue): Boolean;
var
Procno: Cardinal;
PF: PIFPSType;
Par: TIfList;
pp: PParam;
begin
Pf := FUsedTypes.GetItem(GetTypeNo(IVar));
if (pf^.BaseType <> btClass) or (not pf.Ex.SetNil(GetTypeno(IVar), ProcNo)) or ((Ivar.FType <> CVAL_Addr)and(Ivar.FType <> CVAL_AllocatedStackReg)) then
if ((Modifiers and 1) <> 0) and (not IsIntBoolType(GetTypeNo(v))) or ((Modifiers and 2) <> 0) and (not IsRealType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(v)))^.BaseType)) then
begin
DisposePValue(v);
MakeError('', ecTypeMismatch, '');
Cleanup;
exit;
end;
New(p);
p^.C := False;
if ((v^.Modifiers and 1) <> 0) or ((modifiers and 1) <> 0) then
begin
v^.modifiers := v^.modifiers xor (modifiers and 1);
end;
if ((v^.Modifiers and 2) <> 0) or ((modifiers and 2) <> 0) then
begin
v^.modifiers := v^.modifiers xor (modifiers and 2);
end;
p^.OutRec := v;
Items.Add(p);
FParser.Next;
end;
CSTII_Chr:
begin
if modifiers <> 0then
begin
MakeError('', ecTypeMismatch, '');
Cleanup;
exit;
end;
FParser.Next;
if FParser.CurrTokenID <> CSTI_OpenRound then
begin
MakeError('', ecOpenRoundExpected, '');
Cleanup;
exit;
end;
FParser.Next;
v := calc(CSTI_CloseRound);
if v = nil then
begin
Cleanup;
exit;
end;
if FParser.CurrTokenId <> CSTI_CloseRound then
begin
DisposePValue(v);
MakeError('', ecCloseRoundExpected, '');
Cleanup;
exit;
end;
if not IsIntType(PIFPSType(FUsedTypes.GetItem(GetTypeNo(v)))^.BaseType) then
begin
DisposePValue(v);
MakeError('', ecTypeMismatch, '');
Cleanup;
exit;
end;
New(p);
p^.c := False;
New(p^.OutRec);
p^.OutRec^.FType := CVAL_Cast;
p^.OutRec^.Modifiers := 0;
p^.OutRec^.DPos := FParser.CurrTokenPos;
p^.OutRec^.Input := v;
p^.OutRec^.NewTypeNo := GetType(btChar);
Items.Add(p);
FParser.Next;
end;
CSTII_Ord:
begin
FParser.Next;
if FParser.CurrTokenID <> CSTI_OpenRound then
begin
MakeError('', ecOpenRoundExpected, '');
Cleanup;
exit;
end;
FParser.Next;
v := calc(CSTI_CloseRound);
if v = nil then
begin
Cleanup;
exit;
end;
if FParser.CurrTokenId <> CSTI_CloseRound then
begin
DisposePValue(v);
MakeError('', ecCloseRoundExpected, '');
Cleanup;
exit;
end;
Pt := FUsedTypes.GetItem(GetTypeNo(v));
if (pt^.BaseType = btString) and (v^.FType = CVAL_Data) and (Length(v^.FData.Value) =1) then
begin
v^.FData.FType := GetType(btChar);
Pt := FUsedTypes.GetItem(GetTypeNo(v));
end;
New(p);
p^.c := False;
if ((v^.Modifiers and 1) <> 0) or ((modifiers and 1) <> 0) then
begin
v^.modifiers := v^.modifiers xor (modifiers and 1);
end;
if ((v^.Modifiers and 2) <> 0) or ((modifiers and 2) <> 0) then
begin
v^.modifiers := v^.modifiers xor (modifiers and 2);
function ReadInteger(const s: string): PIfRVariant;
var
C: Integer;
begin
New(Result);
Result^.FType := GetType(btS32);
SetLength(Result^.Value, SizeOf(TbtS32));
System.Val(s, TbtS32((@Result^.Value[1])^), C);
if TbtS32((@Result^.Value[1])^) < 0 then
begin
System.Val(s, TbtU32((@Result^.Value[1])^), C);
end;
end;
function ReadString: PIfRVariant;
function ParseString: string;
var
temp3: string;
function ChrToStr(s: string): Char;
begin
Delete(s, 1, 1); {First char : #}
ChrToStr := Chr(StrToInt(s));
end;
function PString(s: string): string;
begin
s := copy(s, 2, Length(s) - 2);
PString := s;
end;
begin
temp3 := '';
while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId =
CSTI_Char) do
begin
if FParser.CurrTokenId = CSTI_String then
begin
temp3 := temp3 + PString(FParser.GetToken);
FParser.Next;
if FParser.CurrTokenId = CSTI_String then
temp3 := temp3 + #39;
end {if}
else
begin
temp3 := temp3 + ChrToStr(FParser.GetToken);
FParser.Next;
end; {else if}
end; {while}
ParseString := temp3;
end;
begin
New(Result);
Result^.FType := GetType(btString);
Result^.Value := ParseString;
end;
function GetConstantIdentifier: PIfRVariant;
var
s: string;
sh: Longint;
i: Longint;
p: PIFPSConstant;
begin
s := FParser.GetToken;
sh := MakeHash(s);
for i := FConstants.Count -1 downto 0 do
begin
p := FConstants.GetItem(I);
if (p^.NameHash = sh) and (p^.Name = s) then
begin
New(Result);
Result^.FType := p^.Value.FType;
Result^.Value := p^.Value.Value;
FParser.Next;
exit;
end;
end;
MakeError('', ecUnknownIdentifier, '');
Result := nil;
end;
begin
Items := TIfList.Create;
ReadConstant := nil;
while True do
begin
modifiers := 0;
if Items.Count and 1 = 0 then
begin
if fParser.CurrTokenID = CSTII_Not then
begin
FParser.Next;
modifiers := 1;
end else // only allow one of these two
if fParser.CurrTokenID = CSTI_Minus then
begin
FParser.Next;
modifiers := 2;
end;
case FParser.CurrTokenId of
CSTI_EOF:
begin
MakeError('', ecUnexpectedEndOfFile, '');
Cleanup;
exit;
end;
CSTI_OpenRound:
begin
FParser.Next;
val := ReadConstant(CSTI_CloseRound);
if val = nil then
begin
Cleanup;
exit;
end;
if FParser.CurrTokenId <> CSTI_CloseRound then
begin
MakeError('', ecCloseRoundExpected, '');
Cleanup;
exit;
end;
if ((Modifiers and 1) <> 0) and (not IsIntType(PIFPSType(FUsedTypes.GetItem(val^.FType))^.BaseType)) or ((Modifiers and 2) <> 0) and (not IsRealType(PIFPSType(FUsedTypes.GetItem(val^.FType))^.BaseType)) then
begin
DisposeVariant(val);
MakeError('', ecTypeMismatch, '');
Cleanup;
exit;
end;
new(tmp);
tmp^.b := False;
tmp^.Rec := Val;
tmp^.DeclPos := FParser.CurrTokenPos;
tmp^.Modifiers := modifiers;
Items.Add(tmp);
FParser.Next;
end;
CSTI_Char, CSTI_String:
begin
if (Modifiers <> 0) then
begin
MakeError('', ecTypeMismatch, '');
Cleanup;
exit;
end;
val := ReadString;
new(tmp);
tmp^.b := False;
tmp^.Rec := Val;
tmp^.DeclPos := FParser.CurrTokenPos;
tmp^.Modifiers := modifiers;
Items.Add(tmp);
end;
CSTI_HexInt, CSTI_Integer:
begin
Val := ReadInteger(FParser.GetToken);
new(tmp);
tmp^.b := False;
tmp^.Rec := Val;
tmp^.DeclPos := FParser.CurrTokenPos;
tmp^.Modifiers := modifiers;
Items.Add(tmp);
FParser.Next;
end;
CSTI_Real:
begin
if ((Modifiers and 1) <> 0) then
begin
MakeError('', ecTypeMismatch, '');
Cleanup;
exit;
end;
Val := ReadReal(FParser.GetToken);
new(tmp);
tmp^.b := False;
tmp^.Rec := Val;
tmp^.DeclPos := FParser.CurrTokenPos;
tmp^.Modifiers := modifiers;
Items.Add(tmp);
FParser.Next;
end;
CSTI_Identifier:
begin
val := GetConstantIdentifier;
if val = nil then
begin
Cleanup;
exit;
end
else
begin
if ((Modifiers and 1) <> 0) and (not IsIntType(PIFPSType(FUsedTypes.GetItem(val^.FType))^.BaseType)) or ((Modifiers and 2) <> 0) and (not IsIntRealType(PIFPSType(FUsedTypes.GetItem(val^.FType))^.BaseType))