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