diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod index d2bb4ab7da3..528c51deaf3 100644 --- a/gcc/m2/gm2-compiler/M2Check.mod +++ b/gcc/m2/gm2-compiler/M2Check.mod @@ -768,6 +768,7 @@ END checkVarEquivalence ; PROCEDURE checkConstMeta (result: status; tinfo: tInfo; left, right: CARDINAL) : status ; VAR + typeLeft, typeRight: CARDINAL ; BEGIN Assert (IsConst (left)) ; @@ -798,6 +799,11 @@ BEGIN RETURN doCheckPair (result, tinfo, Char, typeRight) END END + ELSIF IsTyped (left) AND IsTyped (right) + THEN + typeRight := GetDType (right) ; + typeLeft := GetDType (left) ; + RETURN doCheckPair (result, tinfo, typeLeft, typeRight) END ; RETURN result END checkConstMeta ; diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index 46db4a6556d..d057a27fd86 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -300,6 +300,7 @@ TYPE Dimension : CARDINAL ; ReadWrite : CARDINAL ; name : CARDINAL ; + RangeDep : CARDINAL ; Annotation: String ; tokenno : CARDINAL ; END ; @@ -5623,6 +5624,7 @@ VAR proctok, paramtok : CARDINAL ; n1, n2 : Name ; + ParamCheckId, Dim, Actual, FormalI, @@ -5686,8 +5688,11 @@ BEGIN s := InitString ('actual') ; WarnStringAt (s, paramtok) END ; - - BuildRange (InitTypesParameterCheck (paramtok, Proc, i, FormalI, Actual)) ; + ParamCheckId := InitTypesParameterCheck (paramtok, Proc, i, FormalI, Actual, 0) ; + BuildRange (ParamCheckId) ; + (* Store the ParamCheckId on the quad stack so that any dependant checks + can be cancelled if the type check above detects an error. *) + PutRangeDep (pi, ParamCheckId) ; IF IsConst(Actual) THEN IF IsVarParamAny (Proc, i) @@ -5706,7 +5711,7 @@ BEGIN (* Allow string literals to be passed to ARRAY [0..n] OF CHAR. *) ELSIF (GetStringLength(paramtok, Actual) = 1) (* If = 1 then it maybe treated as a char. *) THEN - CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL) + CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL, ParamCheckId) ELSIF NOT IsUnboundedParamAny (Proc, i) THEN IF IsForC AND (GetSType(FormalI)=Address) @@ -5722,7 +5727,7 @@ BEGIN END END ELSE - CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL) + CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL, ParamCheckId) END ELSE IF IsForC AND UsesVarArgs(Proc) @@ -5752,7 +5757,8 @@ END CheckProcedureParameters ; CheckProcTypeAndProcedure - checks the ProcType with the call. *) -PROCEDURE CheckProcTypeAndProcedure (tokno: CARDINAL; ProcType: CARDINAL; call: CARDINAL) ; +PROCEDURE CheckProcTypeAndProcedure (tokno: CARDINAL; ProcType: CARDINAL; + call: CARDINAL; ParamCheckId: CARDINAL) ; VAR n1, n2 : Name ; i, n, t : CARDINAL ; @@ -5793,8 +5799,7 @@ BEGIN END ; BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i, GetParam (CheckedProcedure, i), - GetParam (ProcType, i))) ; - (* CheckParameter(tokpos, GetParam(CheckedProcedure, i), 0, GetParam(ProcType, i), call, i, TypeList) ; *) + GetParam (ProcType, i), ParamCheckId)) ; INC(i) END END @@ -5911,7 +5916,7 @@ END LegalUnboundedParam ; PROCEDURE CheckParameter (tokpos: CARDINAL; Actual, Dimension, Formal, ProcSym: CARDINAL; - i: CARDINAL; TypeList: List) ; + i: CARDINAL; TypeList: List; ParamCheckId: CARDINAL) ; VAR NewList : BOOLEAN ; ActualType, FormalType: CARDINAL ; @@ -5991,7 +5996,7 @@ BEGIN END END ; (* now to check each parameter of the proc type *) - CheckProcTypeAndProcedure (tokpos, FormalType, Actual) + CheckProcTypeAndProcedure (tokpos, FormalType, Actual, ParamCheckId) ELSIF (ActualType#FormalType) AND (ActualType#NulSym) THEN IF IsUnknown(FormalType) @@ -6657,9 +6662,10 @@ BEGIN THEN IF NOT IsSet (GetDType (FormalI)) THEN - (* tell code generator to test runtime values of assignment so ensure we - catch overflow and underflow *) - BuildRange (InitParameterRangeCheck (tokno, Proc, i, FormalI, Actual)) + (* Tell the code generator to test the runtime values of the assignment + so ensure we catch overflow and underflow. *) + BuildRange (InitParameterRangeCheck (tokno, Proc, i, FormalI, Actual, + OperandRangeDep (pi))) END END END ; @@ -13108,7 +13114,8 @@ BEGIN ReadWrite := NulSym ; tokenno := tok ; Annotation := KillString (Annotation) ; - Annotation := InitString ('%1s(%1d)|%2s(%2d)||boolean var|type') + Annotation := InitString ('%1s(%1d)|%2s(%2d)||boolean var|type') ; + RangeDep := 0 END END ConvertBooleanToVariable ; @@ -14443,7 +14450,8 @@ BEGIN FalseExit := False ; BooleanOp := TRUE ; tokenno := tokno ; - Annotation := NIL + Annotation := NIL ; + RangeDep := 0 END ; PushAddress (BoolStack, f) ; Annotate ('|||true quad|false quad') @@ -14585,6 +14593,34 @@ BEGIN END OperandTok ; +(* + OperandRangeDep - return the range dependant associated with the quad stack. +*) + +PROCEDURE OperandRangeDep (pos: CARDINAL) : CARDINAL ; +VAR + f: BoolFrame ; +BEGIN + Assert (NOT IsBoolean (pos)) ; + f := PeepAddress (BoolStack, pos) ; + RETURN f^.RangeDep +END OperandRangeDep ; + + +(* + PutRangeDep - assigns the quad stack pos RangeDep to dep. +*) + +PROCEDURE PutRangeDep (pos: CARDINAL; dep: CARDINAL) ; +VAR + f: BoolFrame ; +BEGIN + Assert (NOT IsBoolean (pos)) ; + f := PeepAddress (BoolStack, pos) ; + f^.RangeDep := dep +END PutRangeDep ; + + (* BuildCodeOn - generates a quadruple declaring that code should be emmitted from henceforth. diff --git a/gcc/m2/gm2-compiler/M2Range.def b/gcc/m2/gm2-compiler/M2Range.def index f8133d140c5..42aa14237c9 100644 --- a/gcc/m2/gm2-compiler/M2Range.def +++ b/gcc/m2/gm2-compiler/M2Range.def @@ -265,8 +265,9 @@ PROCEDURE InitTypesAssignmentCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL *) PROCEDURE InitTypesParameterCheck (tokno: CARDINAL; - proc: CARDINAL; i: CARDINAL; - formal, actual: CARDINAL) : CARDINAL ; + proc: CARDINAL; paramno: CARDINAL; + formal, actual: CARDINAL; + depRangeId: CARDINAL) : CARDINAL ; (* @@ -275,8 +276,9 @@ PROCEDURE InitTypesParameterCheck (tokno: CARDINAL; *) PROCEDURE InitParameterRangeCheck (tokno: CARDINAL; - proc: CARDINAL; i: CARDINAL; - formal, actual: CARDINAL) : CARDINAL ; + proc: CARDINAL; paramno: CARDINAL; + formal, actual: CARDINAL; + parentRangeId: CARDINAL) : CARDINAL ; (* @@ -304,11 +306,10 @@ PROCEDURE CodeRangeCheck (r: CARDINAL; function: String) ; (* - FoldRangeCheck - returns a Tree representing the code for a - range test defined by, r. + FoldRangeCheck - attempts to resolve the range check. *) -PROCEDURE FoldRangeCheck (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ; +PROCEDURE FoldRangeCheck (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ; (* diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod index a985684583f..347012bf5f1 100644 --- a/gcc/m2/gm2-compiler/M2Range.mod +++ b/gcc/m2/gm2-compiler/M2Range.mod @@ -75,6 +75,7 @@ FROM M2LexBuf IMPORT UnknownTokenNo, GetTokenNo, FindFileNameFromToken, TokenToLineNo, TokenToColumnNo, TokenToLocation, MakeVirtual2Tok ; FROM StrIO IMPORT WriteString, WriteLn ; +FROM NumberIO IMPORT WriteCard ; FROM M2GCCDeclare IMPORT TryDeclareConstant, DeclareConstructor ; FROM M2Quads IMPORT QuadOperator, PutQuad, SubQuad, WriteOperand ; FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc ; @@ -145,6 +146,8 @@ TYPE errorReported : BOOLEAN ; (* error message reported yet? *) strict : BOOLEAN ; (* is it a comparison expression? *) isin : BOOLEAN ; (* expression created by IN operator? *) + cancelled : BOOLEAN ; (* Has this range been cancelled? *) + dependantid : CARDINAL ; (* The associated dependant range test. *) END ; @@ -316,7 +319,9 @@ BEGIN expr2tok := UnknownTokenNo ; byconsttok := UnknownTokenNo ; incrementquad := 0 ; - errorReported := FALSE + errorReported := FALSE ; + cancelled := FALSE ; + dependantid := 0 END ; PutIndice(RangeIndex, r, p) END ; @@ -555,7 +560,8 @@ END PutRangeUnary ; *) PROCEDURE PutRangeParam (tokno: CARDINAL; p: Range; t: TypeOfRange; proc: CARDINAL; - i: CARDINAL; formal, actual: CARDINAL) : Range ; + paramno: CARDINAL; formal, actual: CARDINAL; + depRangeId: CARDINAL) : Range ; BEGIN WITH p^ DO type := t ; @@ -564,11 +570,12 @@ BEGIN desLowestType := NulSym ; exprLowestType := NulSym ; procedure := proc ; - paramNo := i ; + paramNo := paramno ; isLeftValue := FALSE ; tokenNo := tokno ; strict := FALSE ; - isin := FALSE + isin := FALSE ; + dependantid := depRangeId END ; RETURN p END PutRangeParam ; @@ -805,13 +812,16 @@ END InitTypesAssignmentCheck ; and, e, are parameter compatible. *) -PROCEDURE InitTypesParameterCheck (tokno: CARDINAL; proc: CARDINAL; i: CARDINAL; - formal, actual: CARDINAL) : CARDINAL ; +PROCEDURE InitTypesParameterCheck (tokno: CARDINAL; + proc: CARDINAL; paramno: CARDINAL; + formal, actual: CARDINAL; + depRangeId: CARDINAL) : CARDINAL ; VAR r: CARDINAL ; BEGIN r := InitRange () ; - Assert (PutRangeParam (tokno, GetIndice (RangeIndex, r), typeparam, proc, i, formal, actual) # NIL) ; + Assert (PutRangeParam (tokno, GetIndice (RangeIndex, r), typeparam, proc, + paramno, formal, actual, depRangeId) # NIL) ; RETURN r END InitTypesParameterCheck ; @@ -824,7 +834,7 @@ END InitTypesParameterCheck ; *) PROCEDURE PutRangeParamAssign (tokno: CARDINAL; p: Range; t: TypeOfRange; proc: CARDINAL; - i: CARDINAL; formal, actual: CARDINAL) : Range ; + i: CARDINAL; formal, actual: CARDINAL; parentRangeId: CARDINAL) : Range ; BEGIN WITH p^ DO type := t ; @@ -836,7 +846,8 @@ BEGIN paramNo := i ; dimension := i ; isLeftValue := FALSE ; - tokenNo := tokno + tokenNo := tokno ; + dependantid := parentRangeId END ; RETURN( p ) END PutRangeParamAssign ; @@ -847,13 +858,14 @@ END PutRangeParamAssign ; are parameter compatible. *) -PROCEDURE InitParameterRangeCheck (tokno: CARDINAL; proc: CARDINAL; i: CARDINAL; - formal, actual: CARDINAL) : CARDINAL ; +PROCEDURE InitParameterRangeCheck (tokno: CARDINAL; proc: CARDINAL; paramno: CARDINAL; + formal, actual: CARDINAL; parentRangeId: CARDINAL) : CARDINAL ; VAR r: CARDINAL ; BEGIN r := InitRange () ; - Assert (PutRangeParamAssign (tokno, GetIndice (RangeIndex, r), paramassign, proc, i, formal, actual) # NIL) ; + Assert (PutRangeParamAssign (tokno, GetIndice (RangeIndex, r), paramassign, proc, + paramno, formal, actual, parentRangeId) # NIL) ; RETURN r END InitParameterRangeCheck ; @@ -1241,6 +1253,64 @@ BEGIN END FoldAssignment ; +(* + CheckCancelled - check to see if the range has been cancelled and if so remove quad. +*) + +PROCEDURE CheckCancelled (range: CARDINAL; quad: CARDINAL) ; +BEGIN + IF IsCancelled (range) + THEN + SubQuad (quad) + END +END CheckCancelled ; + + +(* + IsCancelled - return the cancelled flag associated with range. +*) + +PROCEDURE IsCancelled (range: CARDINAL) : BOOLEAN ; +VAR + p: Range ; +BEGIN + p := GetIndice (RangeIndex, range) ; + WITH p^ DO + IF cancelled + THEN + RETURN TRUE + END ; + IF (dependantid # 0) AND IsCancelled (dependantid) + THEN + cancelled := TRUE + END ; + RETURN cancelled + END +END IsCancelled ; + + +(* + Cancel - set the cancelled flag in range. +*) + +PROCEDURE Cancel (range: CARDINAL) ; +VAR + p: Range ; +BEGIN + IF range # 0 + THEN + p := GetIndice (RangeIndex, range) ; + WITH p^ DO + IF NOT cancelled + THEN + cancelled := TRUE ; + Cancel (dependantid) + END + END + END +END Cancel ; + + (* FoldParameterAssign - *) @@ -1699,7 +1769,10 @@ END FoldTypeAssign ; The quad is removed if the check succeeds. *) -PROCEDURE FoldTypeParam (q: CARDINAL; tokenNo: CARDINAL; formal, actual, procedure: CARDINAL; paramNo: CARDINAL) ; +PROCEDURE FoldTypeParam (q: CARDINAL; tokenNo: CARDINAL; + formal, actual, procedure: CARDINAL; + paramNo: CARDINAL; + depRangeId: CARDINAL) ; VAR compatible: BOOLEAN ; BEGIN @@ -1724,6 +1797,8 @@ BEGIN IF compatible THEN SubQuad(q) + ELSE + Cancel (depRangeId) END END FoldTypeParam ; @@ -1836,7 +1911,7 @@ BEGIN CASE type OF typeassign: FoldTypeAssign(q, tokenNo, des, expr, r) | - typeparam: FoldTypeParam(q, tokenNo, des, expr, procedure, paramNo) | + typeparam: FoldTypeParam(q, tokenNo, des, expr, procedure, paramNo, r) | typeexpr: FoldTypeExpr(q, tokenNo, des, expr, strict, isin, r) ELSE @@ -2271,7 +2346,7 @@ END FoldZeroRem ; (* - FoldRangeCheck - attempts to resolve the range check, r. + FoldRangeCheck - attempts to resolve the range check. If it evaluates to true then it is replaced by an ErrorOp elsif it evaluates to false then @@ -2280,47 +2355,63 @@ END FoldZeroRem ; it is left alone *) -PROCEDURE FoldRangeCheck (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ; +PROCEDURE FoldRangeCheck (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ; +BEGIN + IF IsCancelled (range) + THEN + SubQuad (quad) + ELSE + FoldRangeCheckLower (tokenno, quad, range) + END +END FoldRangeCheck ; + + +(* + FoldRangeCheckLower - call the appropriate Fold procedure depending upon the type + of range. +*) + +PROCEDURE FoldRangeCheckLower (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ; VAR p: Range ; BEGIN - p := GetIndice(RangeIndex, r) ; + p := GetIndice(RangeIndex, range) ; WITH p^ DO CASE type OF - assignment : FoldAssignment(tokenno, q, r) | - returnassignment : FoldReturn(tokenno, q, r) | + assignment : FoldAssignment(tokenno, quad, range) | + returnassignment : FoldReturn(tokenno, quad, range) | (* subrangeassignment : | unused currently *) - inc : FoldInc(tokenno, q, r) | - dec : FoldDec(tokenno, q, r) | - incl : FoldIncl(tokenno, q, r) | - excl : FoldExcl(tokenno, q, r) | - shift : FoldShift(tokenno, q, r) | - rotate : FoldRotate(tokenno, q, r) | - typeassign : FoldTypeCheck(tokenno, q, r) | - typeparam : FoldTypeCheck(tokenno, q, r) | - typeexpr : FoldTypeCheck(tokenno, q, r) | - paramassign : FoldParameterAssign(tokenno, q, r) | - staticarraysubscript : FoldStaticArraySubscript(tokenno, q, r) | - dynamicarraysubscript: FoldDynamicArraySubscript(tokenno, q, r) | - forloopbegin : FoldForLoopBegin(tokenno, q, r) | - forloopto : FoldForLoopTo(tokenno, q, r) | + inc : FoldInc(tokenno, quad, range) | + dec : FoldDec(tokenno, quad, range) | + incl : FoldIncl(tokenno, quad, range) | + excl : FoldExcl(tokenno, quad, range) | + shift : FoldShift(tokenno, quad, range) | + rotate : FoldRotate(tokenno, quad, range) | + typeassign : FoldTypeCheck(tokenno, quad, range) | + typeparam : FoldTypeCheck(tokenno, quad, range) | + typeexpr : FoldTypeCheck(tokenno, quad, range) | + paramassign : FoldParameterAssign(tokenno, quad, range) | + staticarraysubscript : FoldStaticArraySubscript(tokenno, quad, range) | + dynamicarraysubscript: FoldDynamicArraySubscript(tokenno, quad, range) | + forloopbegin : FoldForLoopBegin(tokenno, quad, range) | + forloopto : FoldForLoopTo(tokenno, quad, range) | forloopend : RETURN (* unable to fold anything at this point, des, will be variable *) | - pointernil : FoldNil(tokenno, q, r) | + pointernil : FoldNil(tokenno, quad, range) | noreturn : RETURN (* nothing to fold *) | noelse : RETURN (* nothing to fold *) | - casebounds : FoldCaseBounds(tokenno, q, r) | - wholenonposdiv : FoldNonPosDiv(tokenno, q, r) | - wholenonposmod : FoldNonPosMod(tokenno, q, r) | - wholezerodiv : FoldZeroDiv(tokenno, q, r) | - wholezerorem : FoldZeroRem(tokenno, q, r) | - none : SubQuad(q) + casebounds : FoldCaseBounds(tokenno, quad, range) | + wholenonposdiv : FoldNonPosDiv(tokenno, quad, range) | + wholenonposmod : FoldNonPosMod(tokenno, quad, range) | + wholezerodiv : FoldZeroDiv(tokenno, quad, range) | + wholezerorem : FoldZeroRem(tokenno, quad, range) | + none : SubQuad(quad) ELSE InternalError ('unexpected case') END END -END FoldRangeCheck ; +END FoldRangeCheckLower ; (* @@ -3595,6 +3686,19 @@ VAR BEGIN p := GetIndice(RangeIndex, r) ; WITH p^ DO + WriteString ('range ') ; + WriteCard (r, 0) ; + WriteString (' ') ; + IF cancelled + THEN + WriteString ('cancelled ') + END ; + IF dependantid # 0 + THEN + WriteString ('dep ') ; + WriteCard (dependantid, 0) ; + WriteString (' ') + END ; CASE type OF assignment : WriteString('assignment (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | diff --git a/gcc/testsuite/gm2/pim/fail/badparamtype.mod b/gcc/testsuite/gm2/pim/fail/badparamtype.mod new file mode 100644 index 00000000000..17f6821ce56 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badparamtype.mod @@ -0,0 +1,10 @@ +MODULE badparamtype ; + +PROCEDURE foo (i: INTEGER) ; +BEGIN + +END foo ; + +BEGIN + foo (3.14) +END badparamtype.