MODULEWe try to evaluate all expressions which can be evaluated at compile time. This code handles both items which must be constant (e.g. the expression in a constant declaration) and also normal expressions which happen to be constant. Note that there are some differences between constant folding in normal expressions and evaluating constant expressions. e.g. CONST C = BYTESIZE(v^); is illegal and must not be evaluated due to potential recursion. On the other hand in: FOR i := 0 TO BYTESIZE(v^) DO It is ok to try and evaluate BYTESIZE; IMPORT Text, Fmt; IMPORT AST, M3AST_AS, M3AST_SM; IMPORT M3AST_AS_F, M3AST_SM_F, M3AST_TM_F; IMPORT SeqM3AST_AS_M3TYPE, SeqM3AST_AS_RANGE_EXP, SeqM3AST_AS_EXP, SeqM3AST_AS_Actual, SeqM3AST_AS_CONS_ELEM; IMPORT M3ASTNext; IMPORT M3CLiteral; IMPORT ASTWalk; IMPORT M3Error, M3Assert; IMPORT M3CStdProcs, M3CWordProcs, M3CStdTypes; IMPORT M3CTypesMisc; IMPORT M3COrdinal; IMPORT M3CExpsMisc; IMPORT M3CBackEnd, M3CBitSize; M3CExpValue
Useful constants
CONST ExpOrType = M3CExpsMisc.ClassSet{M3CExpsMisc.Class.Normal, M3CExpsMisc.Class.Type}; (* Useful when checking actuals to built in functions; these are the only classes we are ever interested in *)Simple utility routines
PROCEDUREEvaluating constant expressions recursively; needs to be done to handle forward referencesBackEndFailure (e: M3AST_AS.EXP; ns: M3CBackEnd.NumStatus) RAISES {}= BEGIN IF ns = M3CBackEnd.NumStatus.Unknown THEN M3Error.Report(e, "expression cannot be evaluated"); ELSIF ns = M3CBackEnd.NumStatus.Overflow THEN M3Error.Report(e, "expression overflow"); END; (* if *) END BackEndFailure; <*INLINE*> PROCEDUREChkVal (e: M3AST_AS.EXP; ns: M3CBackEnd.NumStatus) RAISES {}= BEGIN IF ns # M3CBackEnd.NumStatus.Valid THEN BackEndFailure(e, ns) END; END ChkVal; <*INLINE*> PROCEDUREValIsOK ( e: M3AST_AS.EXP; ns: M3CBackEnd.NumStatus) : BOOLEAN RAISES {}= BEGIN IF ns = M3CBackEnd.NumStatus.Valid THEN RETURN TRUE; ELSE BackEndFailure(e, ns); RETURN TRUE; END; END ValIsOK; PROCEDUREConvertToInt ( e: M3AST_SM.Exp_value; VAR er: M3AST_SM.Exp_value) : M3CBackEnd.NumStatus RAISES {}= BEGIN RETURN M3CBackEnd.ConvertOrdinal(e, M3CStdTypes.Integer(), er); END ConvertToInt; TYPE Mode = {Walk, WalkConst, Recursive}; ModeSet = SET OF Mode; <*INLINE*> PROCEDUREEvalComponent ( e: M3AST_AS.EXP; mode: ModeSet) : M3AST_SM.Exp_value RAISES {}= BEGIN IF Mode.Recursive IN mode THEN RETURN Eval(e, mode); ELSE RETURN e.sm_exp_value; END; END EvalComponent; <*INLINE*> PROCEDURELiteralLastChar (l: M3CLiteral.T): CHAR RAISES {}= VAR t := M3CLiteral.ToText(l); BEGIN (* Assert: lexer guarantees length of literal is never 0 *) RETURN Text.GetChar(t, Text.Length(t) - 1); END LiteralLastChar; PROCEDURENotConstant (e: M3AST_AS.EXP) RAISES {}= BEGIN M3Error.Report(e, "expression is not constant"); END NotConstant;
PROCEDUREGetValueForUsedId ( id: M3AST_AS.Exp_used_id; ccv_id: M3AST_SM.CCV_ID) : M3AST_SM.Exp_value RAISES {}=
'ccv_id' must always be the CCV_ID field of the 'sm_def' of 'id' and the def of 'id' must always be a constant or enumeration id
VAR er: M3AST_SM.Exp_value; BEGIN (* This sets id.sm_exp_value and returns the same value. *) er := ccv_id.sm_exp_value; IF er = NIL THEN TYPECASE id.vUSED_ID.sm_def OF <*NOWARN*> | M3AST_AS.Const_id(constId) => (* Const_ids can be (recursively) computed through the sm_init_exp attribute, but watch for illegal recursive declarations. *) IF NOT constId.tmp_recursive THEN er := Eval(constId.vINIT_ID.sm_init_exp, ModeSet{Mode.Recursive}); ccv_id.sm_exp_value := er; END; | M3AST_AS.Enum_id => (* Should have been precomputed in M3CTypeSpec pass1; if we get here there has been an error; leave 'er' at NIL *) END; (* typecase *) END; (* if *) id.sm_exp_value := er; RETURN er; END GetValueForUsedId;Type utilities
PROCEDUREUsefulIsOrdinal ( VAR ts: M3AST_SM.TYPE_SPEC_UNSET) : BOOLEAN RAISES {}= VAR void: M3AST_SM.TYPE_SPEC_UNSET; BEGIN LOOP TYPECASE ts OF | NULL => RETURN FALSE; | M3AST_AS.Packed_type(packed) => (* We handle this rather than leaving it to 'M3COrdinal' because we want to return FALSE if 'ts' is NIL *) ts := M3CTypesMisc.Unpack(packed); ELSE RETURN M3COrdinal.Is(ts, void); END; END; END IsOrdinal; PROCEDUREIsOrdinalFloatOrArrayType ( VAR (*inout*) ts: M3AST_SM.TYPE_SPEC_UNSET) : BOOLEAN RAISES {}= BEGIN ts := M3CTypesMisc.CheckedUnpack(ts); TYPECASE ts OF | NULL => RETURN FALSE; | M3AST_AS.Array_type(arrayType) => VAR iter := SeqM3AST_AS_M3TYPE.NewIter(arrayType.as_indextype_s); it: M3AST_AS.M3TYPE; BEGIN IF SeqM3AST_AS_M3TYPE.Next(iter, it) THEN M3CTypesMisc.GetTYPE_SPECFromM3TYPE(it, ts); ELSE (* open array/error *) ts := NIL; RETURN FALSE; END; (* if *) END; | M3AST_AS.FLOAT_TYPE => RETURN TRUE; ELSE END; (* if *) RETURN IsOrdinal(ts); END IsOrdinalFloatOrArrayType;
constants
. They are not initialized immediately to avoid problems
with complicated intialization order
VAR minus_g: M3AST_AS.Minus := NIL; plus_g: M3AST_AS.Plus := NIL; zero_g, one_g: M3AST_SM.Exp_value := NIL; PROCEDUREConstructing boolean resultsMinus (): M3AST_AS.Minus RAISES {}= BEGIN IF minus_g = NIL THEN minus_g := NEW(M3AST_AS.Minus).init() END; RETURN minus_g; END Minus; PROCEDUREPlus (): M3AST_AS.Plus RAISES {}= BEGIN IF plus_g = NIL THEN plus_g := NEW(M3AST_AS.Plus).init() END; RETURN plus_g; END Plus; PROCEDUREZero (): M3AST_SM.Exp_value RAISES {}= BEGIN IF zero_g = NIL THEN EVAL M3CBackEnd.Val(0, M3CStdTypes.Integer(), zero_g); END; RETURN zero_g; END Zero; PROCEDUREOne (): M3AST_SM.Exp_value RAISES {}= BEGIN IF one_g = NIL THEN EVAL M3CBackEnd.Val(1, M3CStdTypes.Integer(), one_g); END; RETURN one_g; END One;
PROCEDUREExported utility routinesNewBoolean (b: BOOLEAN): M3AST_SM.Exp_value RAISES {}= VAR er: M3AST_SM.Exp_value; BEGIN M3Assert.Check(M3CBackEnd.Val(ORD(b), M3CStdTypes.Boolean(), er) = M3CBackEnd.NumStatus.Valid); RETURN er; END NewBoolean;
PROCEDUREConstructor operations. Operations on constructors can usually be handled portably so they are done here rather than in 'M3CBackEnd'GetBounds ( ts: M3AST_SM.TYPE_SPEC_UNSET; VAR low, high: M3AST_SM.Exp_value) : M3CBackEnd.NumStatus RAISES {}= BEGIN TYPECASE M3CTypesMisc.CheckedUnpack(ts) OF | NULL => RETURN M3CBackEnd.NumStatus.Unknown | M3AST_AS.Integer_type(integerType) => EVAL M3CBackEnd.StdUnaryTypeOp(M3CStdProcs.T.First, integerType, low); EVAL M3CBackEnd.StdUnaryTypeOp(M3CStdProcs.T.Last, integerType, high); RETURN M3CBackEnd.NumStatus.Valid; | M3AST_AS.Longint_type(longintType) => EVAL M3CBackEnd.StdUnaryTypeOp(M3CStdProcs.T.First, longintType, low); EVAL M3CBackEnd.StdUnaryTypeOp(M3CStdProcs.T.Last, longintType, high); RETURN M3CBackEnd.NumStatus.Valid; | M3AST_AS.WideChar_type(wideCharType) => EVAL M3CBackEnd.StdUnaryTypeOp(M3CStdProcs.T.First, wideCharType, low); EVAL M3CBackEnd.StdUnaryTypeOp(M3CStdProcs.T.Last, wideCharType, high); RETURN M3CBackEnd.NumStatus.Valid; | M3AST_AS.Enumeration_type(enumType) => VAR ord := enumType.sm_num_elements; BEGIN IF ord = 0 THEN RETURN M3CBackEnd.NumStatus.Unknown END; M3Assert.Check(ord > 0 AND M3CBackEnd.ConvertOrdinal(Zero(), enumType, low) = M3CBackEnd.NumStatus.Valid AND M3CBackEnd.Val(ord-1, enumType, high) = M3CBackEnd.NumStatus.Valid); RETURN M3CBackEnd.NumStatus.Valid; END; | M3AST_AS.Subrange_type(subrangeType) => (* Must eval the expressions in case forward refs *) VAR e1 := Eval(subrangeType.as_range.as_exp1, ModeSet{Mode.Recursive}); e2 := Eval(subrangeType.as_range.as_exp2, ModeSet{Mode.Recursive}); BEGIN IF M3COrdinal.ValidBounds(subrangeType, e1, e2) THEN low := e1; high := e2; RETURN M3CBackEnd.NumStatus.Valid; ELSE (* Bounds have not both been evaluated or are not compatible *) RETURN M3CBackEnd.NumStatus.Unknown; END; END; ELSE RETURN M3CBackEnd.NumStatus.Unknown END; END GetBounds; PROCEDURENumber ( ts: M3AST_SM.TYPE_SPEC_UNSET; VAR (*out*) number: M3AST_SM.Exp_value) : M3CBackEnd.NumStatus RAISES {}= BEGIN TYPECASE M3CTypesMisc.CheckedUnpack(ts) OF | NULL => RETURN M3CBackEnd.NumStatus.Unknown; | M3AST_AS.INT_TYPE => RETURN M3CBackEnd.NumStatus.Overflow | M3AST_AS.WideChar_type(wideCharType) => RETURN M3CBackEnd.Val(NUMBER(WIDECHAR), wideCharType, number); | M3AST_AS.Enumeration_type(enumType) => RETURN M3CBackEnd.Val(enumType.sm_num_elements, enumType, number); | M3AST_AS.Subrange_type => VAR low, high, diff: M3AST_SM.Exp_value; BEGIN IF GetBounds(ts, low, high) # M3CBackEnd.NumStatus.Valid OR ConvertToInt(low, low) # M3CBackEnd.NumStatus.Valid OR ConvertToInt(high, high) # M3CBackEnd.NumStatus.Valid THEN RETURN M3CBackEnd.NumStatus.Unknown; END; WITH compare = M3CBackEnd.Compare(low, high) DO IF compare = 0 THEN number := One(); RETURN M3CBackEnd.NumStatus.Valid; ELSIF compare > 0 THEN number := Zero(); RETURN M3CBackEnd.NumStatus.Valid; END; END; WITH valid = M3CBackEnd.BinaryOp(Minus(), high, low, diff) DO IF valid # M3CBackEnd.NumStatus.Valid THEN RETURN valid END; END; RETURN M3CBackEnd.BinaryOp(Plus(), diff, One(), number); END; ELSE RETURN M3CBackEnd.NumStatus.Unknown; END; END Number; <*INLINE*> PROCEDUREOrdinal ( e: M3AST_AS.EXP; VAR (*out*) i: INTEGER) : M3CBackEnd.NumStatus RAISES {}= BEGIN IF M3CBackEnd.IsOrdinal(e.sm_exp_value) THEN RETURN M3CBackEnd.Ord(e.sm_exp_value, i); ELSE RETURN M3CBackEnd.NumStatus.Unknown; END; END Ordinal;
PROCEDURESelection ( lhs: M3AST_AS.EXP; fieldId: M3AST_AS.Field_id) : M3AST_SM.Exp_value RAISES {}=
Only called if 'lhs' is known to be constant
BEGIN TYPECASE M3CTypesMisc.CheckedUnpack(lhs.sm_exp_type_spec) OF | M3AST_AS.Record_type(recordType) => VAR iterFields := M3ASTNext.NewIterField(recordType.as_fields_s); search: M3AST_AS.Field_id; iterRangeExps := SeqM3AST_AS_RANGE_EXP.NewIter( M3CBackEnd.ConstructorOriginal(lhs.sm_exp_value).sm_actual_s); rangeExp: M3AST_AS.RANGE_EXP; BEGIN WHILE M3ASTNext.Field(iterFields, search) AND SeqM3AST_AS_RANGE_EXP.Next(iterRangeExps, rangeExp) DO IF search = fieldId THEN TYPECASE rangeExp OF | M3AST_AS.Range_EXP(rExp) => RETURN rExp.as_exp.sm_exp_value; ELSE END; RETURN NIL; END; END; RETURN NIL; END; ELSE (* Ref record or object - result of dereferencing it is not constant *) RETURN NIL; END; END Selection; PROCEDUREIndex ( index: M3AST_AS.Index; mode: ModeSet) : M3AST_SM.Exp_value RAISES {}=
Called only if 'index.as_array' is known to be constant (so, obviously, 'Eval' must have been called on 'index.as_array). The index expressions have not yet been evaluated, unless 'componentsKnown' is TRUE. No check has been done on the type of 'index.as_array'.
VAR er: M3AST_SM.Exp_value := NIL; arrayExp := index.as_array; arrayExpType := arrayExp.sm_exp_type_spec; iter := SeqM3AST_AS_EXP.NewIter(index.as_exp_s); exp: M3AST_AS.EXP; BEGIN WHILE SeqM3AST_AS_EXP.Next(iter, exp) DO TYPECASE M3CTypesMisc.CheckedUnpack(arrayExpType) OF | NULL => RETURN NIL; | M3AST_AS.Array_type(arrayType) => VAR ix := EvalComponent(exp, mode); ixType: M3AST_SM.TYPE_SPEC_UNSET; low, high, diff: M3AST_SM.Exp_value; ixInt: INTEGER; BEGIN IF NOT M3CBackEnd.IsOrdinal(ix) THEN RETURN NIL END; CASE M3CTypesMisc.Index(arrayType, ixType) OF | M3CTypesMisc.Ix.Ordinal => TYPECASE ixType OF | M3AST_AS.Subrange_type => IF NOT ValIsOK(index, GetBounds(ixType, low, high)) THEN RETURN NIL; END; ELSE low := Zero(); END; | M3CTypesMisc.Ix.Open => low := Zero(); ELSE RETURN NIL; END; IF NOT (M3CBackEnd.Compare(low, ix) <= 0 AND ValIsOK(index, ConvertToInt(ix, ix)) AND ValIsOK(index, ConvertToInt(low, low)) AND ValIsOK(index, M3CBackEnd.BinaryOp(Minus(), ix, low, diff)) AND ValIsOK(index, M3CBackEnd.Ord(diff, ixInt))) THEN RETURN NIL; END; VAR constructor := M3CBackEnd.ConstructorOriginal(arrayExp.sm_exp_value); iter := SeqM3AST_AS_RANGE_EXP.NewIter(constructor.sm_actual_s); rangeExp: M3AST_AS.RANGE_EXP; count := -1; BEGIN REPEAT IF SeqM3AST_AS_RANGE_EXP.Next(iter, rangeExp) THEN INC(count); ELSE IF count < 0 OR constructor.as_propagate = NIL THEN RETURN NIL; ELSE EXIT; END; END; UNTIL count = ixInt; TYPECASE rangeExp OF | M3AST_AS.Range_EXP(rExp) => (* Note constructor cannot contain NIL elements or its 'sm_exp_value' field would not have been set up *) arrayExp := rExp.as_exp; M3CTypesMisc.GetTYPE_SPECFromM3TYPE( arrayType.sm_norm_type.as_elementtype, arrayExpType); er := arrayExp.sm_exp_value; ELSE RETURN NIL; END; END; END; ELSE (* 'arrayExp' does not have array type; if it's a ref array we can't index it in a constant expression; if it's anything else we can't index it at all *) RETURN NIL; END; END; (* while *) RETURN er; END Index; PROCEDUREEqualConstructors (e1, e2: M3AST_AS.EXP): BOOLEAN RAISES {}=
Only called if both 'e1' and 'e2' are known to be constant and either both arrays or both records
VAR c1 := M3CBackEnd.ConstructorOriginal(e1.sm_exp_value); c2 := M3CBackEnd.ConstructorOriginal(e2.sm_exp_value); iter1 := SeqM3AST_AS_RANGE_EXP.NewIter(c1.sm_actual_s); iter2 := SeqM3AST_AS_RANGE_EXP.NewIter(c2.sm_actual_s); re1, re2: M3AST_AS.RANGE_EXP; exp1, exp2: M3AST_AS.EXP; b1, b2: BOOLEAN; BEGIN LOOP b1 := SeqM3AST_AS_RANGE_EXP.Next(iter1, re1); b2 := SeqM3AST_AS_RANGE_EXP.Next(iter2, re2); IF b1 # b2 THEN EXIT END; IF NOT b1 THEN RETURN TRUE END; IF re1 = NIL OR re2 = NIL THEN RETURN FALSE END; TYPECASE re1 OF | M3AST_AS.Range_EXP(rangeExp1) => exp1 := rangeExp1.as_exp; IF exp1 = NIL THEN RETURN FALSE END; TYPECASE re2 OF | M3AST_AS.Range_EXP(rangeExp2) => exp2 := rangeExp2.as_exp; IF exp2 = NIL OR NOT Equal(exp1, exp2) THEN RETURN FALSE END; ELSE RETURN FALSE; END; ELSE RETURN FALSE; END; END; VAR iter: SeqM3AST_AS_RANGE_EXP.Iter; re: M3AST_AS.RANGE_EXP; mustPropagate: M3AST_AS.Constructor; propagated: M3AST_AS.EXP; BEGIN IF b1 THEN mustPropagate := c2; propagated := exp2; iter := iter1; re := re1; ELSE mustPropagate := c1; propagated := exp1; iter := iter2; re := re2; END; IF mustPropagate.as_propagate = NIL THEN RETURN FALSE END; REPEAT TYPECASE re OF | NULL => RETURN FALSE; | M3AST_AS.Range_EXP(rangeExp) => IF rangeExp.as_exp = NIL OR NOT Equal(rangeExp.as_exp, propagated) THEN RETURN FALSE; END; ELSE RETURN FALSE; END; UNTIL NOT SeqM3AST_AS_RANGE_EXP.Next(iter, re); RETURN TRUE; END; END EqualConstructors; PROCEDUREHandling calls of the built in functions (i.e. the operations which look like function calls) and the 'Word' functionsEqual (e1, e2: M3AST_AS.EXP): BOOLEAN RAISES {}= BEGIN IF e1.sm_exp_value # NIL AND e2.sm_exp_value # NIL THEN TYPECASE M3CTypesMisc.CheckedUnpack(e1.sm_exp_type_spec) OF | M3AST_AS.Array_type => TYPECASE M3CTypesMisc.CheckedUnpack(e2.sm_exp_type_spec) OF | M3AST_AS.Array_type => RETURN EqualConstructors(e1, e2); ELSE RETURN FALSE; END; | M3AST_AS.Record_type => TYPECASE M3CTypesMisc.CheckedUnpack(e2.sm_exp_type_spec) OF | M3AST_AS.Record_type => RETURN EqualConstructors(e1, e2); ELSE RETURN FALSE; END; ELSE RETURN M3CBackEnd.Compare(e1.sm_exp_value, e2.sm_exp_value) = 0; END; ELSE RETURN FALSE; END; END Equal;
PROCEDUREThe main routine for evaluating expressionsEvalActual ( actual: M3AST_AS.Actual; mode: ModeSet) : M3AST_SM.Exp_value RAISES {}= BEGIN TYPECASE actual.as_exp_type OF | M3AST_AS.EXP(exp) => RETURN EvalComponent(exp, mode); ELSE RETURN NIL; END; END EvalActual; PROCEDURECheckActual ( a: M3AST_AS.Actual; VAR ts: M3AST_AS.TYPE_SPEC) : M3CExpsMisc.Class RAISES {}= BEGIN TYPECASE a.as_exp_type OF <*NOWARN*> | M3AST_AS.EXP(exp) => ts := exp.sm_exp_type_spec; RETURN M3CExpsMisc.Classify(exp); | M3AST_AS.Bad_M3TYPE => ts := NIL; RETURN M3CExpsMisc.Class.Type; | M3AST_AS.TYPE_SPEC(typeSpec) => ts := typeSpec; RETURN M3CExpsMisc.Class.Type; END; END CheckActual; <*INLINE*> PROCEDUREIsTypeActual ( a: M3AST_AS.Actual; VAR ts: M3AST_AS.TYPE_SPEC) : BOOLEAN RAISES {}= VAR typeSpec: M3AST_SM.TYPE_SPEC_UNSET; BEGIN IF CheckActual(a, typeSpec) = M3CExpsMisc.Class.Type THEN ts := typeSpec; RETURN TRUE; ELSE RETURN FALSE; END; END IsTypeActual; PROCEDURENotInBounds (val, low, high: M3AST_SM.Exp_value): BOOLEAN RAISES {}= BEGIN RETURN NOT (M3CBackEnd.IsOrdinal(val) AND M3CBackEnd.Compare(low, val) <= 0 AND M3CBackEnd.Compare(val, high) <= 0); END NotInBounds; CONST SpecialCall = M3CStdProcs.ProcFuncSet{ M3CStdProcs.T.First, M3CStdProcs.T.Last, M3CStdProcs.T.Number, M3CStdProcs.T.BitSize, M3CStdProcs.T.ByteSize, M3CStdProcs.T.AdrSize}; (* These calls are special because their arguments can be variables, even in a constant expression. Much code follows to deal with this *) TYPE SpecialCallClosure = ASTWalk.Closure OBJECT error := FALSE; OVERRIDES callback := CheckSpecialCallActual; END; (* object *) <*INLINE*> PROCEDUREIsNonNilRefType ( ts: M3AST_SM.TYPE_SPEC_UNSET) : BOOLEAN RAISES {}= BEGIN RETURN ts # NIL AND M3CTypesMisc.IsRef(ts); END IsNonNilRefType; PROCEDURECheckSpecialCallActual ( cl: SpecialCallClosure; n: AST.NODE; <*UNUSED*> vm: ASTWalk.VisitMode) RAISES {}= VAR error := FALSE; BEGIN TYPECASE n OF | M3AST_AS.Deref => error := TRUE; | M3AST_AS.Index(index) => error := IsNonNilRefType(index.as_array.sm_exp_type_spec); | M3AST_AS.Select(select) => error := M3CExpsMisc.Classify(select) = M3CExpsMisc.Class.Normal AND IsNonNilRefType(select.as_exp.sm_exp_type_spec); | M3AST_AS.Call(call) => VAR pf: M3CStdProcs.T; w: M3CWordProcs.T; BEGIN error := NOT( M3CStdProcs.IsStandardCall(call, pf) AND pf IN M3CStdProcs.AllowedInConstantExpressions OR M3CWordProcs.IsWordCall(call, w)) END; ELSE END; IF error THEN cl.error := TRUE; M3Error.Report(n, "operation not allowed in constant expression"); END; END CheckSpecialCallActual; PROCEDUREEvalSpecialCall ( call: M3AST_AS.Call; pf: M3CStdProcs.T; ts: M3AST_AS.TYPE_SPEC) : M3AST_SM.Exp_value RAISES {}= VAR er: M3AST_SM.Exp_value := NIL; BEGIN CASE pf OF <*NOWARN*> | M3CStdProcs.T.Number, M3CStdProcs.T.First, M3CStdProcs.T.Last => IF IsOrdinalFloatOrArrayType(ts) THEN (* 'IsOrdinalFloatOrArrayType' ensures 'ts' is non NIL *) TYPECASE ts OF <*NOWARN*> | M3AST_AS.INT_TYPE, M3AST_AS.FLOAT_TYPE => IF pf = M3CStdProcs.T.Number THEN BackEndFailure(call, M3CBackEnd.NumStatus.Overflow); ELSE ChkVal(call, M3CBackEnd.StdUnaryTypeOp(pf, ts, er)); END; | M3AST_AS.Subrange_type, M3AST_AS.WideChar_type, M3AST_AS.Enumeration_type => IF pf = M3CStdProcs.T.Number THEN ChkVal(call, Number(ts, er)); ELSE VAR first, last: M3AST_SM.Exp_value; BEGIN IF ValIsOK(call, GetBounds(ts, first, last)) THEN IF pf = M3CStdProcs.T.First THEN er := first; ELSE er := last; END; END; END; END; END; (* case *) END; | M3CStdProcs.T.BitSize, M3CStdProcs.T.ByteSize, M3CStdProcs.T.AdrSize => IF ISTYPE(ts, M3AST_AS.Subrange_type) THEN (* just make sure subranges are evaluated *) VAR first, last: M3AST_SM.Exp_value; BEGIN EVAL GetBounds(ts, first, last); END; END; M3CBitSize.Set(ts); IF ts.sm_bitsize > 0 THEN ChkVal(call, M3CBackEnd.StdUnaryTypeOp(pf, ts, er)); END; END; RETURN er; END EvalSpecialCall; PROCEDURECheckSpecialCall ( call: M3AST_AS.Call; pf: M3CStdProcs.T; cl: Closure) : M3AST_SM.Exp_value RAISES {}= VAR actual := SeqM3AST_AS_Actual.First(call.as_param_s); typeSpec: M3AST_SM.TYPE_SPEC_UNSET; class := CheckActual(actual, typeSpec); BEGIN IF typeSpec = NIL OR NOT class IN ExpOrType THEN (* Error elsewhere *) RETURN NIL; END; IF IsTrulyOpenArray(actual, typeSpec) THEN IF cl # NIL AND cl.node # NIL THEN (* We are tree walking an expression which should be constant; we cannot find the bounds or size of an open array. Ignore children and complain *) ASTWalk.IgnoreChildren(cl); NotConstant(call); ELSE (* Either we have been called from a recursive 'Eval' or when tree walking a non constant expression. In either case we do nothing *) END; (* Value of expression cannot be determined at compile time *) RETURN NIL; ELSE IF class = M3CExpsMisc.Class.Normal THEN (* Expression does not need to be evaluated so if we are in a tree walk we ignore children. *) IF cl # NIL THEN ASTWalk.IgnoreChildren(cl) END; (* If we are being called from a recursive 'Eval' or from a tree walk of a constant expression we must check that this is a valid constant expression. To do this we have to check the argument to the call to make sure it contains no operations which are illegal in constants *) IF cl = NIL OR cl.node # NIL THEN VAR scc := NEW(SpecialCallClosure); BEGIN <*FATAL ANY*> BEGIN ASTWalk.VisitNodes(actual, scc); END; IF scc.error THEN RETURN NIL END; END; END; ELSE (* Argument is a type; any tree walk continues in case type contains nested constant expressions *) END; RETURN EvalSpecialCall(call, pf, typeSpec); END; END CheckSpecialCall; PROCEDUREIsTrulyOpenArray ( actual: M3AST_AS.Actual; VAR (*inout *)ts: M3AST_AS.TYPE_SPEC) : BOOLEAN RAISES {}= BEGIN IF M3CTypesMisc.IsOpenArray(ts) THEN (* permit constants of type open array with fixed length constructors *) TYPECASE actual.as_exp_type OF | NULL => | M3AST_AS.Exp_used_id(id) => TYPECASE id.vUSED_ID.sm_def OF | NULL => | M3AST_AS.Const_id(const_id) => VAR cons := M3CBackEnd.ConstructorOriginal( const_id.vCCV_ID.sm_exp_value); cons_l := SeqM3AST_AS_CONS_ELEM.Length(cons.as_element_s); BEGIN IF cons.as_propagate = NIL AND cons_l > 0 THEN (* fake a non-open array type *) VAR nts: M3AST_AS.Array_type := NEW(M3AST_AS.Array_type).init(); sr: M3AST_AS.Subrange_type := NEW(M3AST_AS.Subrange_type).init(); r: M3AST_AS.Range := NEW(M3AST_AS.Range).init(); BEGIN nts.as_elementtype := NARROW(ts, M3AST_AS.Array_type).as_elementtype; nts.sm_norm_type := nts; SeqM3AST_AS_M3TYPE.AddFront(nts.as_indextype_s, sr); sr.as_range := r; sr.sm_base_type_spec := M3CStdTypes.Integer(); r.as_exp1 := NewInteger_literal(0); r.as_exp2 := NewInteger_literal(cons_l-1); ts := nts; END; (* with *) RETURN FALSE; END; (* if *) END; ELSE END; ELSE END; (* typecase *) RETURN TRUE; ELSE (* not an open array *) RETURN FALSE; END; (* if *) END IsTrulyOpenArray; PROCEDURENewInteger_literal (n: INTEGER): M3AST_AS.Integer_literal= VAR lit: M3AST_AS.Integer_literal := NEW(M3AST_AS.Integer_literal).init(); BEGIN lit.lx_litrep := M3CLiteral.Enter(Fmt.Int(n)); lit.sm_exp_type_spec := M3CStdTypes.Integer(); RETURN lit; END NewInteger_literal; PROCEDUREStandardCall ( call: M3AST_AS.Call; pf: M3CStdProcs.T; mode: ModeSet) : M3AST_SM.Exp_value RAISES {}= VAR er: M3AST_SM.Exp_value := NIL; iterActuals := SeqM3AST_AS_Actual.NewIter(call.as_param_s); actual1, actual2: M3AST_AS.Actual; ev1, ev2: M3AST_SM.Exp_value; ts: M3AST_SM.TYPE_SPEC_UNSET; BEGIN IF NOT SeqM3AST_AS_Actual.Next(iterActuals, actual1) THEN RETURN NIL; END; CASE pf OF <*NOWARN*> | M3CStdProcs.T.Abs .. M3CStdProcs.T.Trunc => ev1 := EvalActual(actual1, mode); IF ev1 # NIL THEN IF pf = M3CStdProcs.T.Float THEN VAR it: M3AST_AS.INT_TYPE := NIL; ft: M3AST_AS.FLOAT_TYPE := NIL; BEGIN IF SeqM3AST_AS_Actual.Next(iterActuals, actual2) THEN TYPECASE actual2.as_exp_type OF | NULL => | M3AST_AS.FLOAT_TYPE(x) => ft := x; | M3AST_AS.INT_TYPE(x) => it := x; ELSE END; (* typecase *) ELSE ft := M3CStdTypes.Real(); END; IF ft # NIL THEN ChkVal(call, M3CBackEnd.StdUnaryOp(pf, ev1, er, it, ft)); END; END; ELSE ChkVal(call, M3CBackEnd.StdUnaryOp(pf, ev1, er)); END; (* if *) END; (* if *) | M3CStdProcs.T.Max, M3CStdProcs.T.Min => IF SeqM3AST_AS_Actual.Next(iterActuals, actual2) THEN ev1 := EvalActual(actual1, mode); ev2 := EvalActual(actual2, mode); IF ev1 # NIL AND ev2 # NIL THEN ChkVal(call, M3CBackEnd.StdBinaryOp(pf, ev1, ev2, er)); END; (* if *) END; | M3CStdProcs.T.Ord => (* input may be int, enum or char *) ev1 := EvalActual(actual1, mode); IF M3CBackEnd.IsOrdinal(ev1) THEN ChkVal(call, ConvertToInt(ev1, er)); END; (* if *) | M3CStdProcs.T.Val => IF SeqM3AST_AS_Actual.Next(iterActuals, actual2) THEN ev1 := EvalActual(actual1, mode); IF M3CBackEnd.IsOrdinal(ev1) AND IsTypeActual(actual2, ts) AND IsOrdinal(ts) THEN (* 'IsOrdinal' ensures 'ts' is non NIL *) VAR boundsOK := FALSE; BEGIN VAR low, high: M3AST_SM.Exp_value; BEGIN IF GetBounds(ts, low, high) = M3CBackEnd.NumStatus.Valid THEN IF NotInBounds(ev1, low, high) THEN M3Error.Report(actual1, "VAL expression out of range for type"); ELSE boundsOK := TRUE; END; END; END; IF boundsOK THEN ChkVal(call, M3CBackEnd.ConvertOrdinal(ev1, ts, er)); END; END; ELSE (* Errant; nothing we can do *) END; (* if *) END; | M3CStdProcs.T.Number, M3CStdProcs.T.First, M3CStdProcs.T.Last, M3CStdProcs.T.BitSize, M3CStdProcs.T.ByteSize, M3CStdProcs.T.AdrSize => er := CheckSpecialCall(call, pf, NIL); END; (* case *) RETURN er; END StandardCall; PROCEDUREWordCall ( call: M3AST_AS.Call; w: M3CWordProcs.T; mode: ModeSet) : M3AST_SM.Exp_value RAISES {}= VAR er: M3AST_SM.Exp_value := NIL; iter := SeqM3AST_AS_EXP.NewIter(call.sm_actual_s); exp: M3AST_AS.EXP; values: ARRAY [0..M3CWordProcs.MaxArgCount-1] OF M3AST_SM.Exp_value; baseType: M3AST_SM.TYPE_SPEC_UNSET; pos: CARDINAL := 0; BEGIN WHILE SeqM3AST_AS_EXP.Next(iter, exp) DO IF pos > LAST(values) OR exp = NIL THEN RETURN NIL END; WITH ev = values[pos] DO ev := EvalComponent(exp, mode); IF NOT (ev # NIL AND M3COrdinal.Is(exp.sm_exp_type_spec, baseType) AND baseType # NIL AND ISTYPE(baseType, M3AST_AS.INT_TYPE)) THEN RETURN NIL; END; END; INC(pos); END; IF pos # M3CWordProcs.ArgCount(w) THEN RETURN NIL END; ChkVal(call, M3CBackEnd.WordOp(w, SUBARRAY(values, 0, pos), er)); RETURN er; END WordCall; PROCEDURECanAppearInConst (defId: M3AST_AS.DEF_ID): BOOLEAN RAISES {}= BEGIN TYPECASE defId OF | M3AST_AS.Var_id, M3AST_AS.Exc_id, M3AST_AS.FORMAL_ID, M3AST_AS.For_id, M3AST_AS.Handler_id, M3AST_AS.Tcase_id, M3AST_AS.With_id => RETURN FALSE; ELSE RETURN TRUE; END; END CanAppearInConst;
PROCEDUREEval ( e: M3AST_AS.EXP; mode: ModeSet) : M3AST_SM.Exp_value RAISES {}= VAR er: M3AST_SM.Exp_value := e.sm_exp_value; error := FALSE; BEGIN (* If already evaluated or type unknown (indicating previous error) we return immediately *) IF er # NIL THEN RETURN er END; IF e.sm_exp_type_spec = NIL THEN RETURN NIL END; TYPECASE e OF | M3AST_AS.Longint_literal(longint_literal) => VAR literal := longint_literal.lx_litrep; CONST LongFlag = SET OF CHAR{'l', 'L'}; BEGIN (* Checks like this pick up literals detected as malformed by scanning. They have a suffix BadLiteralTail, declared in MODULE M3CLex.m3, which ends with ')'. *) IF LiteralLastChar(literal) IN LongFlag THEN ChkVal(e, M3CBackEnd.LiteralValue(e, er)); ELSE M3Error.Report(e, "bad longint literal"); END; END; | M3AST_AS.NUMERIC_LITERAL(numeric_literal) => VAR literal := numeric_literal.lx_litrep; CONST HexDigit = SET OF CHAR{'a'..'f', 'A'..'F', '0'..'9'}; BEGIN IF LiteralLastChar(literal) IN HexDigit THEN ChkVal(e, M3CBackEnd.LiteralValue(e, er)); ELSE M3Error.Report(e, "bad numeric literal"); END; END; | M3AST_AS.Nil_literal => ChkVal(e, M3CBackEnd.LiteralValue(e, er)); | M3AST_AS.Text_literal(text_literal) => VAR literal := text_literal.lx_litrep; BEGIN IF LiteralLastChar(literal) = '\"' THEN ChkVal(e, M3CBackEnd.LiteralValue(e, er)); ELSE M3Error.Report(e, "bad text literal"); END; END; | M3AST_AS.WideText_literal(text_literal) => VAR literal := text_literal.lx_litrep; BEGIN IF LiteralLastChar(literal) = '\"' THEN ChkVal(e, M3CBackEnd.LiteralValue(e, er)); ELSE M3Error.Report(e, "bad wide text literal"); END; END; | M3AST_AS.Char_literal(char_literal) => VAR literal := char_literal.lx_litrep; BEGIN IF LiteralLastChar(literal) = '\'' THEN ChkVal(e, M3CBackEnd.LiteralValue(e, er)); ELSE M3Error.Report(e, "bad character literal"); END; END; | M3AST_AS.WideChar_literal(char_literal) => VAR literal := char_literal.lx_litrep; BEGIN IF LiteralLastChar(literal) = '\'' THEN ChkVal(e, M3CBackEnd.LiteralValue(e, er)); ELSE M3Error.Report(e, "bad wide character literal"); END; END; | M3AST_AS.Exp_used_id(exp_used_id) => (* has to be a Const_id *) TYPECASE exp_used_id.vUSED_ID.sm_def OF | NULL => | M3AST_AS.Const_id(constId) => er := GetValueForUsedId(e, constId.vCCV_ID); | M3AST_AS.Proc_id => ChkVal(e, M3CBackEnd.LiteralValue(e, er)); | M3AST_AS.DEF_ID(defId) => IF Mode.WalkConst IN mode AND NOT CanAppearInConst(defId) THEN error := TRUE; END; (**ELSE -- unreachable WKK 5/27/97 **) (* error reported elsewhere *) END; (* case *) | M3AST_AS.Select(b) => (* Validity of selection already established. *) TYPECASE b.as_id.vUSED_ID.sm_def OF | NULL => | M3AST_AS.Const_id(constId) => er := GetValueForUsedId(b.as_id, constId.vCCV_ID); | M3AST_AS.Enum_id(enumId) => er := GetValueForUsedId(b.as_id, enumId.vCCV_ID); | M3AST_AS.Field_id(fieldId) => IF EvalComponent(b.as_exp, mode) # NIL THEN er := Selection(b.as_exp, fieldId); END; | M3AST_AS.Proc_id => TYPECASE b.as_exp OF | M3AST_AS.Exp_used_id(used_id) => WITH def = used_id.vUSED_ID.sm_def DO IF ISTYPE(def, M3AST_AS.Interface_id) OR ISTYPE(def, M3AST_AS.Interface_AS_id) THEN ChkVal(e, M3CBackEnd.LiteralValue(e, er)); END; END; ELSE END; | M3AST_AS.DEF_ID(defId) => IF Mode.WalkConst IN mode AND NOT CanAppearInConst(defId) THEN error := TRUE; END; END; (* case *) | M3AST_AS.BINARY(b) => VAR e1 := b.as_exp1; e2 := b.as_exp2; ev1 := EvalComponent(e1, mode); ev2 := EvalComponent(e2, mode); BEGIN IF ev1 # NIL AND ev2 # NIL THEN (* for all but IN, value types must be identical *) IF ISTYPE(b, M3AST_AS.In) THEN (* As 'ev2' is not NIL we assume its 'sm_exp_type_spec' must be set up *) VAR low, high: M3AST_SM.Exp_value; BEGIN IF ISTYPE(e2.sm_exp_type_spec, M3AST_AS.Set_type) AND M3CBackEnd.IsOrdinal(ev1) AND GetBounds(e2.sm_exp_type_spec, low, high) = M3CBackEnd.NumStatus.Valid THEN IF M3CBackEnd.Compare(low, ev1) <= 0 AND M3CBackEnd.Compare(ev2, high) <= 0 THEN ChkVal(e, M3CBackEnd.InOp(ev1, ev2, er)); ELSE er := NewBoolean(FALSE); END; END; (* if *) END; ELSIF ISTYPE(b, M3AST_AS.Eq) OR ISTYPE(b, M3AST_AS.Ne) THEN er := NewBoolean((ISTYPE(b, M3AST_AS.Eq)) = Equal(e1, e2)); ELSE ChkVal(e, M3CBackEnd.BinaryOp(b, ev1, ev2, er)); END; (* if *) END; (* if *) END; (* with *) | M3AST_AS.UNARY(unary) => VAR ev := EvalComponent(unary.as_exp, mode); BEGIN IF ev # NIL AND NOT ISTYPE(unary, M3AST_AS.Deref) THEN ChkVal(e, M3CBackEnd.UnaryOp(unary, ev, er)); END; (* if *) END; | M3AST_AS.Constructor(constructor) => (* nothing doing if constructor badly typed. *) VAR low, high: M3AST_SM.Exp_value := NIL; BEGIN TYPECASE M3CTypesMisc.CheckedUnpack(e.sm_exp_type_spec) OF | NULL => RETURN NIL; | M3AST_AS.Record_type, M3AST_AS.Array_type => (* ok *) | M3AST_AS.Set_type(st) => VAR baseType: M3AST_SM.TYPE_SPEC_UNSET; BEGIN M3CTypesMisc.GetTYPE_SPECFromM3TYPE(st.as_type, baseType); IF NOT IsOrdinal(baseType) THEN RETURN NIL END; IF GetBounds(baseType, low, high) # M3CBackEnd.NumStatus.Valid THEN RETURN NIL; END; END; ELSE RETURN NIL; END; (* sadly there is no guarantee that the actuals have had their values computed yet, since they can arise from default values of types not yet visited. So we evaluate recursively. *) VAR iterRangeExps := SeqM3AST_AS_RANGE_EXP.NewIter(constructor.sm_actual_s); rangeExp: M3AST_AS.RANGE_EXP; rmode := mode + ModeSet{Mode.Recursive}; BEGIN WHILE SeqM3AST_AS_RANGE_EXP.Next(iterRangeExps, rangeExp) DO TYPECASE rangeExp OF <*NOWARN*> | NULL => RETURN NIL; | M3AST_AS.Range(range) => VAR e1 := EvalComponent(range.as_exp1, rmode); e2 := EvalComponent(range.as_exp2, rmode); BEGIN IF e1 = NIL OR e2 = NIL OR (low # NIL AND (NotInBounds(e1, low, high) OR NotInBounds(e2, low, high))) THEN RETURN NIL; END; END; | M3AST_AS.Range_EXP(rExp) => VAR e1 := EvalComponent(rExp.as_exp, rmode); BEGIN IF e1 = NIL OR (low # NIL AND NotInBounds(e1, low, high)) THEN RETURN NIL; END; END; END; END; (* while *) M3CBitSize.Set(e.sm_exp_type_spec); (* size=0 permits open array constructors *) IF e.sm_exp_type_spec.sm_bitsize >= 0 THEN ChkVal(e, M3CBackEnd.ConstructorValue(e, er)); END; END; END; | M3AST_AS.Call(call) => VAR pf: M3CStdProcs.T; w: M3CWordProcs.T; BEGIN IF M3CStdProcs.IsStandardCall(call, pf) THEN IF pf IN M3CStdProcs.AllowedInConstantExpressions THEN er := StandardCall(call, pf, mode); ELSE IF Mode.WalkConst IN mode THEN error := TRUE END; END; ELSIF M3CWordProcs.IsWordCall(call, w) THEN er := WordCall(call, w, mode); ELSE IF Mode.WalkConst IN mode THEN error := TRUE END; END; END; | M3AST_AS.Index(index) => IF EvalComponent(index.as_array, mode) # NIL THEN (* Note 'e1' non NIL implies that type of 'as_array' is non NIL *) er := Index(index, mode); END; ELSE (* Bad expression *) END; (* case *) IF error THEN NotConstant(e); ELSE e.sm_exp_value := er; END; RETURN er; END Eval; REVEAL Closure = ASTWalk.Closure BRANDED OBJECT interface: BOOLEAN; node: AST.NODE; exp: M3AST_AS.EXP := NIL; OVERRIDES callback := Set; END; PROCEDURENewClosure ( interface: BOOLEAN; node: AST.NODE := NIL) : Closure RAISES {}= BEGIN RETURN NEW(Closure, interface := interface, node := node); END NewClosure; PROCEDURESet ( cl: Closure; an: AST.NODE; vm: ASTWalk.VisitMode) RAISES {}= BEGIN IF vm = ASTWalk.VisitMode.Entry THEN IF cl.node = NIL THEN TYPECASE an OF | M3AST_AS.Var_decl => IF cl.interface THEN cl.node := an END; RETURN; | M3AST_AS.TYPE_SPEC, M3AST_AS.Const_decl, M3AST_AS.Case => cl.node := an; RETURN; ELSE END; ELSE TYPECASE an OF | M3AST_AS.STM => cl.node := NIL; RETURN; ELSE END; END; TYPECASE an OF | M3AST_AS.EXP(exp) => IF cl.node # NIL AND cl.exp = NIL THEN cl.exp := exp END; TYPECASE exp OF | M3AST_AS.Call(call) => VAR pf: M3CStdProcs.T; BEGIN IF M3CStdProcs.IsStandardCall(call, pf) AND pf IN SpecialCall AND NOT SeqM3AST_AS_Actual.Empty(call.as_param_s) THEN call.sm_exp_value := CheckSpecialCall(call, pf, cl); END; END; ELSE END; ELSE END; ELSE IF an = cl.node THEN cl.node := NIL; TYPECASE an OF | M3AST_AS.Const_decl(constDecl) => constDecl.as_id.vCCV_ID.sm_exp_value := constDecl.as_exp.sm_exp_value; ELSE END; RETURN; END; TYPECASE an OF | M3AST_AS.EXP(exp) => VAR mode: ModeSet; BEGIN IF cl.exp # NIL THEN mode := ModeSet{Mode.WalkConst}; ELSE mode := ModeSet{Mode.Walk}; END; EVAL Eval(exp, mode); IF exp = cl.exp THEN cl.exp := NIL; END; END; ELSE END; END; END Set; BEGIN END M3CExpValue.