Cardinal, Char, Integer, IsTrunc,
Boolean, True,
Im, Re, Cmplx, GetCmplxReturnType, GetBaseTypeMinMax,
- CheckAssignmentCompatible, IsAssignmentCompatible ;
+ CheckAssignmentCompatible,
+ IsAssignmentCompatible, IsExpressionCompatible ;
FROM M2Bitset IMPORT Bitset ;
FROM NameKey IMPORT Name, MakeKey, KeyToCharStar, LengthKey, makekey, NulName ;
GetM2OperatorDesc, GetQuadOp,
DisplayQuadList ;
-FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible ;
+FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible, ExpressionTypeCompatible ;
FROM M2SSA IMPORT EnableSSA ;
NegateOp : CodeNegateChecked (q, op1, op3) |
LogicalShiftOp : CodeSetShift (q, op1, op2, op3) |
LogicalRotateOp : CodeSetRotate (q, op1, op2, op3) |
- LogicalOrOp : CodeSetOr (q, op1, op2, op3) |
- LogicalAndOp : CodeSetAnd (q, op1, op2, op3) |
- LogicalXorOp : CodeSetSymmetricDifference (q, op1, op2, op3) |
- LogicalDiffOp : CodeSetLogicalDifference (q, op1, op2, op3) |
+ LogicalOrOp : CodeSetOr (q) |
+ LogicalAndOp : CodeSetAnd (q) |
+ LogicalXorOp : CodeSetSymmetricDifference (q) |
+ LogicalDiffOp : CodeSetLogicalDifference (q) |
IfLessOp : CodeIfLess (q, op1, op2, op3) |
IfEquOp : CodeIfEqu (q, op1, op2, op3) |
IfNotEquOp : CodeIfNotEqu (q, op1, op2, op3) |
(*
- checkArrayElements - return TRUE if op1 or op3 are not arrays.
+ checkArrayElements - return TRUE if des or expr are not arrays.
If they are arrays and have different number of
elements return FALSE, otherwise TRUE.
*)
-PROCEDURE checkArrayElements (op1, op3: CARDINAL) : BOOLEAN ;
+PROCEDURE checkArrayElements (des, expr: CARDINAL; virtpos, despos, exprpos: CARDINAL) : BOOLEAN ;
VAR
e1, e3 : Tree ;
t1, t3 : CARDINAL ;
location: location_t ;
BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
- t1 := GetType(op1) ;
- t3 := GetType(op3) ;
- IF (t1#NulSym) AND (t3#NulSym) AND
- IsArray(SkipType(GetType(op3))) AND IsArray(SkipType(GetType(op1)))
+ t1 := GetType (des) ;
+ t3 := GetType (expr) ;
+ IF (t1 # NulSym) AND (t3 # NulSym) AND
+ IsArray (SkipType (GetType (expr))) AND IsArray (SkipType (GetType (des)))
THEN
(* both arrays continue checking *)
- e1 := GetArrayNoOfElements(location, Mod2Gcc(SkipType(GetType(op1)))) ;
- e3 := GetArrayNoOfElements(location, Mod2Gcc(SkipType(GetType(op3)))) ;
- IF CompareTrees(e1, e3)#0
- THEN
- MetaErrorT2(CurrentQuadToken, 'not allowed to assign array {%2Ead} to {%1ad} as they have a different number of elements',
- op1, op3) ;
+ e1 := GetArrayNoOfElements (TokenToLocation (despos),
+ Mod2Gcc (SkipType (GetType (des)))) ;
+ e3 := GetArrayNoOfElements (TokenToLocation (exprpos),
+ Mod2Gcc (SkipType (GetType (expr)))) ;
+ IF CompareTrees (e1, e3) # 0
+ THEN
+ MetaErrorT2 (virtpos,
+ 'not allowed to assign array {%2Ead} to {%1ad} as they have a different number of elements',
+ des, expr) ;
RETURN( FALSE )
END
END ;
(*
- checkRecordTypes - returns TRUE if op1 is not a record or if the record
- is the same type as op2.
+ checkRecordTypes - returns TRUE if des is not a record or if the record
+ is the same type as expr.
*)
-PROCEDURE checkRecordTypes (op1, op2: CARDINAL) : BOOLEAN ;
+PROCEDURE checkRecordTypes (des, expr: CARDINAL; virtpos: CARDINAL) : BOOLEAN ;
VAR
t1, t2: CARDINAL ;
BEGIN
- IF (GetType(op1)=NulSym) OR (GetMode(op1)=LeftValue)
+ IF (GetType (des) = NulSym) OR (GetMode (des) = LeftValue)
THEN
RETURN( TRUE )
ELSE
- t1 := SkipType(GetType(op1)) ;
- IF IsRecord(t1)
+ t1 := SkipType (GetType (des)) ;
+ IF IsRecord (t1)
THEN
- IF GetType(op2)=NulSym
+ IF GetType (expr) = NulSym
THEN
- MetaErrorT2 (CurrentQuadToken, 'cannot assign an operand of type {%1Ets} to a record type {%2tsa}', op2, op1) ;
+ MetaErrorT2 (virtpos,
+ 'cannot assign an operand of type {%1Ets} to a record type {%2tsa}',
+ expr, des) ;
RETURN( FALSE )
ELSE
- t2 := SkipType(GetType(op2)) ;
- IF t1=t2
+ t2 := SkipType (GetType (expr)) ;
+ IF t1 = t2
THEN
RETURN( TRUE )
ELSE
- MetaErrorT2 (CurrentQuadToken, 'cannot assign an operand of type {%1ts} to a record type {%2tsa}', op2, op1) ;
+ MetaErrorT2 (virtpos,
+ 'cannot assign an operand of type {%1ts} to a record type {%2tsa}',
+ expr, des) ;
RETURN( FALSE )
END
END
(*
- checkIncorrectMeta -
+ checkIncorrectMeta - checks to see if des and expr are assignment compatible is allows
+ generic system types to be assigned.
*)
-PROCEDURE checkIncorrectMeta (op1, op2: CARDINAL) : BOOLEAN ;
+PROCEDURE checkIncorrectMeta (des, expr: CARDINAL; virtpos: CARDINAL) : BOOLEAN ;
VAR
t1, t2: CARDINAL ;
BEGIN
- t1 := SkipType(GetType(op1)) ;
- t2 := SkipType(GetType(op2)) ;
- IF (t1=NulSym) OR (GetMode(op1)=LeftValue) OR
- (t2=NulSym) OR (GetMode(op2)=LeftValue)
+ t1 := SkipType (GetType (des)) ;
+ t2 := SkipType (GetType (expr)) ;
+ IF (t1 = NulSym) OR (GetMode(des) = LeftValue) OR
+ (t2 = NulSym) OR (GetMode(expr) = LeftValue)
THEN
RETURN( TRUE )
- ELSIF (t1#t2) AND (NOT IsGenericSystemType(t1)) AND (NOT IsGenericSystemType(t2))
+ ELSIF (t1 # t2) AND (NOT IsGenericSystemType (t1)) AND (NOT IsGenericSystemType (t2))
THEN
- IF IsArray(t1) OR IsSet(t1) OR IsRecord(t1)
+ IF IsArray (t1) OR IsSet (t1) OR IsRecord (t1)
THEN
- IF NOT IsAssignmentCompatible(t1, t2)
+ IF NOT IsAssignmentCompatible (t1, t2)
THEN
- MetaErrorT2 (CurrentQuadToken, 'illegal assignment error between {%1Etad} and {%2tad}', op1, op2) ;
+ MetaErrorT2 (virtpos,
+ 'illegal assignment error between {%1Etad} and {%2tad}',
+ des, expr) ;
RETURN( FALSE )
END
END
checkBecomes - returns TRUE if the checks pass.
*)
-PROCEDURE checkBecomes (des, expr: CARDINAL) : BOOLEAN ;
+PROCEDURE checkBecomes (des, expr: CARDINAL; virtpos, despos, exprpos: CARDINAL) : BOOLEAN ;
BEGIN
- IF (NOT checkArrayElements (des, expr)) OR
- (NOT checkRecordTypes (des, expr)) OR
- (NOT checkIncorrectMeta (des, expr))
+ IF (NOT checkArrayElements (des, expr, virtpos, despos, exprpos)) OR
+ (NOT checkRecordTypes (des, expr, virtpos)) OR
+ (NOT checkIncorrectMeta (des, expr, virtpos))
THEN
RETURN FALSE
END ;
VAR
overflowChecking: BOOLEAN ;
op : QuadOperator ;
- op1, op2, op3 : CARDINAL ;
+ des, op2, expr : CARDINAL ;
+ virtpos,
becomespos,
- op1pos,
+ despos,
op2pos,
- op3pos : CARDINAL ;
+ exprpos : CARDINAL ;
length,
- op3t : Tree ;
+ exprt : Tree ;
location : location_t ;
BEGIN
- GetQuadOtok (quad, becomespos, op, op1, op2, op3, overflowChecking,
- op1pos, op2pos, op3pos) ;
+ GetQuadOtok (quad, becomespos, op, des, op2, expr, overflowChecking,
+ despos, op2pos, exprpos) ;
Assert (op2pos = UnknownTokenNo) ;
- DeclareConstant (CurrentQuadToken, op3) ; (* Check to see whether op3 is a constant and declare it. *)
- DeclareConstructor (CurrentQuadToken, quad, op3) ;
- location := TokenToLocation (CurrentQuadToken) ;
+ DeclareConstant (exprpos, expr) ; (* Check to see whether expr is a constant and declare it. *)
+ DeclareConstructor (exprpos, quad, expr) ;
+ virtpos := MakeVirtualTok (becomespos, despos, exprpos) ;
+ location := TokenToLocation (virtpos) ;
IF StrictTypeChecking AND
- (NOT AssignmentTypeCompatible (CurrentQuadToken, "", op1, op3))
+ (NOT AssignmentTypeCompatible (virtpos, "", des, expr))
THEN
- MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos),
+ MetaErrorT2 (virtpos,
'assignment check caught mismatch between {%1Ead} and {%2ad}',
- op1, op3)
+ des, expr)
END ;
- IF IsConst (op1) AND (NOT GccKnowsAbout (op1))
+ IF IsConst (des) AND (NOT GccKnowsAbout (des))
THEN
- ConstantKnownAndUsed (op1, CheckConstant (CurrentQuadToken, op1, op3))
- ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char)
+ ConstantKnownAndUsed (des, CheckConstant (virtpos, des, expr))
+ ELSIF IsConstString (expr) AND (SkipTypeAndSubrange (GetType (des)) # Char)
THEN
- checkDeclare (op1) ;
- IF NOT PrepareCopyString (becomespos, length, op3t, op3, SkipType (GetType (op1)))
+ checkDeclare (des) ;
+ IF NOT PrepareCopyString (becomespos, length, exprt, expr, SkipType (GetType (des)))
THEN
- MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos),
+ MetaErrorT2 (virtpos,
'string constant {%1Ea} is too large to be assigned to the array {%2ad}',
- op3, op1)
+ expr, des)
END ;
AddStatement (location,
- MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
- BuildAddr (location, Mod2Gcc (op1), FALSE),
- BuildAddr (location, op3t, FALSE),
+ MaybeDebugBuiltinMemcpy (location, virtpos,
+ BuildAddr (location, Mod2Gcc (des), FALSE),
+ BuildAddr (location, exprt, FALSE),
length))
ELSE
- IF ((IsGenericSystemType(SkipType(GetType(op1))) #
- IsGenericSystemType(SkipType(GetType(op3)))) OR
- (IsUnbounded(SkipType(GetType(op1))) AND
- IsUnbounded(SkipType(GetType(op3))) AND
- (IsGenericSystemType(SkipType(GetType(GetType(op1)))) #
- IsGenericSystemType(SkipType(GetType(GetType(op3))))))) AND
- (NOT IsConstant(op3))
- THEN
- checkDeclare (op1) ;
+ IF ((IsGenericSystemType(SkipType(GetType(des))) #
+ IsGenericSystemType(SkipType(GetType(expr)))) OR
+ (IsUnbounded(SkipType(GetType(des))) AND
+ IsUnbounded(SkipType(GetType(expr))) AND
+ (IsGenericSystemType(SkipType(GetType(GetType(des)))) #
+ IsGenericSystemType(SkipType(GetType(GetType(expr))))))) AND
+ (NOT IsConstant(expr))
+ THEN
+ checkDeclare (des) ;
AddStatement (location,
- MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
- BuildAddr(location, Mod2Gcc (op1), FALSE),
- BuildAddr(location, Mod2Gcc (op3), FALSE),
- BuildSize(location, Mod2Gcc (op1), FALSE)))
+ MaybeDebugBuiltinMemcpy (location, virtpos,
+ BuildAddr(location, Mod2Gcc (des), FALSE),
+ BuildAddr(location, Mod2Gcc (expr), FALSE),
+ BuildSize(location, Mod2Gcc (des), FALSE)))
ELSE
- IF checkBecomes (op1, op3)
+ IF checkBecomes (des, expr, virtpos, despos, exprpos)
THEN
- IF IsVariableSSA (op1)
+ IF IsVariableSSA (des)
THEN
- Replace (op1, FoldConstBecomes (CurrentQuadToken, op1, op3))
+ Replace (des, FoldConstBecomes (virtpos, des, expr))
ELSE
BuildAssignmentStatement (location,
- Mod2Gcc (op1),
- FoldConstBecomes (CurrentQuadToken, op1, op3))
+ Mod2Gcc (des),
+ FoldConstBecomes (virtpos, des, expr))
END
ELSE
SubQuad (quad) (* we don't want multiple errors for the quad. *)
(*
- CodeBinarySet - encode a binary set arithmetic operation.
- Set operands may be longer than a word.
+ NoWalkProcedure -
*)
-PROCEDURE CodeBinarySet (binop: BuildBinProcedure; doOp: DoProcedure;
- quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE NoWalkProcedure (param: CARDINAL) ;
+BEGIN
+END NoWalkProcedure ;
+
+
+(*
+ CheckBinaryExpressionTypes - returns TRUE if all expression checks pass.
+ If the expression check fails quad is removed,
+ the walk procedure (des) is called and NoChange is
+ set to FALSE.
+*)
+
+PROCEDURE CheckBinaryExpressionTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ;
VAR
- location: location_t ;
+ lefttype,
+ righttype,
+ des, left, right: CARDINAL ;
+ overflowChecking: BOOLEAN ;
+ despos, leftpos,
+ rightpos,
+ operatorpos,
+ subexprpos : CARDINAL ;
+ op : QuadOperator ;
BEGIN
- (* firstly ensure that constant literals are declared *)
- DeclareConstant(CurrentQuadToken, op3) ;
- DeclareConstant(CurrentQuadToken, op2) ;
- DeclareConstructor(CurrentQuadToken, quad, op3) ;
- DeclareConstructor(CurrentQuadToken, quad, op2) ;
- location := TokenToLocation(CurrentQuadToken) ;
+ GetQuadOtok (quad, operatorpos, op,
+ des, left, right, overflowChecking,
+ despos, leftpos, rightpos) ;
+ IF ((op # LogicalRotateOp) AND (op # LogicalShiftOp))
+ THEN
+ subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
+ lefttype := GetType (left) ;
+ righttype := GetType (right) ;
+ IF StrictTypeChecking AND
+ (NOT ExpressionTypeCompatible (subexprpos, "", lefttype, righttype,
+ StrictTypeChecking, FALSE))
+ THEN
+ MetaErrorT2 (subexprpos,
+ 'expression mismatch between {%1Etad} and {%2tad}',
+ left, right) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ p (des) ;
+ RETURN FALSE
+ END ;
+ (* --fixme-- the ExpressionTypeCompatible above should be enough
+ and the code below can be removed once ExpressionTypeCompatible
+ is bug free. *)
+ IF NOT IsExpressionCompatible (lefttype, righttype)
+ THEN
+ MetaErrorT2 (subexprpos,
+ 'expression mismatch between {%1Etad} and {%2tad}',
+ left, right) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ p (des) ;
+ RETURN FALSE
+ END
+ END ;
+ RETURN TRUE
+END CheckBinaryExpressionTypes ;
- IF IsConst(op1)
+
+(*
+ CheckElementSetTypes - returns TRUE if all expression checks pass.
+ If the expression check fails quad is removed,
+ the walk procedure (des) is called and NoChange is
+ set to FALSE.
+*)
+
+PROCEDURE CheckElementSetTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ;
+VAR
+ lefttype,
+ righttype,
+ ignore, left, right: CARDINAL ;
+ overflowChecking: BOOLEAN ;
+ ignorepos,
+ leftpos,
+ rightpos,
+ operatorpos,
+ subexprpos : CARDINAL ;
+ op : QuadOperator ;
+BEGIN
+ GetQuadOtok (quad, operatorpos, op,
+ left, right, ignore, overflowChecking,
+ leftpos, rightpos, ignorepos) ;
+ subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
+ lefttype := GetType (left) ;
+ righttype := GetType (right) ;
+ (* --fixme-- the ExpressionTypeCompatible below does not always catch
+ type errors, it needs to be fixed and then some of the subsequent tests
+ can be removed (and/or this procedure function rewritten). *)
+ IF StrictTypeChecking AND
+ (NOT ExpressionTypeCompatible (subexprpos, "", lefttype, righttype,
+ StrictTypeChecking, TRUE))
THEN
- IF IsValueSolved(op2) AND IsValueSolved(op3)
- THEN
- Assert(MixTypes(FindType(op3), FindType(op2), CurrentQuadToken)#NulSym) ;
- PutConst(op1, FindType(op3)) ;
- PushValue(op2) ;
- PushValue(op3) ;
- doOp(CurrentQuadToken) ;
- PopValue(op1) ;
- PutConstSet(op1) ;
+ MetaErrorT2 (subexprpos,
+ 'the types used in expression {%1Etad} {%kIN} {%2tad} are incompatible',
+ left, right) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ RETURN FALSE
+ END ;
+ IF (righttype = NulSym) OR (NOT IsSet (SkipType (righttype)))
+ THEN
+ MetaErrorT1 (rightpos,
+ 'an {%kIN} expression is expecting {%1Etad} to be a {%kSET} type',
+ right) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ RETURN FALSE
+ END ;
+ righttype := GetType (SkipType (righttype)) ;
+ (* Now fall though and compare the set element left against the type of set righttype. *)
+ IF NOT IsExpressionCompatible (lefttype, righttype)
+ THEN
+ MetaErrorT2 (subexprpos,
+ 'the types used in expression {%1Etad} {%kIN} {%2tad} are incompatible',
+ left, right) ;
+ NoChange := FALSE ;
+ SubQuad (quad) ;
+ RETURN FALSE
+ END ;
+ RETURN TRUE
+END CheckElementSetTypes ;
+
+
+(*
+ CodeBinarySet - encode a binary set arithmetic operation.
+ Set operands may be longer than a word.
+*)
+
+PROCEDURE CodeBinarySet (binop: BuildBinProcedure; doOp: DoProcedure;
+ quad: CARDINAL) ;
+VAR
+ location : location_t ;
+ overflowChecking: BOOLEAN ;
+ op : QuadOperator ;
+ virttoken,
+ virtexpr,
+ des,
+ left,
+ right,
+ despos,
+ leftpos,
+ rightpos,
+ operatorpos : CARDINAL ;
+BEGIN
+ GetQuadOtok (quad, operatorpos, op, des, left, right, overflowChecking,
+ despos, leftpos, rightpos) ;
+
+ (* Firstly ensure that constant literals are declared. *)
+ DeclareConstant (rightpos, right) ;
+ DeclareConstant (leftpos, left) ;
+ DeclareConstructor (rightpos, quad, right) ;
+ DeclareConstructor (leftpos, quad, left) ;
+
+ virttoken := MakeVirtualTok (operatorpos, despos, rightpos) ;
+ location := TokenToLocation (virttoken) ;
+ IF CheckBinaryExpressionTypes (quad, NoWalkProcedure)
+ THEN
+ IF IsConst (des)
+ THEN
+ virtexpr := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
+ IF IsValueSolved (left) AND IsValueSolved (right)
+ THEN
+ Assert (MixTypes (FindType (right), FindType (left), virtexpr) # NulSym) ;
+ PutConst (des, FindType (right)) ;
+ PushValue (left) ;
+ PushValue (right) ;
+ doOp (virttoken) ;
+ PopValue (des) ;
+ PutConstSet (des)
+ ELSE
+ MetaErrorT0 (virtexpr, '{%E}constant expression cannot be evaluated')
+ END
ELSE
- MetaErrorT0 (CurrentQuadToken,
- '{%E}constant expression cannot be evaluated')
+ checkDeclare (des) ;
+ BuildBinaryForeachWordDo (location,
+ Mod2Gcc (SkipType (GetType (des))),
+ Mod2Gcc (des), Mod2Gcc (left), Mod2Gcc (right), binop,
+ GetMode (des) = LeftValue,
+ GetMode (left) = LeftValue,
+ GetMode (right) = LeftValue,
+ IsConst (des),
+ IsConst (left),
+ IsConst (right))
END
- ELSE
- checkDeclare (op1) ;
- BuildBinaryForeachWordDo(location,
- Mod2Gcc(SkipType(GetType(op1))),
- Mod2Gcc(op1), Mod2Gcc(op2), Mod2Gcc(op3), binop,
- GetMode(op1)=LeftValue,
- GetMode(op2)=LeftValue,
- GetMode(op3)=LeftValue,
- IsConst(op1),
- IsConst(op2),
- IsConst(op3))
END
END CodeBinarySet ;
TryDeclareConstant(tokenno, op3) ;
location := TokenToLocation(tokenno) ;
- IF IsConst(op2) AND IsConstSet(op2) AND
- IsConst(op3) AND IsConstSet(op3) AND
- IsConst(op1)
+ IF CheckBinaryExpressionTypes (quad, p)
THEN
- IF IsValueSolved(op2) AND IsValueSolved(op3)
+ IF IsConst(op2) AND IsConstSet(op2) AND
+ IsConst(op3) AND IsConstSet(op3) AND
+ IsConst(op1)
THEN
- Assert(MixTypes(FindType(op3), FindType(op2), tokenno)#NulSym) ;
- PutConst(op1, MixTypes(FindType(op3), FindType(op2), tokenno)) ;
- PushValue(op2) ;
- PushValue(op3) ;
- op(tokenno) ;
- PopValue(op1) ;
- PushValue(op1) ;
- PutConstSet(op1) ;
- AddModGcc(op1,
- DeclareKnownConstant(location,
- Mod2Gcc(GetType(op3)),
- PopSetTree(tokenno))) ;
- p(op1) ;
- NoChange := FALSE ;
- SubQuad(quad)
+ IF IsValueSolved(op2) AND IsValueSolved(op3)
+ THEN
+ Assert(MixTypes(FindType(op3), FindType(op2), tokenno)#NulSym) ;
+ PutConst(op1, MixTypes(FindType(op3), FindType(op2), tokenno)) ;
+ PushValue(op2) ;
+ PushValue(op3) ;
+ op(tokenno) ;
+ PopValue(op1) ;
+ PushValue(op1) ;
+ PutConstSet(op1) ;
+ AddModGcc(op1,
+ DeclareKnownConstant(location,
+ Mod2Gcc(GetType(op3)),
+ PopSetTree(tokenno))) ;
+ p(op1) ;
+ NoChange := FALSE ;
+ SubQuad(quad)
+ END
END
END
END FoldBinarySet ;
CodeSetOr - encode set arithmetic or.
*)
-PROCEDURE CodeSetOr (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetOr (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalOr, SetOr, quad, op1, op2, op3)
+ CodeBinarySet (BuildLogicalOr, SetOr, quad)
END CodeSetOr ;
CodeSetAnd - encode set arithmetic and.
*)
-PROCEDURE CodeSetAnd (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetAnd (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalAnd, SetAnd, quad, op1, op2, op3)
+ CodeBinarySet (BuildLogicalAnd, SetAnd, quad)
END CodeSetAnd ;
CodeSetLogicalDifference - encode set arithmetic logical difference.
*)
-PROCEDURE CodeSetLogicalDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetLogicalDifference (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalDifference, SetDifference,
- quad, op1, op2, op3)
+ CodeBinarySet (BuildLogicalDifference, SetDifference, quad)
END CodeSetLogicalDifference ;
CodeSetSymmetricDifference - code set difference.
*)
-PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildSymmetricDifference, SetSymmetricDifference,
- quad, op1, op2, op3)
+ CodeBinarySet (BuildSymmetricDifference, SetSymmetricDifference, quad)
END CodeSetSymmetricDifference ;
THEN
IF IsValueSolved (left) AND IsValueSolved (right)
THEN
- (* fine, we can take advantage of this and evaluate the condition *)
- PushValue (right) ;
- IF SetIn (tokenno, left)
+ IF CheckBinaryExpressionTypes (quad, NoWalkProcedure)
THEN
- PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+ (* fine, we can take advantage of this and evaluate the condition *)
+ PushValue (right) ;
+ IF SetIn (tokenno, left)
+ THEN
+ PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+ ELSE
+ SubQuad (quad)
+ END
ELSE
SubQuad (quad)
END
THEN
IF IsValueSolved (left) AND IsValueSolved (right)
THEN
- (* fine, we can take advantage of this and evaluate the condition *)
- PushValue (right) ;
- IF NOT SetIn (tokenno, left)
+ IF CheckBinaryExpressionTypes (quad, NoWalkProcedure)
THEN
- PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+ (* fine, we can take advantage of this and evaluate the condition *)
+ PushValue (right) ;
+ IF NOT SetIn (tokenno, left)
+ THEN
+ PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+ ELSE
+ SubQuad (quad)
+ END
ELSE
SubQuad (quad)
END
IF IsConst(op1) AND IsConst(op2)
THEN
InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
- ELSE
+ ELSIF CheckElementSetTypes (quad, NoWalkProcedure)
+ THEN
IF IsConst(op1)
THEN
fieldno := GetFieldNo(CurrentQuadToken, op1, GetType(op2), offset) ;
IF IsConst(op1) AND IsConst(op2)
THEN
InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
- ELSE
+ ELSIF CheckElementSetTypes (quad, NoWalkProcedure)
+ THEN
IF IsConst(op1)
THEN
fieldno := GetFieldNo(CurrentQuadToken, op1, SkipType(GetType(op2)), offset) ;
projects / thirdparty / gcc.git / commitdiff
