https://gcc.gnu.org/g:e131ba3de5f487f5e957ba1b011c960fce557c7b
commit r16-1026-ge131ba3de5f487f5e957ba1b011c960fce557c7b
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Sat May 31 01:53:48 2025 +0100
PR modula2/120389 Assigning wrong type to an array causes an ICE
This patch provides follow on fixes for undetected type violations
which can occur then Lvalues are generated during assignment.
For example array accesses and with statements. The type checker
M2Check.mod has been overhauled and cleaned up.
gcc/ChangeLog:
PR modula2/120389
* doc/gm2.texi (-fm2-strict-type-reason): Document new flag.
gcc/m2/ChangeLog:
PR modula2/120389
* gm2-compiler/M2Check.def (AssignmentTypeCompatible): Add new
parameter enableReason.
* gm2-compiler/M2Check.mod (EquivalenceProcedure): New type.
(falseReason2): New procedure function.
(falseReason1): Ditto.
(falseReason0): Ditto.
(checkTypeEquivalence): Rewrite.
(checkUnboundedArray): Ditto.
(checkUnbounded): Ditto.
(checkArrayTypeEquivalence): Ditto.
(checkCharStringTypeEquivalence): Ditto.
(buildError4): Add false reason.
(buildError2): Ditto.
(IsTyped): Use GetDType.
(IsTypeEquivalence): New procedure function.
(checkVarTypeEquivalence): Ditto.
(checkVarEquivalence ): Rewrite.
(checkConstMeta): Ditto.
(checkEnumField): New procedure function.
(checkEnumFieldEquivalence): Ditto.
(checkSubrangeTypeEquivalence): Rewrite.
(checkSystemEquivalence): Ditto.
(checkTypeKindViolation): Ditto.
(doCheckPair): Ditto.
(InitEquivalenceArray): New procedure.
(addEquivalence): Ditto.
(checkProcType): Rewrite.
(deconstruct): Deallocate reason string.
(AssignmentTypeCompatible): Initialize reason and reasonEnable
fields.
(ParameterTypeCompatible): Ditto.
(doExpressionTypeCompatible): Ditto.
* gm2-compiler/M2GenGCC.mod (CodeIndrX) Rewrite.
(CheckBinaryExpressionTypes): Rewrite and simplify now that the
type checker is more robust.
(CheckElementSetTypes): Ditto.
(CodeXIndr): Add new range assignment type check.
* gm2-compiler/M2MetaError.def: Correct comments.
* gm2-compiler/M2Options.def (SetStrictTypeAssignment): New
procedure.
(SetStrictTypeReason): Ditto.
* gm2-compiler/M2Options.mod: (SetStrictTypeAssignment): New
procedure.
(SetStrictTypeReason): Ditto.
(StrictTypeReason): Initialize.
(StrictTypeAssignment): Ditto.
* gm2-compiler/M2Quads.mod (CheckBreak): Delete.
(BreakQuad): New global variable.
(BreakAtQuad): Delete.
(gdbhook): New procedure.
(BreakWhenQuadCreated): Ditto.
(CheckBreak): Ditto.
(Init): Call BreakWhenQuadCreated and gdbhook.
(doBuildAssignment): Add type assignment range check.
(CheckProcTypeAndProcedure): Only check if the procedure
types differ.
(doIndrX): Add type IndrX range check.
(CheckReturnType): Add range return type check.
* gm2-compiler/M2Range.def (InitTypesIndrXCheck): New procedure
function.
(InitTypesReturnTypeCheck): Ditto.
* gm2-compiler/M2Range.mod (InitTypesIndrXCheck): New procedure
function.
(InitTypesReturnTypeCheck): Ditto.
(HandlerExists): Add new clauses.
(FoldAssignment): Pass extra FALSE parameter to
AssignmentTypeCompatible.
(FoldTypeReturnFunc): New procedure.
(FoldTypeAssign): Ditto.
(FoldTypeIndrX): Ditto.
(CodeTypeAssign): Rewrite.
(CodeTypeIndrX): New procedure.
(CodeTypeReturnFunc): Ditto.
(FoldTypeCheck): Add new case clauses.
(CodeTypeCheck): Ditto.
(FoldRangeCheckLower): Ditto.
(IssueWarning): Ditto.
* gm2-gcc/m2options.h (M2Options_SetStrictTypeAssignment): New
function prototype.
(M2Options_SetStrictTypeReason): Ditto.
* gm2-lang.cc (gm2_langhook_handle_option): New case clause
OPT_fm2_strict_type_reason.
* lang.opt (-fm2-strict-type-reason): New option.
gcc/testsuite/ChangeLog:
PR modula2/120389
* gm2/pim/fail/testcharint.mod: New test.
* gm2/pim/fail/testindrx.mod: New test.
* gm2/pim/pass/testxindr.mod: New test.
* gm2/pim/pass/testxindr2.mod: New test.
* gm2/pim/pass/testxindr3.mod: New test.
Signed-off-by: Gaius Mulley <gaiusm...@gmail.com>
Diff:
---
gcc/doc/gm2.texi | 3 +
gcc/m2/gm2-compiler/M2Check.def | 3 +-
gcc/m2/gm2-compiler/M2Check.mod | 522 +++++++++++++++++++++--------
gcc/m2/gm2-compiler/M2GenGCC.mod | 88 +++--
gcc/m2/gm2-compiler/M2MetaError.def | 6 +-
gcc/m2/gm2-compiler/M2Options.def | 16 +
gcc/m2/gm2-compiler/M2Options.mod | 22 ++
gcc/m2/gm2-compiler/M2Quads.mod | 141 +++++---
gcc/m2/gm2-compiler/M2Range.def | 18 +
gcc/m2/gm2-compiler/M2Range.mod | 248 +++++++++++---
gcc/m2/gm2-gcc/m2options.h | 2 +
gcc/m2/gm2-lang.cc | 3 +
gcc/m2/lang.opt | 4 +
gcc/testsuite/gm2/pim/fail/testcharint.mod | 8 +
gcc/testsuite/gm2/pim/fail/testindrx.mod | 8 +
gcc/testsuite/gm2/pim/pass/testxindr.mod | 17 +
gcc/testsuite/gm2/pim/pass/testxindr2.mod | 17 +
gcc/testsuite/gm2/pim/pass/testxindr3.mod | 15 +
18 files changed, 860 insertions(+), 281 deletions(-)
diff --git a/gcc/doc/gm2.texi b/gcc/doc/gm2.texi
index 8293da4994ed..9bd0f0d22142 100644
--- a/gcc/doc/gm2.texi
+++ b/gcc/doc/gm2.texi
@@ -540,6 +540,9 @@ lines compiled.
@item -fm2-strict-type
experimental flag to turn on the new strict type checker.
+@item -fm2-strict-type-reason
+provides more detail why the types are incompatible.
+
@item -fm2-whole-program
compile all implementation modules and program module at once. Notice
that you need to take care if you are compiling different dialect
diff --git a/gcc/m2/gm2-compiler/M2Check.def b/gcc/m2/gm2-compiler/M2Check.def
index 0ceb17357d99..9d9f7609d398 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 d86ef8e88656..614526c0dc06 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 ;
(*
@@ -158,6 +171,53 @@ BEGIN
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,10 +814,20 @@ 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 -
*)
@@ -714,6 +838,38 @@ BEGIN
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
@@ -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
@@ -814,6 +981,58 @@ BEGIN
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
@@ -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,56 +1206,73 @@ 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)
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 2dfa566664a4..4a9ced32dcfa 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 cfe9195adf94..3dfe9fa01b42 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 2b78add36cd3..4cb7f8f483eb 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? *)
@@ -755,6 +757,20 @@ PROCEDURE SetUnusedParameterChecking (value: BOOLEAN) ;
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 39f0b2a73fb2..542b87b12d2c 100644
--- a/gcc/m2/gm2-compiler/M2Options.mod
+++ b/gcc/m2/gm2-compiler/M2Options.mod
@@ -656,6 +656,26 @@ BEGIN
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 402265718974..3c29fdd3b2ba 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 ;
@@ -16060,6 +16058,37 @@ 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.
@@ -16067,6 +16096,18 @@ END StressStack ;
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 42aa14237c9e..e825d948ddd0 100644
--- a/gcc/m2/gm2-compiler/M2Range.def
+++ b/gcc/m2/gm2-compiler/M2Range.def
@@ -290,6 +290,24 @@ PROCEDURE InitTypesExpressionCheck (tokno: CARDINAL; d, e:
CARDINAL;
strict, isin: BOOLEAN) : 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 8e3943ae11c2..fcca9727165f 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 ;
@@ -115,7 +115,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 +291,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 +825,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.
*)
@@ -836,6 +839,38 @@ BEGIN
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 +1254,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 +1283,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 +1298,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 +1314,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
@@ -1756,22 +1797,87 @@ BEGIN
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
+ 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
+ ELSIF AssignmentTypeCompatible (tokenNo, "", returnType, val, 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 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 IsAssignmentCompatible (desType, exprType)
THEN
SubQuad(q)
ELSE
@@ -1785,14 +1891,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 +1967,69 @@ END FoldTypeExpr ;
*)
PROCEDURE CodeTypeAssign (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL)
;
-VAR
- exprType: CARDINAL ;
BEGIN
- IF IsProcedure(expr)
+ IF NOT AssignmentTypeCompatible (tokenNo, "", des, expr, FALSE)
THEN
- exprType := expr
- ELSE
- exprType := GetType(expr)
- END ;
- IF NOT IsAssignmentCompatible(GetType(des), exprType)
+ 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) ;
+BEGIN
+ IF NOT AssignmentTypeCompatible (tokenNo, "", GetType (func), val, FALSE)
THEN
IF NOT reportedError (r)
THEN
- IF IsProcedure(des)
+ MetaErrorsT2 (tokenNo,
+ 'the return type {%1Etad} used in procedure function
{%1Da}',
+ 'is incompatible with the returned expression {%2EUa}
{%2tad:of type {%2tad}}',
+ func, val) ;
+ setReported (r)
+ 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 IsAssignmentCompatible (GetType (des), GetType (expr))
+ THEN
+ IF NOT reportedError (r)
+ THEN
+ 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 +2083,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 +2118,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 +2151,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 +2565,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 +3705,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 +3755,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 +3895,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) |
diff --git a/gcc/m2/gm2-gcc/m2options.h b/gcc/m2/gm2-gcc/m2options.h
index d60b510de34f..041de26cf8dd 100644
--- a/gcc/m2/gm2-gcc/m2options.h
+++ b/gcc/m2/gm2-gcc/m2options.h
@@ -168,6 +168,8 @@ EXTERN char *M2Options_GetM2DumpFilter (void);
EXTERN void M2Options_SetM2DebugTraceFilter (bool value, const char *arg);
EXTERN bool M2Options_SetM2Dump (bool value, const char *arg);
EXTERN bool M2Options_GetDumpGimple (void);
+EXTERN void M2Options_SetStrictTypeAssignment (bool value);
+EXTERN void M2Options_SetStrictTypeReason (bool value);
#undef EXTERN
#endif /* m2options_h. */
diff --git a/gcc/m2/gm2-lang.cc b/gcc/m2/gm2-lang.cc
index e8820daf4745..31a2e46475dc 100644
--- a/gcc/m2/gm2-lang.cc
+++ b/gcc/m2/gm2-lang.cc
@@ -525,6 +525,9 @@ gm2_langhook_handle_option (
case OPT_fm2_strict_type:
M2Options_SetStrictTypeChecking (value);
return 1;
+ case OPT_fm2_strict_type_reason:
+ M2Options_SetStrictTypeReason (value);
+ return 1;
case OPT_fm2_debug_trace_:
M2Options_SetM2DebugTraceFilter (value, arg);
return 1;
diff --git a/gcc/m2/lang.opt b/gcc/m2/lang.opt
index 1ea55f21e4c7..48c2380f565b 100644
--- a/gcc/m2/lang.opt
+++ b/gcc/m2/lang.opt
@@ -190,6 +190,10 @@ fm2-strict-type
Modula-2
experimental flag to turn on the new strict type checker
+fm2-strict-type-reason
+Modula-2
+provides more detail why the types are incompatible
+
fm2-whole-program
Modula-2
compile all implementation modules and program module at once
diff --git a/gcc/testsuite/gm2/pim/fail/testcharint.mod
b/gcc/testsuite/gm2/pim/fail/testcharint.mod
new file mode 100644
index 000000000000..d403651c2b71
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/testcharint.mod
@@ -0,0 +1,8 @@
+MODULE testcharint ; (*!m2iso+gm2*)
+
+VAR
+ ch: CHAR ;
+ i : INTEGER ;
+BEGIN
+ ch := i
+END testcharint.
diff --git a/gcc/testsuite/gm2/pim/fail/testindrx.mod
b/gcc/testsuite/gm2/pim/fail/testindrx.mod
new file mode 100644
index 000000000000..2630ebd6d746
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/testindrx.mod
@@ -0,0 +1,8 @@
+MODULE testindrx ; (*!m2iso+gm2*)
+
+VAR
+ x: ARRAY [1..5] OF INTEGER ;
+ ch: CHAR ;
+BEGIN
+ ch := x[1]
+END testindrx.
diff --git a/gcc/testsuite/gm2/pim/pass/testxindr.mod
b/gcc/testsuite/gm2/pim/pass/testxindr.mod
new file mode 100644
index 000000000000..271f4305478f
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/testxindr.mod
@@ -0,0 +1,17 @@
+MODULE testxindr ; (*!m2iso+gm2*)
+
+CONST
+ NulName = 0 ;
+
+TYPE
+ Name = CARDINAL ;
+
+ ptr = POINTER TO RECORD
+ n: Name ;
+ END ;
+
+VAR
+ p: ptr ;
+BEGIN
+ p^.n := NulName
+END testxindr.
diff --git a/gcc/testsuite/gm2/pim/pass/testxindr2.mod
b/gcc/testsuite/gm2/pim/pass/testxindr2.mod
new file mode 100644
index 000000000000..b0776dcdd905
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/testxindr2.mod
@@ -0,0 +1,17 @@
+MODULE testxindr2 ; (*!m2iso+gm2*)
+
+CONST
+ NulName = 0 ;
+TYPE
+ Name = CARDINAL ;
+
+PROCEDURE set (VAR n: Name) ;
+BEGIN
+ n := NulName
+END set ;
+
+VAR
+ n: Name ;
+BEGIN
+ set (n)
+END testxindr2.
diff --git a/gcc/testsuite/gm2/pim/pass/testxindr3.mod
b/gcc/testsuite/gm2/pim/pass/testxindr3.mod
new file mode 100644
index 000000000000..5625c3eb5143
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/testxindr3.mod
@@ -0,0 +1,15 @@
+MODULE testxindr3 ; (*!m2iso+gm2*)
+
+CONST
+ NulName = 0 ;
+
+PROCEDURE set (VAR n: CARDINAL) ;
+BEGIN
+ n := NulName
+END set ;
+
+VAR
+ n: CARDINAL ;
+BEGIN
+ set (n)
+END testxindr3.
