path: root/gcc/m2/gm2-compiler/M2Check.mod

(* M2Check.mod perform rigerous type checking for fully declared symbols.

Copyright (C) 2020-2023 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE M2Check ;

(*
    Title      : M2Check
    Author     : Gaius Mulley
    System     : GNU Modula-2
    Date       : Fri Mar  6 15:32:10 2020
    Revision   : $Version$
    Description: provides a module to check the symbol type compatibility.
                 It assumes that the declaration of all dependants
                 is complete.
*)

FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ;
FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType ;
FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex ;
FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ;
FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4 ;
FROM StrLib IMPORT StrEqual ;
FROM M2Debug IMPORT Assert ;
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 ;
FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ;
FROM M2System IMPORT Address ;
FROM M2ALU IMPORT Equ, PushIntegerTree ;
FROM m2expr IMPORT AreConstantsEqual ;
FROM SymbolConversion IMPORT Mod2Gcc ;
FROM DynamicStrings IMPORT String, InitString, KillString ;
FROM M2LexBuf IMPORT GetTokenNo ;
FROM Storage IMPORT ALLOCATE ;
FROM libc IMPORT printf ;


CONST
   debugging = FALSE ;

TYPE
   errorSig = POINTER TO RECORD
                            token:  CARDINAL ;
                            left,
                            right:  CARDINAL ;
                         END ;

   pair = POINTER TO RECORD
                        left, right: CARDINAL ;
                        pairStatus : status ;
                        next       : pair ;
                     END ;

   typeCheckFunction = PROCEDURE (status, tInfo, CARDINAL, CARDINAL) : status ;

   checkType = (parameter, assignment, expression) ;

   tInfo = POINTER TO RECORD
                         format    : String ;
                         kind      : checkType ;
                         token,
                         actual,
                         formal,
                         left,
                         right,
                         procedure,
                         nth       : CARDINAL ;
                         isvar     : BOOLEAN ;
                         strict    : BOOLEAN ;  (* Comparison expression.  *)
                         isin      : BOOLEAN ;  (* Expression created by IN?  *)
                         error     : Error ;
                         checkFunc : typeCheckFunction ;
                         visited,
                         resolved,
                         unresolved: Index ;
                         next      : tInfo ;
                      END ;

   status = (true, false, unknown, visited, unused) ;


VAR
   pairFreeList : pair ;
   tinfoFreeList: tInfo ;
   errors       : Index ;


(*
   isKnown - returns BOOLEAN:TRUE if result is status:true or status:false.
*)

PROCEDURE isKnown (result: status) : BOOLEAN ;
BEGIN
   RETURN (result = true) OR (result = false) OR (result = visited)
END isKnown ;


(*
   isTrue - returns BOOLEAN:TRUE if result is status:true

PROCEDURE isTrue (result: status) : BOOLEAN ;
BEGIN
   RETURN result = true
END isTrue ;
*)


(*
   isFalse - returns BOOLEAN:TRUE if result is status:false
*)

PROCEDURE isFalse (result: status) : BOOLEAN ;
BEGIN
   RETURN result = false
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 ;
BEGIN
   (* firstly check to see if we already have resolved this as false.  *)
   IF isFalse (result)
   THEN
      RETURN result
   ELSE
      (* check to see if we dont care about left or right.  *)
      IF (left = NulSym) OR (right = NulSym)
      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
   END ;
   RETURN result
END checkTypeEquivalence ;


(*
   checkSubrange - check to see if subrange types left and right have the same limits.
*)

PROCEDURE checkSubrange (result: status; tinfo: tInfo; left, right: CARDINAL) : status ;
VAR
   lLow,  rLow,
   lHigh, rHigh: CARDINAL ;
BEGIN
   (* firstly check to see if we already have resolved this as false.  *)
   IF isFalse (result)
   THEN
      RETURN result
   ELSE
      Assert (IsSubrange (left)) ;
      Assert (IsSubrange (right)) ;
      lLow := GetTypeMin (left) ;
      lHigh := GetTypeMax (left) ;
      rLow := GetTypeMin (right) ;
      rHigh := GetTypeMax (right) ;
      PushIntegerTree (Mod2Gcc (lLow)) ;
      PushIntegerTree (Mod2Gcc (rLow)) ;
      IF NOT Equ (tinfo^.token)
      THEN
         RETURN false
      END ;
      PushIntegerTree (Mod2Gcc (lHigh)) ;
      PushIntegerTree (Mod2Gcc (rHigh)) ;
      IF NOT Equ (tinfo^.token)
      THEN
         RETURN false
      END
   END ;
   RETURN true
END checkSubrange ;


(*
   checkArrayTypeEquivalence -
*)

PROCEDURE checkArrayTypeEquivalence (result: status; tinfo: tInfo;
                                     left, right: CARDINAL) : status ;
VAR
   lSub , rSub: CARDINAL ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF IsArray (left) AND IsArray (right)
   THEN
      lSub := GetArraySubscript (left) ;
      rSub := GetArraySubscript (right) ;
      result := checkPair (result, tinfo, GetType (left), GetType (right)) ;
      IF (lSub # NulSym) AND (rSub # NulSym)
      THEN
         result := checkSubrange (result, tinfo, GetSType (lSub), GetSType (rSub))
      END
   ELSIF IsUnbounded (left) AND (IsArray (right) OR IsUnbounded (right))
   THEN
      IF IsGenericSystemType (GetSType (left)) OR IsGenericSystemType (GetSType (right))
      THEN
         RETURN true
      ELSE
         result := checkPair (result, tinfo, GetType (left), GetType (right))
      END
   END ;
   RETURN result
END checkArrayTypeEquivalence ;


(*
   checkGenericTypeEquivalence - check left and right for generic equivalence.
*)

PROCEDURE checkGenericTypeEquivalence (result: status; left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF left = right
   THEN
      RETURN true
   ELSE
      RETURN result
   END
END checkGenericTypeEquivalence ;


(*
   firstTime - returns TRUE if the triple (token, left, right) has not been seen before.
*)

PROCEDURE firstTime (token: CARDINAL; left, right: CARDINAL) : BOOLEAN ;
VAR
   p   : errorSig ;
   i, n: CARDINAL ;
BEGIN
   i := 1 ;
   n := HighIndice (errors) ;
   WHILE i <= n DO
      p := GetIndice (errors, i) ;
      IF (p^.token = token) AND (p^.left = left) AND (p^.right = right)
      THEN
         RETURN FALSE
      END ;
      INC (i)
   END ;
   NEW (p) ;
   p^.token := token ;
   p^.left := left ;
   p^.right := right ;
   IncludeIndiceIntoIndex (errors, p) ;
   RETURN TRUE
END firstTime ;


(*
   buildError4 -
*)

PROCEDURE buildError4 (tinfo: tInfo; left, right: CARDINAL) ;
VAR
   s: String ;
BEGIN
   IF firstTime (tinfo^.token, left, right)
   THEN
      IF tinfo^.error = NIL
      THEN
         (* need to create top level error message first.  *)
         tinfo^.error := NewError (tinfo^.token) ;
         s := MetaString4 (tinfo^.format,
                           tinfo^.left, tinfo^.right,
                           tinfo^.procedure, tinfo^.nth) ;
         ErrorString (tinfo^.error, s)
      END ;
      (* and also generate a sub error containing detail.  *)
      IF (left # tinfo^.left) OR (right # tinfo^.right)
      THEN
         tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
         s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
         ErrorString (tinfo^.error, s)
      END
   END
END buildError4 ;


(*
   buildError2 -
*)

PROCEDURE buildError2 (tinfo: tInfo; left, right: CARDINAL) ;
VAR
   s: String ;
BEGIN
   IF firstTime (tinfo^.token, left, right)
   THEN
      IF tinfo^.error = NIL
      THEN
         (* need to create top level error message first.  *)
         tinfo^.error := NewError (tinfo^.token) ;
         s := MetaString2 (tinfo^.format,
                           tinfo^.left, tinfo^.right) ;
         ErrorString (tinfo^.error, s)
      END ;
      (* and also generate a sub error containing detail.  *)
      IF (left # tinfo^.left) OR (right # tinfo^.right)
      THEN
         tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
         s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
         ErrorString (tinfo^.error, s)
      END
   END
END buildError2 ;


(*
   issueError -
*)

PROCEDURE issueError (result: BOOLEAN; tinfo: tInfo; left, right: CARDINAL) : status ;
BEGIN
   IF result
   THEN
      RETURN true
   ELSE
      (* check whether errors are required.  *)
      IF tinfo^.format # NIL
      THEN
         CASE tinfo^.kind OF

         parameter :  buildError4 (tinfo, left, right) |
         assignment:  buildError2 (tinfo, left, right) |
         expression:  buildError2 (tinfo, left, right)

         END ;
         tinfo^.format := NIL    (* string is used by MetaError now.  *)
      END ;
      RETURN false
   END
END issueError ;


(*
   checkBaseEquivalence - the catch all check for types not specifically
                          handled by this module.
*)

PROCEDURE checkBaseEquivalence (result: status; tinfo: tInfo;
                                left, right: CARDINAL) : status ;
BEGIN
   IF isKnown (result)
   THEN
      RETURN result
   ELSE
      CASE tinfo^.kind OF

      parameter :  IF tinfo^.isvar
                   THEN
                      RETURN issueError (IsExpressionCompatible (left, right),
                                         tinfo, left, right)
                   ELSE
                      RETURN issueError (IsAssignmentCompatible (left, right),
                                         tinfo, left, right)
                   END |
      assignment:  RETURN issueError (IsAssignmentCompatible (left, right),
                                      tinfo, left, right) |
      expression:  IF tinfo^.isin
                   THEN
                      IF IsVar (right) OR IsConst (right)
                      THEN
                         right := GetSType (right)
                      END
                   END ;
                   IF tinfo^.strict
                   THEN
                      RETURN issueError (IsComparisonCompatible (left, right),
                                         tinfo, left, right)
                   ELSE
                      RETURN issueError (IsExpressionCompatible (left, right),
                                         tinfo, left, right)
                   END

      ELSE
         InternalError ('unexpected kind value')
      END
   END
   (* should never reach here.  *)
END checkBaseEquivalence ;


(*
   checkPair -
*)

PROCEDURE checkPair (result: status; tinfo: tInfo;
                     left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      exclude (tinfo^.visited, left, right) ;
      RETURN result
   ELSE
      IF in (tinfo^.resolved, left, right)
      THEN
         exclude (tinfo^.visited, left, right) ;
         RETURN getStatus (tinfo^.resolved, left, right)
      ELSIF in (tinfo^.visited, left, right)
      THEN
         RETURN visited
      ELSE
         IF debugging
         THEN
            printf ("   marked as visited (%d, %d)\n", left, right)
         END ;
         include (tinfo^.visited, left, right, unknown) ;
         include (tinfo^.unresolved, left, right, unknown)
      END ;
      RETURN doCheckPair (result, tinfo, left, right)
   END
END checkPair ;


(*
   useBaseCheck -
*)

PROCEDURE useBaseCheck (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN IsBaseType (sym) OR IsSystemType (sym) OR IsMathType (sym) OR IsComplexType (sym)
END useBaseCheck ;


(*
   checkBaseTypeEquivalence -
*)

PROCEDURE checkBaseTypeEquivalence (result: status; tinfo: tInfo;
                                     left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF useBaseCheck (left) AND useBaseCheck (right)
   THEN
      RETURN checkBaseEquivalence (result, tinfo, left, right)
   ELSE
      RETURN result
   END
END checkBaseTypeEquivalence ;


(*
   IsTyped -
*)

PROCEDURE IsTyped (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN IsVar (sym) OR IsVar (sym) OR IsParameter (sym) OR
          (IsConst (sym) AND IsConstructor (sym)) OR IsParameter (sym) OR
          (IsConst (sym) AND (GetType (sym) # NulSym))
END IsTyped ;


(*
   isLValue -
*)

PROCEDURE isLValue (sym: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN IsVar (sym) AND (GetMode (sym) = LeftValue)
END isLValue ;


(*
   checkVarEquivalence - this test must be done first 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
                         and checks the types - after it has considered a possible LValue.
*)

PROCEDURE checkVarEquivalence (result: status; tinfo: tInfo;
                               left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF IsTyped (left) OR IsTyped (right)
   THEN
      IF tinfo^.kind = assignment
      THEN
         (* LValues are only relevant during assignment.  *)
         IF isLValue (left) AND (NOT isLValue (right))
         THEN
            IF SkipType (getType (right)) = Address
            THEN
               RETURN true
            ELSIF IsPointer (SkipType (getType (right)))
            THEN
               right := GetDType (SkipType (getType (right)))
            END
         ELSIF isLValue (right) AND (NOT isLValue (left))
         THEN
            IF SkipType (getType (left)) = Address
            THEN
               RETURN true
            ELSIF IsPointer (SkipType (getType (left)))
            THEN
               left := GetDType (SkipType (getType (left)))
            END
         END
      END ;
      RETURN doCheckPair (result, tinfo, getType (left), getType (right))
   ELSE
      RETURN result
   END
END checkVarEquivalence ;


(*
   checkSubrangeTypeEquivalence -
*)

PROCEDURE checkSubrangeTypeEquivalence (result: status; tinfo: tInfo;
                                        left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSE
      IF IsSubrange (left)
      THEN
         RETURN doCheckPair (result, tinfo, GetDType (left), right)
      END ;
      IF IsSubrange (right)
      THEN
         RETURN doCheckPair (result, tinfo, left, GetDType (right))
      END ;
      IF left = right
      THEN
         RETURN true
      ELSE
         RETURN result
      END
   END
END checkSubrangeTypeEquivalence ;


(*
   isZRC -
*)

PROCEDURE isZRC (zrc, sym: CARDINAL) : BOOLEAN ;
BEGIN
   IF IsConst (sym)
   THEN
      sym := SkipType (GetType (sym))
   END ;
   IF (zrc = CType) AND (IsComplexN (sym) OR IsComplexType (sym))
   THEN
      RETURN TRUE
   END ;
   RETURN (zrc = sym) OR ((zrc = ZType) OR (zrc = RType) AND (NOT IsComposite (sym)))
END isZRC ;


(*
   isSameSizeConst -

*)

PROCEDURE isSameSizeConst (a, b: CARDINAL) : BOOLEAN ;
BEGIN
   IF IsConst (a)
   THEN
      a := SkipType (GetType (a)) ;
      RETURN isZRC (a, b) OR (a = b) OR ((a # NulSym) AND isSameSize (a, b))
   ELSIF IsConst (b)
   THEN
      b := SkipType (GetType (b)) ;
      RETURN isZRC (b, a) OR (a = b) OR ((b # NulSym) AND isSameSize (a, b))
   END ;
   RETURN FALSE
END isSameSizeConst ;


(*
   isSameSize - should only be called if either a or b are WORD, BYTE, etc.
*)

PROCEDURE isSameSize (a, b: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN isSameSizeConst (a, b) OR IsSameSize (a, b)
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 ;
BEGIN
   IF isFalse (result) OR (result = visited)
   THEN
      RETURN result
   ELSE
      IF (IsGenericSystemType (left) OR IsGenericSystemType (right)) AND
         isSameSize (left, right)
      THEN
         RETURN true
      END
   END ;
   RETURN result
END checkSystemEquivalence ;


(*
   doCheckPair -
*)

PROCEDURE doCheckPair (result: status; tinfo: tInfo;
                       left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result) OR (result = visited)
   THEN
      RETURN return (result, tinfo, left, right)
   ELSIF left = right
   THEN
      RETURN return (true, tinfo, left, right)
   ELSE
      result := checkVarEquivalence (unknown, tinfo, left, right) ;
      IF NOT 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)
                        END
                     END
                  END
               END
            END
         END
      END
   END ;
   RETURN return (result, tinfo, left, right)
END doCheckPair ;


(*
   checkProcType -
*)

PROCEDURE checkProcType (result: status; tinfo: tInfo;
                         left, right: CARDINAL) : status ;
VAR
   i, n  : CARDINAL ;
   lt, rt: CARDINAL ;
BEGIN
   Assert (IsProcType (right)) ;
   Assert (IsProcType (left)) ;
   IF isFalse (result)
   THEN
      RETURN result
   ELSE
      lt := GetDType (left) ;
      rt := GetDType (right) ;
      IF (lt = NulSym) AND (rt = NulSym)
      THEN
         result := unknown
      ELSIF lt = NulSym
      THEN
         IF tinfo^.format # NIL
         THEN
            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)
         END ;
         RETURN return (false, tinfo, left, right)
      ELSIF rt = NulSym
      THEN
         IF tinfo^.format # NIL
         THEN
            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)
         END ;
         RETURN return (false, tinfo, left, right)
      ELSE
         (* two return type seen so we check them.  *)
         result := checkPair (unknown, tinfo, lt, rt)
      END ;

      IF NoOfParam (left) # NoOfParam (right)
      THEN
         IF tinfo^.format # NIL
         THEN
            MetaErrorStringT2 (tinfo^.token, InitString ("procedure type {%1a} has a different number of parameters from procedure type {%2ad}"), right, left)
         END ;
         RETURN return (false, tinfo, left, right)
      END ;
      i := 1 ;
      n := NoOfParam (left) ;
      WHILE i <= n DO
         IF IsVarParam (left, i) # IsVarParam (right, i)
         THEN
            IF IsVarParam (left, i)
            THEN
               IF tinfo^.format # NIL
               THEN
                  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)
               END
            ELSE
               IF tinfo^.format # NIL
               THEN
                  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)
               END
            END ;
            RETURN return (false, tinfo, left, right)
         END ;
         result := checkPair (result, tinfo, GetDType (GetNthParam (left, i)), GetDType (GetNthParam (right, i))) ;
         INC (i)
      END
   END ;
   RETURN return (result, tinfo, left, right)
END checkProcType ;


(*
   checkProcedureProcType -
*)

PROCEDURE checkProcedureProcType (result: status; tinfo: tInfo;
                                  left, right: CARDINAL) : status ;
VAR
   i, n  : CARDINAL ;
   lt, rt: CARDINAL ;
BEGIN
   Assert (IsProcedure (right)) ;
   Assert (IsProcType (left)) ;
   IF NOT isFalse (result)
   THEN
      lt := GetDType (left) ;
      rt := GetDType (right) ;
      IF (lt = NulSym) AND (rt = NulSym)
      THEN
         (* nothing.  *)
      ELSIF lt = NulSym
      THEN
         IF tinfo^.format # NIL
         THEN
            MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%1a} does not have a {%kRETURN} type whereas procedure {%2ad} has a {%kRETURN} type {%3ad}"), left, right, rt)
         END ;
         RETURN return (false, tinfo, left, right)
      ELSIF rt = NulSym
      THEN
         IF tinfo^.format # NIL
         THEN
            MetaErrorStringT3 (tinfo^.token, InitString ("procedure {%1a} does not have a {%kRETURN} type whereas procedure type {%2ad} has a {%kRETURN} type {%3ad}"), right, left, lt)
         END ;
         RETURN return (false, tinfo, left, right)
      ELSE
         (* two return type seen so we check them.  *)
         result := checkPair (result, tinfo, lt, rt)
      END ;

      IF NoOfParam (left) # NoOfParam (right)
      THEN
         IF tinfo^.format # NIL
         THEN
            MetaErrorStringT2 (tinfo^.token, InitString ("procedure {%1a} has a different number of parameters from procedure type {%2ad}"), right, left)
         END ;
         RETURN return (false, tinfo, left, right)
      END ;
      i := 1 ;
      n := NoOfParam (left) ;
      WHILE i <= n DO
         IF IsVarParam (left, i) # IsVarParam (right, i)
         THEN
            IF IsVarParam (left, i)
            THEN
               IF tinfo^.format # NIL
               THEN
                  MetaErrorStringT3 (tinfo^.token, InitString ("procedure type {%2a} {%3n} parameter was declared as a {%kVAR} whereas procedure {%1ad} {%3n} parameter was not"), right, left, i)
               END
            ELSE
               IF tinfo^.format # NIL
               THEN
                  MetaErrorStringT3 (tinfo^.token, InitString ("procedure {%1a} {%3n} parameter was declared as a {%kVAR} whereas procedure type {%2ad} {%3n} parameter was not"), right, left, i)
               END
            END ;
            RETURN return (false, tinfo, left, right)
         END ;
         result := checkPair (result, tinfo, GetDType (GetNthParam (left, i)), GetDType (GetNthParam (right, i))) ;
         INC (i)
      END
   END ;
   RETURN return (result, tinfo, left, right)
END checkProcedureProcType ;


(*
   checkProcedure -
*)

PROCEDURE checkProcedure (result: status; tinfo: tInfo;
                          left, right: CARDINAL) : status ;
BEGIN
   Assert (IsProcedure (right)) ;
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF IsVar (left)
   THEN
      RETURN checkProcedure (result, tinfo,
                             GetDType (left), right)
   ELSIF left = Address
   THEN
      RETURN true
   ELSIF IsProcType (left)
   THEN
      RETURN checkProcedureProcType (result, tinfo, left, right)
   ELSE
      RETURN result
   END
END checkProcedure ;


(*
   checkEnumerationEquivalence -
*)

PROCEDURE checkEnumerationEquivalence (result: status;
                                       left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF left = right
   THEN
      RETURN true
   ELSE
      RETURN false
   END
END checkEnumerationEquivalence ;


(*
   checkPointerType - check whether left and right are equal or are of type ADDRESS.
*)

PROCEDURE checkPointerType (result: status; left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF (left = right) OR (left = Address) OR (right = Address)
   THEN
      RETURN true
   ELSE
      RETURN false
   END
END checkPointerType ;


(*
   checkTypeKindEquivalence -
*)

PROCEDURE checkTypeKindEquivalence (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
      (* long cascade of all type kinds.  *)
      IF IsSet (left) AND IsSet (right)
      THEN
         RETURN checkSetEquivalent (result, tinfo, left, right)
      ELSIF IsArray (left) AND IsArray (right)
      THEN
         RETURN checkArrayTypeEquivalence (result, tinfo, left, right)
      ELSIF IsRecord (left) AND IsRecord (right)
      THEN
         RETURN checkRecordEquivalence (result, left, right)
      ELSIF IsEnumeration (left) AND IsEnumeration (right)
      THEN
         RETURN checkEnumerationEquivalence (result, left, right)
      ELSIF IsProcedure (left) AND IsProcType (right)
      THEN
         RETURN checkProcedure (result, tinfo, right, left)
      ELSIF IsProcType (left) AND IsProcedure (right)
      THEN
         RETURN checkProcedure (result, tinfo, left, right)
      ELSIF IsProcType (left) OR IsProcType (right)
      THEN
         RETURN checkProcType (result, tinfo, left, right)
      ELSIF IsReallyPointer (left) AND IsReallyPointer (right)
      THEN
         RETURN checkPointerType (result, left, right)
      ELSE
         RETURN result
      END
   END
END checkTypeKindEquivalence ;


(*
   isSkipEquivalence -
*)

PROCEDURE isSkipEquivalence (left, right: CARDINAL) : BOOLEAN ;
BEGIN
   RETURN SkipType (left) = SkipType (right)
END isSkipEquivalence ;


(*
   checkValueEquivalence - check to see if left and right values are the same.
*)

PROCEDURE checkValueEquivalence (result: status; left, right: CARDINAL) : status ;
BEGIN
   IF isKnown (result)
   THEN
      RETURN result
   ELSIF left = right
   THEN
      RETURN true
   ELSE
      IF AreConstantsEqual (Mod2Gcc (left), Mod2Gcc (right))
      THEN
         RETURN true
      ELSE
         RETURN false
      END
   END
END checkValueEquivalence ;


(*
   and -
*)

PROCEDURE and (left, right: status) : status ;
BEGIN
   IF (left = true) AND (right = true)
   THEN
      RETURN true
   ELSE
      RETURN false
   END
END and ;


(*
   checkTypeRangeEquivalence -
*)

PROCEDURE checkTypeRangeEquivalence (result: status; tinfo: tInfo;
                                     left, right: CARDINAL) : status ;
VAR
   result2, result3: status ;
BEGIN
   result := checkSkipEquivalence (result, left, right) ;
   result2 := checkValueEquivalence (result, GetTypeMin (left), GetTypeMin (right)) ;
   result3 := checkValueEquivalence (result, GetTypeMax (left), GetTypeMax (right)) ;
   RETURN return (and (result2, result3), tinfo, left, right)
END checkTypeRangeEquivalence ;


(*
   include - include pair left:right into pairs with status, s.
*)

PROCEDURE include (pairs: Index; left, right: CARDINAL; s: status) ;
VAR
   p: pair ;
BEGIN
   p := newPair () ;
   p^.left := left ;
   p^.right := right ;
   p^.pairStatus := s ;
   p^.next := NIL ;
   IncludeIndiceIntoIndex (pairs, p)
END include ;


(*
   exclude - exclude pair left:right from pairs.
*)

PROCEDURE exclude (pairs: Index; left, right: CARDINAL) ;
VAR
   p   : pair ;
   i, n: CARDINAL ;
BEGIN
   i := 1 ;
   n := HighIndice (pairs) ;
   WHILE i <= n DO
      p := GetIndice (pairs, i) ;
      IF (p # NIL) AND (p^.left = left) AND (p^.right = right)
      THEN
         PutIndice (pairs, i, NIL) ;
         disposePair (p) ;
         RETURN
      END ;
      INC (i)
   END
END exclude ;


(*
   getStatus -
*)

PROCEDURE getStatus (pairs: Index; left, right: CARDINAL) : status ;
VAR
   p   : pair ;
   i, n: CARDINAL ;
BEGIN
   i := 1 ;
   n := HighIndice (pairs) ;
   WHILE i <= n DO
      p := GetIndice (pairs, i) ;
      IF (p # NIL) AND (p^.left = left) AND (p^.right = right)
      THEN
         RETURN p^.pairStatus
      END ;
      INC (i)
   END ;
   RETURN unknown
END getStatus ;


(*
   return -
*)

PROCEDURE return (result: status; tinfo: tInfo; left, right: CARDINAL) : status ;
BEGIN
   IF result # unknown
   THEN
      IF isKnown (result)
      THEN
         include (tinfo^.resolved, left, right, result) ;
         exclude (tinfo^.unresolved, left, right) ;
         exclude (tinfo^.visited, left, right)   (* no longer visiting as it is resolved.  *)
      END
   END ;
   IF result = false
   THEN
      RETURN issueError (FALSE, tinfo, left, right)
   END ;
   RETURN result
END return ;


(*
   checkSkipEquivalence - return true if left right are equivalent.
*)

PROCEDURE checkSkipEquivalence (result: status; left, right: CARDINAL) : status ;
BEGIN
   IF isKnown (result)
   THEN
      RETURN result
   ELSIF isSkipEquivalence (left, right)
   THEN
      RETURN true
   ELSE
      RETURN result
   END
END checkSkipEquivalence ;


(*
   checkSetEquivalent - compares set types, left and right.
*)

PROCEDURE checkSetEquivalent (result: status; tinfo: tInfo;
                              left, right: CARDINAL) : status ;
BEGIN
   result := checkSkipEquivalence (result, left, right) ;
   result := checkTypeKindEquivalence (result, tinfo, GetDType (left), GetDType (right)) ;
   result := checkTypeRangeEquivalence (result, tinfo, GetDType (left), GetDType (right)) ;
   RETURN return (result, tinfo, left, right)
END checkSetEquivalent ;


(*
   checkRecordEquivalence - compares record types, left and right.
*)

PROCEDURE checkRecordEquivalence (result: status; left, right: CARDINAL) : status ;
BEGIN
   IF isFalse (result)
   THEN
      RETURN result
   ELSIF left = right
   THEN
      RETURN true
   ELSE
      RETURN false
   END
END checkRecordEquivalence ;


(*
   getType - only returns the type of symbol providing it is not a procedure.
*)

PROCEDURE getType (sym: CARDINAL) : CARDINAL ;
BEGIN
   IF IsTyped (sym)
   THEN
      RETURN GetDType (sym)
   ELSE
      RETURN sym
   END
END getType ;


(*
   determineCompatible - check for compatibility by checking
                         equivalence, array, generic and type kind.
*)

PROCEDURE determineCompatible (result: status; tinfo: tInfo; left, right: CARDINAL) : status ;
BEGIN
   result := checkPair (result, tinfo, left, right) ;
   RETURN return (result, tinfo, left, right)
END determineCompatible ;


(*
   get -
*)

PROCEDURE get (pairs: Index; VAR left, right: CARDINAL; s: status) : BOOLEAN ;
VAR
   i, n: CARDINAL ;
   p   : pair ;
BEGIN
   i := 1 ;
   n := HighIndice (pairs) ;
   WHILE i <= n DO
      p := GetIndice (pairs, i) ;
      IF (p # NIL) AND (p^.pairStatus = s)
      THEN
         left := p^.left ;
         right := p^.right ;
         RETURN TRUE
      END ;
      INC (i)
   END ;
   RETURN FALSE
END get ;


(*
   doCheck - keep obtaining an unresolved pair and check for the
             type compatibility.  This is the main check routine used by
             parameter, assignment and expression compatibility.
             It tests all unknown pairs and calls the appropriate
             check function
*)

PROCEDURE doCheck (tinfo: tInfo) : BOOLEAN ;
VAR
   result     : status ;
   left, right: CARDINAL ;
BEGIN
   WHILE get (tinfo^.unresolved, left, right, unknown) DO
      IF debugging
      THEN
         printf ("doCheck (%d, %d)\n", left, right)
      END ;
      (*
      IF in (tinfo^.visited, left, right)
      THEN
         IF debugging
         THEN
            printf ("   already visited (%d, %d)\n", left, right)
         END ;
      ELSE
         IF debugging
         THEN
            printf ("   not visited (%d, %d)\n", left, right)
         END ;
      *)
      result := tinfo^.checkFunc (unknown, tinfo, left, right) ;
      IF isKnown (result)
      THEN
         (* remove this pair from the unresolved list.  *)
         exclude (tinfo^.unresolved, left, right) ;
         (* add it to the resolved list.  *)
         include (tinfo^.resolved, left, right, result) ;
         IF result = false
         THEN
            IF debugging
            THEN
               printf ("   known (%d, %d)  false\n", left, right)
            END ;
            RETURN FALSE
         ELSE
            IF debugging
            THEN
               printf ("   known (%d, %d)  true\n", left, right)
            END
         END
      END
   END ;
   RETURN TRUE
END doCheck ;


(*
   in - returns TRUE if the pair is in the list.
*)

PROCEDURE in (pairs: Index; left, right: CARDINAL) : BOOLEAN ;
VAR
   i, n: CARDINAL ;
   p   : pair ;
BEGIN
   i := 1 ;
   n := HighIndice (pairs) ;
   WHILE i <= n DO
      p := GetIndice (pairs, i) ;
      IF (p # NIL) AND (p^.left = left) AND (p^.right = right)
      THEN
         RETURN TRUE
      END ;
      INC (i)
   END ;
   RETURN FALSE
END in ;


(*
   newPair -
*)

PROCEDURE newPair () : pair ;
VAR
   p: pair ;
BEGIN
   IF pairFreeList = NIL
   THEN
      NEW (p)
   ELSE
      p := pairFreeList ;
      pairFreeList := p^.next
   END ;
   Assert (p # NIL) ;
   RETURN p
END newPair ;


(*
   disposePair - adds pair, p, to the free list.
*)

PROCEDURE disposePair (p: pair) ;
BEGIN
   p^.next := pairFreeList ;
   pairFreeList := p
END disposePair ;


(*
   deconstructIndex -
*)

PROCEDURE deconstructIndex (pairs: Index) : Index ;
VAR
   p   : pair ;
   i, n: CARDINAL ;
BEGIN
   i := 1 ;
   n := HighIndice (pairs) ;
   WHILE i <= n DO
      p := GetIndice (pairs, i) ;
      IF p # NIL
      THEN
         disposePair (p)
      END ;
      INC (i)
   END ;
   RETURN KillIndex (pairs)
END deconstructIndex ;


(*
   deconstruct - deallocate the List data structure.
*)

PROCEDURE deconstruct (tinfo: tInfo) ;
BEGIN
   tinfo^.format := KillString (tinfo^.format) ;
   tinfo^.visited := deconstructIndex (tinfo^.visited) ;
   tinfo^.resolved := deconstructIndex (tinfo^.resolved) ;
   tinfo^.unresolved := deconstructIndex (tinfo^.unresolved)
END deconstruct ;


(*
   newtInfo -
*)

PROCEDURE newtInfo () : tInfo ;
VAR
   tinfo: tInfo ;
BEGIN
   IF tinfoFreeList = NIL
   THEN
      NEW (tinfo)
   ELSE
      tinfo := tinfoFreeList ;
      tinfoFreeList := tinfoFreeList^.next
   END ;
   RETURN tinfo
END newtInfo ;


(*
   collapseString - if the string, a, is "" then return NIL otherwise create
                    and return a dynamic string.
*)

PROCEDURE collapseString (a: ARRAY OF CHAR) : String ;
BEGIN
   IF StrEqual (a, "")
   THEN
      RETURN NIL
   ELSE
      RETURN InitString (a)
   END
END collapseString ;


(*
   AssignmentTypeCompatible - returns TRUE if the des and the expr are assignment compatible.
*)

PROCEDURE AssignmentTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
                                    des, expr: CARDINAL) : BOOLEAN ;
VAR
   tinfo: tInfo ;
BEGIN
   tinfo := newtInfo () ;
   tinfo^.format := collapseString (format) ;
   tinfo^.token := token ;
   tinfo^.kind := assignment ;
   tinfo^.actual := NulSym ;
   tinfo^.formal := NulSym ;
   tinfo^.procedure := NulSym ;
   tinfo^.nth := 0 ;
   tinfo^.isvar := FALSE ;
   tinfo^.error := NIL ;
   tinfo^.left := des ;
   tinfo^.right := expr ;
   tinfo^.checkFunc := determineCompatible ;
   tinfo^.visited := InitIndex (1) ;
   tinfo^.resolved := InitIndex (1) ;
   tinfo^.unresolved := InitIndex (1) ;
   include (tinfo^.unresolved, des, expr, unknown) ;
   tinfo^.strict := FALSE ;
   tinfo^.isin := FALSE ;
   IF doCheck (tinfo)
   THEN
      deconstruct (tinfo) ;
      RETURN TRUE
   ELSE
      deconstruct (tinfo) ;
      RETURN FALSE
   END
END AssignmentTypeCompatible ;


(*
   ParameterTypeCompatible - returns TRUE if the nth procedure parameter formal
                             is compatible with actual.
*)

PROCEDURE ParameterTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
                                   procedure, formal, actual, nth: CARDINAL;
                                   isvar: BOOLEAN) : BOOLEAN ;
VAR
   formalT, actualT: CARDINAL ;
   tinfo           : tInfo ;
BEGIN
   tinfo := newtInfo () ;
   formalT := GetSType (formal) ;
   actualT := GetSType (actual) ;
   tinfo^.format := collapseString (format) ;
   tinfo^.token := token ;
   tinfo^.kind := parameter ;
   tinfo^.actual := actual ;
   tinfo^.formal := formal ;
   tinfo^.procedure := procedure ;
   tinfo^.nth := nth ;
   tinfo^.isvar := isvar ;
   tinfo^.error := NIL ;
   tinfo^.left := formalT ;
   tinfo^.right := actualT ;
   tinfo^.checkFunc := determineCompatible ;
   tinfo^.visited := InitIndex (1) ;
   tinfo^.resolved := InitIndex (1) ;
   tinfo^.unresolved := InitIndex (1) ;
   tinfo^.strict := FALSE ;
   tinfo^.isin := FALSE ;
   include (tinfo^.unresolved, actual, formal, unknown) ;
   IF doCheck (tinfo)
   THEN
      deconstruct (tinfo) ;
      RETURN TRUE
   ELSE
      deconstruct (tinfo) ;
      RETURN FALSE
   END
END ParameterTypeCompatible ;


(*
   doExpressionTypeCompatible -
*)

PROCEDURE doExpressionTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
                                      left, right: CARDINAL;
                                      strict: BOOLEAN) : BOOLEAN ;
VAR
   tinfo: tInfo ;
BEGIN
   tinfo := newtInfo () ;
   tinfo^.format := collapseString (format) ;
   tinfo^.token := token ;
   tinfo^.kind := expression ;
   tinfo^.actual := NulSym ;
   tinfo^.formal := NulSym ;
   tinfo^.procedure := NulSym ;
   tinfo^.nth := 0 ;
   tinfo^.isvar := FALSE ;
   tinfo^.error := NIL ;
   tinfo^.left := left ;
   tinfo^.right := right ;
   tinfo^.checkFunc := determineCompatible ;
   tinfo^.visited := InitIndex (1) ;
   tinfo^.resolved := InitIndex (1) ;
   tinfo^.unresolved := InitIndex (1) ;
   tinfo^.strict := strict ;
   tinfo^.isin := FALSE ;
   include (tinfo^.unresolved, left, right, unknown) ;
   IF doCheck (tinfo)
   THEN
      deconstruct (tinfo) ;
      RETURN TRUE
   ELSE
      deconstruct (tinfo) ;
      RETURN FALSE
   END
END doExpressionTypeCompatible ;


(*
   ExpressionTypeCompatible - returns TRUE if the expressions, left and right,
                              are expression compatible.
*)

PROCEDURE ExpressionTypeCompatible (token: CARDINAL; format: ARRAY OF CHAR;
                                    left, right: CARDINAL;
                                    strict, isin: BOOLEAN) : BOOLEAN ;
BEGIN
   IF (left#NulSym) AND (right#NulSym)
   THEN
      IF isin
      THEN
         IF IsConst (right) OR IsVar (right)
         THEN
            right := GetSType (right)
         END ;
         IF IsSet (right)
         THEN
            right := GetSType (right)
         END
      END
   END ;
   RETURN doExpressionTypeCompatible (token, format, left, right, strict)
END ExpressionTypeCompatible ;


(*
   init - initialise all global data structures for this module.
*)

PROCEDURE init ;
BEGIN
   pairFreeList  := NIL ;
   tinfoFreeList := NIL ;
   errors        := InitIndex (1)
END init ;


BEGIN
   init
END M2Check.