@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
*)
PROCEDURE AssignmentTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
- des, expr: CARDINAL) : BOOLEAN ;
+ des, expr: CARDINAL;
+ enableReason: BOOLEAN) : BOOLEAN ;
(*
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 ;
CONST
- debugging = FALSE ;
+ debugging = FALSE ;
+ MaxEquvalence = 20 ;
TYPE
errorSig = POINTER TO RECORD
checkType = (parameter, assignment, expression) ;
tInfo = POINTER TO RECORD
+ reasonEnable: BOOLEAN ;
+ reason,
format : String ;
kind : checkType ;
token,
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 ;
(*
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.
*)
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 ;
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
*)
PROCEDURE checkUnboundedArray (result: status;
+ tinfo: tInfo;
unbounded, array: CARDINAL) : status ;
VAR
dim : CARDINAL ;
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 ;
(* 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 ;
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 ;
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 ;
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))
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 ;
(*
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. *)
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) ;
(*
- 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) ;
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
THEN
RETURN true
ELSE
- (* check whether errors are required. *)
+ (* Check whether errors are required. *)
IF tinfo^.format # NIL
THEN
CASE tinfo^.kind OF
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 -
*)
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
*)
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 ;
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)
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
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
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 ;
BEGIN
IF IsConst (sym)
THEN
- sym := SkipType (GetType (sym))
+ sym := SkipType (GetDType (sym))
END ;
IF (zrc = CType) AND (IsComplexN (sym) OR IsComplexType (sym))
THEN
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
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
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)
(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
(*
- 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.
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 -
*)
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)
END checkProcTypeEquivalence ;
-
(*
checkTypeKindEquivalence -
*)
THEN
RETURN Address
ELSE
- RETURN GetSType (sym)
+ RETURN GetDType (sym)
END
END getSType ;
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 ;
(*
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
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)
*)
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 ;
tinfo := newtInfo () ;
formalT := getSType (formal) ;
actualT := getSType (actual) ;
+ tinfo^.reasonEnable := StrictTypeReason ;
+ tinfo^.reason := NIL ;
tinfo^.format := collapseString (format) ;
tinfo^.token := token ;
tinfo^.kind := parameter ;
tinfo: tInfo ;
BEGIN
tinfo := newtInfo () ;
+ tinfo^.reasonEnable := StrictTypeReason ;
+ tinfo^.reason := NIL ;
tinfo^.format := collapseString (format) ;
tinfo^.token := token ;
tinfo^.kind := expression ;
BEGIN
pairFreeList := NIL ;
tinfoFreeList := NIL ;
- errors := InitIndex (1)
+ errors := InitIndex (1) ;
+ InitEquivalenceArray
END init ;
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) |
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}',
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 ;
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}',
PROCEDURE CheckBinaryExpressionTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ;
VAR
- lefttype,
- righttype,
des, left, right: CARDINAL ;
typeChecking,
constExpr,
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,
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
PROCEDURE CheckElementSetTypes (quad: CARDINAL) : BOOLEAN ;
VAR
- lefttype,
righttype,
ignore, left, right: CARDINAL ;
constExpr,
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,
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 ;
(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 ;
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}',
%} }
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
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? *)
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.
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.
*)
UnusedVariableChecking := FALSE ;
UnusedParameterChecking := FALSE ;
StrictTypeChecking := TRUE ;
+ StrictTypeAssignment := TRUE ;
+ StrictTypeReason := TRUE ;
AutoInit := FALSE ;
SaveTemps := FALSE ;
ScaffoldDynamic := TRUE ;
GenerateLineDebug, Exceptions,
Profiling, Coding, Optimizing,
UninitVariableChecking,
+ StrictTypeAssignment,
ScaffoldDynamic, ScaffoldStatic, cflag,
ScaffoldMain, SharedFlag, WholeProgram,
GetDumpDir, GetM2DumpFilter,
InitRotateCheck,
InitShiftCheck,
InitTypesAssignmentCheck,
+ InitTypesIndrXCheck,
InitTypesExpressionCheck,
InitTypesParameterCheck,
+ InitTypesReturnTypeCheck,
InitForLoopBeginRangeCheck,
InitForLoopToRangeCheck,
InitForLoopEndRangeCheck,
CONST
DebugStackOn = TRUE ;
DebugVarients = FALSE ;
- BreakAtQuad = 758 ;
DebugTokPos = FALSE ;
TYPE
(* in order. *)
NoOfQuads : CARDINAL ; (* Number of used quadruples. *)
Head : CARDINAL ; (* Head of the list of quadruples. *)
+ BreakQuad : CARDINAL ; (* Stop when BreakQuad is created. *)
(*
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.
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
proctok,
paramtok : CARDINAL ;
n1, n2 : Name ;
- ParamCheckId,
+ ParamCheckId,
Dim,
Actual,
FormalI,
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 ;
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 ;
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 ;
*)
+(*
+ 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') ;
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.
*)
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 ;
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,
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 ) |
(*
- 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.
*)
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.
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 ) |
(*
- 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) ;
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)
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
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
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 ;
(*
*)
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 ;
(*
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')
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')
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',
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) |
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') |
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) |
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) |
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. */
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;
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
--- /dev/null
+MODULE testcharint ; (*!m2iso+gm2*)
+
+VAR
+ ch: CHAR ;
+ i : INTEGER ;
+BEGIN
+ ch := i
+END testcharint.
--- /dev/null
+MODULE testindrx ; (*!m2iso+gm2*)
+
+VAR
+ x: ARRAY [1..5] OF INTEGER ;
+ ch: CHAR ;
+BEGIN
+ ch := x[1]
+END testindrx.
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+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.
projects / thirdparty / gcc.git / commitdiff
