aboutsummaryrefslogtreecommitdiff
path: root/gcc/m2/gm2-compiler
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/m2/gm2-compiler')
-rw-r--r--gcc/m2/gm2-compiler/M2Check.def3
-rw-r--r--gcc/m2/gm2-compiler/M2Check.mod522
-rw-r--r--gcc/m2/gm2-compiler/M2GenGCC.mod88
-rw-r--r--gcc/m2/gm2-compiler/M2MetaError.def6
-rw-r--r--gcc/m2/gm2-compiler/M2Options.def16
-rw-r--r--gcc/m2/gm2-compiler/M2Options.mod22
-rw-r--r--gcc/m2/gm2-compiler/M2Quads.mod141
-rw-r--r--gcc/m2/gm2-compiler/M2Range.def18
-rw-r--r--gcc/m2/gm2-compiler/M2Range.mod274
9 files changed, 810 insertions, 280 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 d86ef8e..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)
@@ -805,7 +970,9 @@ BEGIN
typeLeft := GetDType (left) ;
IF IsZRCType (typeLeft) AND IsUnbounded (typeRight)
THEN
- RETURN false
+ RETURN falseReason2 ('the constant {%1a} is incompatible' +
+ ' with an unbounded array of {%2a}',
+ tinfo, typeLeft, typeRight)
ELSE
RETURN doCheckPair (result, tinfo, typeLeft, typeRight)
END
@@ -815,6 +982,58 @@ 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.
@@ -861,14 +1080,9 @@ 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 ;
@@ -892,7 +1106,7 @@ 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
@@ -911,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
@@ -936,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
@@ -957,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)
@@ -969,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
@@ -977,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.
@@ -989,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)
@@ -1040,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 -
*)
@@ -1090,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)
@@ -1281,7 +1521,6 @@ BEGIN
END checkProcTypeEquivalence ;
-
(*
checkTypeKindEquivalence -
*)
@@ -1551,7 +1790,7 @@ BEGIN
THEN
RETURN Address
ELSE
- RETURN GetSType (sym)
+ RETURN GetDType (sym)
END
END getSType ;
@@ -1627,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 ;
(*
@@ -1650,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
@@ -1757,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)
@@ -1803,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 ;
@@ -1852,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 ;
@@ -1896,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 ;
@@ -1960,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/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index 2dfa566..4a9ced3 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -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) |
@@ -3004,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}',
@@ -3233,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 ;
@@ -3550,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}',
@@ -3918,8 +3918,6 @@ END NoWalkProcedure ;
PROCEDURE CheckBinaryExpressionTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ;
VAR
- lefttype,
- righttype,
des, left, right: CARDINAL ;
typeChecking,
constExpr,
@@ -3937,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,
@@ -3950,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
@@ -3978,7 +3961,6 @@ END CheckBinaryExpressionTypes ;
PROCEDURE CheckElementSetTypes (quad: CARDINAL) : BOOLEAN ;
VAR
- lefttype,
righttype,
ignore, left, right: CARDINAL ;
constExpr,
@@ -3995,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,
@@ -4020,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 ;
@@ -8174,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 ;
@@ -8230,7 +8224,7 @@ BEGIN
DeclareConstant (rightpos, right) ;
DeclareConstructor (rightpos, quad, right) ;
IF StrictTypeChecking AND
- (NOT AssignmentTypeCompatible (xindrpos, "", GetType (left), right))
+ (NOT AssignmentTypeCompatible (xindrpos, "", GetType (left), right, TRUE))
THEN
MetaErrorT2 (tokenno,
'assignment check caught mismatch between {%1Ead} and {%2ad}',
diff --git a/gcc/m2/gm2-compiler/M2MetaError.def b/gcc/m2/gm2-compiler/M2MetaError.def
index cfe9195..3dfe9fa 100644
--- a/gcc/m2/gm2-compiler/M2MetaError.def
+++ b/gcc/m2/gm2-compiler/M2MetaError.def
@@ -93,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
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 4022657..3c29fdd 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -226,6 +226,7 @@ FROM M2Options IMPORT NilChecking,
GenerateLineDebug, Exceptions,
Profiling, Coding, Optimizing,
UninitVariableChecking,
+ StrictTypeAssignment,
ScaffoldDynamic, ScaffoldStatic, cflag,
ScaffoldMain, SharedFlag, WholeProgram,
GetDumpDir, GetM2DumpFilter,
@@ -258,8 +259,10 @@ FROM M2Range IMPORT InitAssignmentRangeCheck,
InitRotateCheck,
InitShiftCheck,
InitTypesAssignmentCheck,
+ InitTypesIndrXCheck,
InitTypesExpressionCheck,
InitTypesParameterCheck,
+ InitTypesReturnTypeCheck,
InitForLoopBeginRangeCheck,
InitForLoopToRangeCheck,
InitForLoopEndRangeCheck,
@@ -284,7 +287,6 @@ IMPORT M2Error, FIO, SFIO, DynamicStrings, StdIO ;
CONST
DebugStackOn = TRUE ;
DebugVarients = FALSE ;
- BreakAtQuad = 758 ;
DebugTokPos = FALSE ;
TYPE
@@ -397,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. *)
(*
@@ -1487,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.
@@ -3888,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
@@ -5628,7 +5619,7 @@ VAR
proctok,
paramtok : CARDINAL ;
n1, n2 : Name ;
- ParamCheckId,
+ ParamCheckId,
Dim,
Actual,
FormalI,
@@ -5770,42 +5761,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,
- GetNthParamAnyClosest (CheckedProcedure, i, GetCurrentModule ()),
- 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 ;
@@ -6272,21 +6267,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 ;
@@ -11295,7 +11293,7 @@ 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 ;
@@ -16061,12 +16059,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 8e3943a..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,
@@ -289,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 ) |
@@ -822,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.
*)
@@ -837,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.
*)
@@ -1219,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 ) |
@@ -1246,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) ;
@@ -1259,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)
@@ -1275,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
@@ -1757,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
@@ -1785,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 ;
(*
@@ -1859,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 ;
(*
@@ -1941,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')
@@ -1974,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')
@@ -2005,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',
@@ -2419,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) |
@@ -3557,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') |
@@ -3605,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) |
@@ -3743,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) |
generated by cgit v1.1 at 2025-06-04 02:45:57 +0000