diff options
Diffstat (limited to 'gcc/m2/gm2-compiler')
-rw-r--r-- | gcc/m2/gm2-compiler/M2Check.def | 3 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Check.mod | 541 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2GCCDeclare.def | 2 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2GCCDeclare.mod | 116 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2GenGCC.mod | 148 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2MetaError.def | 12 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2MetaError.mod | 37 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Options.def | 16 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Options.mod | 22 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.mod | 318 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Range.def | 18 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Range.mod | 319 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2System.mod | 123 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/P2Build.bnf | 79 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/P2SymBuild.mod | 31 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/P3Build.bnf | 99 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/PCBuild.bnf | 97 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/PCSymBuild.mod | 13 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/PHBuild.bnf | 86 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/SymbolTable.def | 18 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/SymbolTable.mod | 138 |
21 files changed, 1629 insertions, 607 deletions
diff --git a/gcc/m2/gm2-compiler/M2Check.def b/gcc/m2/gm2-compiler/M2Check.def index 0ceb173..9d9f760 100644 --- a/gcc/m2/gm2-compiler/M2Check.def +++ b/gcc/m2/gm2-compiler/M2Check.def @@ -50,7 +50,8 @@ PROCEDURE ParameterTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR; *) PROCEDURE AssignmentTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR; - des, expr: CARDINAL) : BOOLEAN ; + des, expr: CARDINAL; + enableReason: BOOLEAN) : BOOLEAN ; (* diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod index 528c51d..614526c 100644 --- a/gcc/m2/gm2-compiler/M2Check.mod +++ b/gcc/m2/gm2-compiler/M2Check.mod @@ -36,26 +36,33 @@ FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ; FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType, Char ; FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex, ForeachIndiceInIndexDo ; FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ; -FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4, MetaError1 ; + +FROM M2MetaError IMPORT MetaErrorStringT0, MetaErrorStringT2, MetaErrorStringT3, + MetaErrorStringT4, + MetaString0, MetaString1, MetaString2, MetaString3, + MetaString4, + MetaError0, MetaError1 ; + FROM StrLib IMPORT StrEqual ; FROM M2Debug IMPORT Assert ; -FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetSType, IsType, +FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetType, IsType, SkipType, IsProcedure, NoOfParamAny, IsVarParamAny, GetNth, GetNthParamAny, IsProcType, IsVar, IsEnumeration, IsArray, IsSubrange, GetArraySubscript, IsConst, IsReallyPointer, IsPointer, IsParameter, ModeOfAddr, - GetMode, GetType, IsUnbounded, IsComposite, IsConstructor, + GetMode, IsUnbounded, IsComposite, IsConstructor, IsParameter, IsConstString, IsConstLitInternal, IsConstLit, GetStringLength, GetProcedureProcType, IsHiddenType, - IsHiddenReallyPointer, GetDimension ; + IsHiddenReallyPointer, GetDimension, IsFieldEnumeration ; FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ; FROM M2System IMPORT Address ; FROM M2ALU IMPORT Equ, PushIntegerTree ; +FROM M2Options IMPORT StrictTypeReason ; FROM m2expr IMPORT AreConstantsEqual ; -FROM SymbolConversion IMPORT Mod2Gcc ; -FROM DynamicStrings IMPORT String, InitString, KillString ; +FROM SymbolConversion IMPORT Mod2Gcc, GccKnowsAbout ; +FROM DynamicStrings IMPORT String, InitString, KillString, ConCat, Mark ; FROM M2LexBuf IMPORT GetTokenNo ; FROM Storage IMPORT ALLOCATE ; FROM SYSTEM IMPORT ADR ; @@ -63,7 +70,8 @@ FROM libc IMPORT printf ; CONST - debugging = FALSE ; + debugging = FALSE ; + MaxEquvalence = 20 ; TYPE errorSig = POINTER TO RECORD @@ -83,6 +91,8 @@ TYPE checkType = (parameter, assignment, expression) ; tInfo = POINTER TO RECORD + reasonEnable: BOOLEAN ; + reason, format : String ; kind : checkType ; token, @@ -105,11 +115,14 @@ TYPE status = (true, false, unknown, visited, unused) ; + EquivalenceProcedure = PROCEDURE (status, tInfo, CARDINAL, CARDINAL) : status ; VAR - pairFreeList : pair ; - tinfoFreeList: tInfo ; - errors : Index ; + pairFreeList : pair ; + tinfoFreeList : tInfo ; + errors : Index ; + HighEquivalence: CARDINAL ; + Equivalence : ARRAY [1..MaxEquvalence] OF EquivalenceProcedure ; (* @@ -159,6 +172,53 @@ END dumptInfo ; (* + falseReason2 - return false. It also stores the message as the + reason for the false value. +*) + +PROCEDURE falseReason2 (message: ARRAY OF CHAR; tinfo: tInfo; + left, right: CARDINAL) : status ; +BEGIN + IF tinfo^.reasonEnable AND (tinfo^.reason = NIL) + THEN + tinfo^.reason := MetaString2 (InitString (message), left, right) + END ; + RETURN false +END falseReason2 ; + + +(* + falseReason1 - return false. It also stores the message as the + reason for the false value. +*) + +PROCEDURE falseReason1 (message: ARRAY OF CHAR; tinfo: tInfo; + operand: CARDINAL) : status ; +BEGIN + IF tinfo^.reasonEnable AND (tinfo^.reason = NIL) + THEN + tinfo^.reason := MetaString1 (InitString (message), operand) + END ; + RETURN false +END falseReason1 ; + + +(* + falseReason0 - return false. It also stores the message as the + reason for the false value. +*) + +PROCEDURE falseReason0 (message: ARRAY OF CHAR; tinfo: tInfo) : status ; +BEGIN + IF tinfo^.reasonEnable AND (tinfo^.reason = NIL) + THEN + tinfo^.reason := MetaString0 (InitString (message)) + END ; + RETURN false +END falseReason0 ; + + +(* isKnown - returns BOOLEAN:TRUE if result is status:true or status:false. *) @@ -192,31 +252,29 @@ END isFalse ; checkTypeEquivalence - returns TRUE if left and right can be skipped and found to be equal. *) -PROCEDURE checkTypeEquivalence (result: status; left, right: CARDINAL) : status ; -VAR - leftT, rightT: CARDINAL ; +PROCEDURE checkTypeEquivalence (result: status; + tinfo: tInfo; + left, right: CARDINAL) : status ; BEGIN - (* firstly check to see if we already have resolved this as false. *) - IF isFalse (result) + IF left = right THEN - RETURN result - ELSE - (* check to see if we dont care about left or right. *) - IF (left = NulSym) OR (right = NulSym) + RETURN true + ELSIF IsType (left) AND IsType (right) + THEN + IF IsHiddenType (left) AND IsHiddenType (right) + THEN + RETURN falseReason2 ('opaque types {%1a} {%2a} differ', tinfo, left, right) + ELSIF (IsHiddenType (left) AND (right = Address)) OR + (IsHiddenType (right) AND (left = Address)) THEN RETURN true - ELSE - leftT := SkipType (left) ; - rightT := SkipType (right) ; - IF leftT = rightT - THEN - RETURN true - ELSIF IsType (leftT) AND IsType (rightT) - THEN - (* the fundamental types are definitely different. *) - RETURN false - END END + ELSIF IsTypeEquivalence (left) + THEN + RETURN checkPair (result, tinfo, GetDType (left), right) + ELSIF IsTypeEquivalence (right) + THEN + RETURN checkPair (result, tinfo, left, GetDType (right)) END ; RETURN result END checkTypeEquivalence ; @@ -246,13 +304,15 @@ BEGIN PushIntegerTree (Mod2Gcc (rLow)) ; IF NOT Equ (tinfo^.token) THEN - RETURN false + RETURN falseReason2 ('low values of the subrange types {%1a} {%2a} differ', + tinfo, left, right) END ; PushIntegerTree (Mod2Gcc (lHigh)) ; PushIntegerTree (Mod2Gcc (rHigh)) ; IF NOT Equ (tinfo^.token) THEN - RETURN false + RETURN falseReason2 ('high values of the subrange types {%1a} {%2a} differ', + tinfo, left, right) END END ; RETURN true @@ -266,6 +326,7 @@ END checkSubrange ; *) PROCEDURE checkUnboundedArray (result: status; + tinfo: tInfo; unbounded, array: CARDINAL) : status ; VAR dim : CARDINAL ; @@ -280,13 +341,13 @@ BEGIN Assert (IsUnbounded (unbounded)) ; Assert (IsArray (array)) ; dim := GetDimension (unbounded) ; - ubtype := GetType (unbounded) ; + ubtype := GetDType (unbounded) ; type := array ; REPEAT - type := GetType (type) ; + type := GetDType (type) ; DEC (dim) ; (* Check type equivalences. *) - IF checkTypeEquivalence (result, type, ubtype) = true + IF checkTypeEquivalence (result, tinfo, type, ubtype) = true THEN RETURN true END ; @@ -294,11 +355,13 @@ BEGIN (* If we have run out of dimensions we conclude false. *) IF dim = 0 THEN - RETURN false + RETURN falseReason0 ('unbounded array has less dimensions than the array', + tinfo) END ; UNTIL NOT IsArray (type) END ; - RETURN false + RETURN falseReason0 ('array has less dimensions than the unbounded array', + tinfo) END checkUnboundedArray ; @@ -327,14 +390,18 @@ BEGIN referenced. We use GetDimension for 'bar' which is 2. *) IF GetDimension (formal) # GetDimension (tinfo^.actual) THEN - RETURN false + RETURN falseReason2 ('the formal parameter unbounded array {%1a} has a different number' + + ' of dimensions to the actual parameter unbounded array {%2a}', + tinfo, formal, actual) END ; - IF checkTypeEquivalence (result, GetType (formal), GetType (actual)) = true + IF checkTypeEquivalence (result, tinfo, GetType (formal), GetType (actual)) = true THEN RETURN true END END ; - RETURN false + RETURN falseReason2 ('the formal unbounded array type {%1a}' + + ' and the actual unbounded array type {%2a} differ', + tinfo, formal, actual) END checkUnboundedUnbounded ; @@ -373,10 +440,14 @@ BEGIN END ELSIF IsArray (right) THEN - RETURN checkUnboundedArray (result, unbounded, right) + RETURN checkUnboundedArray (result, tinfo, unbounded, right) ELSIF IsUnbounded (right) THEN RETURN checkUnboundedUnbounded (result, tinfo, unbounded, right) + ELSE + RETURN falseReason2 ('the formal unbounded array type {%1a}' + + ' and the actual unbounded array type {%2a} differ', + tinfo, unbounded, right) END END END ; @@ -400,7 +471,7 @@ BEGIN THEN lSub := GetArraySubscript (left) ; rSub := GetArraySubscript (right) ; - result := checkPair (result, tinfo, GetSType (left), GetSType (right)) ; + result := checkPair (result, tinfo, GetDType (left), GetDType (right)) ; IF (lSub # NulSym) AND (rSub # NulSym) THEN result := checkSubrange (result, tinfo, getSType (lSub), getSType (rSub)) @@ -423,31 +494,58 @@ BEGIN END ELSIF IsArray (left) AND IsConst (right) THEN - result := checkPair (result, tinfo, GetType (left), GetType (right)) + result := checkPair (result, tinfo, GetDType (left), GetDType (right)) ELSIF IsArray (right) AND IsConst (left) THEN - result := checkPair (result, tinfo, GetType (left), GetType (right)) + result := checkPair (result, tinfo, GetDType (left), GetDType (right)) END ; RETURN result END checkArrayTypeEquivalence ; (* - checkGenericTypeEquivalence - check left and right for generic equivalence. + checkCharStringTypeEquivalence - check char and string constants for type equivalence. *) -PROCEDURE checkGenericTypeEquivalence (result: status; left, right: CARDINAL) : status ; +PROCEDURE checkCharStringTypeEquivalence (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; BEGIN IF isFalse (result) THEN RETURN result - ELSIF left = right + ELSIF left = Char THEN - RETURN true - ELSE - RETURN result - END -END checkGenericTypeEquivalence ; + IF IsConst (right) + THEN + (* We might not know the length of the string yet, in which case we return true. *) + IF IsConstString (right) AND + ((NOT GccKnowsAbout (right)) OR (GetStringLength (tinfo^.token, right) <= 1)) + THEN + RETURN true + ELSE + RETURN falseReason2 ('the string {%2a} does not fit into a {%1a}', + tinfo, left, right) + END + ELSIF IsParameter (right) + THEN + right := GetDType (right) ; + IF (right = Char) OR (IsUnbounded (right) AND (SkipType (GetDType (right)) = Char)) + THEN + RETURN true + END + ELSIF IsArray (right) + THEN + IF Char = SkipType (GetDType (right)) + THEN + RETURN true + END + END + ELSIF right = Char + THEN + RETURN checkCharStringTypeEquivalence (result, tinfo, right, left) + END ; + RETURN result +END checkCharStringTypeEquivalence ; (* @@ -491,7 +589,7 @@ BEGIN THEN IF tinfo^.error = NIL THEN - (* need to create top level error message first. *) + (* We need to create top level error message first. *) tinfo^.error := NewError (tinfo^.token) ; (* The parameters to MetaString4 in buildError4 must match the order of paramters passed to ParameterTypeCompatible. *) @@ -499,9 +597,17 @@ BEGIN tinfo^.procedure, tinfo^.formal, tinfo^.actual, tinfo^.nth) ; + (* Append the overall reason for the failure. *) + IF tinfo^.reason # NIL + THEN + (* The string tinfo^.reason is given to the error handler. *) + s := ConCat (s, Mark (InitString (" because "))) ; + s := ConCat (s, tinfo^.reason) ; + tinfo^.reason := NIL (* Hand over deconstructing to M2MetaError. *) + END ; ErrorString (tinfo^.error, s) END ; - (* and also generate a sub error containing detail. *) + (* And now also generate a sub error containing detail. *) IF (left # tinfo^.left) OR (right # tinfo^.right) THEN MetaError1 ('formal parameter {%1EDad}', right) ; @@ -512,7 +618,7 @@ END buildError4 ; (* - buildError2 - generate a MetaString2 error. This is called by all three kinds of errors. + buildError2 - generate a MetaString2 error. *) PROCEDURE buildError2 (tinfo: tInfo; left, right: CARDINAL) ; @@ -543,6 +649,14 @@ BEGIN left, right) END ; + (* Lastly the overall reason for the failure. *) + IF tinfo^.reason # NIL + THEN + (* The string tinfo^.reason is given to the error handler. *) + s := ConCat (s, Mark (InitString (" because "))) ; + s := ConCat (s, tinfo^.reason) ; + tinfo^.reason := NIL (* Hand over deconstructing to M2MetaError. *) + END ; ErrorString (tinfo^.error, s) END END @@ -559,7 +673,7 @@ BEGIN THEN RETURN true ELSE - (* check whether errors are required. *) + (* Check whether errors are required. *) IF tinfo^.format # NIL THEN CASE tinfo^.kind OF @@ -700,11 +814,21 @@ PROCEDURE IsTyped (sym: CARDINAL) : BOOLEAN ; BEGIN 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)) + (IsConst (sym) AND (GetDType (sym) # NulSym)) END IsTyped ; (* + IsTypeEquivalence - returns TRUE if sym is a type equivalence symbol. +*) + +PROCEDURE IsTypeEquivalence (sym: CARDINAL) : BOOLEAN ; +BEGIN + RETURN IsType (sym) AND (GetDType (sym) # NulSym) AND (GetDType (sym) # sym) +END IsTypeEquivalence ; + + +(* isLValue - *) @@ -715,6 +839,38 @@ END isLValue ; (* + checkVarTypeEquivalence - +*) + +PROCEDURE checkVarTypeEquivalence (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; +BEGIN + IF isFalse (result) + THEN + RETURN result + ELSIF (left = NulSym) OR (right = NulSym) + THEN + RETURN true + ELSE + IF IsVar (left) OR IsVar (right) + THEN + (* Either left or right will change, so we can call doCheckPair. *) + IF IsVar (left) + THEN + left := getType (left) + END ; + IF IsVar (right) + THEN + right := getType (right) + END ; + RETURN doCheckPair (result, tinfo, left, right) + END + END ; + RETURN result +END checkVarTypeEquivalence ; + + +(* checkVarEquivalence - this test must be done early as it checks the symbol mode. An LValue is treated as a pointer during assignment and the LValue is attached to a variable. This function skips the variable @@ -722,40 +878,44 @@ END isLValue ; *) PROCEDURE checkVarEquivalence (result: status; tinfo: tInfo; - left, right: CARDINAL) : status ; + des, expr: CARDINAL) : status ; BEGIN IF isFalse (result) THEN RETURN result - ELSIF IsTyped (left) OR IsTyped (right) + ELSIF IsTyped (des) OR IsTyped (expr) THEN IF tinfo^.kind = assignment THEN + IF GetDType (des) = GetDType (expr) + THEN + RETURN true (* LValues are only relevant during assignment. *) - IF isLValue (left) AND (NOT isLValue (right)) + ELSIF isLValue (des) AND (NOT isLValue (expr)) THEN - IF SkipType (getType (right)) = Address + IF SkipType (getType (expr)) = Address THEN RETURN true - ELSIF IsPointer (SkipType (getType (right))) + ELSIF IsPointer (SkipType (getType (expr))) THEN - right := GetDType (SkipType (getType (right))) + expr := GetDType (SkipType (getType (expr))) ; + RETURN doCheckPair (result, tinfo, getType (des), expr) END - ELSIF isLValue (right) AND (NOT isLValue (left)) + ELSIF isLValue (expr) AND (NOT isLValue (des)) THEN - IF SkipType (getType (left)) = Address + IF SkipType (getType (des)) = Address THEN RETURN true - ELSIF IsPointer (SkipType (getType (left))) + ELSIF IsPointer (SkipType (getType (des))) THEN - left := GetDType (SkipType (getType (left))) + des := GetDType (SkipType (getType (des))) ; + RETURN doCheckPair (result, tinfo, des, getType (expr)) END END END ; - RETURN doCheckPair (result, tinfo, getType (left), getType (right)) - ELSE - RETURN result - END + RETURN doCheckPair (result, tinfo, getType (des), getType (expr)) + END ; + RETURN result END checkVarEquivalence ; @@ -790,10 +950,15 @@ BEGIN IsProcedure (typeRight) OR IsRecord (typeRight) OR IsReallyPointer (typeRight) THEN - RETURN false + RETURN falseReason1 ('constant string is incompatible with {%1ad}', + tinfo, typeRight) ELSIF IsArray (typeRight) THEN - RETURN doCheckPair (result, tinfo, Char, GetType (typeRight)) + RETURN doCheckPair (result, tinfo, Char, GetDType (typeRight)) + ELSIF NOT GccKnowsAbout (left) + THEN + (* We do not know the length of this string, so assume true. *) + RETURN true ELSIF GetStringLength (tinfo^.token, left) = 1 THEN RETURN doCheckPair (result, tinfo, Char, typeRight) @@ -803,13 +968,72 @@ BEGIN THEN typeRight := GetDType (right) ; typeLeft := GetDType (left) ; - RETURN doCheckPair (result, tinfo, typeLeft, typeRight) + IF IsZRCType (typeLeft) AND IsUnbounded (typeRight) + THEN + RETURN falseReason2 ('the constant {%1a} is incompatible' + + ' with an unbounded array of {%2a}', + tinfo, typeLeft, typeRight) + ELSE + RETURN doCheckPair (result, tinfo, typeLeft, typeRight) + END END ; RETURN result END checkConstMeta ; (* + checkEnumField - +*) + +PROCEDURE checkEnumField (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; +VAR + typeRight: CARDINAL ; +BEGIN + Assert (IsFieldEnumeration (left)) ; + IF isFalse (result) + THEN + RETURN result + ELSIF IsTyped (right) + THEN + typeRight := GetDType (right) ; + IF typeRight = NulSym + THEN + RETURN result + ELSE + RETURN doCheckPair (result, tinfo, GetDType (left), typeRight) + END + END ; + RETURN result +END checkEnumField ; + + +(* + checkEnumFieldEquivalence - +*) + +PROCEDURE checkEnumFieldEquivalence (result: status; tinfo: tInfo; + left, right: CARDINAL) : status ; +BEGIN + IF isFalse (result) + THEN + RETURN result + ELSIF (left = NulSym) OR (right = NulSym) + THEN + (* No option but to return true. *) + RETURN true + ELSIF IsFieldEnumeration (left) + THEN + RETURN checkEnumField (result, tinfo, left, right) + ELSIF IsFieldEnumeration (right) + THEN + RETURN checkEnumField (result, tinfo, right, left) + END ; + RETURN result +END checkEnumFieldEquivalence ; + + +(* checkConstEquivalence - this check can be done first as it checks symbols which may have no type. Ie constant strings. These constants will likely have their type set during quadruple folding. @@ -856,26 +1080,33 @@ BEGIN IF IsSubrange (right) THEN RETURN doCheckPair (result, tinfo, left, GetDType (right)) - END ; - IF left = right - THEN - RETURN true - ELSE - RETURN result END - END + END ; + RETURN result END checkSubrangeTypeEquivalence ; (* - isZRC - + IsZRCType - return TRUE if type is a ZType, RType or a CType. +*) + +PROCEDURE IsZRCType (type: CARDINAL) : BOOLEAN ; +BEGIN + RETURN (type = CType) OR (type = ZType) OR (type = RType) +END IsZRCType ; + + +(* + isZRC - return TRUE if zrc is a ZType, RType or a CType + and sym is either a complex type when zrc = CType + or is not a composite type when zrc is a RType or ZType. *) PROCEDURE isZRC (zrc, sym: CARDINAL) : BOOLEAN ; BEGIN IF IsConst (sym) THEN - sym := SkipType (GetType (sym)) + sym := SkipType (GetDType (sym)) END ; IF (zrc = CType) AND (IsComplexN (sym) OR IsComplexType (sym)) THEN @@ -894,11 +1125,11 @@ PROCEDURE isSameSizeConst (a, b: CARDINAL) : BOOLEAN ; BEGIN IF IsConst (a) THEN - a := SkipType (GetType (a)) ; + a := SkipType (GetDType (a)) ; RETURN isZRC (a, b) OR (a = b) OR ((a # NulSym) AND isSameSize (a, b)) ELSIF IsConst (b) THEN - b := SkipType (GetType (b)) ; + b := SkipType (GetDType (b)) ; RETURN isZRC (b, a) OR (a = b) OR ((b # NulSym) AND isSameSize (a, b)) END ; RETURN FALSE @@ -919,13 +1150,15 @@ END isSameSize ; checkSystemEquivalence - check whether left and right are system types and whether they have the same size. *) -PROCEDURE checkSystemEquivalence (result: status; left, right: CARDINAL) : status ; +PROCEDURE checkSystemEquivalence (result: status; tinfo: tInfo <* unused *>; + left, right: CARDINAL) : status ; BEGIN IF isFalse (result) OR (result = visited) THEN RETURN result ELSE IF (IsGenericSystemType (left) OR IsGenericSystemType (right)) AND + GccKnowsAbout (left) AND GccKnowsAbout (right) AND isSameSize (left, right) THEN RETURN true @@ -940,7 +1173,7 @@ END checkSystemEquivalence ; a set, record or array. *) -PROCEDURE checkTypeKindViolation (result: status; +PROCEDURE checkTypeKindViolation (result: status; tinfo: tInfo; left, right: CARDINAL) : status ; BEGIN IF isFalse (result) OR (result = visited) @@ -952,7 +1185,8 @@ BEGIN (IsRecord (left) OR IsRecord (right)) OR (IsArray (left) OR IsArray (right)) THEN - RETURN false + RETURN falseReason2 ('a {%1ad} is incompatible with a {%2ad}', + tinfo, left, right) END END ; RETURN result @@ -960,7 +1194,7 @@ END checkTypeKindViolation ; (* - doCheckPair - invoke a series of ordered type checks checking compatibility + doCheckPair - invoke a series of type checks checking compatibility between left and right modula2 symbols. Pre-condition: left and right are modula-2 symbols. tinfo is configured. @@ -972,50 +1206,28 @@ END checkTypeKindViolation ; PROCEDURE doCheckPair (result: status; tinfo: tInfo; left, right: CARDINAL) : status ; +VAR + i: CARDINAL ; BEGIN - IF isFalse (result) OR (result = visited) + IF (left = NulSym) OR (right = NulSym) + THEN + (* We cannot check NulSym. *) + RETURN true + ELSIF isKnown (result) THEN RETURN return (result, tinfo, left, right) ELSIF left = right THEN RETURN return (true, tinfo, left, right) ELSE - result := checkConstEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkVarEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) + i := 1 ; + WHILE i <= HighEquivalence DO + result := Equivalence[i] (result, tinfo, left, right) ; + IF isKnown (result) THEN - result := checkSystemEquivalence (unknown, left, right) ; - IF NOT isKnown (result) - THEN - result := checkSubrangeTypeEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkBaseTypeEquivalence (unknown, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkTypeEquivalence (unknown, left, right) ; - IF NOT isKnown (result) - THEN - result := checkArrayTypeEquivalence (result, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkGenericTypeEquivalence (result, left, right) ; - IF NOT isKnown (result) - THEN - result := checkTypeKindEquivalence (result, tinfo, left, right) ; - IF NOT isKnown (result) - THEN - result := checkTypeKindViolation (result, left, right) - END - END - END - END - END - END - END - END + RETURN return (result, tinfo, left, right) + END ; + INC (i) END END ; RETURN return (result, tinfo, left, right) @@ -1023,6 +1235,45 @@ END doCheckPair ; (* + InitEquivalenceArray - populate the Equivalence array with the + checking procedures. +*) + +PROCEDURE InitEquivalenceArray ; +BEGIN + HighEquivalence := 0 ; + addEquivalence (checkVarEquivalence) ; + addEquivalence (checkVarTypeEquivalence) ; + addEquivalence (checkCharStringTypeEquivalence) ; + addEquivalence (checkConstEquivalence); + addEquivalence (checkEnumFieldEquivalence) ; + addEquivalence (checkSystemEquivalence) ; + addEquivalence (checkSubrangeTypeEquivalence) ; + addEquivalence (checkBaseTypeEquivalence) ; + addEquivalence (checkTypeEquivalence) ; + addEquivalence (checkArrayTypeEquivalence) ; + addEquivalence (checkTypeKindEquivalence) ; + addEquivalence (checkTypeKindViolation) +END InitEquivalenceArray ; + + +(* + addEquivalence - places proc into Equivalence array. +*) + +PROCEDURE addEquivalence (proc: EquivalenceProcedure) ; +BEGIN + INC (HighEquivalence) ; + IF HighEquivalence <= MaxEquvalence + THEN + Equivalence[HighEquivalence] := proc + ELSE + InternalError ('increase MaxEquivalence constant in M2Check.mod') + END +END addEquivalence ; + + +(* checkProcType - *) @@ -1073,6 +1324,12 @@ BEGIN i := 1 ; n := NoOfParamAny (left) ; WHILE i <= n DO + IF isFalse (result) OR (result = visited) + THEN + (* Seen a mismatch therefore return. *) + RETURN return (result, tinfo, left, right) + END ; + result := unknown ; (* Each parameter must match. *) IF IsVarParamAny (left, i) # IsVarParamAny (right, i) THEN IF IsVarParamAny (left, i) @@ -1264,7 +1521,6 @@ BEGIN END checkProcTypeEquivalence ; - (* checkTypeKindEquivalence - *) @@ -1534,7 +1790,7 @@ BEGIN THEN RETURN Address ELSE - RETURN GetSType (sym) + RETURN GetDType (sym) END END getSType ; @@ -1610,11 +1866,19 @@ BEGIN printf ("doCheck (%d, %d)\n", left, right) ; dumptInfo (tinfo) END ; - IF isInternal (left) OR isInternal (right) + IF (left = NulSym) OR (right = NulSym) + THEN + (* Cannot test if a type is NulSym, we assume true. + It maybe that later on a symbols type is set and later + on checking will be called and more accurately resolved. + For example constant strings can be concatenated during + the quadruple folding phase. *) + RETURN TRUE + ELSIF isInternal (left) OR isInternal (right) THEN (* Do not check constants which have been generated internally. - Currently these are generated by the default BY constant value - in a FOR loop. *) + Currently these are generated by the default BY constant + value in a FOR loop. *) RETURN TRUE END ; (* @@ -1633,9 +1897,9 @@ BEGIN result := tinfo^.checkFunc (unknown, tinfo, left, right) ; IF isKnown (result) THEN - (* remove this pair from the unresolved list. *) + (* Remove this pair from the unresolved list. *) exclude (tinfo^.unresolved, left, right) ; - (* add it to the resolved list. *) + (* Add it to the resolved list. *) include (tinfo^.resolved, left, right, result) ; IF result = false THEN @@ -1740,6 +2004,7 @@ END deconstructIndex ; PROCEDURE deconstruct (tinfo: tInfo) ; BEGIN tinfo^.format := KillString (tinfo^.format) ; + tinfo^.reason := KillString (tinfo^.reason) ; tinfo^.visited := deconstructIndex (tinfo^.visited) ; tinfo^.resolved := deconstructIndex (tinfo^.resolved) ; tinfo^.unresolved := deconstructIndex (tinfo^.unresolved) @@ -1786,11 +2051,14 @@ END collapseString ; *) PROCEDURE AssignmentTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR; - des, expr: CARDINAL) : BOOLEAN ; + des, expr: CARDINAL; + enableReason: BOOLEAN) : BOOLEAN ; VAR tinfo: tInfo ; BEGIN tinfo := newtInfo () ; + tinfo^.reason := NIL ; + tinfo^.reasonEnable := enableReason AND StrictTypeReason ; tinfo^.format := collapseString (format) ; tinfo^.token := token ; tinfo^.kind := assignment ; @@ -1835,6 +2103,8 @@ BEGIN tinfo := newtInfo () ; formalT := getSType (formal) ; actualT := getSType (actual) ; + tinfo^.reasonEnable := StrictTypeReason ; + tinfo^.reason := NIL ; tinfo^.format := collapseString (format) ; tinfo^.token := token ; tinfo^.kind := parameter ; @@ -1879,6 +2149,8 @@ VAR tinfo: tInfo ; BEGIN tinfo := newtInfo () ; + tinfo^.reasonEnable := StrictTypeReason ; + tinfo^.reason := NIL ; tinfo^.format := collapseString (format) ; tinfo^.token := token ; tinfo^.kind := expression ; @@ -1943,7 +2215,8 @@ PROCEDURE init ; BEGIN pairFreeList := NIL ; tinfoFreeList := NIL ; - errors := InitIndex (1) + errors := InitIndex (1) ; + InitEquivalenceArray END init ; diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.def b/gcc/m2/gm2-compiler/M2GCCDeclare.def index 1d87d6b..b3a5790 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.def +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.def @@ -98,7 +98,7 @@ PROCEDURE TryDeclareConstant (tokenno: CARDINAL; sym: CARDINAL) ; then enter it into the to do list. *) -PROCEDURE TryDeclareType (tokenno: CARDINAL; type: CARDINAL) ; +PROCEDURE TryDeclareType (type: CARDINAL) ; (* diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod index 7dcf439..860a89a 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod @@ -144,7 +144,7 @@ FROM M2Base IMPORT IsPseudoBaseProcedure, IsPseudoBaseFunction, Boolean, True, False, Nil, IsRealType, IsNeededAtRunTime, IsComplexType ; -FROM M2System IMPORT IsPseudoSystemFunction, IsSystemType, +FROM M2System IMPORT IsPseudoSystemFunction, IsSystemType, IsRealN, GetSystemTypeMinMax, Address, Word, Byte, Loc, System, IntegerN, CardinalN, WordN, RealN, SetN, ComplexN, CSizeT, CSSizeT, COffT ; @@ -251,6 +251,7 @@ TYPE VAR FreeGroup, GlobalGroup : Group ; (* The global group of all sets. *) + ErrorDepList, (* The set of symbols with dependency errors. *) VisitedList, ChainedList : Set ; HaveInitDefaultTypes: BOOLEAN ; (* Have we initialized them yet? *) @@ -261,9 +262,6 @@ VAR enumDeps : BOOLEAN ; -PROCEDURE mystop ; BEGIN END mystop ; - - (* *************************************************** *) (* PrintNum - @@ -1315,14 +1313,26 @@ END CanBeDeclaredPartiallyViaPartialDependants ; (* - EmitCircularDependancyError - issue a dependancy error. + EmitCircularDependencyError - issue a dependency error. *) -PROCEDURE EmitCircularDependancyError (sym: CARDINAL) ; +PROCEDURE EmitCircularDependencyError (sym: CARDINAL) ; BEGIN - MetaError1('circular dependancy error found when trying to resolve {%1Uad}', - sym) -END EmitCircularDependancyError ; + (* Ensure we only issue one dependency message per symbol for this + error classification. *) + IF NOT IsElementInSet (ErrorDepList, sym) + THEN + IncludeElementIntoSet (ErrorDepList, sym) ; + IF IsVar (sym) OR IsParameter (sym) + THEN + MetaError1 ('circular dependency error found when trying to resolve {%1Had}', + sym) + ELSE + MetaError1 ('circular dependency error found when trying to resolve {%1Dad}', + sym) + END + END +END EmitCircularDependencyError ; TYPE @@ -1529,17 +1539,17 @@ BEGIN IF ForeachTryDeclare (todolist, circulartodo, NotAllDependantsFullyDeclared, - EmitCircularDependancyError) + EmitCircularDependencyError) THEN ELSIF ForeachTryDeclare (partiallydeclared, circularpartial, NotAllDependantsPartiallyDeclared, - EmitCircularDependancyError) + EmitCircularDependencyError) THEN ELSIF ForeachTryDeclare (niltypedarrays, circularniltyped, NotAllDependantsPartiallyDeclared, - EmitCircularDependancyError) + EmitCircularDependencyError) THEN END END ; @@ -1918,7 +1928,7 @@ END IsAnyType ; then enter it into the to do list. *) -PROCEDURE TryDeclareType (tokenno: CARDINAL; type: CARDINAL) ; +PROCEDURE TryDeclareType (type: CARDINAL) ; BEGIN IF (type#NulSym) AND IsAnyType (type) THEN @@ -2013,7 +2023,7 @@ BEGIN ELSIF IsConstructor(sym) THEN DeclareConstantFromTree(sym, PopConstructorTree(tokenno)) - ELSIF IsRealType(GetDType(sym)) + ELSIF IsRealType (GetDType (sym)) OR IsRealN (GetDType (sym)) THEN type := GetDType(sym) ; DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopRealTree(), TRUE)) @@ -2855,13 +2865,8 @@ BEGIN n := 1 ; Var := GetNth(scope, n) ; WHILE Var#NulSym DO - IF NOT AllDependantsFullyDeclared(GetSType(Var)) - THEN - mystop - END ; - IF NOT AllDependantsFullyDeclared(GetSType(Var)) + IF NOT TypeDependentsDeclared (Var, TRUE) THEN - EmitCircularDependancyError(GetSType(Var)) ; failed := TRUE END ; INC(n) ; @@ -2922,14 +2927,12 @@ BEGIN DeclareTypesConstantsProcedures(scope) ; (* will resolved TYPEs and CONSTs on the ToDo *) (* lists. *) ForeachModuleDo(DeclareProcedure) ; - (* - now that all types have been resolved it is safe to declare - variables - *) + (* Now that all types have been resolved it is safe to declare + variables. *) AssertAllTypesDeclared(scope) ; DeclareGlobalVariables(scope) ; ForeachImportedDo(scope, DeclareImportedVariables) ; - (* now it is safe to declare all procedures *) + (* Now it is safe to declare all procedures. *) ForeachProcedureDo(scope, DeclareProcedure) ; ForeachInnerModuleDo(scope, WalkTypesInModule) ; ForeachInnerModuleDo(scope, DeclareTypesConstantsProcedures) ; @@ -2958,14 +2961,12 @@ BEGIN (* lists. *) ForeachModuleDo(DeclareProcedure) ; ForeachModuleDo(DeclareModuleInit) ; - (* - now that all types have been resolved it is safe to declare - variables - *) + (* Now that all types have been resolved it is safe to declare + variables. *) AssertAllTypesDeclared(scope) ; DeclareGlobalVariablesWholeProgram(scope) ; ForeachImportedDo(scope, DeclareImportedVariablesWholeProgram) ; - (* now it is safe to declare all procedures *) + (* Now it is safe to declare all procedures. *) ForeachProcedureDo(scope, DeclareProcedure) ; ForeachInnerModuleDo(scope, WalkTypesInModule) ; ForeachInnerModuleDo(scope, DeclareTypesConstantsProcedures) ; @@ -3411,15 +3412,55 @@ PROCEDURE DoVariableDeclaration (var: CARDINAL; name: ADDRESS; isImported, isExported, isTemporary, isGlobal: BOOLEAN; scope: tree) ; +BEGIN + IF NOT (IsComponent (var) OR IsVarHeap (var)) + THEN + IF TypeDependentsDeclared (var, TRUE) + THEN + PrepareGCCVarDeclaration (var, name, isImported, isExported, + isTemporary, isGlobal, scope) + END + END +END DoVariableDeclaration ; + + +(* + TypeDependentsDeclared - return TRUE if all type dependents of variable + have been declared. +*) + +PROCEDURE TypeDependentsDeclared (variable: CARDINAL; errorMessage: BOOLEAN) : BOOLEAN ; +VAR + type: CARDINAL ; +BEGIN + type := GetSType (variable) ; + IF AllDependantsFullyDeclared (type) + THEN + RETURN TRUE + ELSE + IF errorMessage + THEN + EmitCircularDependencyError (variable) ; + ForeachElementInSetDo (GlobalGroup^.ToDoList, EmitCircularDependencyError) + END + END ; + RETURN FALSE +END TypeDependentsDeclared ; + + +(* + PrepareGCCVarDeclaration - +*) + +PROCEDURE PrepareGCCVarDeclaration (var: CARDINAL; name: ADDRESS; + isImported, isExported, + isTemporary, isGlobal: BOOLEAN; + scope: tree) ; VAR type : tree ; varType : CARDINAL ; location: location_t ; BEGIN - IF IsComponent (var) OR IsVarHeap (var) - THEN - RETURN - END ; IF GetMode (var) = LeftValue THEN (* @@ -3457,7 +3498,7 @@ BEGIN isGlobal, scope, NIL)) ; WatchRemoveList (var, todolist) ; WatchIncludeList (var, fullydeclared) -END DoVariableDeclaration ; +END PrepareGCCVarDeclaration ; (* @@ -3493,7 +3534,6 @@ BEGIN THEN scope := FindContext (ModSym) ; decl := FindOuterModule (variable) ; - Assert (AllDependantsFullyDeclared (GetSType (variable))) ; PushBinding (ModSym) ; DoVariableDeclaration (variable, KeyToCharStar (GetFullSymName (variable)), @@ -3521,7 +3561,6 @@ BEGIN THEN scope := FindContext (mainModule) ; decl := FindOuterModule (variable) ; - Assert (AllDependantsFullyDeclared (GetSType (variable))) ; PushBinding (mainModule) ; DoVariableDeclaration (variable, KeyToCharStar (GetFullSymName (variable)), @@ -3618,7 +3657,6 @@ END DeclareImportedVariablesWholeProgram ; PROCEDURE DeclareLocalVariable (var: CARDINAL) ; BEGIN - Assert (AllDependantsFullyDeclared (var)) ; DoVariableDeclaration (var, KeyToCharStar (GetFullSymName (var)), FALSE, (* local variables cannot be imported *) @@ -3662,7 +3700,6 @@ BEGIN scope := Mod2Gcc (GetProcedureScope (sym)) ; Var := GetNth (sym, i) ; WHILE Var # NulSym DO - Assert (AllDependantsFullyDeclared (GetSType (Var))) ; DoVariableDeclaration (Var, KeyToCharStar (GetFullSymName (Var)), FALSE, (* inner module variables cannot be imported *) @@ -6658,6 +6695,7 @@ END InitDeclarations ; BEGIN FreeGroup := NIL ; GlobalGroup := InitGroup () ; + ErrorDepList := InitSet (1) ; ChainedList := InitSet(1) ; WatchList := InitSet(1) ; VisitedList := NIL ; diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod index ec38dc2..4a9ced3 100644 --- a/gcc/m2/gm2-compiler/M2GenGCC.mod +++ b/gcc/m2/gm2-compiler/M2GenGCC.mod @@ -43,7 +43,7 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue, IsConst, IsConstSet, IsProcedure, IsProcType, IsVar, IsVarParamAny, IsTemporary, IsTuple, IsEnumeration, - IsUnbounded, IsArray, IsSet, IsConstructor, + IsUnbounded, IsArray, IsSet, IsConstructor, IsConstructorConstant, IsProcedureVariable, IsUnboundedParamAny, IsRecordField, IsFieldVarient, IsVarient, IsRecord, @@ -232,7 +232,7 @@ FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunct BuildReturnValueCode, SetLastFunction, BuildIncludeVarConst, BuildIncludeVarVar, BuildExcludeVarConst, BuildExcludeVarVar, - BuildBuiltinCallTree, + BuildBuiltinCallTree, CopyByField, GetParamTree, BuildCleanUp, BuildTryFinally, GetLastFunction, SetLastFunction, @@ -241,7 +241,7 @@ FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunct FROM m2type IMPORT ChainOnParamValue, GetPointerType, GetIntegerType, AddStatement, GetCardinalType, GetWordType, GetM2ZType, GetM2RType, GetM2CType, BuildCharConstant, AddStringToTreeList, BuildArrayStringConstructor, - GetArrayNoOfElements, GetTreeType ; + GetArrayNoOfElements, GetTreeType, IsGccStrictTypeEquivalent ; FROM m2block IMPORT RememberConstant, pushGlobalScope, popGlobalScope, finishFunctionDecl, pushFunctionScope, popFunctionScope, @@ -681,7 +681,7 @@ BEGIN IfGreOp : CodeIfGre (q) | IfInOp : CodeIfIn (q) | IfNotInOp : CodeIfNotIn (q) | - IndrXOp : CodeIndrX (q, op1, op2, op3) | + IndrXOp : CodeIndrX (q) | XIndrOp : CodeXIndr (q) | CallOp : CodeCall (CurrentQuadToken, op3) | ParamOp : CodeParam (q) | @@ -2914,9 +2914,6 @@ BEGIN IF TypeCheckBecomes (p, quad) THEN PerformFoldBecomes (p, quad) - ELSE - GetQuad (quad, op, des, op2, expr) ; - RemoveQuad (p, des, quad) END END END @@ -3007,7 +3004,7 @@ BEGIN despos, op2pos, exprpos) ; Assert (op2pos = UnknownTokenNo) ; IF StrictTypeChecking AND - (NOT AssignmentTypeCompatible (despos, "", des, expr)) + (NOT AssignmentTypeCompatible (despos, "", des, expr, TRUE)) THEN MetaErrorT2 (MakeVirtualTok (becomespos, despos, exprpos), 'assignment check caught mismatch between {%1Ead} and {%2ad}', @@ -3236,7 +3233,7 @@ BEGIN IF SkipType(GetTypeMode(op1))#SkipType(GetTypeMode(op3)) THEN DescribeTypeError (tokenno, op1, op3) ; - (* Assigning an errant op3 might ICE, therefore it is safer to return op1. *) + (* Assigning an errant op3 might ICE, therefore it is safer to return op1. *) RETURN( Mod2Gcc (op1) ) END END ; @@ -3498,6 +3495,29 @@ END checkDeclare ; (* + PerformCodeBecomes - +*) + +PROCEDURE PerformCodeBecomes (location: location_t; + virtpos: CARDINAL; des, expr: CARDINAL) ; +VAR + destree, exprtree: tree ; +BEGIN + destree := Mod2Gcc (des) ; + exprtree := FoldConstBecomes (virtpos, des, expr) ; + IF IsVar (des) AND IsVariableSSA (des) + THEN + Replace (des, exprtree) + ELSIF IsGccStrictTypeEquivalent (destree, exprtree) + THEN + BuildAssignmentStatement (location, destree, exprtree) + ELSE + CopyByField (location, destree, exprtree) + END +END PerformCodeBecomes ; + + +(* ------------------------------------------------------------------------------ := Operator ------------------------------------------------------------------------------ @@ -3530,7 +3550,7 @@ BEGIN location := TokenToLocation (virtpos) ; IF StrictTypeChecking AND - (NOT AssignmentTypeCompatible (virtpos, "", des, expr)) + (NOT AssignmentTypeCompatible (virtpos, "", des, expr, TRUE)) THEN ErrorMessageDecl (virtpos, 'assignment check caught mismatch between {%1Ead} and {%2ad}', @@ -3576,14 +3596,7 @@ BEGIN ELSE IF checkBecomes (des, expr, virtpos, despos, exprpos) THEN - IF IsVar (des) AND IsVariableSSA (des) - THEN - Replace (des, FoldConstBecomes (virtpos, des, expr)) - ELSE - BuildAssignmentStatement (location, - Mod2Gcc (des), - FoldConstBecomes (virtpos, des, expr)) - END + PerformCodeBecomes (location, virtpos, des, expr) ELSE SubQuad (quad) (* We don't want multiple errors for the quad. *) END @@ -3905,8 +3918,6 @@ END NoWalkProcedure ; PROCEDURE CheckBinaryExpressionTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ; VAR - lefttype, - righttype, des, left, right: CARDINAL ; typeChecking, constExpr, @@ -3924,10 +3935,8 @@ BEGIN IF typeChecking AND (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, + (NOT ExpressionTypeCompatible (subexprpos, "", left, right, StrictTypeChecking, FALSE)) THEN MetaErrorT2 (subexprpos, @@ -3937,19 +3946,6 @@ BEGIN 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 - ErrorMessageDecl (subexprpos, - 'expression mismatch between {%1Etad} and {%2tad}', - left, right, TRUE) ; - NoChange := FALSE ; - SubQuad (quad) ; - p (des) ; - RETURN FALSE END END ; RETURN TRUE @@ -3965,7 +3961,6 @@ END CheckBinaryExpressionTypes ; PROCEDURE CheckElementSetTypes (quad: CARDINAL) : BOOLEAN ; VAR - lefttype, righttype, ignore, left, right: CARDINAL ; constExpr, @@ -3982,13 +3977,9 @@ BEGIN overflowChecking, constExpr, 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, + (NOT ExpressionTypeCompatible (subexprpos, "", left, right, StrictTypeChecking, TRUE)) THEN MetaErrorT2 (subexprpos, @@ -4007,17 +3998,6 @@ BEGIN 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 - ErrorMessageDecl (subexprpos, - 'the types used in expression {%1Etad} {%kIN} {%2tad} are incompatible', - left, right, TRUE) ; - NoChange := FALSE ; - SubQuad (quad) ; - RETURN FALSE - END ; RETURN TRUE END CheckElementSetTypes ; @@ -4821,18 +4801,17 @@ END FoldBuiltinTypeInfo ; PROCEDURE FoldTBitsize (tokenno: CARDINAL; p: WalkAction; quad: CARDINAL; - op1, op2, op3: CARDINAL) ; + res, type: CARDINAL) ; VAR - type : CARDINAL ; location: location_t ; BEGIN location := TokenToLocation(tokenno) ; - TryDeclareType (tokenno, op3) ; - type := GetDType (op3) ; + TryDeclareType (type) ; + type := GetDType (type) ; IF CompletelyResolved (type) THEN - AddModGcc (op1, BuildSystemTBitSize (location, Mod2Gcc (type))) ; - p (op1) ; + AddModGcc (res, BuildSystemTBitSize (location, Mod2Gcc (type))) ; + p (res) ; NoChange := FALSE ; SubQuad (quad) END @@ -4971,7 +4950,7 @@ BEGIN END ELSIF op2=TBitSize THEN - FoldTBitsize (tokenno, p, quad, op1, op2, op3) + FoldTBitsize (tokenno, p, quad, op1, op3) ELSE InternalError ('only expecting LENGTH, CAP, ABS, IM, RE') END @@ -8162,25 +8141,52 @@ END CodeIfNotIn ; (op2 is the type of the data being indirectly copied) *) -PROCEDURE CodeIndrX (quad: CARDINAL; op1, op2, op3: CARDINAL) ; +PROCEDURE CodeIndrX (quad: CARDINAL) ; VAR - location: location_t ; + constExpr, + overflowChecking: BOOLEAN ; + op : QuadOperator ; + tokenno, + left, + type, + right, + leftpos, + rightpos, + typepos, + indrxpos : CARDINAL ; + length, + newstr : tree ; + location : location_t ; BEGIN - location := TokenToLocation (CurrentQuadToken) ; + GetQuadOtok (quad, indrxpos, op, left, type, right, + overflowChecking, constExpr, + leftpos, typepos, rightpos) ; + tokenno := MakeVirtualTok (indrxpos, leftpos, rightpos) ; + location := TokenToLocation (tokenno) ; (* Follow the Quadruple rules: *) - DeclareConstant (CurrentQuadToken, op3) ; (* checks to see whether it is a constant and declares it *) - DeclareConstructor (CurrentQuadToken, quad, op3) ; - IF IsConstString (op3) + DeclareConstant (rightpos, right) ; (* Checks to see whether it is a constant + and if necessary declare it. *) + DeclareConstructor (rightpos, quad, right) ; + IF IsConstString (right) THEN InternalError ('not expecting to index through a constant string') + ELSIF StrictTypeChecking AND + (NOT AssignmentTypeCompatible (indrxpos, "", left, GetType (right), TRUE)) + THEN + MetaErrorT2 (tokenno, + 'assignment check caught mismatch between {%1Ead} and {%2ad}', + left, right) ; + SubQuad (quad) ELSE + (* Mem[op1] := Mem[Mem[op3]] *) - BuildAssignmentStatement (location, Mod2Gcc (op1), BuildIndirect (location, Mod2Gcc (op3), Mod2Gcc (op2))) + BuildAssignmentStatement (location, Mod2Gcc (left), + BuildIndirect (location, Mod2Gcc (right), Mod2Gcc (type))) END END CodeIndrX ; @@ -8217,6 +8223,14 @@ BEGIN type := SkipType (type) ; DeclareConstant (rightpos, right) ; DeclareConstructor (rightpos, quad, right) ; + IF StrictTypeChecking AND + (NOT AssignmentTypeCompatible (xindrpos, "", GetType (left), right, TRUE)) + THEN + MetaErrorT2 (tokenno, + 'assignment check caught mismatch between {%1Ead} and {%2ad}', + left, right) ; + SubQuad (quad) + END ; IF IsProcType(SkipType(type)) THEN BuildAssignmentStatement (location, BuildIndirect (location, Mod2Gcc (left), GetPointerType ()), Mod2Gcc (right)) diff --git a/gcc/m2/gm2-compiler/M2MetaError.def b/gcc/m2/gm2-compiler/M2MetaError.def index 637a27d..3dfe9fa 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.def +++ b/gcc/m2/gm2-compiler/M2MetaError.def @@ -73,7 +73,8 @@ FROM NameKey IMPORT Name ; {%kword} the string word is unquoted and rendered as a keyword. {%C} chain this error on the previous rooted error. {%R} this error will be the root of the future chained errors. - {%n} decimal number. Not quoted. + {% n} decimal number. Not quoted. There is no space between the + % and n (this has been added to hide this comment from gettext). {%N} count (number), for example, 1st, 2nd, 3rd, 4th. Not quoted. {%X} push contents of the output string onto the string stack. {%Yname} place contents of dictionary entry name onto the output string. @@ -92,9 +93,9 @@ FROM NameKey IMPORT Name ; %} } the error messages may also embed optional strings such as: - {%1a:this string is emitted if the symbol name is non null} - {!%1a:this string is emitted if the symbol name is null} - {!%1a:{%1d}} + {%1a:this string is emitted if the symbol name is null} + {!%1a:this string is emitted if the symbol name is non null} + {%1a:{%1d}} if the symbol name does not exist then print a description of the symbol. {%1atd} was incompatible with the return type of the procedure @@ -109,7 +110,8 @@ FROM NameKey IMPORT Name ; describe the symbol. If ordinary text is copied then it is not quoted. The color strings are: "filename", "quote", "error", "warning", "note", - "locus", "insert", "delete", "type", "range1", range2". + "locus", "insert", "delete", "type", "range1", + "range2". *) (* diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod index 22bc77f..3aa7543 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.mod +++ b/gcc/m2/gm2-compiler/M2MetaError.mod @@ -1437,35 +1437,22 @@ BEGIN doError (eb, GetDeclaredDef (sym)) ELSE M2Error.EnterErrorScope (GetErrorScope (scope)) ; - IF IsProcedure (scope) + IF IsVar (sym) OR IsParameter (sym) THEN - IF IsVar (sym) OR IsParameter (sym) - THEN - doError (eb, GetVarParamTok (sym)) - ELSE - doError (eb, GetDeclaredDef (sym)) - END + doError (eb, GetVarParamTok (sym)) + ELSIF IsProcedure (scope) + THEN + doError (eb, GetDeclaredDef (sym)) + ELSIF IsModule (scope) + THEN + doError (eb, GetDeclaredMod (sym)) ELSE - IF IsModule (scope) + Assert (IsDefImp (scope)) ; + IF GetDeclaredDefinition (sym) = UnknownTokenNo THEN - IF IsInnerModule (scope) - THEN - doError (eb, GetDeclaredDef (sym)) - ELSE - doError (eb, GetDeclaredDef (sym)) - END + doError (eb, GetDeclaredMod (sym)) ELSE - Assert (IsDefImp (scope)) ; - (* if this fails then we need to skip to the outer scope. - REPEAT - OuterModule := GetScope(OuterModule) - UNTIL GetScope(OuterModule)=NulSym ; *) - IF GetDeclaredDefinition (sym) = UnknownTokenNo - THEN - doError (eb, GetDeclaredMod (sym)) - ELSE - doError (eb, GetDeclaredDef (sym)) - END + doError (eb, GetDeclaredDef (sym)) END END END ; diff --git a/gcc/m2/gm2-compiler/M2Options.def b/gcc/m2/gm2-compiler/M2Options.def index 2b78add..4cb7f8f 100644 --- a/gcc/m2/gm2-compiler/M2Options.def +++ b/gcc/m2/gm2-compiler/M2Options.def @@ -87,6 +87,8 @@ VAR LineDirectives, (* Should compiler understand preprocessor *) (* # linenumber "filename" markers? *) StrictTypeChecking, (* -fm2-strict-type experimental checker. *) + StrictTypeAssignment, (* -fm2-strict-assignment. *) + StrictTypeReason, (* -fm2-strict-reason. *) CPreProcessor, (* Must we run the cpp on the source? *) Xcode, (* Should errors follow Xcode format? *) ExtendedOpaque, (* Do we allow non pointer opaque types? *) @@ -756,6 +758,20 @@ PROCEDURE SetStrictTypeChecking (value: BOOLEAN) ; (* + SetStrictTypeAssignment - assigns the StrictTypeAssignment flag to value. +*) + +PROCEDURE SetStrictTypeAssignment (value: BOOLEAN) ; + + +(* + SetStrictTypeReason - assigns the StrictTypeReason flag to value. +*) + +PROCEDURE SetStrictTypeReason (value: BOOLEAN) ; + + +(* setdefextension - set the source file definition module extension to arg. This should include the . and by default it is set to .def. *) diff --git a/gcc/m2/gm2-compiler/M2Options.mod b/gcc/m2/gm2-compiler/M2Options.mod index 39f0b2a..542b87b 100644 --- a/gcc/m2/gm2-compiler/M2Options.mod +++ b/gcc/m2/gm2-compiler/M2Options.mod @@ -657,6 +657,26 @@ END SetStrictTypeChecking ; (* + SetStrictTypeAssignment - assigns the StrictTypeAssignment flag to value. +*) + +PROCEDURE SetStrictTypeAssignment (value: BOOLEAN) ; +BEGIN + StrictTypeAssignment := value +END SetStrictTypeAssignment ; + + +(* + SetStrictTypeReason - assigns the StrictTypeReason flag to value. +*) + +PROCEDURE SetStrictTypeReason (value: BOOLEAN) ; +BEGIN + StrictTypeReason := value +END SetStrictTypeReason ; + + +(* SetVerboseUnbounded - sets the VerboseUnbounded flag to, value. *) @@ -2111,6 +2131,8 @@ BEGIN UnusedVariableChecking := FALSE ; UnusedParameterChecking := FALSE ; StrictTypeChecking := TRUE ; + StrictTypeAssignment := TRUE ; + StrictTypeReason := TRUE ; AutoInit := FALSE ; SaveTemps := FALSE ; ScaffoldDynamic := TRUE ; diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index a45d67a..748ce24 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -69,6 +69,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown, GetArraySubscript, GetDimension, GetParam, GetNth, GetNthParamAny, + GetNthParamAnyClosest, GetFirstUsed, GetDeclaredMod, GetQuads, GetReadQuads, GetWriteQuads, GetWriteLimitQuads, GetReadLimitQuads, @@ -225,6 +226,7 @@ FROM M2Options IMPORT NilChecking, GenerateLineDebug, Exceptions, Profiling, Coding, Optimizing, UninitVariableChecking, + StrictTypeAssignment, ScaffoldDynamic, ScaffoldStatic, cflag, ScaffoldMain, SharedFlag, WholeProgram, GetDumpDir, GetM2DumpFilter, @@ -257,8 +259,10 @@ FROM M2Range IMPORT InitAssignmentRangeCheck, InitRotateCheck, InitShiftCheck, InitTypesAssignmentCheck, + InitTypesIndrXCheck, InitTypesExpressionCheck, InitTypesParameterCheck, + InitTypesReturnTypeCheck, InitForLoopBeginRangeCheck, InitForLoopToRangeCheck, InitForLoopEndRangeCheck, @@ -283,7 +287,6 @@ IMPORT M2Error, FIO, SFIO, DynamicStrings, StdIO ; CONST DebugStackOn = TRUE ; DebugVarients = FALSE ; - BreakAtQuad = 758 ; DebugTokPos = FALSE ; TYPE @@ -396,6 +399,7 @@ VAR (* in order. *) NoOfQuads : CARDINAL ; (* Number of used quadruples. *) Head : CARDINAL ; (* Head of the list of quadruples. *) + BreakQuad : CARDINAL ; (* Stop when BreakQuad is created. *) (* @@ -1486,22 +1490,6 @@ BEGIN END AddQuadInformation ; -PROCEDURE stop ; BEGIN END stop ; - - -(* - CheckBreak - check whether QuadNo = BreakAtQuad and if so call stop. -*) - -PROCEDURE CheckBreak (QuadNo: CARDINAL) ; -BEGIN - IF QuadNo = BreakAtQuad - THEN - stop - END -END CheckBreak ; - - (* PutQuadO - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and sets a boolean to determinine whether overflow should be checked. @@ -3887,6 +3875,10 @@ BEGIN THEN MetaErrorT1 (combinedtok, 'combined {%1Oad}', Des) END ; + IF StrictTypeAssignment + THEN + BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp)) + END ; IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des))) THEN (* Tell code generator to test runtime values of assignment so ensure we @@ -4654,6 +4646,8 @@ BEGIN BySym) ; MetaErrorDecl (BySym, TRUE) ELSE + e1 := DereferenceLValue (e1tok, e1) ; + e2 := DereferenceLValue (e2tok, e2) ; GenQuadOTypetok (bytok, LastForIteratorOp, LastIterator, Make2Tuple (e1, e2), BySym, FALSE, FALSE, bytok, MakeVirtual2Tok (e1tok, e2tok), bytok) @@ -5627,7 +5621,7 @@ VAR proctok, paramtok : CARDINAL ; n1, n2 : Name ; - ParamCheckId, + ParamCheckId, Dim, Actual, FormalI, @@ -5676,7 +5670,8 @@ BEGIN WHILE i<=ParamTotal DO IF i <= NoOfParamAny (Proc) THEN - FormalI := GetParam(Proc, i) ; + (* FormalI := GetParam(Proc, i) ; *) + FormalI := GetNthParamAnyClosest (Proc, i, GetCurrentModule ()) ; IF CompilerDebugging THEN n1 := GetSymName(FormalI) ; @@ -5768,42 +5763,46 @@ VAR CheckedProcedure: CARDINAL ; e : Error ; BEGIN - n := NoOfParamAny (ProcType) ; IF IsVar(call) OR IsTemporary(call) OR IsParameter(call) THEN CheckedProcedure := GetDType(call) ELSE CheckedProcedure := call END ; - IF n # NoOfParamAny (CheckedProcedure) + IF ProcType # CheckedProcedure THEN - e := NewError(GetDeclaredMod(ProcType)) ; - n1 := GetSymName(call) ; - n2 := GetSymName(ProcType) ; - ErrorFormat2(e, 'procedure (%a) is a parameter being passed as variable (%a) but they are declared with different number of parameters', - n1, n2) ; - e := ChainError(GetDeclaredMod(call), e) ; - t := NoOfParamAny (CheckedProcedure) ; - IF n<2 + n := NoOfParamAny (ProcType) ; + (* We need to check the formal parameters between the procedure and proc type. *) + IF n # NoOfParamAny (CheckedProcedure) THEN - ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameter, declared with (%d)', - n1, n, t) - ELSE - ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameters, declared with (%d)', - n1, n, t) - END - ELSE - i := 1 ; - WHILE i<=n DO - IF IsVarParamAny (ProcType, i) # IsVarParamAny (CheckedProcedure, i) + e := NewError(GetDeclaredMod(ProcType)) ; + n1 := GetSymName(call) ; + n2 := GetSymName(ProcType) ; + ErrorFormat2(e, 'procedure (%a) is a parameter being passed as variable (%a) but they are declared with different number of parameters', + n1, n2) ; + e := ChainError(GetDeclaredMod(call), e) ; + t := NoOfParamAny (CheckedProcedure) ; + IF n<2 THEN - MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth (ProcType, i), i) ; - MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth (call, i), i) - END ; - BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i, - GetParam (CheckedProcedure, i), - GetParam (ProcType, i), ParamCheckId)) ; - INC(i) + ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameter, declared with (%d)', + n1, n, t) + ELSE + ErrorFormat3(e, 'procedure (%a) is being called incorrectly with (%d) parameters, declared with (%d)', + n1, n, t) + END + ELSE + i := 1 ; + WHILE i<=n DO + IF IsVarParamAny (ProcType, i) # IsVarParamAny (CheckedProcedure, i) + THEN + MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth (ProcType, i), i) ; + MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth (call, i), i) + END ; + BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i, + GetNthParamAnyClosest (CheckedProcedure, i, GetCurrentModule ()), + GetParam (ProcType, i), ParamCheckId)) ; + INC(i) + END END END END CheckProcTypeAndProcedure ; @@ -6150,7 +6149,7 @@ BEGIN MetaErrorStringT2 (tokpos, Msg, ProcedureSym, ParameterNo) ; IF NoOfParamAny (ProcedureSym) >= ParameterNo THEN - FormalParam := GetNthParamAny (ProcedureSym, ParameterNo) ; + FormalParam := GetNthParamAnyClosest (ProcedureSym, ParameterNo, GetCurrentModule ()) ; IF IsUnboundedParamAny (ProcedureSym, ParameterNo) THEN MetaErrorT2 (GetVarDeclFullTok (FormalParam), 'formal parameter {%1ad} has an open array type {%2tad}', @@ -6205,7 +6204,7 @@ BEGIN MetaErrorStringT2 (tokpos, Msg, ProcedureSym, ParameterNo) ; IF NoOfParamAny (ProcedureSym) >= ParameterNo THEN - FormalParam := GetNthParamAny (ProcedureSym, ParameterNo) ; + FormalParam := GetNthParamAnyClosest (ProcedureSym, ParameterNo, GetCurrentModule ()) ; IF IsUnboundedParamAny (ProcedureSym, ParameterNo) THEN MetaErrorT2 (GetVarDeclFullTok (FormalParam), '{%W}formal parameter {%1ad} has an open array type {%2tad}', @@ -6270,21 +6269,24 @@ END ExpectVariable ; doIndrX - perform des = *exp with a conversion if necessary. *) -PROCEDURE doIndrX (tok: CARDINAL; - des, exp: CARDINAL) ; +PROCEDURE doIndrX (tok: CARDINAL; des, exp: CARDINAL) ; VAR t: CARDINAL ; BEGIN - IF GetDType(des)=GetDType(exp) + IF GetDType (des) = GetDType (exp) THEN GenQuadOtok (tok, IndrXOp, des, GetSType (des), exp, TRUE, tok, tok, tok) ELSE + IF StrictTypeAssignment + THEN + BuildRange (InitTypesIndrXCheck (tok, des, exp)) + END ; t := MakeTemporary (tok, RightValue) ; PutVar (t, GetSType (exp)) ; GenQuadOtok (tok, IndrXOp, t, GetSType (exp), exp, TRUE, tok, tok, tok) ; - GenQuadOtok (tok, BecomesOp, des, NulSym, doVal (GetSType(des), t), TRUE, + GenQuadOtok (tok, BecomesOp, des, NulSym, doVal (GetSType (des), t), TRUE, tok, UnknownTokenNo, tok) END END doIndrX ; @@ -8474,7 +8476,7 @@ BEGIN THEN (* we cannot test for IsConst(Param) AND (GetSType(Param)=Char) as the type might not be assigned yet *) MetaError1 ('base procedure {%EkHIGH} expects a variable or string constant as its parameter {%1d:rather than {%1d}} {%1asa}', Param) - ELSIF IsUnbounded(Type) + ELSIF (Type # NulSym) AND IsUnbounded(Type) THEN BuildHighFromUnbounded (combinedtok) ELSE @@ -9776,11 +9778,30 @@ END CheckBaseTypeValue ; (* - GetTypeMin - returns the minimium value of type. + GetTypeMin - returns the minimium value of type and generate an error + if this is unavailable. *) PROCEDURE GetTypeMin (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; VAR + min: CARDINAL ; +BEGIN + min := GetTypeMinLower (tok, func, type) ; + IF min = NulSym + THEN + MetaErrorT1 (tok, + 'unable to obtain the {%AkMIN} value for type {%1ad}', type) + END ; + RETURN min +END GetTypeMin ; + + +(* + GetTypeMinLower - obtain the maximum value for type. +*) + +PROCEDURE GetTypeMinLower (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; +VAR min, max: CARDINAL ; BEGIN IF IsSubrange (type) @@ -9803,22 +9824,38 @@ BEGIN RETURN min ELSIF GetSType (type) = NulSym THEN - MetaErrorT1 (tok, - 'unable to obtain the {%AkMIN} value for type {%1ad}', type) ; - (* non recoverable error. *) - InternalError ('MetaErrorT1 {%AkMIN} should call abort') + RETURN NulSym ELSE RETURN GetTypeMin (tok, func, GetSType (type)) END -END GetTypeMin ; +END GetTypeMinLower ; (* - GetTypeMax - returns the maximum value of type. + GetTypeMax - returns the maximum value of type and generate an error + if this is unavailable. *) PROCEDURE GetTypeMax (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; VAR + max: CARDINAL ; +BEGIN + max := GetTypeMaxLower (tok, func, type) ; + IF max = NulSym + THEN + MetaErrorT1 (tok, + 'unable to obtain the {%AkMAX} value for type {%1ad}', type) + END ; + RETURN max +END GetTypeMax ; + + +(* + GetTypeMaxLower - obtain the maximum value for type. +*) + +PROCEDURE GetTypeMaxLower (tok: CARDINAL; func, type: CARDINAL) : CARDINAL ; +VAR min, max: CARDINAL ; BEGIN IF IsSubrange (type) @@ -9841,14 +9878,11 @@ BEGIN RETURN max ELSIF GetSType (type) = NulSym THEN - MetaErrorT1 (tok, - 'unable to obtain the {%AkMAX} value for type {%1ad}', type) ; - (* non recoverable error. *) - InternalError ('MetaErrorT1 {%AkMAX} should call abort') + RETURN NulSym ELSE RETURN GetTypeMax (tok, func, GetSType (type)) END -END GetTypeMax ; +END GetTypeMaxLower ; (* @@ -11261,12 +11295,41 @@ BEGIN n1, n2) ELSE (* this checks the types are compatible, not the data contents. *) - BuildRange (InitTypesAssignmentCheck (tokno, currentProc, actualVal)) + BuildRange (InitTypesReturnTypeCheck (tokno, currentProc, actualVal)) END END CheckReturnType ; (* + BuildReturnLower - check the return type and value to ensure type + compatibility and no range overflow will occur. +*) + +PROCEDURE BuildReturnLower (tokcombined, tokexpr: CARDINAL; e1, t1: CARDINAL) ; +VAR + e2, t2: CARDINAL ; +BEGIN + (* This will check that the type returned is compatible with + the formal return type of the procedure. *) + CheckReturnType (tokcombined, CurrentProc, e1, t1) ; + (* Dereference LeftValue if necessary. *) + IF GetMode (e1) = LeftValue + THEN + t2 := GetSType (CurrentProc) ; + e2 := MakeTemporary (tokexpr, RightValue) ; + PutVar(e2, t2) ; + CheckPointerThroughNil (tokexpr, e1) ; + doIndrX (tokexpr, e2, e1) ; + e1 := e2 + END ; + (* Here we check the data contents to ensure no overflow. *) + BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ; + GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE, + tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) +END BuildReturnLower ; + + +(* BuildReturn - Builds the Return part of the procedure. tokreturn is the location of the RETURN keyword. The Stack is expected to contain: @@ -11285,7 +11348,6 @@ PROCEDURE BuildReturn (tokreturn: CARDINAL) ; VAR tokcombined, tokexpr : CARDINAL ; - e2, t2, e1, t1, t, f, Des : CARDINAL ; @@ -11305,26 +11367,18 @@ BEGIN tokcombined := MakeVirtualTok (tokreturn, tokreturn, tokexpr) ; IF e1 # NulSym THEN - (* this will check that the type returned is compatible with - the formal return type of the procedure. *) - CheckReturnType (tokcombined, CurrentProc, e1, t1) ; - (* dereference LeftValue if necessary *) - IF GetMode (e1) = LeftValue - THEN - t2 := GetSType (CurrentProc) ; - e2 := MakeTemporary (tokexpr, RightValue) ; - PutVar(e2, t2) ; - CheckPointerThroughNil (tokexpr, e1) ; - doIndrX (tokexpr, e2, e1) ; - (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e2)) ; - GenQuadOtok (tokcombined, ReturnValueOp, e2, NulSym, CurrentProc, FALSE, - tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) + (* Check we are in a procedure scope and that the procedure has a return type. *) + IF CurrentProc = NulSym + THEN + MetaErrorT0 (tokcombined, + '{%1E} attempting to return a value when not in a procedure scope') + ELSIF GetSType (CurrentProc) = NulSym + THEN + MetaErrorT1 (tokcombined, + 'attempting to return a value from procedure {%1Ea} which does not have a return type', + CurrentProc) ELSE - (* here we check the data contents to ensure no overflow. *) - BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ; - GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE, - tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc)) + BuildReturnLower (tokcombined, tokexpr, e1, t1) END END ; GenQuadO (tokcombined, GotoOp, NulSym, NulSym, PopWord (ReturnStack), FALSE) ; @@ -11449,13 +11503,12 @@ END BuildDesignatorPointerError ; (* BuildDesignatorArray - Builds the array referencing. The purpose of this procedure is to work out - whether the DesignatorArray is a static or - dynamic array and to call the appropriate + whether the DesignatorArray is a constant string or + dynamic array/static array and to call the appropriate BuildRoutine. The Stack is expected to contain: - Entry Exit ===== ==== @@ -11468,6 +11521,41 @@ END BuildDesignatorPointerError ; *) PROCEDURE BuildDesignatorArray ; +BEGIN + IF IsConst (OperandT (2)) AND IsConstString (OperandT (2)) + THEN + MetaErrorT1 (OperandTtok (2), + '{%1Ead} is not an array, but a constant string. Hint use a string constant created with an array constructor', + OperandT (2)) ; + BuildDesignatorError ('bad array access') + ELSE + BuildDesignatorArrayStaticDynamic + END +END BuildDesignatorArray ; + + +(* + BuildDesignatorArrayStaticDynamic - Builds the array referencing. + The purpose of this procedure is to work out + whether the DesignatorArray is a static or + dynamic array and to call the appropriate + BuildRoutine. + + The Stack is expected to contain: + + + Entry Exit + ===== ==== + + Ptr -> + +--------------+ + | e | <- Ptr + |--------------| +------------+ + | Sym | Type | | S | T | + |--------------| |------------| +*) + +PROCEDURE BuildDesignatorArrayStaticDynamic ; VAR combinedTok, arrayTok, @@ -11480,10 +11568,7 @@ BEGIN IF IsConst (OperandT (2)) THEN type := GetDType (OperandT (2)) ; - IF type = NulSym - THEN - InternalError ('constant type should have been resolved') - ELSIF IsArray (type) + IF (type # NulSym) AND IsArray (type) THEN PopTtok (e, exprTok) ; PopTFDtok (Sym, Type, dim, arrayTok) ; @@ -11501,7 +11586,7 @@ BEGIN IF (NOT IsVar (OperandT (2))) AND (NOT IsTemporary (OperandT (2))) THEN MetaErrorT1 (OperandTtok (2), - 'can only access arrays using variables or formal parameters not {%1Ead}', + 'can only access arrays using constants, variables or formal parameters not {%1Ead}', OperandT (2)) ; BuildDesignatorError ('bad array access') END ; @@ -11528,7 +11613,7 @@ BEGIN Sym) ; BuildDesignatorError ('bad array access') END -END BuildDesignatorArray ; +END BuildDesignatorArrayStaticDynamic ; (* @@ -15996,12 +16081,55 @@ END StressStack ; (* + gdbhook - a debugger convenience hook. +*) + +PROCEDURE gdbhook ; +END gdbhook ; + + +(* + BreakWhenQuadCreated - to be called interactively by gdb. +*) + +PROCEDURE BreakWhenQuadCreated (quad: CARDINAL) ; +BEGIN + BreakQuad := quad +END BreakWhenQuadCreated ; + + +(* + CheckBreak - if quad = BreakQuad then call gdbhook. +*) + +PROCEDURE CheckBreak (quad: CARDINAL) ; +BEGIN + IF quad = BreakQuad + THEN + gdbhook + END +END CheckBreak ; + + +(* Init - initialize the M2Quads module, all the stacks, all the lists and the quads list. *) PROCEDURE Init ; BEGIN + BreakWhenQuadCreated (0) ; (* Disable the intereactive quad watch. *) + (* To examine the quad table when a quad is created run cc1gm2 from gdb + and set a break point on gdbhook. + (gdb) break gdbhook + (gdb) run + Now below interactively call BreakWhenQuadCreated with the quad + under investigation. *) + gdbhook ; + (* Now is the time to interactively call gdb, for example: + (gdb) print BreakWhenQuadCreated (1234) + (gdb) cont + and you will arrive at gdbhook when this quad is created. *) LogicalOrTok := MakeKey('_LOR') ; LogicalAndTok := MakeKey('_LAND') ; LogicalXorTok := MakeKey('_LXOR') ; diff --git a/gcc/m2/gm2-compiler/M2Range.def b/gcc/m2/gm2-compiler/M2Range.def index 42aa142..e825d94 100644 --- a/gcc/m2/gm2-compiler/M2Range.def +++ b/gcc/m2/gm2-compiler/M2Range.def @@ -291,6 +291,24 @@ PROCEDURE InitTypesExpressionCheck (tokno: CARDINAL; d, e: CARDINAL; (* + InitTypesIndrXCheck - checks to see that the types of d and e + are assignment compatible. The type checking + will dereference *e during the type check. + d = *e. +*) + +PROCEDURE InitTypesIndrXCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ; + + +(* + InitTypesReturnTypeCheck - checks to see that the type of val can + be returned from func. +*) + +PROCEDURE InitTypesReturnTypeCheck (tokno: CARDINAL; func, val: CARDINAL) : CARDINAL ; + + +(* InitCaseBounds - creates a case bound range check. *) diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod index 347012b..dcac2ba 100644 --- a/gcc/m2/gm2-compiler/M2Range.mod +++ b/gcc/m2/gm2-compiler/M2Range.mod @@ -58,7 +58,7 @@ FROM M2Debug IMPORT Assert ; FROM Indexing IMPORT Index, InitIndex, InBounds, PutIndice, GetIndice ; FROM Storage IMPORT ALLOCATE ; FROM M2ALU IMPORT PushIntegerTree, PushInt, ConvertToInt, Equ, Gre, Less, GreEqu ; -FROM M2Options IMPORT VariantValueChecking, CaseEnumChecking, GetPIM ; +FROM M2Options IMPORT VariantValueChecking, CaseEnumChecking, GetPIM, StrictTypeAssignment ; FROM M2Error IMPORT Error, InternalError, ErrorFormat0, ErrorFormat1, ErrorFormat2, FlushErrors, GetAnnounceScope ; @@ -91,7 +91,6 @@ FROM M2Check IMPORT ParameterTypeCompatible, ExpressionTypeCompatible, Assignmen FROM M2Base IMPORT Nil, IsRealType, GetBaseTypeMinMax, Cardinal, Integer, ZType, IsComplexType, - IsAssignmentCompatible, IsExpressionCompatible, IsParameterCompatible, ExceptionAssign, @@ -115,7 +114,9 @@ FROM M2CaseList IMPORT CaseBoundsResolved, OverlappingCaseBounds, TYPE TypeOfRange = (assignment, returnassignment, subrangeassignment, inc, dec, incl, excl, shift, rotate, - typeexpr, typeassign, typeparam, paramassign, + typeindrx, typeexpr, typeassign, typeparam, + typereturn, + paramassign, staticarraysubscript, dynamicarraysubscript, forloopbegin, forloopto, forloopend, @@ -154,6 +155,34 @@ TYPE VAR TopOfRange: CARDINAL ; RangeIndex: Index ; + BreakRange: CARDINAL ; + + +PROCEDURE gdbhook ; +END gdbhook ; + + +(* + BreakWhenRangeCreated - to be called interactively by gdb. +*) + +PROCEDURE BreakWhenRangeCreated (r: CARDINAL) ; +BEGIN + BreakRange := r +END BreakWhenRangeCreated ; + + +(* + CheckBreak - if sym = BreakRange then call gdbhook. +*) + +PROCEDURE CheckBreak (r: CARDINAL) ; +BEGIN + IF BreakRange = r + THEN + gdbhook + END +END CheckBreak ; (* @@ -261,9 +290,10 @@ BEGIN excl : RETURN( ExceptionExcl ) | shift : RETURN( ExceptionShift ) | rotate : RETURN( ExceptionRotate ) | - typeassign : InternalError ('not expecting this case value') | - typeparam : InternalError ('not expecting this case value') | - typeexpr : InternalError ('not expecting this case value') | + typeassign, + typeparam, + typeexpr, + typeindrx : InternalError ('not expecting this case value') | paramassign : RETURN( ExceptionParameterBounds ) | staticarraysubscript : RETURN( ExceptionStaticArray ) | dynamicarraysubscript: RETURN( ExceptionDynamicArray ) | @@ -302,6 +332,7 @@ BEGIN THEN InternalError ('out of memory error') ELSE + CheckBreak (r) ; WITH p^ DO type := none ; des := NulSym ; @@ -793,7 +824,7 @@ END InitRotateCheck ; (* - InitTypesAssignmentCheck - checks to see that the types of, d, and, e, + InitTypesAssignmentCheck - checks to see that the types of d and e are assignment compatible. *) @@ -808,6 +839,38 @@ END InitTypesAssignmentCheck ; (* + InitTypesIndrXCheck - checks to see that the types of d and e + are assignment compatible. The type checking + will dereference *e during the type check. + d = *e. +*) + +PROCEDURE InitTypesIndrXCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL ; +VAR + r: CARDINAL ; +BEGIN + r := InitRange () ; + Assert (PutRangeNoLow (tokno, GetIndice (RangeIndex, r), typeindrx, d, e) # NIL) ; + RETURN r +END InitTypesIndrXCheck ; + + +(* + InitTypesReturnTypeCheck - checks to see that the types of des and func + are assignment compatible. +*) + +PROCEDURE InitTypesReturnTypeCheck (tokno: CARDINAL; func, val: CARDINAL) : CARDINAL ; +VAR + r: CARDINAL ; +BEGIN + r := InitRange () ; + Assert (PutRangeNoLow (tokno, GetIndice (RangeIndex, r), typereturn, func, val) # NIL) ; + RETURN r +END InitTypesReturnTypeCheck ; + + +(* InitTypesParameterCheck - checks to see that the types of, d, and, e, are parameter compatible. *) @@ -1190,9 +1253,11 @@ BEGIN excl : RETURN( ExceptionExcl#NulSym ) | shift : RETURN( ExceptionShift#NulSym ) | rotate : RETURN( ExceptionRotate#NulSym ) | - typeassign : RETURN( FALSE ) | - typeparam : RETURN( FALSE ) | - typeexpr : RETURN( FALSE ) | + typereturn, + typeassign, + typeparam, + typeexpr, + typeindrx : RETURN( FALSE ) | paramassign : RETURN( ExceptionParameterBounds#NulSym ) | staticarraysubscript : RETURN( ExceptionStaticArray#NulSym ) | dynamicarraysubscript: RETURN( ExceptionDynamicArray#NulSym ) | @@ -1217,7 +1282,9 @@ END HandlerExists ; (* - FoldAssignment - + FoldAssignment - attempts to fold the range violation checks. + It does not issue errors on type violations as that + is performed by FoldTypeAssign. *) PROCEDURE FoldAssignment (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ; @@ -1230,7 +1297,7 @@ BEGIN TryDeclareConstant (exprtok, expr) ; IF desLowestType # NulSym THEN - IF AssignmentTypeCompatible (tokenno, "", des, expr) + IF AssignmentTypeCompatible (tokenno, "", des, expr, FALSE) THEN IF GccKnowsAbout (expr) AND IsConst (expr) AND GetMinMax (tokenno, desLowestType, min, max) @@ -1246,6 +1313,8 @@ BEGIN END END ELSE + (* We do not issue an error if these types are incompatible here + as this is done by FoldTypeAssign. *) SubQuad (q) END END @@ -1257,6 +1326,7 @@ 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) @@ -1264,6 +1334,7 @@ BEGIN SubQuad (quad) END END CheckCancelled ; +*) (* @@ -1726,21 +1797,94 @@ END FoldRotate ; (* + FoldTypeReturnFunc - checks to see that val can be returned from func. +*) + +PROCEDURE FoldTypeReturnFunc (q: CARDINAL; tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ; +VAR + valType, + returnType: CARDINAL ; +BEGIN + returnType := GetType (func) ; + IF returnType = NulSym + THEN + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'procedure {%1Da} is not a procedure function', + '{%2ad} cannot be returned from {%1Da}', + func, val) ; + SubQuad(q) + END + ELSE + valType := val ; + IF IsVar (val) AND (GetMode (val) = LeftValue) + THEN + valType := GetType (val) + END ; + IF AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE) + THEN + SubQuad (q) + ELSE + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'the return type {%1Etad} used in procedure {%1Da}', + 'is incompatible with the returned expression {%1ad}}', + func, val) ; + setReported (r) ; + FlushErrors + END + END + END +END FoldTypeReturnFunc ; + + +(* FoldTypeAssign - *) PROCEDURE FoldTypeAssign (q: CARDINAL; tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; +BEGIN + IF NOT reportedError (r) + THEN + IF AssignmentTypeCompatible (tokenNo, + 'assignment designator {%1Ea} {%1ta:of type {%1ta}}' + + ' cannot be assigned with' + + ' {%2ad: a {%2td} {%2ad}}{!%2ad: {%2ad} of type {%2tad}}', + des, expr, TRUE) + THEN + SubQuad (q) + ELSE + setReported (r) ; + FlushErrors + END + END +END FoldTypeAssign ; + + +(* + FoldTypeIndrX - check to see that des = *expr is type compatible. +*) + +PROCEDURE FoldTypeIndrX (q: CARDINAL; tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; VAR + desType, exprType: CARDINAL ; BEGIN - IF IsProcedure(expr) + (* Need to skip over a variable or temporary in des and expr so + long as expr is not a procedure. In the case of des = *expr, + both expr and des will be variables due to the property of + indirection. *) + desType := GetType (des) ; + IF IsProcedure (expr) THEN + (* Must not GetType for a procedure as it gives the return type. *) exprType := expr ELSE - exprType := GetType(expr) + exprType := GetType (expr) END ; - - IF IsAssignmentCompatible (GetType(des), exprType) + IF AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE) THEN SubQuad(q) ELSE @@ -1754,14 +1898,16 @@ BEGIN des, expr) ; ELSE MetaErrorT3 (tokenNo, - 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%3ad:of type {%3ad}} are incompatible', + 'assignment designator {%1Ea} {%1ta:of type {%1ta}}' + + ' {%1d:is a {%1d}} and expression {%2a} {%3ad:of type' + + ' {%3ad}} are incompatible', des, expr, exprType) END ; setReported (r) ; FlushErrors END END -END FoldTypeAssign ; +END FoldTypeIndrX ; (* @@ -1828,35 +1974,90 @@ END FoldTypeExpr ; *) PROCEDURE CodeTypeAssign (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; +BEGIN + IF NOT AssignmentTypeCompatible (tokenNo, "", des, expr, FALSE) + THEN + IF NOT reportedError (r) + THEN + MetaErrorT2 (tokenNo, + 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible', + des, expr) + END ; + setReported (r) + END +END CodeTypeAssign ; + + +(* + CodeTypeReturnFunc - +*) + +PROCEDURE CodeTypeReturnFunc (tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ; VAR - exprType: CARDINAL ; + valType, + returnType: CARDINAL ; BEGIN - IF IsProcedure(expr) + returnType := GetType (func) ; + IF returnType = NulSym THEN - exprType := expr + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'procedure {%1Da} is not a procedure function', + '{%2ad} cannot be returned from {%1Da}', + func, val) ; + END ELSE - exprType := GetType(expr) - END ; - IF NOT IsAssignmentCompatible(GetType(des), exprType) + valType := val ; + IF IsVar (val) AND (GetMode (val) = LeftValue) + THEN + valType := GetType (val) + END ; + IF NOT AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE) + THEN + IF NOT reportedError (r) + THEN + MetaErrorsT2 (tokenNo, + 'the return type {%1Etad} used in procedure function {%1Da}', + 'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}', + func, val) + END + END + END +END CodeTypeReturnFunc ; + + +(* + CodeTypeIndrX - checks that des = *expr is type compatible and generates an error if they + are not compatible. It skips over the LValue type so that to allow + the error messages to pick up the source variable name rather than + a temporary name or vague name 'expression'. +*) + +PROCEDURE CodeTypeIndrX (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ; +BEGIN + IF NOT AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE) THEN IF NOT reportedError (r) THEN - IF IsProcedure(des) + IF IsProcedure (des) THEN - MetaErrorsT2(tokenNo, - 'the return type {%1Etad} declared in procedure {%1Da}', - 'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}', - des, expr) ; + MetaErrorsT2 (tokenNo, + 'the return type {%1Etad} declared in procedure {%1Da}', + 'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}', + des, expr) ; ELSE - MetaErrorT2(tokenNo, - 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible', - des, expr) + MetaErrorT2 (tokenNo, + 'assignment designator {%1Ea} {%1ta:of type {%1ta}}' + + ' {%1d:is a {%1d}} and expression {%2a}' + + ' {%2tad:of type {%2tad}} are incompatible', + des, expr) END ; setReported (r) END (* FlushErrors *) END -END CodeTypeAssign ; +END CodeTypeIndrX ; (* @@ -1910,9 +2111,11 @@ BEGIN THEN CASE type OF - typeassign: FoldTypeAssign(q, tokenNo, des, expr, r) | - typeparam: FoldTypeParam(q, tokenNo, des, expr, procedure, paramNo, r) | - typeexpr: FoldTypeExpr(q, tokenNo, des, expr, strict, isin, r) + typeassign: FoldTypeAssign (q, tokenNo, des, expr, r) | + typeparam : FoldTypeParam (q, tokenNo, des, expr, procedure, paramNo, r) | + typeexpr : FoldTypeExpr (q, tokenNo, des, expr, strict, isin, r) | + typeindrx : FoldTypeIndrX (q, tokenNo, des, expr, r) | + typereturn: FoldTypeReturnFunc (q, tokenNo, des, expr, r) ELSE InternalError ('not expecting to reach this point') @@ -1943,9 +2146,11 @@ BEGIN THEN CASE type OF - typeassign: CodeTypeAssign(tokenNo, des, expr, r) | - typeparam: CodeTypeParam(tokenNo, des, expr, procedure, paramNo) | - typeexpr: CodeTypeExpr(tokenNo, des, expr, strict, isin, r) + typeassign: CodeTypeAssign (tokenNo, des, expr, r) | + typeparam : CodeTypeParam (tokenNo, des, expr, procedure, paramNo) | + typeexpr : CodeTypeExpr (tokenNo, des, expr, strict, isin, r) | + typeindrx : CodeTypeIndrX (tokenNo, des, expr, r) | + typereturn: CodeTypeReturnFunc (tokenNo, des, expr, r) ELSE InternalError ('not expecting to reach this point') @@ -1974,7 +2179,7 @@ BEGIN success := TRUE ; WITH p^ DO combinedtok := MakeVirtual2Tok (destok, exprtok) ; - IF NOT AssignmentTypeCompatible (combinedtok, "", des, expr) + IF NOT AssignmentTypeCompatible (combinedtok, "", des, expr, TRUE) THEN MetaErrorT2 (combinedtok, 'type incompatibility between {%1Et} and {%2t} detected during the assignment of the designator {%1a} to the first expression {%2a} in the {%kFOR} loop', @@ -2388,9 +2593,11 @@ BEGIN 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) | + typereturn, + typeassign, + typeparam, + typeexpr, + typeindrx : FoldTypeCheck (tokenno, quad, range) | paramassign : FoldParameterAssign(tokenno, quad, range) | staticarraysubscript : FoldStaticArraySubscript(tokenno, quad, range) | dynamicarraysubscript: FoldDynamicArraySubscript(tokenno, quad, range) | @@ -3526,6 +3733,8 @@ BEGIN typeassign : s := NIL | typeparam : s := NIL | typeexpr : s := NIL | + typeindrx : s := InitString ('assignment between designator {%1ad} and {%2ad} is incompatible') | + typereturn : s := InitString ('the value {%2ad} returned from procedure function {%1a} is type incompatible, expecting {%1tad} rather than a {%2tad}') | paramassign : s := InitString('if this call is executed then the actual parameter {%2Wa} will be out of range of the {%3N} formal parameter {%1a}') | staticarraysubscript : s := InitString('if this access to the static array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') | dynamicarraysubscript: s := InitString('if this access to the dynamic array {%1Wa:{%2a:{%1a}[{%2a}]}} is ever made then the index will be out of bounds in the {%3N} array subscript') | @@ -3574,9 +3783,11 @@ BEGIN excl : CodeInclExcl (tokenNo, r, function, message) | shift, rotate : CodeShiftRotate (tokenNo, r, function, message) | - typeassign : CodeTypeCheck (tokenNo, r) | - typeparam : CodeTypeCheck (tokenNo, r) | - typeexpr : CodeTypeCheck (tokenNo, r) | + typeassign, + typeparam, + typeexpr, + typeindrx, + typereturn : CodeTypeCheck (tokenNo, r) | staticarraysubscript : CodeStaticArraySubscript (tokenNo, r, function, message) | dynamicarraysubscript: CodeDynamicArraySubscript (tokenNo, r, function, message) | forloopbegin : CodeForLoopBegin (tokenNo, r, function, message) | @@ -3712,6 +3923,8 @@ BEGIN rotate : WriteString('rotate(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | typeexpr : WriteString('expr compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | typeassign : WriteString('assignment compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | + typeindrx : WriteString('indrx compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | + typereturn : WriteString('return compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | typeparam : WriteString('parameter compatible (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | paramassign : WriteString('parameter range (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | staticarraysubscript : WriteString('staticarraysubscript(') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) | @@ -3744,7 +3957,19 @@ END WriteRangeCheck ; PROCEDURE Init ; BEGIN TopOfRange := 0 ; - RangeIndex := InitIndex(1) + RangeIndex := InitIndex(1) ; + BreakWhenRangeCreated (0) ; (* Disable the intereactive range watch. *) + (* To examine the range when it is created run cc1gm2 from gdb + and set a break point on gdbhook. + (gdb) break gdbhook + (gdb) run + Now below interactively call BreakWhenRangeCreated with the symbol + under investigation. *) + gdbhook ; + (* Now is the time to interactively call gdb, for example: + (gdb) print BreakWhenRangeCreated (1234) + (gdb) cont + and you will arrive at gdbhook when this symbol is created. *) END Init ; diff --git a/gcc/m2/gm2-compiler/M2System.mod b/gcc/m2/gm2-compiler/M2System.mod index efd5d11..68ed9dc 100644 --- a/gcc/m2/gm2-compiler/M2System.mod +++ b/gcc/m2/gm2-compiler/M2System.mod @@ -61,7 +61,7 @@ FROM NameKey IMPORT Name, MakeKey, NulName ; FROM M2Batch IMPORT MakeDefinitionSource ; FROM M2Base IMPORT Cardinal, ZType ; FROM M2Size IMPORT Size, MakeSize ; -FROM M2ALU IMPORT PushCard, PushIntegerTree, DivTrunc ; +FROM M2ALU IMPORT PushCard, PushIntegerTree, PushRealTree, DivTrunc ; FROM M2Error IMPORT InternalError ; FROM Lists IMPORT List, InitList, IsItemInList, PutItemIntoList, GetItemFromList, NoOfItemsInList ; FROM SymbolKey IMPORT SymbolTree, InitTree, GetSymKey, PutSymKey ; @@ -114,21 +114,32 @@ END Init ; (* - CreateMinMaxFor - creates the min and max values for, type, given gccType. + CreateMinMaxFor - creates the min and max values for type given gccType. *) -PROCEDURE CreateMinMaxFor (type: CARDINAL; min, max: ARRAY OF CHAR; gccType: tree) ; +PROCEDURE CreateMinMaxFor (type: CARDINAL; min, max: ARRAY OF CHAR; + gccType: tree; realtype: BOOLEAN) ; VAR maxval, minval: CARDINAL ; BEGIN maxval := MakeConstVar (BuiltinTokenNo, MakeKey(max)) ; - PushIntegerTree (GetMaxFrom (BuiltinsLocation (), gccType)) ; + IF realtype + THEN + PushRealTree (GetMaxFrom (BuiltinsLocation (), gccType)) + ELSE + PushIntegerTree (GetMaxFrom (BuiltinsLocation (), gccType)) + END ; PopValue (maxval) ; PutVar (maxval, type) ; PutSymKey (MaxValues, GetSymName (type), maxval) ; minval := MakeConstVar (BuiltinTokenNo, MakeKey(min)) ; - PushIntegerTree (GetMinFrom (BuiltinsLocation (), gccType)) ; + IF realtype + THEN + PushRealTree (GetMinFrom (BuiltinsLocation (), gccType)) + ELSE + PushIntegerTree (GetMinFrom (BuiltinsLocation (), gccType)) + END ; PopValue (minval) ; PutVar (minval, type) ; PutSymKey (MinValues, GetSymName (type), minval) @@ -136,31 +147,32 @@ END CreateMinMaxFor ; (* - MapType - + MapType - create a mapping of the M2 frontend type to gcctype. *) PROCEDURE MapType (type: CARDINAL; name, min, max: ARRAY OF CHAR; - needsExporting: BOOLEAN; t: tree) ; + needsExporting: BOOLEAN; + gcctype: tree; realtype: BOOLEAN) ; VAR n: Name ; BEGIN - PushIntegerTree(BuildSize(BuiltinsLocation(), t, FALSE)) ; - PopSize(type) ; - IF IsItemInList(SystemTypes, type) + PushIntegerTree (BuildSize (BuiltinsLocation (), gcctype, FALSE)) ; + PopSize (type) ; + IF IsItemInList (SystemTypes, type) THEN InternalError ('not expecting system type to already be declared') END ; - PutItemIntoList(SystemTypes, type) ; + PutItemIntoList (SystemTypes, type) ; - (* create min, max constants if type is ordinal *) - IF (NOT StrEqual(min, '')) AND (NOT StrEqual(max, '')) + (* Create min, max constants if type is ordinal or a floating point type. *) + IF (NOT StrEqual (min, '')) AND (NOT StrEqual (max, '')) THEN - CreateMinMaxFor(type, min, max, t) + CreateMinMaxFor (type, min, max, gcctype, realtype) END ; IF needsExporting AND DumpSystemExports THEN - n := GetSymName(type) ; + n := GetSymName (type) ; printf1('SYSTEM module creates type: %a\n', n) END END MapType ; @@ -171,7 +183,8 @@ END MapType ; *) PROCEDURE CreateType (name, min, max: ARRAY OF CHAR; - needsExporting: BOOLEAN; gccType: tree) : CARDINAL ; + needsExporting: BOOLEAN; gccType: tree; + realtype: BOOLEAN) : CARDINAL ; VAR type: CARDINAL ; BEGIN @@ -183,7 +196,7 @@ BEGIN (* Create base type. *) type := MakeType (BuiltinTokenNo, MakeKey (name)) ; PutType (type, NulSym) ; (* a Base Type *) - MapType (type, name, min, max, needsExporting, gccType) ; + MapType (type, name, min, max, needsExporting, gccType, realtype) ; RETURN type END END CreateType ; @@ -195,9 +208,11 @@ END CreateType ; *) PROCEDURE AttemptToCreateType (name, min, max: ARRAY OF CHAR; - needsExporting: BOOLEAN; gccType: tree) ; + needsExporting: BOOLEAN; gccType: tree; + realtype: BOOLEAN) ; BEGIN - Assert (IsLegal (CreateType (name, min, max, needsExporting, gccType))) + Assert (IsLegal (CreateType (name, min, max, needsExporting, + gccType, realtype))) END AttemptToCreateType ; @@ -226,7 +241,7 @@ BEGIN subrange := MakeSubrange (BuiltinTokenNo, NulName) ; PutSubrange (subrange, low, high, Cardinal) ; PutSet (type, subrange, FALSE) ; - MapType (type, name, '', '', needsExporting, gccType) ; + MapType (type, name, '', '', needsExporting, gccType, FALSE) ; RETURN type END END CreateSetType ; @@ -251,33 +266,33 @@ END AttemptToCreateSetType ; PROCEDURE MakeFixedSizedTypes ; BEGIN - AttemptToCreateType ('INTEGER8', 'MinInteger8', 'MaxInteger8', TRUE, GetM2Integer8 ()) ; - AttemptToCreateType ('INTEGER16', 'MinInteger16', 'MaxInteger16', TRUE, GetM2Integer16 ()) ; - AttemptToCreateType ('INTEGER32', 'MinInteger32', 'MaxInteger32', TRUE, GetM2Integer32 ()) ; - AttemptToCreateType ('INTEGER64', 'MinInteger64', 'MaxInteger64', TRUE, GetM2Integer64 ()) ; + AttemptToCreateType ('INTEGER8', 'MinInteger8', 'MaxInteger8', TRUE, GetM2Integer8 (), FALSE) ; + AttemptToCreateType ('INTEGER16', 'MinInteger16', 'MaxInteger16', TRUE, GetM2Integer16 (), FALSE) ; + AttemptToCreateType ('INTEGER32', 'MinInteger32', 'MaxInteger32', TRUE, GetM2Integer32 (), FALSE) ; + AttemptToCreateType ('INTEGER64', 'MinInteger64', 'MaxInteger64', TRUE, GetM2Integer64 (), FALSE) ; - AttemptToCreateType ('CARDINAL8', 'MinCardinal8', 'MaxCardinal8', TRUE, GetM2Cardinal8 ()) ; - AttemptToCreateType ('CARDINAL16', 'MinCardinal16', 'MaxCardinal16', TRUE, GetM2Cardinal16 ()) ; - AttemptToCreateType ('CARDINAL32', 'MinCardinal32', 'MaxCardinal32', TRUE, GetM2Cardinal32 ()) ; - AttemptToCreateType ('CARDINAL64', 'MinCardinal64', 'MaxCardinal64', TRUE, GetM2Cardinal64 ()) ; + AttemptToCreateType ('CARDINAL8', 'MinCardinal8', 'MaxCardinal8', TRUE, GetM2Cardinal8 (), FALSE) ; + AttemptToCreateType ('CARDINAL16', 'MinCardinal16', 'MaxCardinal16', TRUE, GetM2Cardinal16 (), FALSE) ; + AttemptToCreateType ('CARDINAL32', 'MinCardinal32', 'MaxCardinal32', TRUE, GetM2Cardinal32 (), FALSE) ; + AttemptToCreateType ('CARDINAL64', 'MinCardinal64', 'MaxCardinal64', TRUE, GetM2Cardinal64 (), FALSE) ; - AttemptToCreateType ('WORD16', '', '', TRUE, GetM2Word16 ()) ; - AttemptToCreateType ('WORD32', '', '', TRUE, GetM2Word32 ()) ; - AttemptToCreateType ('WORD64', '', '', TRUE, GetM2Word64 ()) ; + AttemptToCreateType ('WORD16', '', '', TRUE, GetM2Word16 (), FALSE) ; + AttemptToCreateType ('WORD32', '', '', TRUE, GetM2Word32 (), FALSE) ; + AttemptToCreateType ('WORD64', '', '', TRUE, GetM2Word64 (), FALSE) ; AttemptToCreateSetType ('BITSET8' , '7' , TRUE, GetM2Bitset8 ()) ; AttemptToCreateSetType ('BITSET16', '15', TRUE, GetM2Bitset16 ()) ; AttemptToCreateSetType ('BITSET32', '31', TRUE, GetM2Bitset32 ()) ; - AttemptToCreateType ('REAL32', '', '', TRUE, GetM2Real32 ()) ; - AttemptToCreateType ('REAL64', '', '', TRUE, GetM2Real64 ()) ; - AttemptToCreateType ('REAL96', '', '', TRUE, GetM2Real96 ()) ; - AttemptToCreateType ('REAL128', '', '', TRUE, GetM2Real128 ()) ; + AttemptToCreateType ('REAL32', 'MinReal32', 'MaxReal32', TRUE, GetM2Real32 (), TRUE) ; + AttemptToCreateType ('REAL64', 'MinReal64', 'MaxReal64', TRUE, GetM2Real64 (), TRUE) ; + AttemptToCreateType ('REAL96', 'MinReal96', 'MaxReal96', TRUE, GetM2Real96 (), TRUE) ; + AttemptToCreateType ('REAL128', 'MinReal128', 'MaxReal128', TRUE, GetM2Real128 (), TRUE) ; - AttemptToCreateType ('COMPLEX32', '', '', TRUE, GetM2Complex32 ()) ; - AttemptToCreateType ('COMPLEX64', '', '', TRUE, GetM2Complex64 ()) ; - AttemptToCreateType ('COMPLEX96', '', '', TRUE, GetM2Complex96 ()) ; - AttemptToCreateType ('COMPLEX128', '', '', TRUE, GetM2Complex128 ()) + AttemptToCreateType ('COMPLEX32', '', '', TRUE, GetM2Complex32 (), TRUE) ; + AttemptToCreateType ('COMPLEX64', '', '', TRUE, GetM2Complex64 (), TRUE) ; + AttemptToCreateType ('COMPLEX96', '', '', TRUE, GetM2Complex96 (), TRUE) ; + AttemptToCreateType ('COMPLEX128', '', '', TRUE, GetM2Complex128 (), TRUE) END MakeFixedSizedTypes ; @@ -287,16 +302,16 @@ END MakeFixedSizedTypes ; PROCEDURE InitPIMTypes ; BEGIN - Loc := CreateType ('LOC', '', '', TRUE, GetISOLocType()) ; + Loc := CreateType ('LOC', '', '', TRUE, GetISOLocType(), FALSE) ; InitSystemTypes(BuiltinsLocation(), Loc) ; - Word := CreateType ('WORD', '', '', TRUE, GetWordType()) ; - Byte := CreateType ('BYTE', '', '', TRUE, GetByteType()) ; + Word := CreateType ('WORD', '', '', TRUE, GetWordType(), FALSE) ; + Byte := CreateType ('BYTE', '', '', TRUE, GetByteType(), FALSE) ; (* ADDRESS = POINTER TO BYTE *) Address := MakePointer (BuiltinTokenNo, MakeKey('ADDRESS')) ; PutPointer (Address, Byte) ; (* Base Type *) - MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType()) + MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType(), FALSE) END InitPIMTypes ; @@ -306,17 +321,15 @@ END InitPIMTypes ; PROCEDURE InitISOTypes ; BEGIN - Loc := CreateType ('LOC', 'MinLoc', 'MaxLoc', TRUE, GetISOLocType ()) ; + Loc := CreateType ('LOC', 'MinLoc', 'MaxLoc', TRUE, GetISOLocType (), FALSE) ; InitSystemTypes (BuiltinsLocation (), Loc) ; Address := MakePointer (BuiltinTokenNo, MakeKey ('ADDRESS')) ; PutPointer (Address, Loc) ; (* Base Type *) - MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType()) ; - - Byte := CreateType ('BYTE', '', '', TRUE, GetISOByteType()) ; - Word := CreateType ('WORD', '', '', TRUE, GetISOWordType()) ; + MapType (Address, 'ADDRESS', '', '', TRUE, GetPointerType(), FALSE) ; - (* CreateMinMaxFor(Loc, 'MinLoc', 'MaxLoc', GetISOLocType()) *) + Byte := CreateType ('BYTE', '', '', TRUE, GetISOByteType(), FALSE) ; + Word := CreateType ('WORD', '', '', TRUE, GetISOWordType(), FALSE) ; END InitISOTypes ; @@ -327,9 +340,9 @@ END InitISOTypes ; PROCEDURE MakeExtraSystemTypes ; BEGIN - CSizeT := CreateType ('CSIZE_T' , '', '', TRUE, GetCSizeTType ()) ; - CSSizeT := CreateType ('CSSIZE_T', '', '', TRUE, GetCSSizeTType ()) ; - COffT := CreateType ('COFF_T', '', '', TRUE, GetCOffTType ()) ; + CSizeT := CreateType ('CSIZE_T' , '', '', TRUE, GetCSizeTType (), FALSE) ; + CSSizeT := CreateType ('CSSIZE_T', '', '', TRUE, GetCSSizeTType (), FALSE) ; + COffT := CreateType ('COFF_T', '', '', TRUE, GetCOffTType (), FALSE) END MakeExtraSystemTypes ; @@ -425,9 +438,9 @@ BEGIN MakeKey('THROW')) ; (* Procedure *) PutProcedureNoReturn (Throw, DefProcedure, TRUE) ; - CreateMinMaxFor(Word, 'MinWord', 'MaxWord', GetWordType()) ; - CreateMinMaxFor(Address, 'MinAddress', 'MaxAddress', GetPointerType()) ; - CreateMinMaxFor(Byte, 'MinByte', 'MaxByte', GetByteType()) ; + CreateMinMaxFor(Word, 'MinWord', 'MaxWord', GetWordType(), FALSE) ; + CreateMinMaxFor(Address, 'MinAddress', 'MaxAddress', GetPointerType(), FALSE) ; + CreateMinMaxFor(Byte, 'MinByte', 'MaxByte', GetByteType(), FALSE) ; MakeFixedSizedTypes ; MakeExtraSystemTypes ; diff --git a/gcc/m2/gm2-compiler/P2Build.bnf b/gcc/m2/gm2-compiler/P2Build.bnf index b9a6daa..c28e630 100644 --- a/gcc/m2/gm2-compiler/P2Build.bnf +++ b/gcc/m2/gm2-compiler/P2Build.bnf @@ -46,7 +46,8 @@ see <https://www.gnu.org/licenses/>. *) IMPLEMENTATION MODULE P2Build ; FROM M2LexBuf IMPORT currentstring, currenttoken, GetToken, InsertToken, - InsertTokenAndRewind, GetTokenNo, MakeVirtual2Tok ; + InsertTokenAndRewind, GetTokenNo, MakeVirtual2Tok, + MakeVirtualTok ; FROM M2MetaError IMPORT MetaErrorStringT0, MetaErrorT1 ; FROM NameKey IMPORT NulName, Name, makekey, MakeKey ; @@ -128,13 +129,13 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput PutGnuAsmOutput, PutGnuAsmTrash, PutGnuAsmVolatile, MakeRegInterface, PutRegInterface, GetRegInterface, - GetSymName, GetType, MakeConstLit, + GetSymName, GetType, MakeConstLit, IsProcType, NulSym, - StartScope, EndScope, + StartScope, EndScope, GetCurrentModule, PutIncluded, PutExceptionFinally, PutExceptionBlock, GetCurrentScope, IsVarParam, IsProcedure, IsDefImp, IsModule, - IsRecord, IsAModula2Type, + IsRecord, IsAModula2Type, IsImported, RequestSym ; IMPORT M2Error ; @@ -450,6 +451,54 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF IsImported (GetCurrentModule (), init) AND (IsDefImp (init) OR IsModule (init)) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + init := nextLevel + END ; + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) + THEN + PushTtok (init, tok) + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END ; + PutIncluded (init) + ELSE + PushTFtok (init, GetType (init), tok) ; + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") + END +END CheckModuleQualident ; + + % module P2Build end END P2Build. % rules @@ -609,28 +658,10 @@ ImplementationOrProgramModule := ImplementationModule | ProgramModule =: Number := Integer | Real =: -Qualident := % VAR name: Name ; - Type, Sym, tok: CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tok) ; - Sym := RequestSym (tok, name) ; - IF IsDefImp(Sym) OR IsModule(Sym) - THEN - Expect(periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope(Sym) ; - Qualident(stopset0, stopset1, stopset2) ; - (* should we test for lack of ident? *) - PopTFtok(Sym, Type, tok) ; - PushTFtok(Sym, Type, tok) ; - Annotate("%1s(%1d)|%1s(%1d)||qualident|type") ; - EndScope ; - PutIncluded(Sym) - ELSE - PushTFtok(Sym, GetType(Sym), tok) ; - Annotate("%1s(%1d)|%1s(%1d)||qualident|type") - END + CheckModuleQualident (stopset0, stopset1, stopset2) ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod index 8f3b499..5c82ec8 100644 --- a/gcc/m2/gm2-compiler/P2SymBuild.mod +++ b/gcc/m2/gm2-compiler/P2SymBuild.mod @@ -1225,7 +1225,8 @@ VAR Sym, Type : CARDINAL ; name : Name ; - tokno : CARDINAL ; + nametokno, + typetokno: CARDINAL ; BEGIN (* Two cases @@ -1234,8 +1235,8 @@ BEGIN - when type with a name that is different to Name. In which case we create a new type. *) - PopTtok(Type, tokno) ; - PopT(name) ; + PopTtok (Type, typetokno) ; + PopTtok (name, nametokno) ; IF Debugging THEN n1 := GetSymName(GetCurrentModule()) ; @@ -1264,11 +1265,11 @@ BEGIN *) (* WriteString('Blank name type') ; WriteLn ; *) - PushTFtok(Type, name, tokno) ; + PushTFtok(Type, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") ELSIF IsError(Type) THEN - PushTFtok(Type, name, tokno) ; + PushTFtok(Type, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||error type|error type name|token no") ELSIF GetSymName(Type)=name THEN @@ -1276,7 +1277,7 @@ BEGIN IF isunknown OR (NOT IsDeclaredIn(GetCurrentScope(), Type)) THEN - Sym := MakeType(tokno, name) ; + Sym := MakeType (typetokno, name) ; IF NOT IsError(Sym) THEN IF Sym=Type @@ -1295,19 +1296,23 @@ BEGIN CheckForEnumerationInCurrentModule(Type) END END ; - PushTFtok(Sym, name, tokno) ; + PushTFtok(Sym, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") ELSE - PushTFtok(Type, name, tokno) ; + PushTFtok(Type, name, typetokno) ; Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") END ELSE (* example TYPE a = CARDINAL *) - Sym := MakeType(tokno, name) ; - PutType(Sym, Type) ; - CheckForExportedImplementation(Sym) ; (* May be an exported hidden type *) - PushTFtok(Sym, name, tokno) ; - Annotate("%1s(%1d)|%2n|%3d||type|type name|token no") + Sym := MakeType (nametokno, name) ; + PutType (Sym, Type) ; + CheckForExportedImplementation (Sym) ; (* May be an exported hidden type *) + PushTFtok (Sym, name, nametokno) ; + Annotate ("%1s(%1d)|%2n|%3d||type|type name|token no") ; + IF Debugging + THEN + MetaErrorT1 (nametokno, 'type pos {%1Wa}', Sym) + END END END BuildType ; diff --git a/gcc/m2/gm2-compiler/P3Build.bnf b/gcc/m2/gm2-compiler/P3Build.bnf index 4f6ffb7..0033d33 100644 --- a/gcc/m2/gm2-compiler/P3Build.bnf +++ b/gcc/m2/gm2-compiler/P3Build.bnf @@ -166,14 +166,14 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput MakeRegInterface, PutRegInterface, IsRegInterface, IsGnuAsmVolatile, IsGnuAsm, - GetCurrentModule, + GetCurrentModule, IsInnerModule, GetSymName, GetType, SkipType, NulSym, StartScope, EndScope, PutIncluded, IsVarParam, IsProcedure, IsDefImp, IsModule, IsProcType, IsRecord, - RequestSym, IsExported, + RequestSym, IsExported, IsImported, GetSym, GetLocalSym ; FROM M2Batch IMPORT IsModuleKnown ; @@ -468,6 +468,69 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + PushTFQualident - push the result of the Qualident + to the stack. It checks to see if init + is a procedure or proc type and if so + it does not push the return type. +*) + +PROCEDURE PushTFQualident (tok, tokstart: CARDINAL; + init: CARDINAL) ; +BEGIN + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) OR IsModule (init) OR IsDefImp (init) + THEN + PushTtok (init, tok) ; + Annotate ("%1s(%1d)||qualident procedure/proctype") ; + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END +END PushTFQualident ; + + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF (IsImported (GetCurrentModule (), init) AND IsDefImp (init)) OR + IsModule (init) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + CheckCanBeImported (init, nextLevel) ; + init := nextLevel + END ; + PushTFQualident (tok, tokstart, init) ; + PutIncluded (init) + ELSE + PushTFQualident (tok, tokstart, init) + END +END CheckModuleQualident ; + % module P3Build end BEGIN BlockState := InitState () @@ -643,37 +706,11 @@ Number := Integer | Real =: -- IsAutoPushOff then we just consume tokens. -- -Qualident := % VAR name : Name ; - init, ip1, - tokstart, tok : CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tokstart) ; - tok := tokstart ; - init := RequestSym (tok, name) ; - WHILE IsDefImp (init) OR IsModule (init) DO - Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope (init) ; - Ident (stopset0, stopset1, stopset2) ; - PopTtok (name, tok) ; - ip1 := RequestSym (tok, name) ; - PutIncluded(ip1) ; - EndScope ; - CheckCanBeImported(init, ip1) ; - init := ip1 - END ; - IF tok#tokstart - THEN - tok := MakeVirtualTok (tokstart, tokstart, tok) - END ; - IF IsProcedure(init) OR IsProcType(init) - THEN - PushTtok(init, tok) - ELSE - PushTFtok(init, GetType(init), tok) ; - END - ELSE % + CheckModuleQualident (stopset0, stopset1, stopset2) + ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-compiler/PCBuild.bnf b/gcc/m2/gm2-compiler/PCBuild.bnf index a05a55f..ddbe2f1 100644 --- a/gcc/m2/gm2-compiler/PCBuild.bnf +++ b/gcc/m2/gm2-compiler/PCBuild.bnf @@ -65,7 +65,7 @@ FROM M2Quads IMPORT Top, PushT, PopT, PushTF, PopTF, PopNothing, OperandT, Opera PushTFA, PushTFn, PopTFn, PushTFtok, PopTtok, PopTFtok, PushTtok, PushTFntok, PushT, PushTF, IsAutoPushOn, PushAutoOff, PushAutoOn, PopAuto, - DupFrame, + DupFrame, Annotate, BuildTypeForConstructor, BuildConstructor, BuildConstructorEnd, PopConstructor, NextConstructorField, SilentBuildConstructor, @@ -118,6 +118,7 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput PutIncluded, IsVarParam, IsProcedure, IsDefImp, IsModule, IsRecord, IsProcType, + GetCurrentModule, IsInnerModule, IsImported, RequestSym, GetSym, GetLocalSym ; @@ -412,6 +413,68 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + PushTFQualident - push the result of the Qualident + to the stack. It checks to see if init + is a procedure or proc type and if so + it does not push the return type. +*) + +PROCEDURE PushTFQualident (tok, tokstart: CARDINAL; + init: CARDINAL) ; +BEGIN + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) + THEN + PushTtok (init, tok) ; + Annotate ("%1s(%1d)||qualident procedure/proctype") ; + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END +END PushTFQualident ; + + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF IsImported (GetCurrentModule (), init) AND (IsDefImp (init) OR IsModule (init)) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + CheckCanBeImported (init, nextLevel) ; + init := nextLevel + END ; + PushTFQualident (tok, tokstart, init) ; + PutIncluded (init) + ELSE + PushTFQualident (tok, tokstart, init) + END +END CheckModuleQualident ; + % module PCBuild end BEGIN BlockState := InitState () @@ -569,37 +632,11 @@ ImplementationOrProgramModule := % Pus Number := Integer | Real =: -Qualident := % VAR name : Name ; - init, ip1, - tokstart, tok : CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tokstart) ; - tok := tokstart ; - init := RequestSym (tok, name) ; - WHILE IsDefImp (init) OR IsModule (init) DO - Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope (init) ; - Ident (stopset0, stopset1, stopset2) ; - PopTtok (name, tok) ; - ip1 := RequestSym (tok, name) ; - PutIncluded(ip1) ; - EndScope ; - CheckCanBeImported(init, ip1) ; - init := ip1 - END ; - IF tok#tokstart - THEN - tok := MakeVirtualTok (tokstart, tokstart, tok) - END ; - IF IsProcedure(init) OR IsProcType(init) - THEN - PushTtok(init, tok) - ELSE - PushTFtok(init, GetType(init), tok) ; - END - ELSE % + CheckModuleQualident (stopset0, stopset1, stopset2) + ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-compiler/PCSymBuild.mod b/gcc/m2/gm2-compiler/PCSymBuild.mod index b124c3e..3bffe86 100644 --- a/gcc/m2/gm2-compiler/PCSymBuild.mod +++ b/gcc/m2/gm2-compiler/PCSymBuild.mod @@ -64,7 +64,7 @@ FROM SymbolTable IMPORT NulSym, ModeOfAddr, ProcedureKind, GetFromOuterModule, CheckForEnumerationInCurrentModule, GetMode, PutVariableAtAddress, ModeOfAddr, SkipType, - IsSet, PutConstSet, + IsSet, PutConstSet, IsType, IsConst, IsConstructor, PutConst, PutConstructor, PopValue, PushValue, MakeTemporary, PutVar, @@ -1408,9 +1408,10 @@ END TypeToMeta ; (* - buildConstFunction - we are only concerned about resolving the return type o + buildConstFunction - we are only concerned about resolving the return type of a function, so we can ignore all parameters - except - the first one in the case of VAL(type, foo). + the first one in the case of VAL(type, foo) + and the type of bar in MIN (bar) and MAX (bar). buildConstFunction uses a unary exprNode to represent a function. *) @@ -1866,11 +1867,11 @@ BEGIN THEN IF (func=Min) OR (func=Max) THEN - IF IsSet (sym) + IF IsSet (sym) OR (IsType (sym) AND IsSet (SkipType (sym))) THEN - type := SkipType(GetType(sym)) + type := GetType (SkipType (sym)) ELSE - (* sym is the type required for MAX, MIN and VAL *) + (* sym is the type required for MAX, MIN and VAL. *) type := sym END ELSE diff --git a/gcc/m2/gm2-compiler/PHBuild.bnf b/gcc/m2/gm2-compiler/PHBuild.bnf index 7bd5bcc..8153870 100644 --- a/gcc/m2/gm2-compiler/PHBuild.bnf +++ b/gcc/m2/gm2-compiler/PHBuild.bnf @@ -130,12 +130,12 @@ FROM SymbolTable IMPORT MakeGnuAsm, PutGnuAsmVolatile, PutGnuAsm, PutGnuAsmInput PutGnuAsmOutput, PutGnuAsmTrash, PutGnuAsmVolatile, MakeRegInterface, PutRegInterface, GetRegInterface, - GetSymName, GetType, + GetSymName, GetType, GetCurrentModule, NulSym, StartScope, EndScope, PutIncluded, IsVarParam, IsProcedure, IsDefImp, IsModule, - IsRecord, IsProcType, + IsRecord, IsProcType, IsInnerModule, IsImported, RequestSym, GetSym, GetLocalSym ; @@ -368,6 +368,68 @@ BEGIN Expect(realtok, stopset0, stopset1, stopset2) END Real ; + +(* + PushTFQualident - push the result of the Qualident + to the stack. It checks to see if init + is a procedure or proc type and if so + it does not push the return type. +*) + +PROCEDURE PushTFQualident (tok, tokstart: CARDINAL; + init: CARDINAL) ; +BEGIN + IF tok#tokstart + THEN + tok := MakeVirtualTok (tokstart, tokstart, tok) + END ; + IF IsProcedure (init) OR IsProcType (init) + THEN + PushTtok (init, tok) ; + Annotate ("%1s(%1d)||qualident procedure/proctype") ; + ELSE + Annotate ("%1s(%1d)|%1s(%1d)||qualident|type") ; + PushTFtok (init, GetType (init), tok) ; + END +END PushTFQualident ; + + +(* + CheckModuleQualident - check to see if the beginning ident of the qualident is an + imported module. +*) + +PROCEDURE CheckModuleQualident (stopset0: SetOfStop0; + stopset1: SetOfStop1; + stopset2: SetOfStop2) ; +VAR + name : Name ; + init, + nextLevel, + tok, tokstart: CARDINAL ; +BEGIN + PopTtok (name, tokstart) ; + tok := tokstart ; + init := RequestSym (tok, name) ; + IF IsImported (GetCurrentModule (), init) AND (IsDefImp (init) OR IsModule (init)) + THEN + WHILE IsDefImp (init) OR IsModule (init) DO + Expect (periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; + StartScope (init) ; + Ident (stopset0, stopset1, stopset2) ; + PopTtok (name, tok) ; + nextLevel := RequestSym (tok, name) ; + EndScope ; + CheckCanBeImported (init, nextLevel) ; + init := nextLevel + END ; + PushTFQualident (tok, tokstart, init) ; + PutIncluded (init) + ELSE + PushTFQualident (tok, tokstart, init) + END +END CheckModuleQualident ; + % module PHBuild end END PHBuild. % rules @@ -541,26 +603,10 @@ ImplementationOrProgramModule := % Pus Number := Integer | Real =: -Qualident := % VAR name: Name ; - Type, Sym, tok: CARDINAL ; % - Ident +Qualident := Ident % IF IsAutoPushOn() THEN - PopTtok(name, tok) ; - Sym := RequestSym (tok, name) ; - IF IsDefImp(Sym) OR IsModule(Sym) - THEN - Expect(periodtok, stopset0, stopset1, stopset2 + SetOfStop2{identtok}) ; - StartScope(Sym) ; - Qualident(stopset0, stopset1, stopset2) ; - (* should we test for lack of ident? *) - PopTFtok(Sym, Type, tok) ; - PushTFtok(Sym, Type, tok) ; - EndScope ; - PutIncluded(Sym) - ELSE - PushTFtok(Sym, GetType(Sym), tok) ; - END + CheckModuleQualident (stopset0, stopset1, stopset2) ELSE (* just parse qualident *) % { "." Ident } % END % =: diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def index d9d4c87..2a9865a 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.def +++ b/gcc/m2/gm2-compiler/SymbolTable.def @@ -2025,7 +2025,7 @@ PROCEDURE PutIncludedByDefinition (Sym: CARDINAL) ; (* IsIncludedByDefinition - returns TRUE if definition module symbol, Sym, was included - by ModSym's definition module. + by ModSyms definition module. *) PROCEDURE IsIncludedByDefinition (ModSym, Sym: CARDINAL) : BOOLEAN ; @@ -3478,4 +3478,20 @@ PROCEDURE UsesOptArgAny (Sym: CARDINAL) : BOOLEAN ; PROCEDURE GetProcedureKindDesc (kind: ProcedureKind) : String ; +(* + GetNthParamAnyClosest - returns the nth parameter from the order + proper procedure, forward declaration + or definition module procedure. + It chooses the parameter which is closest + in source terms to currentmodule. + The same module will return using the order + proper procedure, forward procedure, definition module. + Whereas an imported procedure will choose from + DefProcedure, ProperProcedure, ForwardProcedure. +*) + +PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL; + currentmodule: CARDINAL) : CARDINAL ; + + END SymbolTable. diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod index 826d2d3..ff661dc 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.mod +++ b/gcc/m2/gm2-compiler/SymbolTable.mod @@ -122,8 +122,6 @@ CONST UnboundedAddressName = "_m2_contents" ; UnboundedHighName = "_m2_high_%d" ; - BreakSym = 203 ; - TYPE ProcAnyBoolean = PROCEDURE (CARDINAL, ProcedureKind) : BOOLEAN ; ProcAnyCardinal = PROCEDURE (CARDINAL, ProcedureKind) : CARDINAL ; @@ -930,6 +928,7 @@ VAR (* passes and reduce duplicate *) (* errors. *) ConstLitArray : Indexing.Index ; + BreakSym : CARDINAL ; (* Allows interactive debugging. *) (* @@ -1032,11 +1031,34 @@ END FinalSymbol ; (* - stop - a debugger convenience hook. + gdbhook - a debugger convenience hook. +*) + +PROCEDURE gdbhook ; +END gdbhook ; + + +(* + BreakWhenSymCreated - to be called interactively by gdb. *) -PROCEDURE stop ; -END stop ; +PROCEDURE BreakWhenSymCreated (sym: CARDINAL) ; +BEGIN + BreakSym := sym +END BreakWhenSymCreated ; + + +(* + CheckBreak - if sym = BreakSym then call gdbhook. +*) + +PROCEDURE CheckBreak (sym: CARDINAL) ; +BEGIN + IF sym = BreakSym + THEN + gdbhook + END +END CheckBreak ; (* @@ -1053,10 +1075,7 @@ BEGIN SymbolType := DummySym END ; PutIndice(Symbols, sym, pSym) ; - IF sym = BreakSym - THEN - stop - END ; + CheckBreak (sym) ; INC(FreeSymbol) END NewSym ; @@ -1660,6 +1679,18 @@ PROCEDURE Init ; VAR pCall: PtrToCallFrame ; BEGIN + BreakWhenSymCreated (NulSym) ; (* Disable the intereactive sym watch. *) + (* To examine the symbol table when a symbol is created run cc1gm2 from gdb + and set a break point on gdbhook. + (gdb) break gdbhook + (gdb) run + Now below interactively call BreakWhenSymCreated with the symbol + under investigation. *) + gdbhook ; + (* Now is the time to interactively call gdb, for example: + (gdb) print BreakWhenSymCreated (1234) + (gdb) cont + and you will arrive at gdbhook when this symbol is created. *) AnonymousName := 0 ; CurrentError := NIL ; InitTree (ConstLitPoolTree) ; @@ -3959,10 +3990,7 @@ VAR BEGIN tok := CheckTok (tok, 'procedure') ; Sym := DeclareSym(tok, ProcedureName) ; - IF Sym = BreakSym - THEN - stop - END ; + CheckBreak (Sym) ; IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; @@ -6926,6 +6954,89 @@ END GetNthParamAny ; (* + GetNthParamChoice - returns the parameter definition from + sym:ParamNo:kind or NulSym. +*) + +PROCEDURE GetNthParamChoice (sym: CARDINAL; ParamNo: CARDINAL; + kind: ProcedureKind) : CARDINAL ; +BEGIN + IF GetProcedureParametersDefined (sym, kind) + THEN + RETURN GetNthParam (sym, kind, ParamNo) + ELSE + RETURN NulSym + END +END GetNthParamChoice ; + + +(* + GetNthParamOrdered - returns the parameter definition from list {a, b, c} + in order. + sym:ParamNo:{a,b,c} or NulSym. +*) + +PROCEDURE GetNthParamOrdered (sym: CARDINAL; ParamNo: CARDINAL; + a, b, c: ProcedureKind) : CARDINAL ; +VAR + param: CARDINAL ; +BEGIN + param := GetNthParamChoice (sym, ParamNo, a) ; + IF param = NulSym + THEN + param := GetNthParamChoice (sym, ParamNo, b) ; + IF param = NulSym + THEN + param := GetNthParamChoice (sym, ParamNo, c) + END + END ; + RETURN param +END GetNthParamOrdered ; + + +(* + GetNthParamAnyClosest - returns the nth parameter from the order + proper procedure, forward declaration + or definition module procedure. + It chooses the parameter which is closest + in source terms to currentmodule. + The same module will return using the order + proper procedure, forward procedure, definition module. + Whereas an imported procedure will choose from + DefProcedure, ProperProcedure, ForwardProcedure. +*) + +PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL; + currentmodule: CARDINAL) : CARDINAL ; +BEGIN + IF GetOuterModuleScope (currentmodule) = GetOuterModuleScope (sym) + THEN + (* Same module. *) + RETURN GetNthParamOrdered (sym, ParamNo, + ProperProcedure, ForwardProcedure, DefProcedure) + ELSE + (* Procedure is imported. *) + RETURN GetNthParamOrdered (sym, ParamNo, + DefProcedure, ProperProcedure, ForwardProcedure) + END +END GetNthParamAnyClosest ; + + +(* + GetOuterModuleScope - returns the outer module symbol scope for sym. +*) + +PROCEDURE GetOuterModuleScope (sym: CARDINAL) : CARDINAL ; +BEGIN + WHILE NOT (IsDefImp (sym) OR + (IsModule (sym) AND (GetScope (sym) = NulSym))) DO + sym := GetScope (sym) + END ; + RETURN sym +END GetOuterModuleScope ; + + +(* The Following procedures fill in the symbol table with the symbol entities. *) @@ -7154,6 +7265,7 @@ VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; + CheckBreak (Sym) ; WITH pSym^ DO CASE SymbolType OF |