GetDeclaredMod, IsSubrange, GetArraySubscript, IsConst,
IsReallyPointer, IsPointer, IsParameter, ModeOfAddr,
GetMode, GetType, IsUnbounded, IsComposite, IsConstructor,
- IsParameter, IsConstString, IsConstLitInternal, IsConstLit ;
+ IsParameter, IsConstString, IsConstLitInternal, IsConstLit,
+ GetStringLength ;
FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ;
FROM M2System IMPORT Address ;
(*
- checkArrayTypeEquivalence -
+ checkUnbounded - check to see if the unbounded is type compatible with right.
+ This is only allowed during parameter passing.
+*)
+
+PROCEDURE checkUnbounded (result: status; tinfo: tInfo; unbounded, right: CARDINAL) : status ;
+VAR
+ lLow, rLow,
+ lHigh, rHigh: CARDINAL ;
+BEGIN
+ (* Firstly check to see if we have resolved this as false. *)
+ IF isFalse (result)
+ THEN
+ RETURN result
+ ELSE
+ Assert (IsUnbounded (unbounded)) ;
+ IF tinfo^.kind = parameter
+ THEN
+ (* --fixme-- we should check the unbounded data type against the type of right. *)
+ RETURN true
+ ELSE
+ (* Not allowed to use an unbounded symbol (type) in an expression or assignment. *)
+ RETURN false
+ END
+ END
+END checkUnbounded ;
+
+
+(*
+ checkArrayTypeEquivalence - check array and unbounded array type equivalence.
*)
PROCEDURE checkArrayTypeEquivalence (result: status; tinfo: tInfo;
THEN
lSub := GetArraySubscript (left) ;
rSub := GetArraySubscript (right) ;
- result := checkPair (result, tinfo, GetType (left), GetType (right)) ;
+ result := checkPair (result, tinfo, GetSType (left), GetSType (right)) ;
IF (lSub # NulSym) AND (rSub # NulSym)
THEN
result := checkSubrange (result, tinfo, getSType (lSub), getSType (rSub))
THEN
RETURN true
ELSE
- result := checkPair (result, tinfo, GetType (left), GetType (right))
+ result := checkUnbounded (result, tinfo, left, right)
END
+ ELSIF IsUnbounded (right) AND (IsArray (left) OR IsUnbounded (left))
+ THEN
+ IF IsGenericSystemType (getSType (right)) OR IsGenericSystemType (getSType (left))
+ THEN
+ RETURN true
+ ELSE
+ result := checkUnbounded (result, tinfo, right, left)
+ END
+ ELSIF IsArray (left) AND IsConst (right)
+ THEN
+ result := checkPair (result, tinfo, GetType (left), GetType (right))
+ ELSIF IsArray (right) AND IsConst (left)
+ THEN
+ result := checkPair (result, tinfo, GetType (left), GetType (right))
END ;
RETURN result
END checkArrayTypeEquivalence ;
(*
- IsTyped -
+ IsTyped - returns TRUE if sym will have a type.
*)
PROCEDURE IsTyped (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN IsVar (sym) OR IsVar (sym) OR IsParameter (sym) OR
+ RETURN IsVar (sym) OR IsParameter (sym) OR IsConstructor (sym) OR
(IsConst (sym) AND IsConstructor (sym)) OR IsParameter (sym) OR
(IsConst (sym) AND (GetType (sym) # NulSym))
END IsTyped ;
RETURN result
ELSIF IsConstString (left)
THEN
- typeRight := GetDType (right) ;
- IF typeRight = NulSym
+ IF IsConstString (right)
THEN
- RETURN result
- ELSIF IsSet (typeRight) OR IsEnumeration (typeRight) OR IsProcedure (typeRight) OR
- IsRecord (typeRight)
+ RETURN true
+ ELSIF IsTyped (right)
THEN
- RETURN false
- ELSE
- RETURN doCheckPair (result, tinfo, Char, typeRight)
+ typeRight := GetDType (right) ;
+ IF typeRight = NulSym
+ THEN
+ RETURN result
+ ELSIF IsSet (typeRight) OR IsEnumeration (typeRight) OR
+ IsProcedure (typeRight) OR IsRecord (typeRight)
+ THEN
+ RETURN false
+ ELSIF IsArray (typeRight)
+ THEN
+ RETURN doCheckPair (result, tinfo, Char, GetType (typeRight))
+ ELSIF GetStringLength (tinfo^.token, left) = 1
+ THEN
+ RETURN doCheckPair (result, tinfo, Char, typeRight)
+ END
END
END ;
RETURN result
END checkSystemEquivalence ;
+(*
+ checkTypeKindViolation - returns false if one operand left or right is
+ a set, record or array.
+*)
+
+PROCEDURE checkTypeKindViolation (result: status; tinfo: tInfo;
+ left, right: CARDINAL) : status ;
+BEGIN
+ IF isFalse (result) OR (result = visited)
+ THEN
+ RETURN result
+ ELSE
+ (* We have checked IsSet (left) and IsSet (right) etc in doCheckPair. *)
+ IF (IsSet (left) OR IsSet (right)) OR
+ (IsRecord (left) OR IsRecord (right)) OR
+ (IsArray (left) OR IsArray (right))
+ THEN
+ RETURN false
+ END
+ END ;
+ RETURN result
+END checkTypeKindViolation ;
+
+
(*
doCheckPair -
*)
result := checkGenericTypeEquivalence (result, left, right) ;
IF NOT isKnown (result)
THEN
- result := checkTypeKindEquivalence (result, tinfo, left, right)
+ result := checkTypeKindEquivalence (result, tinfo, left, right) ;
+ IF NOT isKnown (result)
+ THEN
+ result := checkTypeKindViolation (result, tinfo, left, right)
+ END
END
END
END
LogicalXorOp : CodeSetSymmetricDifference (q) |
LogicalDiffOp : CodeSetLogicalDifference (q) |
IfLessOp : CodeIfLess (q, op1, op2, op3) |
- IfEquOp : CodeIfEqu (q, op1, op2, op3) |
- IfNotEquOp : CodeIfNotEqu (q, op1, op2, op3) |
+ IfEquOp : CodeIfEqu (q) |
+ IfNotEquOp : CodeIfNotEqu (q) |
IfGreEquOp : CodeIfGreEqu (q, op1, op2, op3) |
IfLessEquOp : CodeIfLessEqu (q, op1, op2, op3) |
IfGreOp : CodeIfGre (q, op1, op2, op3) |
(*
CodeParam - builds a parameter list.
-
- NOTE that we almost can treat VAR and NON VAR parameters the same, expect for
- some types:
-
- procedure parameters
- unbounded parameters
-
- these require special attention and thus it is easier to test individually
- for VAR and NON VAR parameters.
-
- NOTE that we CAN ignore ModeOfAddr though
+ Note that we can ignore ModeOfAddr as any lvalue will
+ have been created in a preceeding quadruple.
*)
PROCEDURE CodeParam (quad: CARDINAL) ;
(*
- CodeIfEqu - codes the quadruple if op1 = op2 then goto op3
+ PerformCodeIfEqu -
*)
-PROCEDURE CodeIfEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfEqu (quad: CARDINAL) ;
VAR
- tl, tr: Tree ;
- location : location_t ;
+ tl, tr : Tree ;
+ location : location_t ;
+ left, right, dest, combined,
+ leftpos, rightpos, destpos : CARDINAL ;
+ overflow : BOOLEAN ;
+ op : QuadOperator ;
BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- (* firstly ensure that any constant literal is declared *)
- DeclareConstant(CurrentQuadToken, op1) ;
- DeclareConstant(CurrentQuadToken, op2) ;
- DeclareConstructor(CurrentQuadToken, quad, op1) ;
- DeclareConstructor(CurrentQuadToken, quad, op2) ;
- IF IsConst(op1) AND IsConst(op2)
+ (* Ensure that any remaining undeclared constant literal is declared. *)
+ GetQuadOtok (quad, combined, op,
+ left, right, dest, overflow,
+ leftpos, rightpos, destpos) ;
+ location := TokenToLocation (combined) ;
+ IF IsConst (left) AND IsConst (right)
THEN
- PushValue(op1) ;
- PushValue(op2) ;
- IF Equ(CurrentQuadToken)
+ PushValue (left) ;
+ PushValue (right) ;
+ IF Equ (combined)
THEN
- BuildGoto(location, string(CreateLabelName(op3)))
+ BuildGoto (location, string (CreateLabelName (dest)))
ELSE
- (* fall through *)
+ (* Fall through. *)
END
- ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
- IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
+ ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR
+ IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right))))
THEN
- CodeIfSetEqu(quad, op1, op2, op3)
+ CodeIfSetEqu (quad, left, right, dest)
ELSE
- IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
+ IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
THEN
- MetaErrorT2 (CurrentQuadToken,
+ MetaErrorT2 (combined,
'equality tests between composite types not allowed {%1Eatd} and {%2atd}',
- op1, op2)
+ left, right)
ELSE
- ConvertBinaryOperands(location,
- tl, tr,
- ComparisonMixTypes (SkipType (GetType (op1)),
- SkipType (GetType (op2)),
- CurrentQuadToken),
- op1, op2) ;
- DoJump(location, BuildEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
+ ConvertBinaryOperands (location,
+ tl, tr,
+ ComparisonMixTypes (SkipType (GetType (left)),
+ SkipType (GetType (right)),
+ combined),
+ left, right) ;
+ DoJump (location, BuildEqualTo (location, tl, tr), NIL,
+ string (CreateLabelName (dest)))
END
END
-END CodeIfEqu ;
+END PerformCodeIfEqu ;
(*
- CodeIfNotEqu - codes the quadruple if op1 # op2 then goto op3
+ PerformCodeIfNotEqu -
*)
-PROCEDURE CodeIfNotEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfNotEqu (quad: CARDINAL) ;
VAR
- tl, tr : Tree ;
- location: location_t ;
+ tl, tr : Tree ;
+ location : location_t ;
+ left, right, dest, combined,
+ leftpos, rightpos, destpos : CARDINAL ;
+ overflow : BOOLEAN ;
+ op : QuadOperator ;
BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- (* firstly ensure that any constant literal is declared *)
- DeclareConstant(CurrentQuadToken, op1) ;
- DeclareConstant(CurrentQuadToken, op2) ;
- DeclareConstructor(CurrentQuadToken, quad, op1) ;
- DeclareConstructor(CurrentQuadToken, quad, op2) ;
- IF IsConst(op1) AND IsConst(op2)
+ (* Ensure that any remaining undeclared constant literal is declared. *)
+ GetQuadOtok (quad, combined, op,
+ left, right, dest, overflow,
+ leftpos, rightpos, destpos) ;
+ location := TokenToLocation (combined) ;
+ IF IsConst (left) AND IsConst (right)
THEN
- PushValue(op1) ;
- PushValue(op2) ;
- IF NotEqu(CurrentQuadToken)
+ PushValue (left) ;
+ PushValue (right) ;
+ IF NotEqu (combined)
THEN
- BuildGoto(location, string(CreateLabelName(op3)))
+ BuildGoto (location, string (CreateLabelName (dest)))
ELSE
- (* fall through *)
+ (* Fall through. *)
END
- ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
- IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
+ ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR
+ IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right))))
THEN
- CodeIfSetNotEqu (op1, op2, op3)
+ CodeIfSetNotEqu (left, right, dest)
ELSE
- IF IsComposite(op1) OR IsComposite(op2)
+ IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
THEN
- MetaErrorT2 (CurrentQuadToken,
+ MetaErrorT2 (combined,
'inequality tests between composite types not allowed {%1Eatd} and {%2atd}',
- op1, op2)
+ left, right)
ELSE
- ConvertBinaryOperands(location,
- tl, tr,
- ComparisonMixTypes (SkipType (GetType (op1)),
- SkipType (GetType (op2)),
- CurrentQuadToken),
- op1, op2) ;
- DoJump(location,
- BuildNotEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
+ ConvertBinaryOperands (location,
+ tl, tr,
+ ComparisonMixTypes (SkipType (GetType (left)),
+ SkipType (GetType (right)),
+ combined),
+ left, right) ;
+ DoJump (location, BuildNotEqualTo (location, tl, tr), NIL,
+ string (CreateLabelName (dest)))
END
END
+END PerformCodeIfNotEqu ;
+
+
+(*
+ IsValidExpressionRelOp -
+*)
+
+PROCEDURE IsValidExpressionRelOp (quad: CARDINAL) : BOOLEAN ;
+CONST
+ Verbose = FALSE ;
+VAR
+ lefttype, righttype,
+ left, right, dest, combined,
+ leftpos, rightpos, destpos : CARDINAL ;
+ overflow : BOOLEAN ;
+ op : QuadOperator ;
+BEGIN
+ (* Ensure that any remaining undeclared constant literal is declared. *)
+ GetQuadOtok (quad, combined, op,
+ left, right, dest, overflow,
+ leftpos, rightpos, destpos) ;
+ DeclareConstant (leftpos, left) ;
+ DeclareConstant (rightpos, right) ;
+ DeclareConstructor (leftpos, quad, left) ;
+ DeclareConstructor (rightpos, quad, right) ;
+ lefttype := GetType (left) ;
+ righttype := GetType (right) ;
+ IF ExpressionTypeCompatible (combined, "", left, right,
+ StrictTypeChecking, FALSE)
+ THEN
+ RETURN TRUE
+ ELSE
+ IF Verbose
+ THEN
+ MetaErrorT2 (combined,
+ 'expression mismatch between {%1Etad} and {%2tad} seen during comparison',
+ left, right)
+ END ;
+ RETURN FALSE
+ END
+END IsValidExpressionRelOp ;
+
+
+(*
+ CodeIfEqu - codes the quadruple if op1 = op2 then goto op3
+*)
+
+PROCEDURE CodeIfEqu (quad: CARDINAL) ;
+BEGIN
+ IF IsValidExpressionRelOp (quad)
+ THEN
+ PerformCodeIfEqu (quad)
+ END
+END CodeIfEqu ;
+
+
+(*
+ CodeIfNotEqu - codes the quadruple if op1 # op2 then goto op3
+*)
+
+PROCEDURE CodeIfNotEqu (quad: CARDINAL) ;
+BEGIN
+ IF IsValidExpressionRelOp (quad)
+ THEN
+ PerformCodeIfNotEqu (quad)
+ END
END CodeIfNotEqu ;
projects / thirdparty / gcc.git / commitdiff
