1 (* M2Check.mod perform rigerous type checking for fully declared symbols.
3 Copyright (C) 2020-2024 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
6 This file is part of GNU Modula-2.
8 GNU Modula-2 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Modula-2 is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Modula-2; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. *)
22 IMPLEMENTATION MODULE M2Check ;
28 Date : Fri Mar 6 15:32:10 2020
30 Description: provides a module to check the symbol type compatibility.
31 It assumes that the declaration of all dependants
35 FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ;
36 FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType ;
37 FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex ;
38 FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ;
39 FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4 ;
40 FROM StrLib IMPORT StrEqual ;
41 FROM M2Debug IMPORT Assert ;
42 FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetSType, IsType, SkipType, IsProcedure, NoOfParam, IsVarParam, GetNth, GetNthParam, IsProcType, IsVar, IsEnumeration, IsArray, GetDeclaredMod, IsSubrange, GetArraySubscript, IsConst, IsReallyPointer, IsPointer, IsParameter, ModeOfAddr, GetMode, GetType, IsUnbounded, IsComposite, IsConstructor, IsParameter, IsConstString ;
43 FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ;
44 FROM M2System IMPORT Address ;
45 FROM M2ALU IMPORT Equ, PushIntegerTree ;
46 FROM m2expr IMPORT AreConstantsEqual ;
47 FROM SymbolConversion IMPORT Mod2Gcc ;
48 FROM DynamicStrings IMPORT String, InitString, KillString ;
49 FROM M2LexBuf IMPORT GetTokenNo ;
50 FROM Storage IMPORT ALLOCATE ;
51 FROM libc IMPORT printf ;
58 errorSig = POINTER TO RECORD
64 pair = POINTER TO RECORD
65 left, right: CARDINAL ;
70 typeCheckFunction = PROCEDURE (status, tInfo, CARDINAL, CARDINAL) : status ;
72 checkType = (parameter, assignment, expression) ;
74 tInfo = POINTER TO RECORD
85 strict : BOOLEAN ; (* Comparison expression. *)
86 isin : BOOLEAN ; (* Expression created by IN? *)
88 checkFunc : typeCheckFunction ;
95 status = (true, false, unknown, visited, unused) ;
100 tinfoFreeList: tInfo ;
105 isKnown - returns BOOLEAN:TRUE if result is status:true or status:false.
108 PROCEDURE isKnown (result: status) : BOOLEAN ;
110 RETURN (result = true) OR (result = false) OR (result = visited)
115 isTrue - returns BOOLEAN:TRUE if result is status:true
117 PROCEDURE isTrue (result: status) : BOOLEAN ;
125 isFalse - returns BOOLEAN:TRUE if result is status:false
128 PROCEDURE isFalse (result: status) : BOOLEAN ;
130 RETURN result = false
135 checkTypeEquivalence - returns TRUE if left and right can be skipped and found to be equal.
138 PROCEDURE checkTypeEquivalence (result: status; left, right: CARDINAL) : status ;
140 leftT, rightT: CARDINAL ;
142 (* firstly check to see if we already have resolved this as false. *)
147 (* check to see if we dont care about left or right. *)
148 IF (left = NulSym) OR (right = NulSym)
152 leftT := SkipType (left) ;
153 rightT := SkipType (right) ;
157 ELSIF IsType (leftT) AND IsType (rightT)
159 (* the fundamental types are definitely different. *)
165 END checkTypeEquivalence ;
169 checkSubrange - check to see if subrange types left and right have the same limits.
172 PROCEDURE checkSubrange (result: status; tinfo: tInfo; left, right: CARDINAL) : status ;
175 lHigh, rHigh: CARDINAL ;
177 (* firstly check to see if we already have resolved this as false. *)
182 Assert (IsSubrange (left)) ;
183 Assert (IsSubrange (right)) ;
184 lLow := GetTypeMin (left) ;
185 lHigh := GetTypeMax (left) ;
186 rLow := GetTypeMin (right) ;
187 rHigh := GetTypeMax (right) ;
188 PushIntegerTree (Mod2Gcc (lLow)) ;
189 PushIntegerTree (Mod2Gcc (rLow)) ;
190 IF NOT Equ (tinfo^.token)
194 PushIntegerTree (Mod2Gcc (lHigh)) ;
195 PushIntegerTree (Mod2Gcc (rHigh)) ;
196 IF NOT Equ (tinfo^.token)
206 checkArrayTypeEquivalence -
209 PROCEDURE checkArrayTypeEquivalence (result: status; tinfo: tInfo;
210 left, right: CARDINAL) : status ;
212 lSub , rSub: CARDINAL ;
217 ELSIF IsArray (left) AND IsArray (right)
219 lSub := GetArraySubscript (left) ;
220 rSub := GetArraySubscript (right) ;
221 result := checkPair (result, tinfo, GetType (left), GetType (right)) ;
222 IF (lSub # NulSym) AND (rSub # NulSym)
224 result := checkSubrange (result, tinfo, getSType (lSub), getSType (rSub))
226 ELSIF IsUnbounded (left) AND (IsArray (right) OR IsUnbounded (right))
228 IF IsGenericSystemType (getSType (left)) OR IsGenericSystemType (getSType (right))
232 result := checkPair (result, tinfo, GetType (left), GetType (right))
236 END checkArrayTypeEquivalence ;
240 checkGenericTypeEquivalence - check left and right for generic equivalence.
243 PROCEDURE checkGenericTypeEquivalence (result: status; left, right: CARDINAL) : status ;
254 END checkGenericTypeEquivalence ;
258 firstTime - returns TRUE if the triple (token, left, right) has not been seen before.
261 PROCEDURE firstTime (token: CARDINAL; left, right: CARDINAL) : BOOLEAN ;
267 n := HighIndice (errors) ;
269 p := GetIndice (errors, i) ;
270 IF (p^.token = token) AND (p^.left = left) AND (p^.right = right)
280 IncludeIndiceIntoIndex (errors, p) ;
289 PROCEDURE buildError4 (tinfo: tInfo; left, right: CARDINAL) ;
293 IF firstTime (tinfo^.token, left, right)
295 IF tinfo^.error = NIL
297 (* need to create top level error message first. *)
298 tinfo^.error := NewError (tinfo^.token) ;
299 (* The parameters to MetaString4 in buildError4 must match the order
300 of paramters passed to ParameterTypeCompatible. *)
301 s := MetaString4 (tinfo^.format,
303 tinfo^.left, tinfo^.right,
305 ErrorString (tinfo^.error, s)
307 (* and also generate a sub error containing detail. *)
308 IF (left # tinfo^.left) OR (right # tinfo^.right)
310 tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
311 s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
312 ErrorString (tinfo^.error, s)
322 PROCEDURE buildError2 (tinfo: tInfo; left, right: CARDINAL) ;
326 IF firstTime (tinfo^.token, left, right)
328 IF tinfo^.error = NIL
330 (* need to create top level error message first. *)
331 tinfo^.error := NewError (tinfo^.token) ;
332 s := MetaString2 (tinfo^.format,
333 tinfo^.left, tinfo^.right) ;
334 ErrorString (tinfo^.error, s)
336 (* and also generate a sub error containing detail. *)
337 IF (left # tinfo^.left) OR (right # tinfo^.right)
339 tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
340 s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
341 ErrorString (tinfo^.error, s)
351 PROCEDURE issueError (result: BOOLEAN; tinfo: tInfo; left, right: CARDINAL) : status ;
357 (* check whether errors are required. *)
358 IF tinfo^.format # NIL
362 parameter : buildError4 (tinfo, left, right) |
363 assignment: buildError2 (tinfo, left, right) |
364 expression: buildError2 (tinfo, left, right)
367 tinfo^.format := NIL (* string is used by MetaError now. *)
375 checkBaseEquivalence - the catch all check for types not specifically
376 handled by this module.
379 PROCEDURE checkBaseEquivalence (result: status; tinfo: tInfo;
380 left, right: CARDINAL) : status ;
388 parameter : IF tinfo^.isvar
390 RETURN issueError (IsExpressionCompatible (left, right),
393 RETURN issueError (IsAssignmentCompatible (left, right),
396 assignment: RETURN issueError (IsAssignmentCompatible (left, right),
397 tinfo, left, right) |
398 expression: IF tinfo^.isin
400 IF IsVar (right) OR IsConst (right)
402 right := getSType (right)
407 RETURN issueError (IsComparisonCompatible (left, right),
410 RETURN issueError (IsExpressionCompatible (left, right),
415 InternalError ('unexpected kind value')
418 (* should never reach here. *)
419 END checkBaseEquivalence ;
426 PROCEDURE checkPair (result: status; tinfo: tInfo;
427 left, right: CARDINAL) : status ;
431 exclude (tinfo^.visited, left, right) ;
434 IF in (tinfo^.resolved, left, right)
436 exclude (tinfo^.visited, left, right) ;
437 RETURN getStatus (tinfo^.resolved, left, right)
438 ELSIF in (tinfo^.visited, left, right)
444 printf (" marked as visited (%d, %d)\n", left, right)
446 include (tinfo^.visited, left, right, unknown) ;
447 include (tinfo^.unresolved, left, right, unknown)
449 RETURN doCheckPair (result, tinfo, left, right)
458 PROCEDURE useBaseCheck (sym: CARDINAL) : BOOLEAN ;
460 RETURN IsBaseType (sym) OR IsSystemType (sym) OR IsMathType (sym) OR IsComplexType (sym)
465 checkBaseTypeEquivalence -
468 PROCEDURE checkBaseTypeEquivalence (result: status; tinfo: tInfo;
469 left, right: CARDINAL) : status ;
474 ELSIF useBaseCheck (left) AND useBaseCheck (right)
476 RETURN checkBaseEquivalence (result, tinfo, left, right)
480 END checkBaseTypeEquivalence ;
487 PROCEDURE IsTyped (sym: CARDINAL) : BOOLEAN ;
489 RETURN IsVar (sym) OR IsVar (sym) OR IsParameter (sym) OR
490 (IsConst (sym) AND IsConstructor (sym)) OR IsParameter (sym) OR
491 (IsConst (sym) AND (GetType (sym) # NulSym))
499 PROCEDURE isLValue (sym: CARDINAL) : BOOLEAN ;
501 RETURN IsVar (sym) AND (GetMode (sym) = LeftValue)
506 checkVarEquivalence - this test must be done early as it checks the symbol mode.
507 An LValue is treated as a pointer during assignment and the
508 LValue is attached to a variable. This function skips the variable
509 and checks the types - after it has considered a possible LValue.
512 PROCEDURE checkVarEquivalence (result: status; tinfo: tInfo;
513 left, right: CARDINAL) : status ;
518 ELSIF IsTyped (left) OR IsTyped (right)
520 IF tinfo^.kind = assignment
522 (* LValues are only relevant during assignment. *)
523 IF isLValue (left) AND (NOT isLValue (right))
525 IF SkipType (getType (right)) = Address
528 ELSIF IsPointer (SkipType (getType (right)))
530 right := GetDType (SkipType (getType (right)))
532 ELSIF isLValue (right) AND (NOT isLValue (left))
534 IF SkipType (getType (left)) = Address
537 ELSIF IsPointer (SkipType (getType (left)))
539 left := GetDType (SkipType (getType (left)))
543 RETURN doCheckPair (result, tinfo, getType (left), getType (right))
547 END checkVarEquivalence ;
554 PROCEDURE checkConstMeta (result: status;
555 left, right: CARDINAL) : status ;
557 typeRight: CARDINAL ;
559 Assert (IsConst (left)) ;
563 ELSIF IsConstString (left)
565 typeRight := GetDType (right) ;
566 IF typeRight = NulSym
569 ELSIF IsSet (typeRight) OR IsEnumeration (typeRight)
579 checkConstEquivalence - this check can be done first as it checks symbols which
580 may have no type. Ie constant strings. These constants
581 will likely have their type set during quadruple folding.
582 But we can check the meta type for obvious mismatches
583 early on. For example adding a string to an enum or set.
586 PROCEDURE checkConstEquivalence (result: status;
587 left, right: CARDINAL) : status ;
592 ELSIF (left = NulSym) OR (right = NulSym)
594 (* No option but to return true. *)
598 RETURN checkConstMeta (result, left, right)
599 ELSIF IsConst (right)
601 RETURN checkConstMeta (result, right, left)
604 END checkConstEquivalence ;
608 checkSubrangeTypeEquivalence -
611 PROCEDURE checkSubrangeTypeEquivalence (result: status; tinfo: tInfo;
612 left, right: CARDINAL) : status ;
620 RETURN doCheckPair (result, tinfo, GetDType (left), right)
622 IF IsSubrange (right)
624 RETURN doCheckPair (result, tinfo, left, GetDType (right))
633 END checkSubrangeTypeEquivalence ;
640 PROCEDURE isZRC (zrc, sym: CARDINAL) : BOOLEAN ;
644 sym := SkipType (GetType (sym))
646 IF (zrc = CType) AND (IsComplexN (sym) OR IsComplexType (sym))
650 RETURN (zrc = sym) OR ((zrc = ZType) OR (zrc = RType) AND (NOT IsComposite (sym)))
659 PROCEDURE isSameSizeConst (a, b: CARDINAL) : BOOLEAN ;
663 a := SkipType (GetType (a)) ;
664 RETURN isZRC (a, b) OR (a = b) OR ((a # NulSym) AND isSameSize (a, b))
667 b := SkipType (GetType (b)) ;
668 RETURN isZRC (b, a) OR (a = b) OR ((b # NulSym) AND isSameSize (a, b))
671 END isSameSizeConst ;
675 isSameSize - should only be called if either a or b are WORD, BYTE, etc.
678 PROCEDURE isSameSize (a, b: CARDINAL) : BOOLEAN ;
680 RETURN isSameSizeConst (a, b) OR IsSameSize (a, b)
685 checkSystemEquivalence - check whether left and right are system types and whether they have the same size.
688 PROCEDURE checkSystemEquivalence (result: status; left, right: CARDINAL) : status ;
690 IF isFalse (result) OR (result = visited)
694 IF (IsGenericSystemType (left) OR IsGenericSystemType (right)) AND
695 isSameSize (left, right)
701 END checkSystemEquivalence ;
708 PROCEDURE doCheckPair (result: status; tinfo: tInfo;
709 left, right: CARDINAL) : status ;
711 IF isFalse (result) OR (result = visited)
713 RETURN return (result, tinfo, left, right)
716 RETURN return (true, tinfo, left, right)
718 result := checkConstEquivalence (unknown, left, right) ;
719 IF NOT isKnown (result)
721 result := checkVarEquivalence (unknown, tinfo, left, right) ;
722 IF NOT isKnown (result)
724 result := checkSystemEquivalence (unknown, left, right) ;
725 IF NOT isKnown (result)
727 result := checkSubrangeTypeEquivalence (unknown, tinfo, left, right) ;
728 IF NOT isKnown (result)
730 result := checkBaseTypeEquivalence (unknown, tinfo, left, right) ;
731 IF NOT isKnown (result)
733 result := checkTypeEquivalence (unknown, left, right) ;
734 IF NOT isKnown (result)
736 result := checkArrayTypeEquivalence (result, tinfo, left, right) ;
737 IF NOT isKnown (result)
739 result := checkGenericTypeEquivalence (result, left, right) ;
740 IF NOT isKnown (result)
742 result := checkTypeKindEquivalence (result, tinfo, left, right)
752 RETURN return (result, tinfo, left, right)
760 PROCEDURE checkProcType (result: status; tinfo: tInfo;
761 left, right: CARDINAL) : status ;
766 Assert (IsProcType (right)) ;
767 Assert (IsProcType (left)) ;
772 lt := GetDType (left) ;
773 rt := GetDType (right) ;
774 IF (lt = NulSym) AND (rt = NulSym)
779 IF tinfo^.format # NIL
781 MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%1a} does not have a {%kRETURN} type whereas procedure type {%2ad} has a {%kRETURN} type {%3ad}"), left, right, rt)
783 RETURN return (false, tinfo, left, right)
786 IF tinfo^.format # NIL
788 MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%1a} does not have a {%kRETURN} type whereas procedure type {%2ad} has a {%kRETURN} type {%3ad}"), right, left, lt)
790 RETURN return (false, tinfo, left, right)
792 (* two return type seen so we check them. *)
793 result := checkPair (unknown, tinfo, lt, rt)
796 IF NoOfParam (left) # NoOfParam (right)
798 IF tinfo^.format # NIL
800 MetaErrorStringT2 (tinfo^.token, InitString ("procedure type {%1a} has a different number of parameters from procedure type {%2ad}"), right, left)
802 RETURN return (false, tinfo, left, right)
805 n := NoOfParam (left) ;
807 IF IsVarParam (left, i) # IsVarParam (right, i)
809 IF IsVarParam (left, i)
811 IF tinfo^.format # NIL
813 MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%2a} {%3n} parameter was declared as a {%kVAR} whereas procedure type {%1ad} {%3n} parameter was not"), right, left, i)
816 IF tinfo^.format # NIL
818 MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%1a} {%3n} parameter was declared as a {%kVAR} whereas procedure type {%2ad} {%3n} parameter was not"), right, left, i)
821 RETURN return (false, tinfo, left, right)
823 result := checkPair (result, tinfo, GetDType (GetNthParam (left, i)), GetDType (GetNthParam (right, i))) ;
827 RETURN return (result, tinfo, left, right)
832 checkProcedureProcType -
835 PROCEDURE checkProcedureProcType (result: status; tinfo: tInfo;
836 left, right: CARDINAL) : status ;
841 Assert (IsProcedure (right)) ;
842 Assert (IsProcType (left)) ;
843 IF NOT isFalse (result)
845 lt := GetDType (left) ;
846 rt := GetDType (right) ;
847 IF (lt = NulSym) AND (rt = NulSym)
852 IF tinfo^.format # NIL
854 MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%1a} does not have a {%kRETURN} type whereas procedure {%2ad} has a {%kRETURN} type {%3ad}"), left, right, rt)
856 RETURN return (false, tinfo, left, right)
859 IF tinfo^.format # NIL
861 MetaErrorStringT3 (tinfo^.token, InitString ("procedure {%1a} does not have a {%kRETURN} type whereas procedure type {%2ad} has a {%kRETURN} type {%3ad}"), right, left, lt)
863 RETURN return (false, tinfo, left, right)
865 (* two return type seen so we check them. *)
866 result := checkPair (result, tinfo, lt, rt)
869 IF NoOfParam (left) # NoOfParam (right)
871 IF tinfo^.format # NIL
873 MetaErrorStringT2 (tinfo^.token, InitString ("procedure {%1a} has a different number of parameters from procedure type {%2ad}"), right, left)
875 RETURN return (false, tinfo, left, right)
878 n := NoOfParam (left) ;
880 IF IsVarParam (left, i) # IsVarParam (right, i)
882 IF IsVarParam (left, i)
884 IF tinfo^.format # NIL
886 MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%2a} {%3n} parameter was declared as a {%kVAR} whereas procedure {%1ad} {%3n} parameter was not"), right, left, i)
889 IF tinfo^.format # NIL
891 MetaErrorStringT3 (tinfo^.token, InitString ("procedure {%1a} {%3n} parameter was declared as a {%kVAR} whereas procedure type {%2ad} {%3n} parameter was not"), right, left, i)
894 RETURN return (false, tinfo, left, right)
896 result := checkPair (result, tinfo, GetDType (GetNthParam (left, i)), GetDType (GetNthParam (right, i))) ;
900 RETURN return (result, tinfo, left, right)
901 END checkProcedureProcType ;
908 PROCEDURE checkProcedure (result: status; tinfo: tInfo;
909 left, right: CARDINAL) : status ;
911 Assert (IsProcedure (right)) ;
917 RETURN checkProcedure (result, tinfo,
918 GetDType (left), right)
922 ELSIF IsProcType (left)
924 RETURN checkProcedureProcType (result, tinfo, left, right)
932 checkEnumerationEquivalence -
935 PROCEDURE checkEnumerationEquivalence (result: status;
936 left, right: CARDINAL) : status ;
947 END checkEnumerationEquivalence ;
951 checkPointerType - check whether left and right are equal or are of type ADDRESS.
954 PROCEDURE checkPointerType (result: status; left, right: CARDINAL) : status ;
959 ELSIF (left = right) OR (left = Address) OR (right = Address)
965 END checkPointerType ;
969 checkProcTypeEquivalence - allow proctype to be compared against another
970 proctype or procedure. It is legal to be compared
974 PROCEDURE checkProcTypeEquivalence (result: status; tinfo: tInfo;
975 left, right: CARDINAL) : status ;
980 ELSIF IsProcedure (left) AND IsProcType (right)
982 RETURN checkProcedure (result, tinfo, right, left)
983 ELSIF IsProcType (left) AND IsProcedure (right)
985 RETURN checkProcedure (result, tinfo, left, right)
986 ELSIF IsProcType (left) AND IsProcType (right)
988 RETURN checkProcType (result, tinfo, left, right)
989 ELSIF (left = Address) OR (right = Address)
995 END checkProcTypeEquivalence ;
1000 checkTypeKindEquivalence -
1003 PROCEDURE checkTypeKindEquivalence (result: status; tinfo: tInfo;
1004 left, right: CARDINAL) : status ;
1009 ELSIF (left = NulSym) OR (right = NulSym)
1013 (* Long cascade of all type kinds. *)
1014 IF IsSet (left) AND IsSet (right)
1016 RETURN checkSetEquivalent (result, tinfo, left, right)
1017 ELSIF IsArray (left) AND IsArray (right)
1019 RETURN checkArrayTypeEquivalence (result, tinfo, left, right)
1020 ELSIF IsRecord (left) AND IsRecord (right)
1022 RETURN checkRecordEquivalence (result, left, right)
1023 ELSIF IsEnumeration (left) AND IsEnumeration (right)
1025 RETURN checkEnumerationEquivalence (result, left, right)
1026 ELSIF IsProcType (left) OR IsProcType (right)
1028 RETURN checkProcTypeEquivalence (result, tinfo, right, left)
1029 ELSIF IsReallyPointer (left) AND IsReallyPointer (right)
1031 RETURN checkPointerType (result, left, right)
1036 END checkTypeKindEquivalence ;
1043 PROCEDURE isSkipEquivalence (left, right: CARDINAL) : BOOLEAN ;
1045 RETURN SkipType (left) = SkipType (right)
1046 END isSkipEquivalence ;
1050 checkValueEquivalence - check to see if left and right values are the same.
1053 PROCEDURE checkValueEquivalence (result: status; left, right: CARDINAL) : status ;
1062 IF AreConstantsEqual (Mod2Gcc (left), Mod2Gcc (right))
1069 END checkValueEquivalence ;
1076 PROCEDURE and (left, right: status) : status ;
1078 IF (left = true) AND (right = true)
1088 checkTypeRangeEquivalence -
1091 PROCEDURE checkTypeRangeEquivalence (result: status; tinfo: tInfo;
1092 left, right: CARDINAL) : status ;
1094 result2, result3: status ;
1096 result := checkSkipEquivalence (result, left, right) ;
1097 result2 := checkValueEquivalence (result, GetTypeMin (left), GetTypeMin (right)) ;
1098 result3 := checkValueEquivalence (result, GetTypeMax (left), GetTypeMax (right)) ;
1099 RETURN return (and (result2, result3), tinfo, left, right)
1100 END checkTypeRangeEquivalence ;
1104 include - include pair left:right into pairs with status, s.
1107 PROCEDURE include (pairs: Index; left, right: CARDINAL; s: status) ;
1114 p^.pairStatus := s ;
1116 IncludeIndiceIntoIndex (pairs, p)
1121 exclude - exclude pair left:right from pairs.
1124 PROCEDURE exclude (pairs: Index; left, right: CARDINAL) ;
1130 n := HighIndice (pairs) ;
1132 p := GetIndice (pairs, i) ;
1133 IF (p # NIL) AND (p^.left = left) AND (p^.right = right)
1135 PutIndice (pairs, i, NIL) ;
1148 PROCEDURE getStatus (pairs: Index; left, right: CARDINAL) : status ;
1154 n := HighIndice (pairs) ;
1156 p := GetIndice (pairs, i) ;
1157 IF (p # NIL) AND (p^.left = left) AND (p^.right = right)
1159 RETURN p^.pairStatus
1171 PROCEDURE return (result: status; tinfo: tInfo; left, right: CARDINAL) : status ;
1177 include (tinfo^.resolved, left, right, result) ;
1178 exclude (tinfo^.unresolved, left, right) ;
1179 exclude (tinfo^.visited, left, right) (* no longer visiting as it is resolved. *)
1184 RETURN issueError (FALSE, tinfo, left, right)
1191 checkSkipEquivalence - return true if left right are equivalent.
1194 PROCEDURE checkSkipEquivalence (result: status; left, right: CARDINAL) : status ;
1199 ELSIF isSkipEquivalence (left, right)
1205 END checkSkipEquivalence ;
1209 checkSetEquivalent - compares set types, left and right.
1212 PROCEDURE checkSetEquivalent (result: status; tinfo: tInfo;
1213 left, right: CARDINAL) : status ;
1215 result := checkSkipEquivalence (result, left, right) ;
1216 result := checkTypeKindEquivalence (result, tinfo, GetDType (left), GetDType (right)) ;
1217 result := checkTypeRangeEquivalence (result, tinfo, GetDType (left), GetDType (right)) ;
1218 RETURN return (result, tinfo, left, right)
1219 END checkSetEquivalent ;
1223 checkRecordEquivalence - compares record types, left and right.
1226 PROCEDURE checkRecordEquivalence (result: status; left, right: CARDINAL) : status ;
1237 END checkRecordEquivalence ;
1241 getType - only returns the type of symbol providing it is not a procedure.
1244 PROCEDURE getType (sym: CARDINAL) : CARDINAL ;
1246 IF (sym # NulSym) AND IsProcedure (sym)
1251 RETURN GetDType (sym)
1262 PROCEDURE getSType (sym: CARDINAL) : CARDINAL ;
1264 IF IsProcedure (sym)
1268 RETURN GetSType (sym)
1274 determineCompatible - check for compatibility by checking
1275 equivalence, array, generic and type kind.
1278 PROCEDURE determineCompatible (result: status; tinfo: tInfo; left, right: CARDINAL) : status ;
1280 result := checkPair (result, tinfo, left, right) ;
1281 RETURN return (result, tinfo, left, right)
1282 END determineCompatible ;
1289 PROCEDURE get (pairs: Index; VAR left, right: CARDINAL; s: status) : BOOLEAN ;
1295 n := HighIndice (pairs) ;
1297 p := GetIndice (pairs, i) ;
1298 IF (p # NIL) AND (p^.pairStatus = s)
1311 doCheck - keep obtaining an unresolved pair and check for the
1312 type compatibility. This is the main check routine used by
1313 parameter, assignment and expression compatibility.
1314 It tests all unknown pairs and calls the appropriate
1318 PROCEDURE doCheck (tinfo: tInfo) : BOOLEAN ;
1321 left, right: CARDINAL ;
1323 WHILE get (tinfo^.unresolved, left, right, unknown) DO
1326 printf ("doCheck (%d, %d)\n", left, right)
1329 IF in (tinfo^.visited, left, right)
1333 printf (" already visited (%d, %d)\n", left, right)
1338 printf (" not visited (%d, %d)\n", left, right)
1341 result := tinfo^.checkFunc (unknown, tinfo, left, right) ;
1344 (* remove this pair from the unresolved list. *)
1345 exclude (tinfo^.unresolved, left, right) ;
1346 (* add it to the resolved list. *)
1347 include (tinfo^.resolved, left, right, result) ;
1352 printf (" known (%d, %d) false\n", left, right)
1358 printf (" known (%d, %d) true\n", left, right)
1368 in - returns TRUE if the pair is in the list.
1371 PROCEDURE in (pairs: Index; left, right: CARDINAL) : BOOLEAN ;
1377 n := HighIndice (pairs) ;
1379 p := GetIndice (pairs, i) ;
1380 IF (p # NIL) AND (p^.left = left) AND (p^.right = right)
1394 PROCEDURE newPair () : pair ;
1398 IF pairFreeList = NIL
1403 pairFreeList := p^.next
1411 disposePair - adds pair, p, to the free list.
1414 PROCEDURE disposePair (p: pair) ;
1416 p^.next := pairFreeList ;
1425 PROCEDURE deconstructIndex (pairs: Index) : Index ;
1431 n := HighIndice (pairs) ;
1433 p := GetIndice (pairs, i) ;
1440 RETURN KillIndex (pairs)
1441 END deconstructIndex ;
1445 deconstruct - deallocate the List data structure.
1448 PROCEDURE deconstruct (tinfo: tInfo) ;
1450 tinfo^.format := KillString (tinfo^.format) ;
1451 tinfo^.visited := deconstructIndex (tinfo^.visited) ;
1452 tinfo^.resolved := deconstructIndex (tinfo^.resolved) ;
1453 tinfo^.unresolved := deconstructIndex (tinfo^.unresolved)
1461 PROCEDURE newtInfo () : tInfo ;
1465 IF tinfoFreeList = NIL
1469 tinfo := tinfoFreeList ;
1470 tinfoFreeList := tinfoFreeList^.next
1477 collapseString - if the string, a, is "" then return NIL otherwise create
1478 and return a dynamic string.
1481 PROCEDURE collapseString (a: ARRAY OF CHAR) : String ;
1487 RETURN InitString (a)
1489 END collapseString ;
1493 AssignmentTypeCompatible - returns TRUE if the des and the expr are assignment compatible.
1496 PROCEDURE AssignmentTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
1497 des, expr: CARDINAL) : BOOLEAN ;
1501 tinfo := newtInfo () ;
1502 tinfo^.format := collapseString (format) ;
1503 tinfo^.token := token ;
1504 tinfo^.kind := assignment ;
1505 tinfo^.actual := NulSym ;
1506 tinfo^.formal := NulSym ;
1507 tinfo^.procedure := NulSym ;
1509 tinfo^.isvar := FALSE ;
1510 tinfo^.error := NIL ;
1511 tinfo^.left := des ;
1512 tinfo^.right := expr ;
1513 tinfo^.checkFunc := determineCompatible ;
1514 tinfo^.visited := InitIndex (1) ;
1515 tinfo^.resolved := InitIndex (1) ;
1516 tinfo^.unresolved := InitIndex (1) ;
1517 include (tinfo^.unresolved, des, expr, unknown) ;
1518 tinfo^.strict := FALSE ;
1519 tinfo^.isin := FALSE ;
1522 deconstruct (tinfo) ;
1525 deconstruct (tinfo) ;
1528 END AssignmentTypeCompatible ;
1532 ParameterTypeCompatible - returns TRUE if the nth procedure parameter formal
1533 is compatible with actual.
1536 PROCEDURE ParameterTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
1537 procedure, formal, actual, nth: CARDINAL;
1538 isvar: BOOLEAN) : BOOLEAN ;
1540 formalT, actualT: CARDINAL ;
1543 tinfo := newtInfo () ;
1544 formalT := getSType (formal) ;
1545 actualT := getSType (actual) ;
1546 tinfo^.format := collapseString (format) ;
1547 tinfo^.token := token ;
1548 tinfo^.kind := parameter ;
1549 tinfo^.actual := actual ;
1550 tinfo^.formal := formal ;
1551 tinfo^.procedure := procedure ;
1553 tinfo^.isvar := isvar ;
1554 tinfo^.error := NIL ;
1555 tinfo^.left := formalT ;
1556 tinfo^.right := actualT ;
1557 tinfo^.checkFunc := determineCompatible ;
1558 tinfo^.visited := InitIndex (1) ;
1559 tinfo^.resolved := InitIndex (1) ;
1560 tinfo^.unresolved := InitIndex (1) ;
1561 tinfo^.strict := FALSE ;
1562 tinfo^.isin := FALSE ;
1563 include (tinfo^.unresolved, actual, formal, unknown) ;
1566 deconstruct (tinfo) ;
1569 deconstruct (tinfo) ;
1572 END ParameterTypeCompatible ;
1576 doExpressionTypeCompatible -
1579 PROCEDURE doExpressionTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
1580 left, right: CARDINAL;
1581 strict: BOOLEAN) : BOOLEAN ;
1585 tinfo := newtInfo () ;
1586 tinfo^.format := collapseString (format) ;
1587 tinfo^.token := token ;
1588 tinfo^.kind := expression ;
1589 tinfo^.actual := NulSym ;
1590 tinfo^.formal := NulSym ;
1591 tinfo^.procedure := NulSym ;
1593 tinfo^.isvar := FALSE ;
1594 tinfo^.error := NIL ;
1595 tinfo^.left := left ;
1596 tinfo^.right := right ;
1597 tinfo^.checkFunc := determineCompatible ;
1598 tinfo^.visited := InitIndex (1) ;
1599 tinfo^.resolved := InitIndex (1) ;
1600 tinfo^.unresolved := InitIndex (1) ;
1601 tinfo^.strict := strict ;
1602 tinfo^.isin := FALSE ;
1603 include (tinfo^.unresolved, left, right, unknown) ;
1606 deconstruct (tinfo) ;
1609 deconstruct (tinfo) ;
1612 END doExpressionTypeCompatible ;
1616 ExpressionTypeCompatible - returns TRUE if the expressions, left and right,
1617 are expression compatible.
1620 PROCEDURE ExpressionTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
1621 left, right: CARDINAL;
1622 strict, isin: BOOLEAN) : BOOLEAN ;
1624 IF (left#NulSym) AND (right#NulSym)
1628 IF IsConst (right) OR IsVar (right)
1630 right := getSType (right)
1634 right := getSType (right)
1638 RETURN doExpressionTypeCompatible (token, format, left, right, strict)
1639 END ExpressionTypeCompatible ;
1643 init - initialise all global data structures for this module.
1648 pairFreeList := NIL ;
1649 tinfoFreeList := NIL ;
1650 errors := InitIndex (1)