(* decl.mod declaration nodes used to create the AST.

Copyright (C) 2015-2024 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius@glam.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 decl ; (*!m2pim*)

FROM ASCII IMPORT lf, tab ;
FROM symbolKey IMPORT NulKey, symbolTree, initTree, getSymKey, putSymKey, foreachNodeDo ;
FROM mcDebug IMPORT assert ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM nameKey IMPORT NulName, makeKey, lengthKey, makekey, keyToCharStar ;
FROM SFIO IMPORT OpenToWrite, WriteS ;
FROM FIO IMPORT File, Close, FlushBuffer, StdOut, WriteLine, WriteChar ;
FROM DynamicStrings IMPORT String, InitString, EqualArray, InitStringCharStar, KillString, ConCat, Mark, RemoveWhitePostfix, RemoveWhitePrefix ;
FROM StringConvert IMPORT CardinalToString, ostoc ;

FROM mcOptions IMPORT getOutputFile, getDebugTopological, getHPrefix, getIgnoreFQ,
                      getExtendedOpaque, writeGPLheader, getGccConfigSystem,
                      getScaffoldDynamic, getScaffoldMain, getSuppressNoReturn,
                      useBool, getCRealType, getCShortRealType,
                      getCLongRealType ;

FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ;
FROM libc IMPORT printf, memset ;
FROM mcMetaError IMPORT metaError1, metaError2, metaError3, metaErrors1, metaErrors2 ;
FROM mcError IMPORT errorAbort0, flushErrors ;

FROM mcLexBuf IMPORT findFileNameFromToken, tokenToLineNo, tokenToColumnNo,
                     getProcedureComment, getBodyComment, getAfterComment,
		     lastcomment ;

FROM mcComment IMPORT commentDesc, isProcedureComment, isAfterComment, isBodyComment, getContent, initComment, addText ;

FROM StrLib IMPORT StrEqual, StrLen ;

FROM mcPretty IMPORT pretty, initPretty, dupPretty, killPretty, print, prints, raw,
                     setNeedSpace, noSpace, setindent, getindent, getcurpos,
		     getseekpos, getcurline,
		     pushPretty, popPretty ;

FROM Indexing IMPORT Index, InitIndex, ForeachIndiceInIndexDo,
                     IncludeIndiceIntoIndex, IsIndiceInIndex,
		     HighIndice, LowIndice, GetIndice, RemoveIndiceFromIndex,
		     PutIndice, InBounds ;

IMPORT DynamicStrings ;
IMPORT alists, wlists ;
IMPORT keyc ;
IMPORT mcStream ;

FROM alists IMPORT alist ;
FROM wlists IMPORT wlist ;


CONST
   indentation     = 3 ;
   indentationC    = 2 ;
   debugScopes     = FALSE ;
   debugDecl       = FALSE ;
   caseException   = TRUE ;
   returnException = TRUE ;
   (* this is a work around to avoid ever having to handle dangling else.  *)
   forceCompoundStatement = TRUE ;    (* TRUE will avoid dangling else, by always using {}.  *)
   enableDefForCStrings   = FALSE ;   (* currently disabled.  *)
   enableMemsetOnAllocation = TRUE ;  (* Should we memset (..., 0, ...) the allocated mem?  *)
   forceQualified  = TRUE ;

TYPE
   language = (ansiC, ansiCP, pim4) ;

   nodeT = (explist, funccall,
            exit, return, stmtseq, comment, halt,
            new, dispose, inc, dec, incl, excl,
	    length,
            (* base constants.  *)
	    nil, true, false,
            (* system types.  *)
   	    address, loc, byte, word,
            csizet, cssizet,
            (* base types.  *)
	    char,
	    cardinal, longcard, shortcard,
            integer, longint, shortint,
	    real, longreal, shortreal,
	    bitset, boolean, proc,
	    ztype, rtype,
	    complex, longcomplex, shortcomplex,
	    (* language features and compound type attributes.  *)
            type, record, varient, var, enumeration,
            subrange, array, subscript,
            string, const, literal, varparam, param, varargs, optarg,
	    pointer, recordfield, varientfield, enumerationfield,
            set, proctype,
	    (* blocks.  *)
	    procedure, def, imp, module,
	    (* statements.  *)
            loop, while, for, repeat,
	    case, caselabellist, caselist, range,
	    assignment,
	    if, elsif,
	    (* expressions.  *)
	    constexp,
	    neg,
	    cast, val,
	    plus, sub, div, mod, mult, divide, in,
	    adr, size, tsize, ord, float, trunc, chr, abs, cap,
	    high, throw, unreachable,
	    cmplx, re, im,
	    min, max,
            componentref, pointerref, arrayref, deref,
	    equal, notequal, less, greater, greequal, lessequal,
	    lsl, lsr, lor, land, lnot, lxor,
	    and, or, not, identlist, vardecl, setvalue) ;

    node = POINTER TO nodeRec ;

    nodeRec =         RECORD
                         CASE kind: nodeT OF

                         unreachable,
			 throw,
                         new,
                         dispose,
                         inc,
                         dec,
                         incl,
                         excl,
                         halt            : intrinsicF: intrinsicT |
			 explist         : explistF: explistT |
                         exit            : exitF   : exitT |
			 return          : returnF : returnT |
			 stmtseq         : stmtF   : stmtT |
			 comment         : commentF: commentT |
                         (* base constants.  *)
                         nil,
			 true,
			 false,
			 (* system types.  *)
                         address,
			 loc,
                         byte,
			 word,
                         csizet,
                         cssizet         : |
                         (* base types.  *)
			 boolean,
 			 proc,
                         char,
                         integer,
                         cardinal,
                         longcard,
                         shortcard,
                         longint,
                         shortint,
                         real,
                         longreal,
			 shortreal,
                         bitset,
                         ztype,
                         rtype,
			 complex,
			 longcomplex,
			 shortcomplex    :  |
                         (* language features and compound type attributes.  *)
                         type            :  typeF            : typeT |
                         record          :  recordF          : recordT |
                         varient         :  varientF         : varientT |
                         var             :  varF             : varT |
                         enumeration     :  enumerationF     : enumerationT |
                         subrange        :  subrangeF        : subrangeT |
                         subscript       :  subscriptF       : subscriptT |
                         array           :  arrayF           : arrayT |
                         string          :  stringF          : stringT |
                         const           :  constF           : constT |
                         literal         :  literalF         : literalT |
			 varparam        :  varparamF        : varparamT |
                         param           :  paramF           : paramT |
			 varargs         :  varargsF         : varargsT |
			 optarg          :  optargF          : optargT |
			 pointer         :  pointerF         : pointerT |
                         recordfield     :  recordfieldF     : recordfieldT |
			 varientfield    :  varientfieldF    : varientfieldT |
			 enumerationfield:  enumerationfieldF: enumerationfieldT |
                         set             :  setF             : setT |
			 proctype        :  proctypeF        : proctypeT |
                         (* blocks.  *)
                         procedure       :  procedureF       : procedureT |
                         def             :  defF             : defT |
			 imp             :  impF             : impT |
			 module          :  moduleF          : moduleT |
                         (* statements.  *)
                         loop            :  loopF            : loopT |
                         while           :  whileF           : whileT |
                         for             :  forF             : forT |
                         repeat          :  repeatF          : repeatT |
			 case            :  caseF            : caseT |
                         caselabellist   :  caselabellistF   : caselabellistT |
			 caselist        :  caselistF        : caselistT |
			 range           :  rangeF           : rangeT |
                         if              :  ifF              : ifT |
                         elsif           :  elsifF           : elsifT |
			 assignment      :  assignmentF      : assignmentT |
                         (* expressions.  *)
 			 arrayref        :  arrayrefF        : arrayrefT |
                         pointerref      :  pointerrefF      : pointerrefT |
                         componentref    :  componentrefF    : componentrefT |
			 cmplx,
			 and,
			 or,
                         equal,
                         notequal,
			 less,
			 greater,
			 greequal,
			 lessequal,
                         val,
                         cast,
                         plus,
                         sub,
                         div,
			 mod,
			 mult,
			 divide,
			 in              :  binaryF          : binaryT |
			 constexp,
			 deref,
			 abs,
			 chr,
			 cap,
                         high,
                         ord,
			 float,
			 trunc,
			 re,
			 im,
			 not,
			 neg,
                         adr,
                         size,
			 tsize,
			 min,
			 max             :  unaryF           : unaryT |
			 identlist       :  identlistF       : identlistT |
			 vardecl         :  vardeclF         : vardeclT |
                         funccall        :  funccallF        : funccallT |
			 setvalue        :  setvalueF        : setvalueT

                         END ;
                         at: where ;
                      END ;

       intrinsicT = RECORD
                       args            : node ;
                       noArgs          : CARDINAL ;
                       type            : node ;
                       intrinsicComment: commentPair ;
                       postUnreachable : BOOLEAN ;
                    END ;

       fixupInfo = RECORD
                      count: CARDINAL ;
                      info : Index ;
                   END ;

       explistT = RECORD
                     exp:  Index ;
                  END ;

       setvalueT = RECORD
                      type:  node ;
		      values:  Index ;
                   END ;

       identlistT = RECORD
                       names : wlist ;
		       cnamed: BOOLEAN ;
                    END ;

       funccallT = RECORD
                      function       : node ;
		      args           : node ;
		      type           : node ;
		      funccallComment: commentPair ;
                   END ;

       commentT = RECORD
                     content:  commentDesc ;
                  END ;

       stmtT = RECORD
                  statements:  Index ;
               END ;

       returnT = RECORD
                    exp          : node ;
                    scope        : node ;
		    returnComment: commentPair ;
                 END ;

       exitT = RECORD
                  loop:  node ;
               END ;

       vardeclT = RECORD
                     names:  wlist ;
		     type :  node ;
		     scope:  node ;
                  END ;

       typeT = RECORD
                  name      :  Name ;
		  type      :  node ;
		  scope     :  node ;
		  isHidden,
		  isInternal:  BOOLEAN ;
               END ;

       recordT = RECORD
		    localSymbols:  symbolTree ;
                    listOfSons  :  Index ;
		    scope       :  node ;
                 END ;

       varientT = RECORD
		     listOfSons:  Index ;
		     varient   :  node ;
		     tag       :  node ;
		     scope     :  node ;
                  END ;

       varT = RECORD
                 name          :  Name ;
		 type          :  node ;
		 decl          :  node ;
		 scope         :  node ;
		 isInitialised,
		 isParameter,
		 isVarParameter,
                 isUsed        :  BOOLEAN ;
                 cname         :  cnameT ;
              END ;

       enumerationT = RECORD
			 noOfElements: CARDINAL ;
                         localSymbols: symbolTree ;
			 listOfSons  : Index ;
                         low, high   : node ;
			 scope       : node ;
                      END ;

       subrangeT = RECORD
		      low,
		      high :  node ;
		      type :  node ;
		      scope:  node ;
                   END ;

       subscriptT = RECORD
                       type:  node ;
		       expr:  node ;
                    END ;

       arrayT = RECORD
		   subr       :  node ;
		   type,
		   scope      :  node ;
		   isUnbounded:  BOOLEAN ;
                END ;

       stringT = RECORD
                    name            :  Name ;
		    length          :  CARDINAL ;
		    isCharCompatible:  BOOLEAN ;
		    cstring         :  String ;
		    clength         :  CARDINAL ;
		    cchar           :  String ;
                 END ;

       literalT = RECORD
                     name :  Name ;
		     type :  node ;
                  END ;

       constT = RECORD
                   name :  Name ;
		   type :  node ;
                   value:  node ;
                   scope:  node ;
                END ;

       varparamT = RECORD
                      namelist   :  node ;
                      type       :  node ;
		      scope      :  node ;
                      isUnbounded:  BOOLEAN ;
                      isForC     :  BOOLEAN ;
                      isUsed     :  BOOLEAN ;
                   END ;

       paramT = RECORD
                   namelist   :  node ;
                   type       :  node ;
                   scope      :  node ;
                   isUnbounded:  BOOLEAN ;
                   isForC     :  BOOLEAN ;
                   isUsed     :  BOOLEAN ;
                END ;

       varargsT = RECORD
                     scope    :  node ;
                  END ;

       optargT = RECORD
                    namelist  :  node ;
		    type      :  node ;
		    scope     :  node ;
		    init      :  node ;
                 END ;

       pointerT = RECORD
                     type :  node ;
                     scope:  node ;
                  END ;

       recordfieldT = RECORD
                         name   :  Name ;
			 type   :  node ;
			 tag    :  BOOLEAN ;
			 parent :  node ;
			 varient:  node ;
			 scope  :  node ;
			 cname  :  cnameT ;
                      END ;

       varientfieldT = RECORD
                          name      :  Name ;
			  parent    :  node ;
			  varient   :  node ;
                          simple    :  BOOLEAN ;
			  listOfSons:  Index ;
			  scope     :  node ;
                       END ;

       enumerationfieldT = RECORD
                              name :  Name ;
                              type :  node ;
			      scope:  node ;
                              value:  CARDINAL ;
                              cname:  cnameT ;
                           END ;

       setT = RECORD
                 type :  node ;
                 scope:  node ;
              END ;

       componentrefT = RECORD
                          rec       :  node ;
                          field     :  node ;
                          resultType:  node ;
                       END ;

       pointerrefT = RECORD
                        ptr       :  node ;
                        field     :  node ;
                        resultType:  node ;
                     END ;

       arrayrefT = RECORD
                      array     :  node ;
                      index     :  node ;
                      resultType:  node ;
                   END ;

       commentPair = RECORD
			after,
                        body :  node ;
                     END ;

       assignmentT = RECORD
                        des,
                        expr         :  node ;
			assignComment: commentPair ;
                     END ;

       ifT = RECORD
                expr,
                elsif,      (* either else or elsif must be NIL.  *)
                then,
                else        :  node ;
		ifComment,
		elseComment,  (* used for else or elsif *)
		endComment  : commentPair ;
             END ;

       elsifT = RECORD
                   expr,
                   elsif,     (* either else or elsif must be NIL.  *)
                   then,
                   else       :  node ;
                   elseComment:  commentPair ;  (* used for else or elsif *)
                END ;

       loopT = RECORD
                  statements:  node ;
		  labelno   :  CARDINAL ;  (* 0 means no label.  *)
               END ;

       whileT = RECORD
                   expr,
                   statements:  node ;
                   doComment,
                   endComment:  commentPair ;
                END ;

       repeatT = RECORD
                    expr,
                    statements   :  node ;
                    repeatComment,
		    untilComment :  commentPair ;
                 END ;

       caseT = RECORD
                  expression   :  node ;
                  caseLabelList:  Index ;
		  else         :  node ;
               END ;

       caselabellistT = RECORD
                           caseList  :  node ;
			   statements:  node ;
                        END ;

       caselistT = RECORD
                      rangePairs:  Index ;
                   END ;

       rangeT = RECORD
                   lo,
                   hi:  node ;
                END ;

       forT = RECORD
                 des,
                 start,
		 end,
                 increment,
                 statements:  node ;
              END ;

       statementT = RECORD
                       sequence:  Index ;
                    END ;

       scopeT = RECORD
                   symbols   :  symbolTree ;
                   constants,
                   types,
		   procedures,
                   variables :  Index ;
                END ;

       procedureT = RECORD
                       name           :  Name ;
                       decls          :  scopeT ;
                       scope          :  node ;
                       parameters     :  Index ;
                       isForC,
		       built,
		       checking,
                       returnopt,
		       vararg,
		       noreturnused,
		       noreturn       :  BOOLEAN ;
		       paramcount     :  CARDINAL ;
                       optarg         :  node ;
		       returnType     :  node ;
                       beginStatements:  node ;
                       cname          :  cnameT ;
		       defComment,
		       modComment     :  commentDesc ;
                    END ;

       proctypeT = RECORD
                      parameters:  Index ;
                      returnopt,
                      vararg    :  BOOLEAN ;
                      optarg    :  node ;
		      scope     :  node ;
                      returnType:  node ;
                   END ;

       binaryT = RECORD
                    left,
		    right,
                    resultType:  node ;
                 END ;

       unaryT = RECORD
                   arg,
                   resultType:  node ;
                END ;

       moduleT = RECORD
                    name             :  Name ;
                    source           :  Name ;
                    importedModules  :  Index ;
                    constFixup,
                    enumFixup        :  fixupInfo ;
                    decls            :  scopeT ;
                    beginStatements,
                    finallyStatements:  node ;
                    enumsComplete,
		    constsComplete,
		    visited          :  BOOLEAN ;
                    com              :  commentPair ;
                 END ;

       defT = RECORD
                 name             :  Name ;
                 source           :  Name ;
		 hasHidden,
                 forC             :  BOOLEAN ;
                 exported,
                 importedModules  :  Index ;
                 constFixup,
                 enumFixup        :  fixupInfo ;
                 decls            :  scopeT ;
		 enumsComplete,
                 constsComplete,
                 visited          :  BOOLEAN ;
                 com              :  commentPair ;
              END ;

       impT = RECORD
                 name             :  Name ;
                 source           :  Name ;
                 importedModules  :  Index ;
                 constFixup,
                 enumFixup        :  fixupInfo ;
                 beginStatements,
                 finallyStatements:  node ;
		 definitionModule :  node ;
                 decls            :  scopeT ;
                 enumsComplete,
                 constsComplete,
                 visited          :  BOOLEAN ;
                 com              :  commentPair ;
              END ;

       where = RECORD
                  defDeclared,
                  modDeclared,
                  firstUsed  :  CARDINAL ;
               END ;

       outputStates = (text, punct, space) ;

       nodeProcedure = PROCEDURE (node) ;

       dependentState = (completed, blocked, partial, recursive) ;

       cnameT = RECORD
                   name :  Name ;
                   init :  BOOLEAN ;
                END ;

VAR
   outputFile    : File ;
   lang          : language ;
   bitsperunitN,
   bitsperwordN,
   bitspercharN,
   unitsperwordN,
   mainModule,
   currentModule,
   defModule,
   systemN,
   addressN,
   locN,
   byteN,
   wordN,
   csizetN,
   cssizetN,
   adrN,
   sizeN,
   tsizeN,
   newN,
   disposeN,
   lengthN,
   incN,
   decN,
   inclN,
   exclN,
   highN,
   m2rtsN,
   haltN,
   throwN,
   chrN,
   capN,
   absN,
   floatN,
   truncN,
   ordN,
   valN,
   minN,
   maxN,
   booleanN,
   procN,
   charN,
   integerN,
   cardinalN,
   longcardN,
   shortcardN,
   longintN,
   shortintN,
   bitsetN,
   bitnumN,
   ztypeN,
   rtypeN,
   complexN,
   longcomplexN,
   shortcomplexN,
   cmplxN,
   reN,
   imN,
   realN,
   longrealN,
   shortrealN,
   nilN,
   trueN,
   falseN        : node ;
   scopeStack,
   defUniverseI,
   modUniverseI  : Index ;
   modUniverse,
   defUniverse   : symbolTree ;
   baseSymbols   : symbolTree ;
   outputState   : outputStates ;
   doP           : pretty ;
   todoQ,
   partialQ,
   doneQ         : alist ;
   mustVisitScope,
   simplified    : BOOLEAN ;
   tempCount     : CARDINAL ;


(*
   newNode - create and return a new node of kind k.
*)

PROCEDURE newNode (k: nodeT) : node ;
VAR
   d: node ;
BEGIN
   NEW (d) ;
   IF enableMemsetOnAllocation
   THEN
      d := memset (d, 0, SIZE (d^))
   END ;
   IF d=NIL
   THEN
      HALT
   ELSE
      d^.kind := k ;
      d^.at.defDeclared := 0 ;
      d^.at.modDeclared := 0 ;
      d^.at.firstUsed := 0 ;
      RETURN d
   END
END newNode ;


(*
   disposeNode - dispose node, n.
*)

PROCEDURE disposeNode (VAR n: node) ;
BEGIN
   DISPOSE (n) ;
   n := NIL
END disposeNode ;


(*
   getDeclaredDef - returns the token number associated with the nodes declaration
                    in the definition module.
*)

PROCEDURE getDeclaredDef (n: node) : CARDINAL ;
BEGIN
   RETURN n^.at.defDeclared
END getDeclaredDef ;


(*
   getDeclaredMod - returns the token number associated with the nodes declaration
                    in the implementation or program module.
*)

PROCEDURE getDeclaredMod (n: node) : CARDINAL ;
BEGIN
   RETURN n^.at.modDeclared
END getDeclaredMod ;


(*
   getFirstUsed - returns the token number associated with the first use of
                  node, n.
*)

PROCEDURE getFirstUsed (n: node) : CARDINAL ;
BEGIN
   RETURN n^.at.firstUsed
END getFirstUsed ;


(*
   setVisited - set the visited flag on a def/imp/module node.
*)

PROCEDURE setVisited (n: node) ;
BEGIN
   CASE n^.kind OF

   def   :  n^.defF.visited := TRUE |
   imp   :  n^.impF.visited := TRUE |
   module:  n^.moduleF.visited := TRUE

   END
END setVisited ;


(*
   unsetVisited - unset the visited flag on a def/imp/module node.
*)

PROCEDURE unsetVisited (n: node) ;
BEGIN
   CASE n^.kind OF

   def   :  n^.defF.visited := FALSE |
   imp   :  n^.impF.visited := FALSE |
   module:  n^.moduleF.visited := FALSE

   END
END unsetVisited ;


(*
   isVisited - returns TRUE if the node was visited.
*)

PROCEDURE isVisited (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   def   :  RETURN n^.defF.visited |
   imp   :  RETURN n^.impF.visited |
   module:  RETURN n^.moduleF.visited

   END
END isVisited ;


(*
   isDef - return TRUE if node, n, is a definition module.
*)

PROCEDURE isDef (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = def
END isDef ;


(*
   isImp - return TRUE if node, n, is an implementation module.
*)

PROCEDURE isImp (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = imp
END isImp ;


(*
   isModule - return TRUE if node, n, is a program module.
*)

PROCEDURE isModule (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = module
END isModule ;


(*
   isImpOrModule - returns TRUE if, n, is a program module or implementation module.
*)

PROCEDURE isImpOrModule (n: node) : BOOLEAN ;
BEGIN
   RETURN isImp (n) OR isModule (n)
END isImpOrModule ;


(*
   isProcedure - returns TRUE if node, n, is a procedure.
*)

PROCEDURE isProcedure (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = procedure
END isProcedure ;


(*
   isConst - returns TRUE if node, n, is a const.
*)

PROCEDURE isConst (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = const
END isConst ;


(*
   isType - returns TRUE if node, n, is a type.
*)

PROCEDURE isType (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = type
END isType ;


(*
   isVar - returns TRUE if node, n, is a type.
*)

PROCEDURE isVar (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = var
END isVar ;


(*
   isTemporary - returns TRUE if node, n, is a variable and temporary.
*)

PROCEDURE isTemporary (n: node) : BOOLEAN ;
BEGIN
   RETURN FALSE
END isTemporary ;


(*
   isExported - returns TRUE if symbol, n, is exported from
                the definition module.
*)

PROCEDURE isExported (n: node) : BOOLEAN ;
VAR
   s: node ;
BEGIN
   s := getScope (n) ;
   IF s#NIL
   THEN
      CASE s^.kind OF

      def:  RETURN IsIndiceInIndex (s^.defF.exported, n)

      ELSE
         RETURN FALSE
      END
   END ;
   RETURN FALSE
END isExported ;


(*
   isLocal - returns TRUE if symbol, n, is locally declared in a procedure.
*)

PROCEDURE isLocal (n: node) : BOOLEAN ;
VAR
   s: node ;
BEGIN
   s := getScope (n) ;
   IF s#NIL
   THEN
      RETURN isProcedure (s)
   END ;
   RETURN FALSE
END isLocal ;


(*
   lookupExported - attempts to lookup a node named, i, from definition
                    module, n.  The node is returned if found.
                    NIL is returned if not found.
*)

PROCEDURE lookupExported (n: node; i: Name) : node ;
VAR
   r: node ;
BEGIN
   assert (isDef (n)) ;
   r := getSymKey (n^.defF.decls.symbols, i) ;
   IF (r#NIL) AND isExported (r)
   THEN
      RETURN r
   END ;
   RETURN NIL
END lookupExported ;


(*
   importEnumFields - if, n, is an enumeration type import the all fields into module, m.
*)

PROCEDURE importEnumFields (m, n: node) ;
VAR
   r, e: node ;
   i, h: CARDINAL ;
BEGIN
   assert (isDef (m) OR isModule (m) OR isImp (m)) ;
   n := skipType (n) ;
   IF (n#NIL) AND isEnumeration (n)
   THEN
      i := LowIndice (n^.enumerationF.listOfSons) ;
      h := HighIndice (n^.enumerationF.listOfSons) ;
      WHILE i<=h DO
         e := GetIndice (n^.enumerationF.listOfSons, i) ;
         r := import (m, e) ;
         IF e#r
         THEN
            metaError2 ('enumeration field {%1ad} cannot be imported implicitly into {%2d} due to a name clash',
                        e, m)
         END ;
         INC (i)
      END
   END
END importEnumFields ;


(*
   import - attempts to add node, n, into the scope of module, m.
            It might fail due to a name clash in which case the
            previous named symbol is returned.  On success, n,
            is returned.
*)

PROCEDURE import (m, n: node) : node ;
VAR
   name: Name ;
   r   : node ;
BEGIN
   assert (isDef (m) OR isModule (m) OR isImp (m)) ;
   name := getSymName (n) ;
   r := lookupInScope (m, name) ;
   IF r=NIL
   THEN
      CASE m^.kind OF

      def   :  putSymKey (m^.defF.decls.symbols, name, n) |
      imp   :  putSymKey (m^.impF.decls.symbols, name, n) |
      module:  putSymKey (m^.moduleF.decls.symbols, name, n)

      END ;
      importEnumFields (m, n) ;
      RETURN n
   END ;
   RETURN r
END import ;


(*
   isZtype - returns TRUE if, n, is the Z type.
*)

PROCEDURE isZtype (n: node) : BOOLEAN ;
BEGIN
   RETURN n = ztypeN
END isZtype ;


(*
   isRtype - returns TRUE if, n, is the R type.
*)

PROCEDURE isRtype (n: node) : BOOLEAN ;
BEGIN
   RETURN n = rtypeN
END isRtype ;


(*
   isComplex - returns TRUE if, n, is the complex type.
*)

PROCEDURE isComplex (n: node) : BOOLEAN ;
BEGIN
   RETURN n = complexN
END isComplex ;


(*
   isLongComplex - returns TRUE if, n, is the longcomplex type.
*)

PROCEDURE isLongComplex (n: node) : BOOLEAN ;
BEGIN
   RETURN n = longcomplexN
END isLongComplex ;


(*
   isShortComplex - returns TRUE if, n, is the shortcomplex type.
*)

PROCEDURE isShortComplex (n: node) : BOOLEAN ;
BEGIN
   RETURN n = shortcomplexN
END isShortComplex ;


(*
   isLiteral - returns TRUE if, n, is a literal.
*)

PROCEDURE isLiteral (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = literal
END isLiteral ;


(*
   isConstSet - returns TRUE if, n, is a constant set.
*)

PROCEDURE isConstSet (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   IF isLiteral (n) OR isConst (n)
   THEN
      RETURN isSet (skipType (getType (n)))
   END ;
   RETURN FALSE
END isConstSet ;


(*
   isEnumerationField - returns TRUE if, n, is an enumeration field.
*)

PROCEDURE isEnumerationField (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = enumerationfield
END isEnumerationField ;


(*
   isUnbounded - returns TRUE if, n, is an unbounded array.
*)

PROCEDURE isUnbounded (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN (n^.kind = array) AND (n^.arrayF.isUnbounded)
END isUnbounded ;


(*
   isParameter - returns TRUE if, n, is a parameter.
*)

PROCEDURE isParameter (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN (n^.kind = param) OR (n^.kind = varparam)
END isParameter ;


(*
   isVarParam - returns TRUE if, n, is a var parameter.
*)

PROCEDURE isVarParam (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = varparam
END isVarParam ;


(*
   isParam - returns TRUE if, n, is a non var parameter.
*)

PROCEDURE isParam (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = param
END isParam ;


(*
   isNonVarParam - is an alias to isParam.
*)

PROCEDURE isNonVarParam (n: node) : BOOLEAN ;
BEGIN
   RETURN isParam (n)
END isNonVarParam ;


(*
   isRecord - returns TRUE if, n, is a record.
*)

PROCEDURE isRecord (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = record
END isRecord ;


(*
   isRecordField - returns TRUE if, n, is a record field.
*)

PROCEDURE isRecordField (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = recordfield
END isRecordField ;


(*
   isArray - returns TRUE if, n, is an array.
*)

PROCEDURE isArray (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = array
END isArray ;


(*
   isProcType - returns TRUE if, n, is a procedure type.
*)

PROCEDURE isProcType (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = proctype
END isProcType ;


(*
   isAProcType - returns TRUE if, n, is a proctype or proc node.
*)

PROCEDURE isAProcType (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN isProcType (n) OR (n = procN)
END isAProcType ;


(*
   isProcedure - returns TRUE if, n, is a procedure.
*)

PROCEDURE isProcedure (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = procedure
END isProcedure ;


(*
   isPointer - returns TRUE if, n, is a pointer.
*)

PROCEDURE isPointer (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = pointer
END isPointer ;


(*
   isVarient - returns TRUE if, n, is a varient record.
*)

PROCEDURE isVarient (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = varient
END isVarient ;


(*
   isVarientField - returns TRUE if, n, is a varient field.
*)

PROCEDURE isVarientField (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = varientfield
END isVarientField ;


(*
   isSet - returns TRUE if, n, is a set type.
*)

PROCEDURE isSet (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = set
END isSet ;


(*
   isSubrange - returns TRUE if, n, is a subrange type.
*)

PROCEDURE isSubrange (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = subrange
END isSubrange ;


(*
   isMainModule - return TRUE if node, n, is the main module specified
                  by the source file.  This might be a definition,
                  implementation or program module.
*)

PROCEDURE isMainModule (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n = mainModule
END isMainModule ;


(*
   setMainModule - sets node, n, as the main module to be compiled.
*)

PROCEDURE setMainModule (n: node) ;
BEGIN
   assert (n#NIL) ;
   mainModule := n
END setMainModule ;


(*
   getMainModule - returns the main module node.
*)

PROCEDURE getMainModule () : node ;
BEGIN
   RETURN mainModule
END getMainModule ;


(*
   setCurrentModule - sets node, n, as the current module being compiled.
*)

PROCEDURE setCurrentModule (n: node) ;
BEGIN
   assert (n#NIL) ;
   currentModule := n
END setCurrentModule ;


(*
   getCurrentModule - returns the current module being compiled.
*)

PROCEDURE getCurrentModule () : node ;
BEGIN
   RETURN currentModule
END getCurrentModule ;


(*
   initFixupInfo - initialize the fixupInfo record.
*)

PROCEDURE initFixupInfo () : fixupInfo ;
VAR
   f: fixupInfo ;
BEGIN
   f.count := 0 ;
   f.info := InitIndex (1) ;
   RETURN f
END initFixupInfo ;


(*
   makeDef - returns a definition module node named, n.
*)

PROCEDURE makeDef (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := newNode (def) ;
   WITH d^ DO
      defF.name := n ;
      defF.source := NulName ;
      defF.hasHidden := FALSE ;
      defF.forC := FALSE ;
      defF.exported := InitIndex (1) ;
      defF.importedModules := InitIndex (1) ;
      defF.constFixup := initFixupInfo () ;
      defF.enumFixup := initFixupInfo () ;
      initDecls (defF.decls) ;
      defF.enumsComplete := FALSE ;
      defF.constsComplete := FALSE ;
      defF.visited := FALSE ;
      initPair (defF.com)
   END ;
   RETURN d
END makeDef ;


(*
   makeImp - returns an implementation module node named, n.
*)

PROCEDURE makeImp (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := newNode (imp) ;
   WITH d^ DO
      impF.name := n ;
      impF.source := NulName ;
      impF.importedModules := InitIndex (1) ;
      impF.constFixup := initFixupInfo () ;
      impF.enumFixup := initFixupInfo () ;
      initDecls (impF.decls) ;
      impF.beginStatements := NIL ;
      impF.finallyStatements := NIL ;
      impF.definitionModule := NIL ;
      impF.enumsComplete := FALSE ;
      impF.constsComplete := FALSE ;
      impF.visited := FALSE ;
      initPair (impF.com)
   END ;
   RETURN d
END makeImp ;


(*
   makeModule - returns a module node named, n.
*)

PROCEDURE makeModule (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := newNode (module) ;
   WITH d^ DO
      moduleF.name := n ;
      moduleF.source := NulName ;
      moduleF.importedModules := InitIndex (1) ;
      moduleF.constFixup := initFixupInfo () ;
      moduleF.enumFixup := initFixupInfo () ;
      initDecls (moduleF.decls) ;
      moduleF.beginStatements := NIL ;
      moduleF.finallyStatements := NIL ;
      moduleF.enumsComplete := FALSE ;
      moduleF.constsComplete := FALSE ;
      moduleF.visited := FALSE ;
      initPair (moduleF.com)
   END ;
   RETURN d
END makeModule ;


(*
   putDefForC - the definition module was defined FOR "C".
*)

PROCEDURE putDefForC (n: node) ;
BEGIN
   assert (isDef (n)) ;
   n^.defF.forC := TRUE
END putDefForC ;


(*
   isDefForC - returns TRUE if the definition module was defined FOR "C".
*)

PROCEDURE isDefForC (n: node) : BOOLEAN ;
BEGIN
   RETURN isDef (n) AND n^.defF.forC
END isDefForC ;


(*
   lookupDef - returns a definition module node named, n.
*)

PROCEDURE lookupDef (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := getSymKey (defUniverse, n) ;
   IF d=NIL
   THEN
      d := makeDef (n) ;
      putSymKey (defUniverse, n, d) ;
      IncludeIndiceIntoIndex (defUniverseI, d)
   END ;
   RETURN d
END lookupDef ;


(*
   lookupImp - returns an implementation module node named, n.
*)

PROCEDURE lookupImp (n: Name) : node ;
VAR
   m: node ;
BEGIN
   m := getSymKey (modUniverse, n) ;
   IF m=NIL
   THEN
      m := makeImp (n) ;
      putSymKey (modUniverse, n, m) ;
      IncludeIndiceIntoIndex (modUniverseI, m)
   END ;
   assert (NOT isModule (m)) ;
   RETURN m
END lookupImp ;


(*
   lookupModule - returns a module node named, n.
*)

PROCEDURE lookupModule (n: Name) : node ;
VAR
   m: node ;
BEGIN
   m := getSymKey (modUniverse, n) ;
   IF m=NIL
   THEN
      m := makeModule (n) ;
      putSymKey (modUniverse, n, m) ;
      IncludeIndiceIntoIndex (modUniverseI, m)
   END ;
   assert (NOT isImp (m)) ;
   RETURN m
END lookupModule ;


(*
   setSource - sets the source filename for module, n, to s.
*)

PROCEDURE setSource (n: node; s: Name) ;
BEGIN
   WITH n^ DO
      CASE kind OF

      def   :  defF.source := s |
      module:  moduleF.source := s |
      imp   :  impF.source := s

      END
   END
END setSource ;


(*
   getSource - returns the source filename for module, n.
*)

PROCEDURE getSource (n: node) : Name ;
BEGIN
   WITH n^ DO
      CASE kind OF

      def   :  RETURN defF.source |
      module:  RETURN moduleF.source |
      imp   :  RETURN impF.source

      END
   END
END getSource ;


(*
   initDecls - initialize the decls, scopeT.
*)

PROCEDURE initDecls (VAR decls: scopeT) ;
BEGIN
   decls.symbols := initTree () ;
   decls.constants := InitIndex (1) ;
   decls.types := InitIndex (1) ;
   decls.procedures := InitIndex (1) ;
   decls.variables := InitIndex (1)
END initDecls ;


(*
   enterScope - pushes symbol, n, to the scope stack.
*)

PROCEDURE enterScope (n: node) ;
BEGIN
   IF IsIndiceInIndex (scopeStack, n)
   THEN
      HALT
   ELSE
      IncludeIndiceIntoIndex (scopeStack, n)
   END ;
   IF debugScopes
   THEN
      printf ("enter scope\n") ;
      dumpScopes
   END
END enterScope ;


(*
   leaveScope - removes the top level scope.
*)

PROCEDURE leaveScope ;
VAR
   i: CARDINAL ;
   n: node ;
BEGIN
   i := HighIndice (scopeStack) ;
   n := GetIndice (scopeStack, i) ;
   RemoveIndiceFromIndex (scopeStack, n) ;
   IF debugScopes
   THEN
      printf ("leave scope\n") ;
      dumpScopes
   END
END leaveScope ;


(*
   getDeclScope - returns the node representing the
                  current declaration scope.
*)

PROCEDURE getDeclScope () : node ;
VAR
   i: CARDINAL ;
BEGIN
   i := HighIndice (scopeStack) ;
   RETURN GetIndice (scopeStack, i)
END getDeclScope ;


(*
   addTo - adds node, d, to scope decls and returns, d.
           It stores, d, in the symbols tree associated with decls.
*)

PROCEDURE addTo (VAR decls: scopeT; d: node) : node ;
VAR
   n: Name ;
BEGIN
   n := getSymName (d) ;
   IF n#NulName
   THEN
      IF getSymKey (decls.symbols, n)=NIL
      THEN
         putSymKey (decls.symbols, n, d)
      ELSE
         metaError1 ('{%1DMad} was declared', d) ;
         metaError1 ('{%1k} and is being declared again', n)
      END
   END ;
   IF isConst (d)
   THEN
      IncludeIndiceIntoIndex (decls.constants, d)
   ELSIF isVar (d)
   THEN
      IncludeIndiceIntoIndex (decls.variables, d)
   ELSIF isType (d)
   THEN
      IncludeIndiceIntoIndex (decls.types, d)
   ELSIF isProcedure (d)
   THEN
      IncludeIndiceIntoIndex (decls.procedures, d) ;
      IF debugDecl
      THEN
         printf ("%d procedures on the dynamic array\n",
                 HighIndice (decls.procedures))
      END
   END ;
   RETURN d
END addTo ;


(*
   export - export node, n, from definition module, d.
*)

PROCEDURE export (d, n: node) ;
BEGIN
   assert (isDef (d)) ;
   IncludeIndiceIntoIndex (d^.defF.exported, n)
END export ;


(*
   addToScope - adds node, n, to the current scope and returns, n.
*)

PROCEDURE addToScope (n: node) : node ;
VAR
   s: node ;
   i: CARDINAL ;
BEGIN
   i := HighIndice (scopeStack) ;
   s := GetIndice (scopeStack, i) ;
   IF isProcedure (s)
   THEN
      IF debugDecl
      THEN
         outText (doP, "adding ") ;
         doNameC (doP, n) ;
         outText (doP, " to procedure\n")
      END ;
      RETURN addTo (s^.procedureF.decls, n)
   ELSIF isModule (s)
   THEN
      IF debugDecl
      THEN
         outText (doP, "adding ") ;
         doNameC (doP, n) ;
         outText (doP, " to module\n")
      END ;
      RETURN addTo (s^.moduleF.decls, n)
   ELSIF isDef (s)
   THEN
      IF debugDecl
      THEN
         outText (doP, "adding ") ;
         doNameC (doP, n) ;
         outText (doP, " to definition module\n")
      END ;
      export (s, n) ;
      RETURN addTo (s^.defF.decls, n)
   ELSIF isImp (s)
   THEN
      IF debugDecl
      THEN
         outText (doP, "adding ") ;
         doNameC (doP, n) ;
         outText (doP, " to implementation module\n")
      END ;
      RETURN addTo (s^.impF.decls, n)
   END ;
   HALT
END addToScope ;


(*
   addModuleToScope - adds module, i, to module, m, scope.
*)

PROCEDURE addModuleToScope (m, i: node) ;
BEGIN
   assert (getDeclScope () = m) ;
   IF lookupSym (getSymName (i))=NIL
   THEN
      i := addToScope (i)
   END
END addModuleToScope ;


(*
   addImportedModule - add module, i, to be imported by, m.
                       If scoped then module, i, is added to the
                       module, m, scope.
*)

PROCEDURE addImportedModule (m, i: node; scoped: BOOLEAN) ;
BEGIN
   assert (isDef (i) OR isModule (i)) ;
   IF isDef (m)
   THEN
      IncludeIndiceIntoIndex (m^.defF.importedModules, i)
   ELSIF isImp (m)
   THEN
      IncludeIndiceIntoIndex (m^.impF.importedModules, i)
   ELSIF isModule (m)
   THEN
      IncludeIndiceIntoIndex (m^.moduleF.importedModules, i)
   ELSE
      HALT
   END ;
   IF scoped
   THEN
      addModuleToScope (m, i)
   END
END addImportedModule ;


(*
   completedEnum - assign boolean enumsComplete to TRUE if a definition,
                   implementation or module symbol.
*)

PROCEDURE completedEnum (n: node) ;
BEGIN
   assert (isDef (n) OR isImp (n) OR isModule (n)) ;
   IF isDef (n)
   THEN
      n^.defF.enumsComplete := TRUE
   ELSIF isImp (n)
   THEN
      n^.impF.enumsComplete := TRUE
   ELSIF isModule (n)
   THEN
      n^.moduleF.enumsComplete := TRUE
   END
END completedEnum ;


(*
   setUnary - sets a unary node to contain, arg, a, and type, t.
*)

PROCEDURE setUnary (u: node; k: nodeT; a, t: node) ;
BEGIN
   CASE k OF

   constexp,
   deref,
   chr,
   cap,
   abs,
   float,
   trunc,
   ord,
   high,
   throw,
   re,
   im,
   not,
   neg,
   adr,
   size,
   tsize,
   min,
   max     :  u^.kind := k ;
              u^.unaryF.arg := a ;
	      u^.unaryF.resultType := t

   END
END setUnary ;


(*
   makeConst - create, initialise and return a const node.
*)

PROCEDURE makeConst (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := newNode (const) ;
   WITH d^ DO
      constF.name := n ;
      constF.type := NIL ;
      constF.scope := getDeclScope () ;
      constF.value := NIL
   END ;
   RETURN addToScope (d)
END makeConst ;


(*
   makeType - create, initialise and return a type node.
*)

PROCEDURE makeType (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := newNode (type) ;
   WITH d^ DO
      typeF.name := n ;
      typeF.type := NIL ;
      typeF.scope := getDeclScope () ;
      typeF.isHidden := FALSE ;
      typeF.isInternal := FALSE
   END ;
   RETURN addToScope (d)
END makeType ;


(*
   makeTypeImp - lookup a type in the definition module
                 and return it.  Otherwise create a new type.
*)

PROCEDURE makeTypeImp (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := lookupSym (n) ;
   IF d#NIL
   THEN
      d^.typeF.isHidden := FALSE ;
      RETURN addToScope (d)
   ELSE
      d := newNode (type) ;
      WITH d^ DO
         typeF.name := n ;
         typeF.type := NIL ;
         typeF.scope := getDeclScope () ;
         typeF.isHidden := FALSE
      END ;
      RETURN addToScope (d)
   END
END makeTypeImp ;


(*
   makeVar - create, initialise and return a var node.
*)

PROCEDURE makeVar (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := newNode (var) ;
   WITH d^ DO
      varF.name := n ;
      varF.type := NIL ;
      varF.decl := NIL ;
      varF.scope := getDeclScope () ;
      varF.isInitialised := FALSE ;
      varF.isParameter := FALSE ;
      varF.isVarParameter := FALSE ;
      initCname (varF.cname)
   END ;
   RETURN addToScope (d)
END makeVar ;


(*
   putVar - places, type, as the type for var.
*)

PROCEDURE putVar (var, type, decl: node) ;
BEGIN
   assert (var#NIL) ;
   assert (isVar (var)) ;
   var^.varF.type := type ;
   var^.varF.decl := decl
END putVar ;


(*
   putVarBool - assigns the four booleans associated with a variable.
*)

PROCEDURE putVarBool (v: node; init, param, isvar, isused: BOOLEAN) ;
BEGIN
   assert (isVar (v)) ;
   v^.varF.isInitialised := init ;
   v^.varF.isParameter := param ;
   v^.varF.isVarParameter := isvar ;
   v^.varF.isUsed := isused
END putVarBool ;


(*
   checkPtr - in C++ we need to create a typedef for a pointer
              in case we need to use reinterpret_cast.
*)

PROCEDURE checkPtr (n: node) : node ;
VAR
   s: String ;
   p: node ;
BEGIN
   IF lang = ansiCP
   THEN
      IF isPointer (n)
      THEN
         s := tempName () ;
         p := makeType (makekey (DynamicStrings.string (s))) ;
         putType (p, n) ;
         s := KillString (s) ;
	 RETURN p
      END
   END ;
   RETURN n
END checkPtr ;


(*
   makeVarDecl - create a vardecl node and create a shadow variable in the
                 current scope.
*)

PROCEDURE makeVarDecl (i: node; type: node) : node ;
VAR
   d, v: node ;
   j, n: CARDINAL ;
BEGIN
   type := checkPtr (type) ;
   d := newNode (vardecl) ;
   WITH d^ DO
      vardeclF.names := i^.identlistF.names ;
      vardeclF.type := type ;
      vardeclF.scope := getDeclScope ()
   END ;
   n := wlists.noOfItemsInList (d^.vardeclF.names) ;
   j := 1 ;
   WHILE j<=n DO
      v := lookupSym (wlists.getItemFromList (d^.vardeclF.names, j)) ;
      assert (isVar (v)) ;
      putVar (v, type, d) ;
      INC (j)
   END ;
   RETURN d
END makeVarDecl ;


(*
   isVarDecl - returns TRUE if, n, is a vardecl node.
*)

PROCEDURE isVarDecl (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = vardecl
END isVarDecl ;


(*
   makeVariablesFromParameters - creates variables which are really parameters.
*)

PROCEDURE makeVariablesFromParameters (proc, id, type: node; isvar, isused: BOOLEAN) ;
VAR
   v   : node ;
   i, n: CARDINAL ;
   m   : Name ;
   s   : String ;
BEGIN
   assert (isProcedure (proc)) ;
   assert (isIdentList (id)) ;
   i := 1 ;
   n := wlists.noOfItemsInList (id^.identlistF.names) ;
   WHILE i<=n DO
      m := wlists.getItemFromList (id^.identlistF.names, i) ;
      v := makeVar (m) ;
      putVar (v, type, NIL) ;
      putVarBool (v, TRUE, TRUE, isvar, isused) ;
      IF debugScopes
      THEN
         printf ("adding parameter variable into top scope\n") ;
         dumpScopes ;
         printf (" variable name is: ") ;
         s := InitStringCharStar (keyToCharStar (m)) ;
         IF KillString (WriteS (StdOut, s))=NIL
         THEN
         END ;
         printf ("\n")
      END ;
      INC (i)
   END
END makeVariablesFromParameters ;


(*
   addProcedureToScope - add a procedure name n and node d to the
                         current scope.
*)

PROCEDURE addProcedureToScope (d: node; n: Name) : node ;
VAR
   m: node ;
   i: CARDINAL ;
BEGIN
   i := HighIndice (scopeStack) ;
   m := GetIndice (scopeStack, i) ;
   IF isDef (m) AND
      (getSymName (m) = makeKey ('M2RTS')) AND
      (getSymName (d) = makeKey ('HALT'))
   THEN
      haltN := d ;
      putSymKey (baseSymbols, n, haltN)
   END ;
   RETURN addToScope (d)
END addProcedureToScope ;


(*
   makeProcedure - create, initialise and return a procedure node.
*)

PROCEDURE makeProcedure (n: Name) : node ;
VAR
   d: node ;
BEGIN
   d := lookupSym (n) ;
   IF d=NIL
   THEN
      d := newNode (procedure) ;
      WITH d^ DO
         procedureF.name := n ;
         initDecls (procedureF.decls) ;
         procedureF.scope := getDeclScope () ;
         procedureF.parameters := InitIndex (1) ;
         procedureF.isForC := isDefForCNode (getDeclScope ()) ;
	 procedureF.built := FALSE ;
         procedureF.returnopt := FALSE ;
         procedureF.optarg := NIL ;
	 procedureF.noreturnused := FALSE ;
         procedureF.noreturn := FALSE ;
         procedureF.vararg := FALSE ;
         procedureF.checking := FALSE ;
	 procedureF.paramcount := 0 ;
         procedureF.returnType := NIL ;
         procedureF.beginStatements := NIL ;
         initCname (procedureF.cname) ;
	 procedureF.defComment := NIL ;
	 procedureF.modComment := NIL ;
      END
   END ;
   RETURN addProcedureToScope (d, n)
END makeProcedure ;


(*
   putCommentDefProcedure - remembers the procedure comment (if it exists) as a
                            definition module procedure heading.  NIL is placed
                            if there is no procedure comment available.
*)

PROCEDURE putCommentDefProcedure (n: node) ;
BEGIN
   assert (isProcedure (n)) ;
   IF isProcedureComment (lastcomment)
   THEN
      n^.procedureF.defComment := lastcomment
   END
END putCommentDefProcedure ;


(*
   putCommentModProcedure - remembers the procedure comment (if it exists) as an
                            implementation/program module procedure heading.  NIL is placed
                            if there is no procedure comment available.
*)

PROCEDURE putCommentModProcedure (n: node) ;
BEGIN
   assert (isProcedure (n)) ;
   IF isProcedureComment (lastcomment)
   THEN
      n^.procedureF.modComment := lastcomment
   END
END putCommentModProcedure ;


(*
   paramEnter - reset the parameter count.
*)

PROCEDURE paramEnter (n: node) ;
BEGIN
   assert (isProcedure (n)) ;
   n^.procedureF.paramcount := 0
END paramEnter ;


(*
   paramLeave - set paramater checking to TRUE from now onwards.
*)

PROCEDURE paramLeave (n: node) ;
BEGIN
   assert (isProcedure (n)) ;
   n^.procedureF.checking := TRUE ;
   IF isImp (currentModule) OR isModule (currentModule)
   THEN
      n^.procedureF.built := TRUE
   END
END paramLeave ;


(*
   putReturnType - sets the return type of procedure or proctype, proc, to, type.
*)

PROCEDURE putReturnType (proc, type: node) ;
BEGIN
   assert (isProcedure (proc) OR isProcType (proc)) ;
   IF isProcedure (proc)
   THEN
      proc^.procedureF.returnType := type
   ELSE
      proc^.proctypeF.returnType := type
   END
END putReturnType ;


(*
   putOptReturn - sets, proctype or procedure, proc, to have an optional return type.
*)

PROCEDURE putOptReturn (proc: node) ;
BEGIN
   assert (isProcedure (proc) OR isProcType (proc)) ;
   IF isProcedure (proc)
   THEN
      proc^.procedureF.returnopt := TRUE
   ELSE
      proc^.proctypeF.returnopt := TRUE
   END
END putOptReturn ;


(*
   makeProcType - returns a proctype node.
*)

PROCEDURE makeProcType () : node ;
VAR
   d: node ;
BEGIN
   d := newNode (proctype) ;
   WITH d^ DO
      proctypeF.scope := getDeclScope () ;
      proctypeF.parameters := InitIndex (1) ;
      proctypeF.returnopt := FALSE ;
      proctypeF.optarg := NIL ;
      proctypeF.vararg := FALSE ;
      proctypeF.returnType := NIL
   END ;
   RETURN d
END makeProcType ;


(*
   putProcTypeReturn - sets the return type of, proc, to, type.
*)

PROCEDURE putProcTypeReturn (proc, type: node) ;
BEGIN
   assert (isProcType (proc)) ;
   proc^.proctypeF.returnType := type
END putProcTypeReturn ;


(*
   putProcTypeOptReturn - sets, proc, to have an optional return type.
*)

PROCEDURE putProcTypeOptReturn (proc: node) ;
BEGIN
   assert (isProcType (proc)) ;
   proc^.proctypeF.returnopt := TRUE
END putProcTypeOptReturn ;


(*
   makeNonVarParameter - returns a non var parameter node with, name: type.
*)

PROCEDURE makeNonVarParameter (l: node; type, proc: node; isused: BOOLEAN) : node ;
VAR
   d: node ;
BEGIN
   assert ((l=NIL) OR isIdentList (l)) ;
   d := newNode (param) ;
   d^.paramF.namelist := l ;
   d^.paramF.type := type ;
   d^.paramF.scope := proc ;
   d^.paramF.isUnbounded := FALSE ;
   d^.paramF.isForC := isDefForCNode (proc) ;
   d^.paramF.isUsed := isused ;
   RETURN d
END makeNonVarParameter ;


(*
   makeVarParameter - returns a var parameter node with, name: type.
*)

PROCEDURE makeVarParameter (l: node; type, proc: node; isused: BOOLEAN) : node ;
VAR
   d: node ;
BEGIN
   assert ((l=NIL) OR isIdentList (l)) ;
   d := newNode (varparam) ;
   d^.varparamF.namelist := l ;
   d^.varparamF.type := type ;
   d^.varparamF.scope := proc ;
   d^.varparamF.isUnbounded := FALSE ;
   d^.varparamF.isForC := isDefForCNode (proc) ;
   d^.varparamF.isUsed := isused ;
   RETURN d
END makeVarParameter ;


(*
   makeVarargs - returns a varargs node.
*)

PROCEDURE makeVarargs () : node ;
VAR
   d: node ;
BEGIN
   d := newNode (varargs) ;
   d^.varargsF.scope := NIL ;
   RETURN d
END makeVarargs ;


(*
   isVarargs - returns TRUE if, n, is a varargs node.
*)

PROCEDURE isVarargs (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = varargs
END isVarargs ;


(*
   addParameter - adds a parameter, param, to procedure or proctype, proc.
*)

PROCEDURE addParameter (proc, param: node) ;
BEGIN
   assert (isVarargs (param) OR isParam (param) OR isVarParam (param) OR isOptarg (param)) ;
   CASE proc^.kind OF

   procedure:  IncludeIndiceIntoIndex (proc^.procedureF.parameters, param) ;
               IF isVarargs (param)
               THEN
                  proc^.procedureF.vararg := TRUE
               END ;
	       IF isOptarg (param)
               THEN
                  proc^.procedureF.optarg := param
               END |
   proctype :  IncludeIndiceIntoIndex (proc^.proctypeF.parameters, param) ;
               IF isVarargs (param)
               THEN
                  proc^.proctypeF.vararg := TRUE
               END ;
               IF isOptarg (param)
               THEN
                  proc^.proctypeF.optarg := param
               END

   END
END addParameter ;


(*
   isOptarg - returns TRUE if, n, is an optarg.
*)

PROCEDURE isOptarg (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = optarg
END isOptarg ;


(*
   makeOptParameter - creates and returns an optarg.
*)

PROCEDURE makeOptParameter (l, type, init: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (optarg) ;
   n^.optargF.namelist := l ;
   n^.optargF.type := type ;
   n^.optargF.init := init ;
   n^.optargF.scope := NIL ;
   RETURN n
END makeOptParameter ;


(*
   addOptParameter - returns an optarg which has been created and added to
                     procedure node, proc.  It has a name, id, and, type,
                     and an initial value, init.
*)

PROCEDURE addOptParameter (proc: node; id: Name; type, init: node) : node ;
VAR
   p, l: node ;
BEGIN
   assert (isProcedure (proc)) ;
   l := makeIdentList () ;
   assert (putIdent (l, id)) ;
   checkMakeVariables (proc, l, type, FALSE, TRUE) ;
   IF NOT proc^.procedureF.checking
   THEN
      p := makeOptParameter (l, type, init) ;
      addParameter (proc, p)
   END ;
   RETURN p
END addOptParameter ;


VAR
   globalNode: node ;


(*
   setwatch - assign the globalNode to n.
*)

PROCEDURE setwatch (n: node) : BOOLEAN ;
BEGIN
   globalNode := n ;
   RETURN TRUE
END setwatch ;


(*
   runwatch - set the globalNode to an identlist.
*)

PROCEDURE runwatch () : BOOLEAN ;
BEGIN
   RETURN globalNode^.kind = identlist
END runwatch ;


(*
   makeIdentList - returns a node which will be used to maintain an ident list.
*)

PROCEDURE makeIdentList () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (identlist) ;
   n^.identlistF.names := wlists.initList () ;
   n^.identlistF.cnamed := FALSE ;
   RETURN n
END makeIdentList ;


(*
   isIdentList - returns TRUE if, n, is an identlist.
*)

PROCEDURE isIdentList (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = identlist
END isIdentList ;


(*
   putIdent - places ident, i, into identlist, n.  It returns TRUE if
              ident, i, is unique.
*)

PROCEDURE putIdent (n: node; i: Name) : BOOLEAN ;
BEGIN
   assert (isIdentList (n)) ;
   IF wlists.isItemInList (n^.identlistF.names, i)
   THEN
      RETURN FALSE
   ELSE
      wlists.putItemIntoList (n^.identlistF.names, i) ;
      RETURN TRUE
   END
END putIdent ;


(*
   identListLen - returns the length of identlist.
*)

PROCEDURE identListLen (n: node) : CARDINAL ;
BEGIN
   IF n=NIL
   THEN
      RETURN 0
   ELSE
      assert (isIdentList (n)) ;
      RETURN wlists.noOfItemsInList (n^.identlistF.names)
   END
END identListLen ;


(*
   checkParameters - placeholder for future parameter checking.
*)

PROCEDURE checkParameters (p: node; i: node; type: node; isvar, isused: BOOLEAN) ;
BEGIN
   (* do check.  *)
   disposeNode (i)
END checkParameters ;

(*
(*
   avoidCnames - checks each name in, n, against C reserved
                 keywords and macros.
*)

PROCEDURE avoidCnames (n: node) ;
VAR
   i, j: CARDINAL ;
BEGIN
   assert (isIdentList (n)) ;
   IF NOT n^.identlistF.cnamed
   THEN
      n^.identlistF.cnamed := TRUE ;
      j := wlists.noOfItemsInList (n^.identlistF.names) ;
      i := 1 ;
      WHILE i<=j DO
         wlists.replaceItemInList (n^.identlistF.names,
                                   i,
                                   keyc.cnamen (wlists.getItemFromList (n^.identlistF.names, i), FALSE)) ;
         INC (i)
      END
   END
END avoidCnames ;
*)


(*
   checkMakeVariables - create shadow local variables for parameters providing that
                        procedure n has not already been built and we are compiling
                        a module or an implementation module.
*)

PROCEDURE checkMakeVariables (n, i, type: node; isvar, isused: BOOLEAN) ;
BEGIN
   IF (isImp (currentModule) OR isModule (currentModule)) AND
      (NOT n^.procedureF.built)
   THEN
      makeVariablesFromParameters (n, i, type, isvar, isused)
   END ;
END checkMakeVariables ;


(*
   addVarParameters - adds the identlist, i, of, type, to be VAR parameters
                      in procedure, n.
*)

PROCEDURE addVarParameters (n: node; i: node; type: node; isused: BOOLEAN) ;
VAR
   p: node ;
BEGIN
   assert (isIdentList (i)) ;
   assert (isProcedure (n)) ;
   checkMakeVariables (n, i, type, TRUE, isused) ;
   IF n^.procedureF.checking
   THEN
      checkParameters (n, i, type, TRUE, isused)  (* will destroy, i.  *)
   ELSE
      p := makeVarParameter (i, type, n, isused) ;
      IncludeIndiceIntoIndex (n^.procedureF.parameters, p) ;
   END ;
END addVarParameters ;


(*
   addNonVarParameters - adds the identlist, i, of, type, to be parameters
                         in procedure, n.
*)

PROCEDURE addNonVarParameters (n: node; i: node; type: node; isused: BOOLEAN) ;
VAR
   p: node ;
BEGIN
   assert (isIdentList (i)) ;
   assert (isProcedure (n)) ;
   checkMakeVariables (n, i, type, FALSE, isused) ;
   IF n^.procedureF.checking
   THEN
      checkParameters (n, i, type, FALSE, isused)  (* will destroy, i.  *)
   ELSE
      p := makeNonVarParameter (i, type, n, isused) ;
      IncludeIndiceIntoIndex (n^.procedureF.parameters, p)
   END ;
END addNonVarParameters ;


(*
   makeSubrange - returns a subrange node, built from range: low..high.
*)

PROCEDURE makeSubrange (low, high: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (subrange) ;
   n^.subrangeF.low := low ;
   n^.subrangeF.high := high ;
   n^.subrangeF.type := NIL ;
   n^.subrangeF.scope := getDeclScope () ;
   RETURN n
END makeSubrange ;


(*
   putSubrangeType - assigns, type, to the subrange type, sub.
*)

PROCEDURE putSubrangeType (sub, type: node) ;
BEGIN
   assert (isSubrange (sub)) ;
   sub^.subrangeF.type := type
END putSubrangeType ;


(*
   makeSet - returns a set of, type, node.
*)

PROCEDURE makeSet (type: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (set) ;
   n^.setF.type := type ;
   n^.setF.scope := getDeclScope () ;
   RETURN n
END makeSet ;


(*
   makeSetValue - creates and returns a setvalue node.
*)

PROCEDURE makeSetValue () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (setvalue) ;
   n^.setvalueF.type := bitsetN ;
   n^.setvalueF.values := InitIndex (1) ;
   RETURN n
END makeSetValue ;


(*
   isSetValue - returns TRUE if, n, is a setvalue node.
*)

PROCEDURE isSetValue (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = setvalue
END isSetValue ;


(*
   putSetValue - assigns the type, t, to the set value, n.  The
                 node, n, is returned.
*)

PROCEDURE putSetValue (n, t: node) : node ;
BEGIN
   assert (isSetValue (n)) ;
   n^.setvalueF.type := t ;
   RETURN n
END putSetValue ;


(*
   includeSetValue - includes the range l..h into the setvalue.
                     h might be NIL indicating that a single element
                       is to be included into the set.
                     n is returned.
*)

PROCEDURE includeSetValue (n: node; l, h: node) : node ;
BEGIN
   assert (isSetValue (n)) ;
   IncludeIndiceIntoIndex (n^.setvalueF.values, l) ;
   RETURN n
END includeSetValue ;


(*
   makePointer - returns a pointer of, type, node.
*)

PROCEDURE makePointer (type: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (pointer) ;
   n^.pointerF.type := type ;
   n^.pointerF.scope := getDeclScope () ;
   RETURN n
END makePointer ;


(*
   makeArray - returns a node representing ARRAY subr OF type.
*)

PROCEDURE makeArray (subr, type: node) : node ;
VAR
   n, s: node ;
BEGIN
   s := skipType (subr) ;
   assert (isSubrange (s) OR isOrdinal (s) OR isEnumeration (s)) ;
   n := newNode (array) ;
   n^.arrayF.subr := subr ;
   n^.arrayF.type := type ;
   n^.arrayF.scope := getDeclScope () ;
   n^.arrayF.isUnbounded := FALSE ;
   RETURN n
END makeArray ;


(*
   makeRecord - creates and returns a record node.
*)

PROCEDURE makeRecord () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (record) ;
   n^.recordF.localSymbols := initTree () ;
   n^.recordF.listOfSons := InitIndex (1) ;
   n^.recordF.scope := getDeclScope () ;
   RETURN n
END makeRecord ;


(*
   addFieldsToRecord - adds fields, i, of type, t, into a record, r.
                       It returns, r.
*)

PROCEDURE addFieldsToRecord (r, v, i, t: node) : node ;
VAR
   p, fj: node ;
   j, n : CARDINAL ;
   fn   : Name ;
BEGIN
   IF isRecord (r)
   THEN
      p := r ;
      v := NIL
   ELSE
      p := getRecord (getParent (r)) ;
      assert (isVarientField (r)) ;
      assert (isVarient (v)) ;
      putFieldVarient (r, v)
   END ;
   n := wlists.noOfItemsInList (i^.identlistF.names) ;
   j := 1 ;
   WHILE j<=n DO
      fn := wlists.getItemFromList (i^.identlistF.names, j) ;
      fj := getSymKey (p^.recordF.localSymbols, n) ;
      IF fj=NIL
      THEN
         fj := putFieldRecord (r, fn, t, v)
      ELSE
         metaErrors2 ('record field {%1ad} has already been declared inside a {%2Dd} {%2a}',
                      'attempting to declare a duplicate record field', fj, p)
      END ;
      INC (j)
   END ;
   RETURN r;
END addFieldsToRecord ;


(*
   makeVarient - creates a new symbol, a varient symbol for record or varient field
                 symbol, r.
*)

PROCEDURE makeVarient (r: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (varient) ;
   WITH n^ DO
      varientF.listOfSons := InitIndex (1) ;
      (* do we need to remember our parent (r) ?  *)
      (* if so use this   n^.varientF.parent := r  *)
      IF isRecord (r)
      THEN
         varientF.varient := NIL
      ELSE
         varientF.varient := r
      END ;
      varientF.tag := NIL ;
      varientF.scope := getDeclScope () ;
   END ;
   (* now add, n, to the record/varient, r, field list *)
   WITH r^ DO
      CASE kind OF

      record      :  IncludeIndiceIntoIndex (recordF.listOfSons, n) |
      varientfield:  IncludeIndiceIntoIndex (varientfieldF.listOfSons, n)

      END
   END ;
   RETURN n
END makeVarient ;


(*
   buildVarientFieldRecord - builds a varient field into a varient symbol, v.
                             The varient field is returned.
*)

PROCEDURE buildVarientFieldRecord (v: node; p: node) : node ;
VAR
   f: node ;
BEGIN
   assert (isVarient (v)) ;
   f := makeVarientField (v, p) ;
   assert (isVarientField (f)) ;
   putFieldVarient (f, v) ;
   RETURN f
END buildVarientFieldRecord ;


(*
   makeVarientField - create a varient field within varient, v,
                      The new varient field is returned.
*)

PROCEDURE makeVarientField (v: node; p: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (varientfield) ;
   WITH n^.varientfieldF DO
      name := NulName ;
      parent := p ;
      varient := v ;
      simple := FALSE ;
      listOfSons := InitIndex (1) ;
      scope := getDeclScope ()
   END ;
   RETURN n
END makeVarientField ;


(*
   putFieldVarient - places the field varient, f, as a brother to, the
                     varient symbol, v, and also tells, f, that its varient
                     parent is, v.
*)

PROCEDURE putFieldVarient (f, v: node) ;
BEGIN
   assert (isVarient (v)) ;
   assert (isVarientField (f)) ;
   WITH v^ DO
      CASE kind OF

      varient:  IncludeIndiceIntoIndex (varientF.listOfSons, f)

      END
   END ;
   WITH f^ DO
      CASE kind OF

      varientfield:  varientfieldF.varient := v

      END
   END
END putFieldVarient ;


(*
   putFieldRecord - create a new recordfield and place it into record r.
                    The new field has a tagname and type and can have a
                    variant field v.
*)

PROCEDURE putFieldRecord (r: node; tag: Name; type, v: node) : node ;
VAR
   f, n, p: node ;
BEGIN
   n := newNode (recordfield) ;
   WITH r^ DO
      CASE kind OF

      record:  IncludeIndiceIntoIndex (recordF.listOfSons, n) ;
               (* ensure that field, n, is in the parents Local Symbols.  *)
               IF tag#NulName
               THEN
                  IF getSymKey (recordF.localSymbols, tag) = NulKey
                  THEN
                     putSymKey (recordF.localSymbols, tag, n)
                  ELSE
                     f := getSymKey (recordF.localSymbols, tag) ;
                     metaErrors1 ('field record {%1Dad} has already been declared',
                                  'field record duplicate', f)
                  END
               END |
      varientfield:  IncludeIndiceIntoIndex (varientfieldF.listOfSons, n) ;
                     p := getParent (r) ;
                     assert (p^.kind=record) ;
                     IF tag#NulName
                     THEN
                        putSymKey (p^.recordF.localSymbols, tag, n)
                     END

      END
   END ;
   (* fill in, n.  *)
   n^.recordfieldF.type := type ;
   n^.recordfieldF.name := tag ;
   n^.recordfieldF.parent := r ;
   n^.recordfieldF.varient := v ;
   n^.recordfieldF.tag := FALSE ;
   n^.recordfieldF.scope := NIL ;
   initCname (n^.recordfieldF.cname) ;
   (*
   IF r^.kind=record
   THEN
      doRecordM2 (doP, r)
   END ;
   *)
   RETURN n
END putFieldRecord ;


(*
   buildVarientSelector - builds a field of name, tag, of, type onto:
                          record or varient field, r.
                          varient, v.
*)

PROCEDURE buildVarientSelector (r, v: node; tag: Name; type: node) ;
VAR
   f: node ;
BEGIN
   assert (isRecord (r) OR isVarientField (r)) ;
   IF isRecord (r) OR isVarientField (r)
   THEN
      IF (type=NIL) AND (tag=NulName)
      THEN
         metaError1 ('expecting a tag field in the declaration of a varient record {%1Ua}', r)
      ELSIF type=NIL
      THEN
         f := lookupSym (tag) ;
         putVarientTag (v, f)
      ELSE
         f := putFieldRecord (r, tag, type, v) ;
	 assert (isRecordField (f)) ;
         f^.recordfieldF.tag := TRUE ;
         putVarientTag (v, f)
      END
   END
END buildVarientSelector ;


(*
   ensureOrder - ensures that, a, and, b, exist in, i, and also
                 ensure that, a, is before, b.
*)

PROCEDURE ensureOrder (i: Index; a, b: node) ;
BEGIN
   assert (IsIndiceInIndex (i, a)) ;
   assert (IsIndiceInIndex (i, b)) ;
   RemoveIndiceFromIndex (i, a) ;
   RemoveIndiceFromIndex (i, b) ;
   IncludeIndiceIntoIndex (i, a) ;
   IncludeIndiceIntoIndex (i, b) ;
   assert (IsIndiceInIndex (i, a)) ;
   assert (IsIndiceInIndex (i, b))
END ensureOrder ;


(*
   putVarientTag - places tag into variant v.
*)

PROCEDURE putVarientTag (v: node; tag: node) ;
VAR
   p: node ;
BEGIN
   assert (isVarient (v)) ;
   CASE v^.kind OF

   varient:  v^.varientF.tag := tag

   END
END putVarientTag ;


(*
   getParent - returns the parent field of recordfield or varientfield symbol, n.
*)

PROCEDURE getParent (n: node) : node ;
BEGIN
   CASE n^.kind OF

   recordfield:  RETURN n^.recordfieldF.parent |
   varientfield:  RETURN n^.varientfieldF.parent

   END
END getParent ;


(*
   getRecord - returns the record associated with node, n.
               (Parental record).
*)

PROCEDURE getRecord (n: node) : node ;
BEGIN
   assert (n^.kind # varient) ;  (* if this fails then we need to add parent field to varient.  *)
   CASE n^.kind OF

   record      :  RETURN n |
   varientfield:  RETURN getRecord (getParent (n))

   END
END getRecord ;


(*
   putUnbounded - sets array, n, as unbounded.
*)

PROCEDURE putUnbounded (n: node) ;
BEGIN
   assert (n^.kind = array) ;
   n^.arrayF.isUnbounded := TRUE
END putUnbounded ;


(*
   isConstExp - return TRUE if the node kind is a constexp.
*)

PROCEDURE isConstExp (c: node) : BOOLEAN ;
BEGIN
   assert (c#NIL) ;
   RETURN c^.kind = constexp
END isConstExp ;


(*
   addEnumToModule - adds enumeration type, e, into the list of enums
                     in module, m.
*)

PROCEDURE addEnumToModule (m, e: node) ;
BEGIN
   assert (isEnumeration (e) OR isEnumerationField (e)) ;
   assert (isModule (m) OR isDef (m) OR isImp (m)) ;
   IF isModule (m)
   THEN
      IncludeIndiceIntoIndex (m^.moduleF.enumFixup.info, e)
   ELSIF isDef (m)
   THEN
      IncludeIndiceIntoIndex (m^.defF.enumFixup.info, e)
   ELSIF isImp (m)
   THEN
      IncludeIndiceIntoIndex (m^.impF.enumFixup.info, e)
   END
END addEnumToModule ;


(*
   getNextFixup - return the next fixup from from f.
*)

PROCEDURE getNextFixup (VAR f: fixupInfo) : node ;
BEGIN
   INC (f.count) ;
   RETURN GetIndice (f.info, f.count)
END getNextFixup ;


(*
   getNextEnum - returns the next enumeration node.
*)

PROCEDURE getNextEnum () : node ;
VAR
   n: node ;
BEGIN
   n := NIL ;
   assert (isDef (currentModule) OR isImp (currentModule) OR isModule (currentModule)) ;
   WITH currentModule^ DO
      IF isDef (currentModule)
      THEN
         n := getNextFixup (defF.enumFixup)
      ELSIF isImp (currentModule)
      THEN
         n := getNextFixup (impF.enumFixup)
      ELSIF isModule (currentModule)
      THEN
         n := getNextFixup (moduleF.enumFixup)
      END
   END ;
   assert (n # NIL) ;
   assert (isEnumeration (n) OR isEnumerationField (n)) ;
   RETURN n
END getNextEnum ;


(*
   resetEnumPos - resets the index into the saved list of enums inside
                  module, n.
*)

PROCEDURE resetEnumPos (n: node) ;
BEGIN
   assert (isDef (n) OR isImp (n) OR isModule (n)) ;
   IF isDef (n)
   THEN
      n^.defF.enumFixup.count := 0
   ELSIF isImp (n)
   THEN
      n^.impF.enumFixup.count := 0
   ELSIF isModule (n)
   THEN
      n^.moduleF.enumFixup.count := 0
   END
END resetEnumPos ;


(*
   getEnumsComplete - gets the field from the def or imp or module, n.
*)

PROCEDURE getEnumsComplete (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   def   :  RETURN n^.defF.enumsComplete |
   imp   :  RETURN n^.impF.enumsComplete |
   module:  RETURN n^.moduleF.enumsComplete

   END
END getEnumsComplete ;


(*
   setEnumsComplete - sets the field inside the def or imp or module, n.
*)

PROCEDURE setEnumsComplete (n: node) ;
BEGIN
   CASE n^.kind OF

   def   :  n^.defF.enumsComplete := TRUE |
   imp   :  n^.impF.enumsComplete := TRUE |
   module:  n^.moduleF.enumsComplete := TRUE

   END
END setEnumsComplete ;


(*
   doMakeEnum - create an enumeration type and add it to the current module.
*)

PROCEDURE doMakeEnum () : node ;
VAR
   e: node ;
BEGIN
   e := newNode (enumeration) ;
   WITH e^ DO
      enumerationF.noOfElements := 0 ;
      enumerationF.localSymbols := initTree () ;
      enumerationF.scope := getDeclScope () ;
      enumerationF.listOfSons := InitIndex (1) ;
      enumerationF.low := NIL ;
      enumerationF.high := NIL ;
   END ;
   addEnumToModule (currentModule, e) ;
   RETURN e
END doMakeEnum ;


(*
   makeEnum - creates an enumerated type and returns the node.
*)

PROCEDURE makeEnum () : node ;
BEGIN
   IF (currentModule#NIL) AND getEnumsComplete (currentModule)
   THEN
      RETURN getNextEnum ()
   ELSE
      RETURN doMakeEnum ()
   END
END makeEnum ;


(*
   doMakeEnumField - create an enumeration field name and add it to enumeration e.
                     Return the new field.
*)

PROCEDURE doMakeEnumField (e: node; n: Name) : node ;
VAR
   f: node ;
BEGIN
   assert (isEnumeration (e)) ;
   f := lookupSym (n) ;
   IF f=NIL
   THEN
      f := newNode (enumerationfield) ;
      putSymKey (e^.enumerationF.localSymbols, n, f) ;
      IncludeIndiceIntoIndex (e^.enumerationF.listOfSons, f) ;
      WITH f^ DO
         enumerationfieldF.name := n ;
         enumerationfieldF.type := e ;
         enumerationfieldF.scope := getDeclScope () ;
         enumerationfieldF.value := e^.enumerationF.noOfElements ;
         initCname (enumerationfieldF.cname)
      END ;
      INC (e^.enumerationF.noOfElements) ;
      assert (GetIndice (e^.enumerationF.listOfSons, e^.enumerationF.noOfElements) = f) ;
      addEnumToModule (currentModule, f) ;
      IF e^.enumerationF.low = NIL
      THEN
         e^.enumerationF.low := f
      END ;
      e^.enumerationF.high := f ;
      RETURN addToScope (f)
   ELSE
      metaErrors2 ('cannot create enumeration field {%1k} as the name is already in use',
                   '{%2DMad} was declared elsewhere', n, f)
   END ;
   RETURN f
END doMakeEnumField ;


(*
   makeEnumField - returns an enumeration field, named, n.
*)

PROCEDURE makeEnumField (e: node; n: Name) : node ;
BEGIN
   IF (currentModule#NIL) AND getEnumsComplete (currentModule)
   THEN
      RETURN getNextEnum ()
   ELSE
      RETURN doMakeEnumField (e, n)
   END
END makeEnumField ;


(*
   isEnumeration - returns TRUE if node, n, is an enumeration type.
*)

PROCEDURE isEnumeration (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind = enumeration
END isEnumeration ;


(*
   makeExpList - creates and returns an expList node.
*)

PROCEDURE makeExpList () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (explist) ;
   n^.explistF.exp := InitIndex (1) ;
   RETURN n
END makeExpList ;


(*
   isExpList - returns TRUE if, n, is an explist node.
*)

PROCEDURE isExpList (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = explist
END isExpList ;


(*
   putExpList - places, expression, e, within the explist, n.
*)

PROCEDURE putExpList (n: node; e: node) ;
BEGIN
   assert (n # NIL) ;
   assert (isExpList (n)) ;
   PutIndice (n^.explistF.exp, HighIndice (n^.explistF.exp) + 1, e)
END putExpList ;


(*
   getExpList - returns the, n, th argument in an explist.
*)

PROCEDURE getExpList (p: node; n: CARDINAL) : node ;
BEGIN
   assert (p#NIL) ;
   assert (isExpList (p)) ;
   assert (n <= HighIndice (p^.explistF.exp)) ;
   RETURN GetIndice (p^.explistF.exp, n)
END getExpList ;


(*
   expListLen - returns the length of explist, p.
*)

PROCEDURE expListLen (p: node) : CARDINAL ;
BEGIN
   IF p = NIL
   THEN
      RETURN 0
   ELSE
      assert (isExpList (p)) ;
      RETURN HighIndice (p^.explistF.exp)
   END
END expListLen ;


(*
   getConstExpComplete - gets the field from the def or imp or module, n.
*)

PROCEDURE getConstExpComplete (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   def   :  RETURN n^.defF.constsComplete |
   imp   :  RETURN n^.impF.constsComplete |
   module:  RETURN n^.moduleF.constsComplete

   END
END getConstExpComplete ;


(*
   setConstExpComplete - sets the field inside the def or imp or module, n.
*)

PROCEDURE setConstExpComplete (n: node) ;
BEGIN
   CASE n^.kind OF

   def   :  n^.defF.constsComplete := TRUE |
   imp   :  n^.impF.constsComplete := TRUE |
   module:  n^.moduleF.constsComplete := TRUE

   END
END setConstExpComplete ;


(*
   getNextConstExp - returns the next constexp node.
*)

PROCEDURE getNextConstExp () : node ;
VAR
   n: node ;
BEGIN
   assert (isDef (currentModule) OR isImp (currentModule) OR isModule (currentModule)) ;
   WITH currentModule^ DO
      IF isDef (currentModule)
      THEN
         RETURN getNextFixup (defF.constFixup)
      ELSIF isImp (currentModule)
      THEN
         RETURN getNextFixup (impF.constFixup)
      ELSIF isModule (currentModule)
      THEN
         RETURN getNextFixup (moduleF.constFixup)
      END
   END ;
   RETURN n
END getNextConstExp ;


(*
   resetConstExpPos - resets the index into the saved list of constexps inside
                      module, n.
*)

PROCEDURE resetConstExpPos (n: node) ;
BEGIN
   assert (isDef (n) OR isImp (n) OR isModule (n)) ;
   IF isDef (n)
   THEN
      n^.defF.constFixup.count := 0
   ELSIF isImp (n)
   THEN
      n^.impF.constFixup.count := 0
   ELSIF isModule (n)
   THEN
      n^.moduleF.constFixup.count := 0
   END
END resetConstExpPos ;


(*
   addConstToModule - adds const exp, e, into the list of constant
                      expressions in module, m.
*)

PROCEDURE addConstToModule (m, e: node) ;
BEGIN
   assert (isModule (m) OR isDef (m) OR isImp (m)) ;
   IF isModule (m)
   THEN
      IncludeIndiceIntoIndex (m^.moduleF.constFixup.info, e)
   ELSIF isDef (m)
   THEN
      IncludeIndiceIntoIndex (m^.defF.constFixup.info, e)
   ELSIF isImp (m)
   THEN
      IncludeIndiceIntoIndex (m^.impF.constFixup.info, e)
   END
END addConstToModule ;


(*
   doMakeConstExp - create a constexp node and add it to the current module.
*)

PROCEDURE doMakeConstExp () : node ;
VAR
   c: node ;
BEGIN
   c := makeUnary (constexp, NIL, NIL) ;
   addConstToModule (currentModule, c) ;
   RETURN c
END doMakeConstExp ;


(*
   makeConstExp - returns a constexp node.
*)

PROCEDURE makeConstExp () : node ;
BEGIN
   IF (currentModule#NIL) AND getConstExpComplete (currentModule)
   THEN
      RETURN getNextConstExp ()
   ELSE
      RETURN doMakeConstExp ()
   END
END makeConstExp ;


(*
   fixupConstExp - assign fixup expression, e, into the argument of, c.
*)

PROCEDURE fixupConstExp (c, e: node) : node ;
BEGIN
   assert (isConstExp (c)) ;
   c^.unaryF.arg := e ;
   RETURN c
END fixupConstExp ;


(*
   isAnyType - return TRUE if node n is any type kind.
*)

PROCEDURE isAnyType (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   CASE n^.kind OF

   address,
   loc,
   byte,
   word,
   char,
   cardinal,
   longcard,
   shortcard,
   integer,
   longint,
   shortint,
   complex,
   longcomplex,
   shortcomplex,
   bitset,
   boolean,
   proc,
   type     :  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isAnyType ;


(*
   makeVal - creates a VAL (type, expression) node.
*)

PROCEDURE makeVal (params: node) : node ;
BEGIN
   assert (isExpList (params)) ;
   IF expListLen (params) = 2
   THEN
      RETURN makeBinary (val,
                         getExpList (params, 1),
                         getExpList (params, 2),
                         getExpList (params, 1))
   ELSE
      HALT
   END
END makeVal ;


(*
   makeCast - creates a cast node TYPENAME (expr).
*)

PROCEDURE makeCast (c, p: node) : node ;
BEGIN
   assert (isExpList (p)) ;
   IF expListLen (p) = 1
   THEN
      RETURN makeBinary (cast, c, getExpList (p, 1), c)
   ELSE
      HALT
   END
END makeCast ;


(*
   makeIntrisicProc - create an intrinsic node.
*)

PROCEDURE makeIntrinsicProc (k: nodeT; noArgs: CARDINAL; p: node) : node ;
VAR
   f: node ;
BEGIN
   f := newNode (k) ;
   f^.intrinsicF.args := p ;
   f^.intrinsicF.noArgs := noArgs ;
   f^.intrinsicF.type := NIL ;
   f^.intrinsicF.postUnreachable := (k = halt) ;
   initPair (f^.intrinsicF.intrinsicComment) ;
   RETURN f
END makeIntrinsicProc ;


(*
   makeIntrinsicUnaryType - create an intrisic unary type.
*)

PROCEDURE makeIntrinsicUnaryType (k: nodeT; paramList: node; returnType: node) : node ;
BEGIN
   RETURN makeUnary (k, getExpList (paramList, 1), returnType)
END makeIntrinsicUnaryType ;


(*
   makeIntrinsicBinaryType - create an intrisic binary type.
*)

PROCEDURE makeIntrinsicBinaryType (k: nodeT; paramList: node; returnType: node) : node ;
BEGIN
   RETURN makeBinary (k, getExpList (paramList, 1), getExpList (paramList, 2), returnType)
END makeIntrinsicBinaryType ;


(*
   checkIntrinsic - checks to see if the function call to, c, with
                    parameter list, n, is really an intrinic.  If it
                    is an intrinic then an intrinic node is created
                    and returned.  Otherwise NIL is returned.
*)

PROCEDURE checkIntrinsic (c, n: node) : node ;
BEGIN
   IF isAnyType (c)
   THEN
      RETURN makeCast (c, n)
   ELSIF c = maxN
   THEN
      RETURN makeIntrinsicUnaryType (max, n, NIL)
   ELSIF c = minN
   THEN
      RETURN makeIntrinsicUnaryType (min, n, NIL)
   ELSIF c = haltN
   THEN
      RETURN makeIntrinsicProc (halt, expListLen (n), n)
   ELSIF c = valN
   THEN
      RETURN makeVal (n)
   ELSIF c = adrN
   THEN
      RETURN makeIntrinsicUnaryType (adr, n, addressN)
   ELSIF c = sizeN
   THEN
      RETURN makeIntrinsicUnaryType (size, n, cardinalN)
   ELSIF c = tsizeN
   THEN
      RETURN makeIntrinsicUnaryType (tsize, n, cardinalN)
   ELSIF c = floatN
   THEN
      RETURN makeIntrinsicUnaryType (float, n, realN)
   ELSIF c = truncN
   THEN
      RETURN makeIntrinsicUnaryType (trunc, n, integerN)
   ELSIF c = ordN
   THEN
      RETURN makeIntrinsicUnaryType (ord, n, cardinalN)
   ELSIF c = chrN
   THEN
      RETURN makeIntrinsicUnaryType (chr, n, charN)
   ELSIF c = capN
   THEN
      RETURN makeIntrinsicUnaryType (cap, n, charN)
   ELSIF c = absN
   THEN
      RETURN makeIntrinsicUnaryType (abs, n, NIL)
   ELSIF c = imN
   THEN
      RETURN makeIntrinsicUnaryType (im, n, NIL)
   ELSIF c = reN
   THEN
      RETURN makeIntrinsicUnaryType (re, n, NIL)
   ELSIF c = cmplxN
   THEN
      RETURN makeIntrinsicBinaryType (cmplx, n, NIL)
   ELSIF c = highN
   THEN
      RETURN makeIntrinsicUnaryType (high, n, cardinalN)
   ELSIF c = incN
   THEN
      RETURN makeIntrinsicProc (inc, expListLen (n), n)
   ELSIF c = decN
   THEN
      RETURN makeIntrinsicProc (dec, expListLen (n), n)
   ELSIF c = inclN
   THEN
      RETURN makeIntrinsicProc (incl, expListLen (n), n)
   ELSIF c = exclN
   THEN
      RETURN makeIntrinsicProc (excl, expListLen (n), n)
   ELSIF c = newN
   THEN
      RETURN makeIntrinsicProc (new, 1, n)
   ELSIF c = disposeN
   THEN
      RETURN makeIntrinsicProc (dispose, 1, n)
   ELSIF c = lengthN
   THEN
      RETURN makeIntrinsicUnaryType (length, n, cardinalN)
   ELSIF c = throwN
   THEN
      keyc.useThrow ;
      RETURN makeIntrinsicProc (throw, 1, n)
   END ;
   RETURN NIL
END checkIntrinsic ;


(*
   checkCHeaders - check to see if the function is a C system function and
                   requires a header file included.
*)

PROCEDURE checkCHeaders (c: node) ;
VAR
   name: Name ;
   s   : node ;
BEGIN
   IF isProcedure (c)
   THEN
      s := getScope (c) ;
      IF getSymName (s) = makeKey ('libc')
      THEN
         name := getSymName (c) ;
         IF (name = makeKey ('read')) OR
            (name = makeKey ('write')) OR
            (name = makeKey ('open')) OR
            (name = makeKey ('close'))
         THEN
            keyc.useUnistd
         END
      END
   END
END checkCHeaders ;


(*
   makeFuncCall - builds a function call to c with param list, n.
*)

PROCEDURE makeFuncCall (c, n: node) : node ;
VAR
   f: node ;
BEGIN
   assert ((n=NIL) OR isExpList (n)) ;
   IF (c = haltN) AND
      (getMainModule () # lookupDef (makeKey ('M2RTS'))) AND
      (getMainModule () # lookupImp (makeKey ('M2RTS')))
   THEN
      addImportedModule (getMainModule (), lookupDef (makeKey ('M2RTS')), FALSE)
   END ;
   f := checkIntrinsic (c, n) ;
   checkCHeaders (c) ;
   IF f = NIL
   THEN
      f := newNode (funccall) ;
      f^.funccallF.function := c ;
      f^.funccallF.args := n ;
      f^.funccallF.type := NIL ;
      initPair (f^.funccallF.funccallComment)
   END ;
   RETURN f
END makeFuncCall ;


(*
   isFuncCall - returns TRUE if, n, is a function/procedure call.
*)

PROCEDURE isFuncCall (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = funccall
END isFuncCall ;


(*
   putType - places, exp, as the type alias to des.
             TYPE des = exp ;
*)

PROCEDURE putType (des, exp: node) ;
BEGIN
   assert (des#NIL) ;
   assert (isType (des)) ;
   des^.typeF.type := exp
END putType ;


(*
   putTypeHidden - marks type, des, as being a hidden type.
                   TYPE des ;
*)

PROCEDURE putTypeHidden (des: node) ;
VAR
   s: node ;
BEGIN
   assert (des#NIL) ;
   assert (isType (des)) ;
   des^.typeF.isHidden := TRUE ;
   s := getScope (des) ;
   assert (isDef (s)) ;
   s^.defF.hasHidden := TRUE
END putTypeHidden ;


(*
   isTypeHidden - returns TRUE if type, n, is hidden.
*)

PROCEDURE isTypeHidden (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   assert (isType (n)) ;
   RETURN n^.typeF.isHidden
END isTypeHidden ;


(*
   hasHidden - returns TRUE if module, n, has a hidden type.
*)

PROCEDURE hasHidden (n: node) : BOOLEAN ;
BEGIN
   assert (isDef (n)) ;
   RETURN n^.defF.hasHidden
END hasHidden ;


(*
   putTypeInternal - marks type, des, as being an internally generated type.
*)

PROCEDURE putTypeInternal (des: node) ;
BEGIN
   assert (des#NIL) ;
   assert (isType (des)) ;
   des^.typeF.isInternal := TRUE
END putTypeInternal ;


(*
   isTypeInternal - returns TRUE if type, n, is internal.
*)

PROCEDURE isTypeInternal (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   assert (isType (n)) ;
   RETURN n^.typeF.isInternal
END isTypeInternal ;


(*
   putConst - places value, v, into node, n.
*)

PROCEDURE putConst (n: node; v: node) ;
BEGIN
   assert (isConst (n)) ;
   n^.constF.value := v
END putConst ;


(*
   makeLiteralInt - creates and returns a literal node based on an integer type.
*)

PROCEDURE makeLiteralInt (n: Name) : node ;
VAR
   m: node ;
   s: String ;
BEGIN
   m := newNode (literal) ;
   s := InitStringCharStar (keyToCharStar (n)) ;
   WITH m^ DO
      literalF.name := n ;
      IF DynamicStrings.char (s, -1)='C'
      THEN
         literalF.type := charN
      ELSE
         literalF.type := ztypeN
      END
   END ;
   s := KillString (s) ;
   RETURN m
END makeLiteralInt ;


(*
   makeLiteralReal - creates and returns a literal node based on a real type.
*)

PROCEDURE makeLiteralReal (n: Name) : node ;
VAR
   m: node ;
BEGIN
   m := newNode (literal) ;
   WITH m^ DO
      literalF.name := n ;
      literalF.type := rtypeN
   END ;
   RETURN m
END makeLiteralReal ;


(*
   makeString - creates and returns a node containing string, n.
*)

PROCEDURE makeString (n: Name) : node ;
VAR
   m: node ;
BEGIN
   m := newNode (string) ;
   WITH m^ DO
      stringF.name := n ;
      stringF.length := lengthKey (n) ;
      stringF.isCharCompatible := (stringF.length <= 3) ;
      stringF.cstring := toCstring (n) ;
      stringF.clength := lenCstring (stringF.cstring) ;
      IF stringF.isCharCompatible
      THEN
         stringF.cchar := toCchar (n)
      ELSE
         stringF.cchar := NIL
      END
   END ;
   RETURN m
END makeString ;


(*
   getBuiltinConst - creates and returns a builtin const if available.
*)

PROCEDURE getBuiltinConst (n: Name) : node ;
BEGIN
   IF n=makeKey ('BITS_PER_UNIT')
   THEN
      RETURN bitsperunitN
   ELSIF n=makeKey ('BITS_PER_WORD')
   THEN
      RETURN bitsperwordN
   ELSIF n=makeKey ('BITS_PER_CHAR')
   THEN
      RETURN bitspercharN
   ELSIF n=makeKey ('UNITS_PER_WORD')
   THEN
      RETURN unitsperwordN
   ELSE
      RETURN NIL
   END
END getBuiltinConst ;


(*
   lookupInScope - looks up a symbol named, n, from, scope.
*)

PROCEDURE lookupInScope (scope: node; n: Name) : node ;
BEGIN
   CASE scope^.kind OF

   def      :  RETURN getSymKey (scope^.defF.decls.symbols, n) |
   module   :  RETURN getSymKey (scope^.moduleF.decls.symbols, n) |
   imp      :  RETURN getSymKey (scope^.impF.decls.symbols, n) |
   procedure:  RETURN getSymKey (scope^.procedureF.decls.symbols, n) |
   record   :  RETURN getSymKey (scope^.recordF.localSymbols, n)

   END
END lookupInScope ;


(*
   lookupBase - return node named n from the base symbol scope.
*)

PROCEDURE lookupBase (n: Name) : node ;
VAR
   m: node ;
BEGIN
   m := getSymKey (baseSymbols, n) ;
   IF m=procN
   THEN
      keyc.useProc
   ELSIF (m=complexN) OR (m=longcomplexN) OR (m=shortcomplexN)
   THEN
      keyc.useComplex
   END ;
   RETURN m
END lookupBase ;


(*
   dumpScopes - display the names of all the scopes stacked.
*)

PROCEDURE dumpScopes ;
VAR
   h: CARDINAL ;
   s: node ;
BEGIN
   h := HighIndice (scopeStack) ;
   printf ("total scopes stacked %d\n", h);

   WHILE h>=1 DO
      s := GetIndice (scopeStack, h) ;
      out2 (" scope [%d] is %s\n", h, s) ;
      DEC (h)
   END
END dumpScopes ;


(*
   out0 - write string a to StdOut.
*)

PROCEDURE out0 (a: ARRAY OF CHAR) ;
VAR
   m: String ;
BEGIN
   m := Sprintf0 (InitString (a)) ;
   m := KillString (WriteS (StdOut, m))
END out0 ;


(*
   out1 - write string a to StdOut using format specifier a.
*)

PROCEDURE out1 (a: ARRAY OF CHAR; s: node) ;
VAR
   m: String ;
   d: CARDINAL ;
BEGIN
   m := getFQstring (s) ;
   IF EqualArray (m, '')
   THEN
      d := VAL (CARDINAL, VAL (LONGCARD, s)) ;
      m := KillString (m) ;
      m := Sprintf1 (InitString ('[%d]'), d)
   END ;
   m := Sprintf1 (InitString (a), m) ;
   m := KillString (WriteS (StdOut, m))
END out1 ;


(*
   out2 - write string a to StdOut using format specifier a.
*)

PROCEDURE out2 (a: ARRAY OF CHAR; c: CARDINAL; s: node) ;
VAR
   m, m1: String ;
BEGIN
   m1 := getString (s) ;
   m := Sprintf2 (InitString (a), c, m1) ;
   m := KillString (WriteS (StdOut, m)) ;
   m1 := KillString (m1)
END out2 ;


(*
   out3 - write string a to StdOut using format specifier a.
*)

PROCEDURE out3 (a: ARRAY OF CHAR; l: CARDINAL; n: Name; s: node) ;
VAR
   m, m1, m2: String ;
BEGIN
   m1 := InitStringCharStar (keyToCharStar (n)) ;
   m2 := getString (s) ;
   m := Sprintf3 (InitString (a), l, m1, m2) ;
   m := KillString (WriteS (StdOut, m)) ;
   m1 := KillString (m1) ;
   m2 := KillString (m2)
END out3 ;


(*
   lookupSym - returns the symbol named, n, from the scope stack.
*)

PROCEDURE lookupSym (n: Name) : node ;
VAR
   s, m: node ;
   l, h: CARDINAL ;
BEGIN
   l := LowIndice (scopeStack) ;
   h := HighIndice (scopeStack) ;

   WHILE h>=l DO
      s := GetIndice (scopeStack, h) ;
      m := lookupInScope (s, n) ;
      IF debugScopes AND (m=NIL)
      THEN
         out3 (" [%d] search for symbol name %s in scope %s\n", h, n, s)
      END ;
      IF m#NIL
      THEN
         IF debugScopes
         THEN
            out3 (" [%d] search for symbol name %s in scope %s (found)\n", h, n, s)
         END ;
         RETURN m
      END ;
      DEC (h)
   END ;
   RETURN lookupBase (n)
END lookupSym ;


(*
   getSymName - returns the name of symbol, n.
*)

PROCEDURE getSymName (n: node) : Name ;
BEGIN
   WITH n^ DO
      CASE kind OF

      new             :  RETURN makeKey ('NEW') |
      dispose         :  RETURN makeKey ('DISPOSE') |
      length          :  RETURN makeKey ('LENGTH') |
      inc             :  RETURN makeKey ('INC') |
      dec             :  RETURN makeKey ('DEC') |
      incl            :  RETURN makeKey ('INCL') |
      excl            :  RETURN makeKey ('EXCL') |
      nil             :  RETURN makeKey ('NIL') |
      true            :  RETURN makeKey ('TRUE') |
      false           :  RETURN makeKey ('FALSE') |
      address         :  RETURN makeKey ('ADDRESS') |
      loc             :  RETURN makeKey ('LOC') |
      byte            :  RETURN makeKey ('BYTE') |
      word            :  RETURN makeKey ('WORD') |
      csizet          :  RETURN makeKey ('CSIZE_T') |
      cssizet         :  RETURN makeKey ('CSSIZE_T') |
      (* base types.  *)
      boolean         :  RETURN makeKey ('BOOLEAN') |
      proc            :  RETURN makeKey ('PROC') |
      char            :  RETURN makeKey ('CHAR') |
      cardinal        :  RETURN makeKey ('CARDINAL') |
      longcard        :  RETURN makeKey ('LONGCARD') |
      shortcard       :  RETURN makeKey ('SHORTCARD') |
      integer         :  RETURN makeKey ('INTEGER') |
      longint         :  RETURN makeKey ('LONGINT') |
      shortint        :  RETURN makeKey ('SHORTINT') |
      real            :  RETURN makeKey ('REAL') |
      longreal        :  RETURN makeKey ('LONGREAL') |
      shortreal       :  RETURN makeKey ('SHORTREAL') |
      bitset          :  RETURN makeKey ('BITSET') |
      ztype           :  RETURN makeKey ('_ZTYPE') |
      rtype           :  RETURN makeKey ('_RTYPE') |
      complex         :  RETURN makeKey ('COMPLEX') |
      longcomplex     :  RETURN makeKey ('LONGCOMPLEX') |
      shortcomplex    :  RETURN makeKey ('SHORTCOMPLEX') |

      (* language features and compound type attributes.  *)
      type            :  RETURN typeF.name |
      record          :  RETURN NulName |
      varient         :  RETURN NulName |
      var             :  RETURN varF.name |
      enumeration     :  RETURN NulName |
      subrange        :  RETURN NulName |
      pointer         :  RETURN NulName |
      array           :  RETURN NulName |
      string          :  RETURN stringF.name |
      const           :  RETURN constF.name |
      literal         :  RETURN literalF.name |
      varparam        :  RETURN NulName |
      param           :  RETURN NulName |
      optarg          :  RETURN NulName |
      recordfield     :  RETURN recordfieldF.name |
      varientfield    :  RETURN varientfieldF.name |
      enumerationfield:  RETURN enumerationfieldF.name |
      set             :  RETURN NulName |
      proctype        :  RETURN NulName |
      subscript       :  RETURN NulName |
      (* blocks.  *)
      procedure       :  RETURN procedureF.name |
      def             :  RETURN defF.name |
      imp             :  RETURN impF.name |
      module          :  RETURN moduleF.name |
      (* statements.  *)
      loop,
      while,
      for,
      repeat,
      if,
      elsif,
      assignment      :  RETURN NulName |
      (* expressions.  *)
      constexp,
      deref,
      arrayref,
      componentref,
      cast,
      val,
      plus,
      sub,
      div,
      mod,
      mult,
      divide,
      in,
      neg,
      equal,
      notequal,
      less,
      greater,
      greequal,
      lessequal       :  RETURN NulName |
      adr             :  RETURN makeKey ('ADR') |
      size            :  RETURN makeKey ('SIZE') |
      tsize           :  RETURN makeKey ('TSIZE') |
      chr             :  RETURN makeKey ('CHR') |
      abs             :  RETURN makeKey ('ABS') |
      ord             :  RETURN makeKey ('ORD') |
      float           :  RETURN makeKey ('FLOAT') |
      trunc           :  RETURN makeKey ('TRUNC') |
      high            :  RETURN makeKey ('HIGH') |
      throw           :  RETURN makeKey ('THROW') |
      unreachable     :  RETURN makeKey ('builtin_unreachable') |
      cmplx           :  RETURN makeKey ('CMPLX') |
      re              :  RETURN makeKey ('RE') |
      im              :  RETURN makeKey ('IM') |
      max             :  RETURN makeKey ('MAX') |
      min             :  RETURN makeKey ('MIN') |
      pointerref      :  RETURN NulName |
      funccall        :  RETURN NulName |
      identlist       :  RETURN NulName

      ELSE
         HALT
      END
   END
END getSymName ;


(*
   isUnary - returns TRUE if, n, is an unary node.
*)

PROCEDURE isUnary (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   CASE n^.kind OF

   length,
   re,
   im,
   deref,
   high,
   chr,
   cap,
   abs,
   ord,
   float,
   trunc,
   constexp,
   not,
   neg,
   adr,
   size,
   tsize,
   min,
   max     :  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isUnary ;


(*
   isBinary - returns TRUE if, n, is an binary node.
*)

PROCEDURE isBinary (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   CASE n^.kind OF

   cmplx,
   and,
   or,
   equal,
   notequal,
   less,
   greater,
   greequal,
   lessequal,
   val,
   cast,
   plus,
   sub,
   div,
   mod,
   mult,
   divide,
   in      :  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isBinary ;


(*
   makeUnary - create a unary expression node with, e, as the argument
               and res as the return type.
*)

PROCEDURE makeUnary (k: nodeT; e: node; res: node) : node ;
VAR
   n: node ;
BEGIN
   IF k=plus
   THEN
      RETURN e
   ELSE
      n := newNode (k) ;
      WITH n^ DO
         CASE kind OF

         min,
         max,
         throw,
         re,
         im,
         deref,
         high,
         chr,
	 cap,
         abs,
         ord,
         float,
         trunc,
         length,
         constexp,
         not,
         neg,
         adr,
         size,
         tsize:  WITH unaryF DO
                    arg := e ;
                    resultType := res
                 END

         END
      END
   END ;
   RETURN n
END makeUnary ;


(*
   isLeafString - returns TRUE if n is a leaf node which is a string constant.
*)

PROCEDURE isLeafString (n: node) : BOOLEAN ;
BEGIN
   RETURN isString (n) OR
          (isLiteral (n) AND (getType (n) = charN)) OR
	  (isConst (n) AND (getExprType (n) = charN))
END isLeafString ;


(*
   getLiteralStringContents - return the contents of a literal node as a string.
*)

PROCEDURE getLiteralStringContents (n: node) : String ;
VAR
   number,
   content,
   s      : String ;
BEGIN
   assert (n^.kind = literal) ;
   s := InitStringCharStar (keyToCharStar (n^.literalF.name)) ;
   content := NIL ;
   IF n^.literalF.type = charN
   THEN
      IF DynamicStrings.char (s, -1) = 'C'
      THEN
         IF DynamicStrings.Length (s) > 1
         THEN
            number := DynamicStrings.Slice (s, 0, -1) ;
            content := DynamicStrings.InitStringChar (VAL (CHAR, ostoc (number))) ;
            number := DynamicStrings.KillString (number)
         ELSE
            content := DynamicStrings.InitStringChar ('C')
         END
      ELSE
         content := DynamicStrings.Dup (s)
      END
   ELSE
      metaError1 ('cannot obtain string contents from {%1k}', n^.literalF.name)
   END ;
   s := DynamicStrings.KillString (s) ;
   RETURN content
END getLiteralStringContents ;


(*
   getStringContents - return the string contents of a constant, literal,
                       string or a constexp node.
*)

PROCEDURE getStringContents (n: node) : String ;
BEGIN
   IF isConst (n)
   THEN
      RETURN getStringContents (n^.constF.value)
   ELSIF isLiteral (n)
   THEN
      RETURN getLiteralStringContents (n)
   ELSIF isString (n)
   THEN
      RETURN getString (n)
   ELSIF isConstExp (n)
   THEN
      RETURN getStringContents (n^.unaryF.arg)
   END ;
   HALT
END getStringContents ;


(*
   addNames -
*)

PROCEDURE addNames (a, b: node) : Name ;
VAR
   sa, sb: String ;
   n     : Name ;
BEGIN
   sa := DynamicStrings.InitStringCharStar (keyToCharStar (getSymName (a))) ;
   sb := DynamicStrings.InitStringCharStar (keyToCharStar (getSymName (b))) ;
   sa := ConCat (sa, sb) ;
   n := makekey (DynamicStrings.string (sa)) ;
   sa := KillString (sa) ;
   sb := KillString (sb) ;
   RETURN n
END addNames ;


(*
   resolveString -
*)

PROCEDURE resolveString (n: node) : node ;
BEGIN
   WHILE isConst (n) OR isConstExp (n) DO
      IF isConst (n)
      THEN
         n := n^.constF.value
      ELSE
         n := n^.unaryF.arg
      END
   END ;
   IF n^.kind = plus
   THEN
      n := makeString (addNames (resolveString (n^.binaryF.left),
                                 resolveString (n^.binaryF.right)))
   END ;
   RETURN n
END resolveString ;


(*
   foldBinary -
*)

PROCEDURE foldBinary (k: nodeT; l, r: node; res: node) : node ;
VAR
   n : node ;
   ls,
   rs: String ;
BEGIN
   n := NIL ;
   IF (k = plus) AND isLeafString (l) AND isLeafString (r)
   THEN
      ls := getStringContents (l) ;
      rs := getStringContents (r) ;
      ls := DynamicStrings.Add (ls, rs) ;
      n := makeString (makekey (DynamicStrings.string (ls))) ;
      ls := DynamicStrings.KillString (ls) ;
      rs := DynamicStrings.KillString (rs)
   END ;
   RETURN n
END foldBinary ;


(*
   makeBinary - create a binary node with left/right/result type:  l, r and resultType.
*)

PROCEDURE makeBinary (k: nodeT; l, r: node; resultType: node) : node ;
VAR
   n: node ;
BEGIN
   n := foldBinary (k, l, r, resultType) ;
   IF n = NIL
   THEN
      n := doMakeBinary (k, l, r, resultType)
   END ;
   RETURN n
END makeBinary ;


(*
   doMakeBinary - returns a binary node containing left/right/result values
                  l, r, res, with a node operator, k.
*)

PROCEDURE doMakeBinary (k: nodeT; l, r: node; res: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (k) ;
   WITH n^ DO
      CASE kind OF

      cmplx,
      equal,
      notequal,
      less,
      greater,
      greequal,
      lessequal,
      and,
      or,
      cast,
      val,
      plus,
      sub,
      div,
      mod,
      mult,
      divide,
      in  :  WITH binaryF DO
                left := l ;
                right := r ;
                resultType := res
             END

      END
   END ;
   RETURN n
END doMakeBinary ;


(*
   doMakeComponentRef -
*)

PROCEDURE doMakeComponentRef (rec, field: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (componentref) ;
   n^.componentrefF.rec := rec ;
   n^.componentrefF.field := field ;
   n^.componentrefF.resultType := getType (field) ;
   RETURN n
END doMakeComponentRef ;


(*
   makeComponentRef - build a componentref node which accesses, field,
                      within, record, rec.
*)

PROCEDURE makeComponentRef (rec, field: node) : node ;
VAR
   n, a: node ;
BEGIN
(*
   n := getLastOp (rec) ;
   IF (n#NIL) AND (isDeref (n) OR isPointerRef (n)) AND
      (skipType (getType (rec)) = skipType (getType (n)))
   THEN
      a := n^.unaryF.arg ;
      n^.kind := pointerref ;
      n^.pointerrefF.ptr := a ;
      n^.pointerrefF.field := field ;
      n^.pointerrefF.resultType := getType (field) ;
      RETURN n
   ELSE
      RETURN doMakeComponentRef (rec, field)
   END
*)
   IF isDeref (rec)
   THEN
      a := rec^.unaryF.arg ;
      rec^.kind := pointerref ;
      rec^.pointerrefF.ptr := a ;
      rec^.pointerrefF.field := field ;
      rec^.pointerrefF.resultType := getType (field) ;
      RETURN rec
   ELSE
      RETURN doMakeComponentRef (rec, field)
   END
END makeComponentRef ;


(*
   isComponentRef -
*)

PROCEDURE isComponentRef (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = componentref
END isComponentRef ;


(*
   makePointerRef - build a pointerref node which accesses, field,
                    within, pointer to record, ptr.
*)

PROCEDURE makePointerRef (ptr, field: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (pointerref) ;
   n^.pointerrefF.ptr := ptr ;
   n^.pointerrefF.field := field ;
   n^.pointerrefF.resultType := getType (field) ;
   RETURN n
END makePointerRef ;


(*
   isPointerRef - returns TRUE if, n, is a pointerref node.
*)

PROCEDURE isPointerRef (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = pointerref
END isPointerRef ;


(*
   makeArrayRef - build an arrayref node which access element,
                  index, in, array.  array is a variable/expression/constant
                  which has a type array.
*)

PROCEDURE makeArrayRef (array, index: node) : node ;
VAR
   n, t: node ;
   i, j: CARDINAL ;
BEGIN
   n := newNode (arrayref) ;
   n^.arrayrefF.array := array ;
   n^.arrayrefF.index := index ;
   t := array ;
   j := expListLen (index) ;
   i := 1 ;
   t := skipType (getType (t)) ;
   REPEAT
      IF isArray (t)
      THEN
         t := skipType (getType (t))
      ELSE
         metaError2 ('cannot access {%1N} dimension of array {%2a}', i, t)
      END ;
      INC (i)
   UNTIL i > j ;
   n^.arrayrefF.resultType := t ;
   RETURN n
END makeArrayRef ;


(*
   isArrayRef - returns TRUE if the node was an arrayref.
*)

PROCEDURE isArrayRef (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = arrayref
END isArrayRef ;


(*
   makeDeRef - dereferences the pointer defined by, n.
*)

PROCEDURE makeDeRef (n: node) : node ;
VAR
   t: node ;
BEGIN
   t := skipType (getType (n)) ;
   assert (isPointer (t)) ;
   RETURN makeUnary (deref, n, getType (t))
END makeDeRef ;


(*
   isDeref - returns TRUE if, n, is a deref node.
*)

PROCEDURE isDeref (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = deref
END isDeref ;


(*
   makeBase - create a base type or constant.
              It only supports the base types and constants
              enumerated below.
*)

PROCEDURE makeBase (k: nodeT) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (k) ;
   WITH n^ DO
      CASE k OF

      new,
      dispose,
      length,
      inc,
      dec,
      incl,
      excl,
      nil,
      true,
      false,
      address,
      loc,
      byte,
      word,
      csizet,
      cssizet,
      char,
      cardinal,
      longcard,
      shortcard,
      integer,
      longint,
      shortint,
      real,
      longreal,
      shortreal,
      bitset,
      boolean,
      proc,
      ztype,
      rtype,
      complex,
      longcomplex,
      shortcomplex,
      adr,
      chr,
      cap,
      abs,
      float,
      trunc,
      ord,
      high,
      throw,
      re,
      im,
      cmplx,
      size,
      tsize,
      val,
      min,
      max     :  (* legal kind.  *) |

      ELSE
         HALT
      END
   END ;
   RETURN n
END makeBase ;


(*
   makeBinaryTok - creates and returns a boolean type node with,
                   l, and, r, nodes.
*)

PROCEDURE makeBinaryTok (op: toktype; l, r: node) : node ;
BEGIN
   IF op=equaltok
   THEN
      RETURN makeBinary (equal, l, r, booleanN)
   ELSIF (op=hashtok) OR (op=lessgreatertok)
   THEN
      RETURN makeBinary (notequal, l, r, booleanN)
   ELSIF op=lesstok
   THEN
      RETURN makeBinary (less, l, r, booleanN)
   ELSIF op=greatertok
   THEN
      RETURN makeBinary (greater, l, r, booleanN)
   ELSIF op=greaterequaltok
   THEN
      RETURN makeBinary (greequal, l, r, booleanN)
   ELSIF op=lessequaltok
   THEN
      RETURN makeBinary (lessequal, l, r, booleanN)
   ELSIF op=andtok
   THEN
      RETURN makeBinary (and, l, r, booleanN)
   ELSIF op=ortok
   THEN
      RETURN makeBinary (or, l, r, booleanN)
   ELSIF op=plustok
   THEN
      RETURN makeBinary (plus, l, r, NIL)
   ELSIF op=minustok
   THEN
      RETURN makeBinary (sub, l, r, NIL)
   ELSIF op=divtok
   THEN
      RETURN makeBinary (div, l, r, NIL)
   ELSIF op=timestok
   THEN
      RETURN makeBinary (mult, l, r, NIL)
   ELSIF op=modtok
   THEN
      RETURN makeBinary (mod, l, r, NIL)
   ELSIF op=intok
   THEN
      RETURN makeBinary (in, l, r, NIL)
   ELSIF op=dividetok
   THEN
      RETURN makeBinary (divide, l, r, NIL)
   ELSE
      HALT  (* most likely op needs a clause as above.  *)
   END
END makeBinaryTok ;


(*
   makeUnaryTok - creates and returns a boolean type node with,
                  e, node.
*)

PROCEDURE makeUnaryTok (op: toktype; e: node) : node ;
BEGIN
   IF op=nottok
   THEN
      RETURN makeUnary (not, e, booleanN)
   ELSIF op=plustok
   THEN
      RETURN makeUnary (plus, e, NIL)
   ELSIF op=minustok
   THEN
      RETURN makeUnary (neg, e, NIL)
   ELSE
      HALT  (* most likely op needs a clause as above.  *)
   END
END makeUnaryTok ;


(*
   isOrdinal - returns TRUE if, n, is an ordinal type.
*)

PROCEDURE isOrdinal (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   address,
   loc,
   byte,
   word,
   csizet,
   cssizet,
   char,
   integer,
   longint,
   shortint,
   cardinal,
   longcard,
   shortcard,
   bitset   :  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isOrdinal ;


(*
   getType - returns the type associated with node, n.
*)

PROCEDURE getType (n: node) : node ;
BEGIN
   WITH n^ DO
      CASE kind OF

      new,
      dispose         :  RETURN NIL |
      length          :  RETURN cardinalN |
      inc,
      dec,
      incl,
      excl            :  RETURN NIL |
      nil             :  RETURN addressN |
      true,
      false           :  RETURN booleanN |
      address         :  RETURN n |
      loc             :  RETURN n |
      byte            :  RETURN n |
      word            :  RETURN n |
      csizet          :  RETURN n |
      cssizet         :  RETURN n |
      (* base types.  *)
      boolean         :  RETURN n |
      proc            :  RETURN n |
      char            :  RETURN n |
      cardinal        :  RETURN n |
      longcard        :  RETURN n |
      shortcard       :  RETURN n |
      integer         :  RETURN n |
      longint         :  RETURN n |
      shortint        :  RETURN n |
      real            :  RETURN n |
      longreal        :  RETURN n |
      shortreal       :  RETURN n |
      bitset          :  RETURN n |
      ztype           :  RETURN n |
      rtype           :  RETURN n |
      complex         :  RETURN n |
      longcomplex     :  RETURN n |
      shortcomplex    :  RETURN n |

      (* language features and compound type attributes.  *)
      type            :  RETURN typeF.type |
      record          :  RETURN n |
      varient         :  RETURN n |
      var             :  RETURN varF.type |
      enumeration     :  RETURN n |
      subrange        :  RETURN subrangeF.type |
      array           :  RETURN arrayF.type |
      string          :  RETURN charN |
      const           :  RETURN constF.type |
      literal         :  RETURN literalF.type |
      varparam        :  RETURN varparamF.type |
      param           :  RETURN paramF.type |
      optarg          :  RETURN optargF.type |
      pointer         :  RETURN pointerF.type |
      recordfield     :  RETURN recordfieldF.type |
      varientfield    :  RETURN n |
      enumerationfield:  RETURN enumerationfieldF.type |
      set             :  RETURN setF.type |
      proctype        :  RETURN proctypeF.returnType |
      subscript       :  RETURN subscriptF.type |
      (* blocks.  *)
      procedure       :  RETURN procedureF.returnType |
      throw           :  RETURN NIL |
      unreachable     :  RETURN NIL |
      def,
      imp,
      module,
      (* statements.  *)
      loop,
      while,
      for,
      repeat,
      if,
      elsif,
      assignment      :  HALT |
      (* expressions.  *)
      cmplx,
      cast,
      val,
      plus,
      sub,
      div,
      mod,
      mult,
      divide          :  RETURN binaryF.resultType |
      in              :  RETURN booleanN |
      max,
      min,
      re,
      im,
      abs,
      constexp,
      deref,
      neg,
      adr,
      size,
      tsize           :  RETURN unaryF.resultType |
      and,
      or,
      not,
      equal,
      notequal,
      less,
      greater,
      greequal,
      lessequal       :  RETURN booleanN |
      trunc           :  RETURN integerN |
      float           :  RETURN realN |
      high            :  RETURN cardinalN |
      ord             :  RETURN cardinalN |
      chr             :  RETURN charN |
      cap             :  RETURN charN |
      arrayref        :  RETURN arrayrefF.resultType |
      componentref    :  RETURN componentrefF.resultType |
      pointerref      :  RETURN pointerrefF.resultType |
      funccall        :  RETURN funccallF.type |
      setvalue        :  RETURN setvalueF.type

      END
   END ;
   HALT
END getType ;


(*
   mixTypes -
*)

PROCEDURE mixTypes (a, b: node) : node ;
BEGIN
   IF (a = addressN) OR (b = addressN)
   THEN
      RETURN addressN
   END ;
   RETURN a
END mixTypes ;


(*
   doSetExprType -
*)

PROCEDURE doSetExprType (VAR t: node; n: node) : node ;
BEGIN
   IF t = NIL
   THEN
      t := n
   END ;
   RETURN t
END doSetExprType ;


(*
   getMaxMinType -
*)

PROCEDURE getMaxMinType (n: node) : node ;
BEGIN
   IF isVar (n) OR isConst (n)
   THEN
      RETURN getType (n)
   ELSIF isConstExp (n)
   THEN
      n := getExprType (n^.unaryF.arg) ;
      IF n = bitsetN
      THEN
         RETURN ztypeN
      ELSE
         RETURN n
      END
   ELSE
      RETURN n
   END
END getMaxMinType ;


(*
   doGetFuncType -
*)

PROCEDURE doGetFuncType (n: node) : node ;
BEGIN
   assert (isFuncCall (n)) ;
   RETURN doSetExprType (n^.funccallF.type, getType (n^.funccallF.function))
END doGetFuncType ;


(*
   doGetExprType - works out the type which is associated with node, n.
*)

PROCEDURE doGetExprType (n: node) : node ;
BEGIN
   WITH n^ DO
      CASE kind OF

      max,
      min             :  RETURN getMaxMinType (n^.unaryF.arg) |
      cast,
      val             :  RETURN doSetExprType (n^.binaryF.resultType, n^.binaryF.left) |
      halt,
      new,
      dispose         :  RETURN NIL |
      inc,
      dec,
      incl,
      excl            :  RETURN NIL |
      nil             :  RETURN addressN |
      true,
      false           :  RETURN booleanN |
      address         :  RETURN n |
      loc             :  RETURN n |
      byte            :  RETURN n |
      word            :  RETURN n |
      csizet          :  RETURN n |
      cssizet         :  RETURN n |
      (* base types.  *)
      boolean         :  RETURN n |
      proc            :  RETURN n |
      char            :  RETURN n |
      cardinal        :  RETURN n |
      longcard        :  RETURN n |
      shortcard       :  RETURN n |
      integer         :  RETURN n |
      longint         :  RETURN n |
      shortint        :  RETURN n |
      real            :  RETURN n |
      longreal        :  RETURN n |
      shortreal       :  RETURN n |
      bitset          :  RETURN n |
      ztype           :  RETURN n |
      rtype           :  RETURN n |
      complex         :  RETURN n |
      longcomplex     :  RETURN n |
      shortcomplex    :  RETURN n |

      (* language features and compound type attributes.  *)
      type            :  RETURN typeF.type |
      record          :  RETURN n |
      varient         :  RETURN n |
      var             :  RETURN varF.type |
      enumeration     :  RETURN n |
      subrange        :  RETURN subrangeF.type |
      array           :  RETURN arrayF.type |
      string          :  RETURN charN |
      const           :  RETURN doSetExprType (constF.type, getExprType (constF.value)) |
      literal         :  RETURN literalF.type |
      varparam        :  RETURN varparamF.type |
      param           :  RETURN paramF.type |
      optarg          :  RETURN optargF.type |
      pointer         :  RETURN pointerF.type |
      recordfield     :  RETURN recordfieldF.type |
      varientfield    :  RETURN n |
      enumerationfield:  RETURN enumerationfieldF.type |
      set             :  RETURN setF.type |
      proctype        :  RETURN proctypeF.returnType |
      subscript       :  RETURN subscriptF.type |
      (* blocks.  *)
      procedure       :  RETURN procedureF.returnType |
      throw           :  RETURN NIL |
      unreachable     :  RETURN NIL |
      def,
      imp,
      module,
      (* statements.  *)
      loop,
      while,
      for,
      repeat,
      if,
      elsif,
      assignment      :  HALT |
      (* expressions.  *)
      plus,
      sub,
      div,
      mod,
      mult,
      divide          :  RETURN doSetExprType (binaryF.resultType, mixTypes (getExprType (binaryF.left), getExprType (binaryF.right))) |
      in,
      and,
      or,
      equal,
      notequal,
      less,
      greater,
      greequal,
      lessequal       :  RETURN doSetExprType (binaryF.resultType, booleanN) |
      cmplx           :  RETURN doSetExprType (binaryF.resultType, complexN) |
      abs,
      constexp,
      deref,
      neg             :  RETURN doSetExprType (unaryF.resultType, getExprType (unaryF.arg)) |
      adr             :  RETURN doSetExprType (unaryF.resultType, addressN) |
      size,
      tsize           :  RETURN doSetExprType (unaryF.resultType, cardinalN) |
      high,
      ord             :  RETURN doSetExprType (unaryF.resultType, cardinalN) |
      float           :  RETURN doSetExprType (unaryF.resultType, realN) |
      trunc           :  RETURN doSetExprType (unaryF.resultType, integerN) |
      chr             :  RETURN doSetExprType (unaryF.resultType, charN) |
      cap             :  RETURN doSetExprType (unaryF.resultType, charN) |
      not             :  RETURN doSetExprType (unaryF.resultType, booleanN) |
      re              :  RETURN doSetExprType (unaryF.resultType, realN) |
      im              :  RETURN doSetExprType (unaryF.resultType, realN) |
      arrayref        :  RETURN arrayrefF.resultType |
      componentref    :  RETURN componentrefF.resultType |
      pointerref      :  RETURN pointerrefF.resultType |
      funccall        :  RETURN doSetExprType (funccallF.type, doGetFuncType (n)) |
      setvalue        :  RETURN setvalueF.type

      END
   END ;
   HALT
END doGetExprType ;


(*
   getExprType - return the expression type.
*)

PROCEDURE getExprType (n: node) : node ;
VAR
   t: node ;
BEGIN
   IF isFuncCall (n) AND (getType (n) # NIL) AND isProcType (skipType (getType (n)))
   THEN
      RETURN getType (skipType (getType (n)))
   END ;
   t := getType (n) ;
   IF t = NIL
   THEN
      t := doGetExprType (n)
   END ;
   RETURN t
END getExprType ;


(*
   skipType - skips over type aliases.
*)

PROCEDURE skipType (n: node) : node ;
BEGIN
   WHILE (n#NIL) AND isType (n) DO
      IF getType (n) = NIL
      THEN
         (* this will occur if, n, is an opaque type.  *)
         RETURN n
      END ;
      n := getType (n)
   END ;
   RETURN n
END skipType ;


(*
   getScope - returns the scope associated with node, n.
*)

PROCEDURE getScope (n: node) : node ;
BEGIN
   WITH n^ DO
      CASE kind OF

      stmtseq,
      exit,
      return,
      comment,
      identlist,
      setvalue,
      halt,
      new,
      dispose,
      length,
      inc,
      dec,
      incl,
      excl,
      nil,
      true,
      false           :  RETURN NIL |
      address,
      loc,
      byte,
      word,
      csizet,
      cssizet         : RETURN systemN |
      (* base types.  *)
      boolean,
      proc,
      char,
      cardinal,
      longcard,
      shortcard,
      integer,
      longint,
      shortint,
      real,
      longreal,
      shortreal,
      bitset,
      ztype,
      rtype,
      complex,
      longcomplex,
      shortcomplex    :  RETURN NIL |
      (* language features and compound type attributes.  *)
      type            :  RETURN typeF.scope |
      record          :  RETURN recordF.scope |
      varient         :  RETURN varientF.scope |
      var             :  RETURN varF.scope |
      enumeration     :  RETURN enumerationF.scope |
      subrange        :  RETURN subrangeF.scope |
      array           :  RETURN arrayF.scope |
      string          :  RETURN NIL |
      const           :  RETURN constF.scope |
      literal         :  RETURN NIL |
      varparam        :  RETURN varparamF.scope |
      param           :  RETURN paramF.scope |
      optarg          :  RETURN optargF.scope |
      pointer         :  RETURN pointerF.scope |
      recordfield     :  RETURN recordfieldF.scope |
      varientfield    :  RETURN varientfieldF.scope |
      enumerationfield:  RETURN enumerationfieldF.scope |
      set             :  RETURN setF.scope |
      proctype        :  RETURN proctypeF.scope |
      subscript       :  RETURN NIL |
      (* blocks.  *)
      procedure       :  RETURN procedureF.scope |
      def,
      imp,
      module,
      (* statements.  *)
      case,
      loop,
      while,
      for,
      repeat,
      if,
      elsif,
      assignment      :  RETURN NIL |
      (* expressions.  *)
      componentref,
      pointerref,
      arrayref,
      chr,
      cap,
      ord,
      float,
      trunc,
      high,
      cast,
      val,
      plus,
      sub,
      div,
      mod,
      mult,
      divide,
      in              :  RETURN NIL |
      neg             :  RETURN NIL |
      lsl,
      lsr,
      lor,
      land,
      lnot,
      lxor,
      and,
      or,
      not,
      constexp,
      deref,
      equal,
      notequal,
      less,
      greater,
      greequal,
      lessequal       :  RETURN NIL |
      adr,
      size,
      tsize,
      throw           :  RETURN systemN |
      unreachable,
      cmplx, re, im,
      min,
      max             :  RETURN NIL |
      vardecl         :  RETURN vardeclF.scope |
      funccall        :  RETURN NIL |
      explist         :  RETURN NIL |
      caselabellist   :  RETURN NIL |
      caselist        :  RETURN NIL |
      range           :  RETURN NIL |
      varargs         :  RETURN varargsF.scope

      END
   END
END getScope ;


(*
   foreachDefModuleDo - foreach definition node, n, in the module universe,
                        call p (n).
*)

PROCEDURE foreachDefModuleDo (p: performOperation) ;
BEGIN
   ForeachIndiceInIndexDo (defUniverseI, p)
END foreachDefModuleDo ;


(*
   foreachModModuleDo - foreach implementation or module node, n, in the module universe,
                        call p (n).
*)

PROCEDURE foreachModModuleDo (p: performOperation) ;
BEGIN
   ForeachIndiceInIndexDo (modUniverseI, p)
END foreachModModuleDo ;


(*
   openOutput -
*)

PROCEDURE openOutput ;
VAR
   s: String ;
BEGIN
   s := getOutputFile () ;
   IF EqualArray (s, '-')
   THEN
      outputFile := StdOut
   ELSE
      outputFile := OpenToWrite (s)
   END ;
   mcStream.setDest (outputFile)
END openOutput ;


(*
   closeOutput -
*)

PROCEDURE closeOutput ;
VAR
   s: String ;
BEGIN
   s := getOutputFile () ;
   outputFile := mcStream.combine () ;
   IF NOT EqualArray (s, '-')
   THEN
      Close (outputFile)
   END
END closeOutput ;


(*
   write - outputs a single char, ch.
*)

PROCEDURE write (ch: CHAR) ;
BEGIN
   WriteChar (outputFile, ch) ;
   FlushBuffer (outputFile)
END write ;


(*
   writeln -
*)

PROCEDURE writeln ;
BEGIN
   WriteLine (outputFile) ;
   FlushBuffer (outputFile)
END writeln ;


(*
   doIncludeC - include header file for definition module, n.
*)

PROCEDURE doIncludeC (n: node) ;
VAR
   s: String ;
BEGIN
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   IF getExtendedOpaque ()
   THEN
      (* no include in this case.  *)
   ELSIF isDef (n)
   THEN
      print (doP, '#   include "') ;
      prints (doP, getHPrefix ()) ;
      prints (doP, s) ;
      print (doP, '.h"\n') ;
      foreachNodeDo (n^.defF.decls.symbols, addDoneDef)
   END ;
   s := KillString (s)
END doIncludeC ;


(*
   getSymScope - returns the scope where node, n, was declared.
*)

PROCEDURE getSymScope (n: node) : node ;
BEGIN
   WITH n^ DO
      CASE kind OF

      const    :  RETURN constF.scope |
      type     :  RETURN typeF.scope |
      var      :  RETURN varF.scope |
      procedure:  RETURN procedureF.scope

      END
   END ;
   HALT
END getSymScope ;


(*
   isQualifiedForced - should the node be written with a module prefix?
*)

PROCEDURE isQualifiedForced (n: node) : BOOLEAN ;
BEGIN
   RETURN (forceQualified AND
           (isType (n) OR isRecord (n) OR isArray (n) OR isEnumeration (n) OR isEnumerationField (n)))
END isQualifiedForced ;


(*
   getFQstring -
*)

PROCEDURE getFQstring (n: node) : String ;
VAR
   i, s: String ;
BEGIN
   IF getScope (n) = NIL
   THEN
      RETURN InitStringCharStar (keyToCharStar (getSymName (n)))
   ELSIF isQualifiedForced (n)
   THEN
      i := InitStringCharStar (keyToCharStar (getSymName (n))) ;
      s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ;
      RETURN Sprintf2 (InitString ("%s_%s"), s, i)
   ELSIF (NOT isExported (n)) OR getIgnoreFQ ()
   THEN
      RETURN InitStringCharStar (keyToCharStar (getSymName (n)))
   ELSE
      i := InitStringCharStar (keyToCharStar (getSymName (n))) ;
      s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ;
      RETURN Sprintf2 (InitString ("%s_%s"), s, i)
   END
END getFQstring ;


(*
   getFQDstring -
*)

PROCEDURE getFQDstring (n: node; scopes: BOOLEAN) : String ;
VAR
   i, s: String ;
BEGIN
   IF getScope (n) = NIL
   THEN
      RETURN InitStringCharStar (keyToCharStar (getDName (n, scopes)))
   ELSIF isQualifiedForced (n)
   THEN
      (* we assume a qualified name will never conflict.  *)
      i := InitStringCharStar (keyToCharStar (getSymName (n))) ;
      s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ;
      RETURN Sprintf2 (InitString ("%s_%s"), s, i)
   ELSIF (NOT isExported (n)) OR getIgnoreFQ ()
   THEN
      RETURN InitStringCharStar (keyToCharStar (getDName (n, scopes)))
   ELSE
      (* we assume a qualified name will never conflict.  *)
      i := InitStringCharStar (keyToCharStar (getSymName (n))) ;
      s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ;
      RETURN Sprintf2 (InitString ("%s_%s"), s, i)
   END
END getFQDstring ;


(*
   getString - returns the name as a string.
*)

PROCEDURE getString (n: node) : String ;
BEGIN
   IF getSymName (n) = NulName
   THEN
      RETURN InitString ('')
   ELSE
      RETURN InitStringCharStar (keyToCharStar (getSymName (n)))
   END
END getString ;


(*
   getCardinal - returns the cardinal type node.
*)

PROCEDURE getCardinal () : node ;
BEGIN
   RETURN cardinalN
END getCardinal ;


(*
   doNone - call HALT.
*)

PROCEDURE doNone (n: node) ;
BEGIN
   HALT
END doNone ;


(*
   doNothing - does nothing!
*)

PROCEDURE doNothing (n: node) ;
BEGIN
END doNothing ;


(*
   doConstC -
*)

PROCEDURE doConstC (n: node) ;
BEGIN
   IF NOT alists.isItemInList (doneQ, n)
   THEN
      print (doP, "#   define ") ;
      doFQNameC (doP, n) ;
      setNeedSpace (doP) ;
      doExprC (doP, n^.constF.value) ;
      print (doP, '\n') ;
      alists.includeItemIntoList (doneQ, n)
   END
END doConstC ;


(*
   needsParen - returns TRUE if expression, n, needs to be enclosed in ().
*)

PROCEDURE needsParen (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   WITH n^ DO
      CASE kind OF

      nil,
      true,
      false           :  RETURN FALSE |
      constexp        :  RETURN needsParen (unaryF.arg) |
      neg             :  RETURN needsParen (unaryF.arg) |
      not             :  RETURN needsParen (unaryF.arg) |
      adr,
      size,
      tsize,
      ord,
      float,
      trunc,
      chr,
      cap,
      high            :  RETURN FALSE |
      deref           :  RETURN FALSE |
      equal,
      notequal,
      less,
      greater,
      greequal,
      lessequal       :  RETURN TRUE |
      componentref    :  RETURN FALSE |
      pointerref      :  RETURN FALSE |
      cast            :  RETURN TRUE |
      val             :  RETURN TRUE |
      abs             :  RETURN FALSE |
      plus,
      sub,
      div,
      mod,
      mult,
      divide,
      in              :  RETURN TRUE |
      literal,
      const,
      enumerationfield,
      string          :  RETURN FALSE |
      max             :  RETURN TRUE |
      min             :  RETURN TRUE |
      var             :  RETURN FALSE |
      arrayref        :  RETURN FALSE |
      and,
      or              :  RETURN TRUE |
      funccall        :  RETURN TRUE |
      recordfield     :  RETURN FALSE |
      loc,
      byte,
      word,
      type,
      char,
      cardinal,
      longcard,
      shortcard,
      integer,
      longint,
      shortint,
      real,
      longreal,
      shortreal,
      complex,
      longcomplex,
      shortcomplex,
      bitset,
      boolean,
      proc            :  RETURN FALSE |
      setvalue        :  RETURN FALSE |
      address         :  RETURN TRUE |
      procedure       :  RETURN FALSE |
      length,
      cmplx, re, im   :  RETURN TRUE

      END
   END ;
   RETURN TRUE
END needsParen ;


(*
   doUnary -
*)

PROCEDURE doUnary (p: pretty; op: ARRAY OF CHAR; expr, type: node; l, r: BOOLEAN) ;
BEGIN
   IF l
   THEN
      setNeedSpace (p)
   END ;
   print (p, op) ;
   IF r
   THEN
      setNeedSpace (p)
   END ;
   IF needsParen (expr)
   THEN
      outText (p, '(') ;
      doExprC (p, expr) ;
      outText (p, ')')
   ELSE
      doExprC (p, expr)
   END
END doUnary ;


(*
   doSetSub - perform  l & (~ r)
*)

PROCEDURE doSetSub (p: pretty; left, right: node) ;
BEGIN
   IF needsParen (left)
   THEN
      outText (p, '(') ;
      doExprC (p, left) ;
      outText (p, ')')
   ELSE
      doExprC (p, left)
   END ;
   setNeedSpace (p) ;
   outText (p, '&') ;
   setNeedSpace (p) ;
   IF needsParen (right)
   THEN
      outText (p, '(~(') ;
      doExprC (p, right) ;
      outText (p, '))')
   ELSE
      outText (p, '(~') ;
      doExprC (p, right) ;
      outText (p, ')')
   END
END doSetSub ;


(*
   doPolyBinary -
*)

PROCEDURE doPolyBinary (p: pretty; op: nodeT; left, right: node; l, r: BOOLEAN) ;
VAR
   lt, rt: node ;
BEGIN
   lt := skipType (getExprType (left)) ;
   rt := skipType (getExprType (right)) ;
   IF ((lt # NIL) AND (isSet (lt) OR isBitset (lt))) OR
      ((rt # NIL) AND (isSet (rt) OR isBitset (rt)))
   THEN
      CASE op OF

      plus   :  doBinary (p, '|', left, right, l, r, FALSE) |
      sub    :  doSetSub (p, left, right) |
      mult   :  doBinary (p, '&', left, right, l, r, FALSE) |
      divide :  doBinary (p, '^', left, right, l, r, FALSE)

      END
   ELSE
      CASE op OF

      plus   :  doBinary (p, '+', left, right, l, r, FALSE) |
      sub    :  doBinary (p, '-', left, right, l, r, FALSE) |
      mult   :  doBinary (p, '*', left, right, l, r, FALSE) |
      divide :  doBinary (p, '/', left, right, l, r, FALSE)

      END
   END
END doPolyBinary ;


(*
   doBinary -
*)

PROCEDURE doBinary (p: pretty; op: ARRAY OF CHAR; left, right: node; l, r, unpackProc: BOOLEAN) ;
BEGIN
   IF needsParen (left)
   THEN
      outText (p, '(') ;
      doExprCup (p, left, unpackProc) ;
      outText (p, ')')
   ELSE
      doExprCup (p, left, unpackProc)
   END ;
   IF l
   THEN
      setNeedSpace (p)
   END ;
   outText (p, op) ;
   IF r
   THEN
      setNeedSpace (p)
   END ;
   IF needsParen (right)
   THEN
      outText (p, '(') ;
      doExprCup (p, right, unpackProc) ;
      outText (p, ')')
   ELSE
      doExprCup (p, right, unpackProc)
   END
END doBinary ;


(*
   doPostUnary -
*)

PROCEDURE doPostUnary (p: pretty; op: ARRAY OF CHAR; expr: node) ;
BEGIN
   doExprC (p, expr) ;
   outText (p, op)
END doPostUnary ;


(*
   doDeRefC -
*)

PROCEDURE doDeRefC (p: pretty; expr: node) ;
BEGIN
   outText (p, '(*') ;
   doExprC (p, expr) ;
   outText (p, ')')
END doDeRefC ;


(*
   doGetLastOp - returns, a, if b is a terminal otherwise walk right.
*)

PROCEDURE doGetLastOp (a, b: node) : node ;
BEGIN
   WITH b^ DO
      CASE kind OF

      nil             :  RETURN a |
      true            :  RETURN a |
      false           :  RETURN a |
      constexp        :  RETURN doGetLastOp (b, unaryF.arg) |
      neg             :  RETURN doGetLastOp (b, unaryF.arg) |
      not             :  RETURN doGetLastOp (b, unaryF.arg) |
      adr             :  RETURN doGetLastOp (b, unaryF.arg) |
      size            :  RETURN doGetLastOp (b, unaryF.arg) |
      tsize           :  RETURN doGetLastOp (b, unaryF.arg) |
      ord             :  RETURN doGetLastOp (b, unaryF.arg) |
      float,
      trunc           :  RETURN doGetLastOp (b, unaryF.arg) |
      chr             :  RETURN doGetLastOp (b, unaryF.arg) |
      cap             :  RETURN doGetLastOp (b, unaryF.arg) |
      high            :  RETURN doGetLastOp (b, unaryF.arg) |
      deref           :  RETURN doGetLastOp (b, unaryF.arg) |
      re,
      im              :  RETURN doGetLastOp (b, unaryF.arg) |
      equal           :  RETURN doGetLastOp (b, binaryF.right) |
      notequal        :  RETURN doGetLastOp (b, binaryF.right) |
      less            :  RETURN doGetLastOp (b, binaryF.right) |
      greater         :  RETURN doGetLastOp (b, binaryF.right) |
      greequal        :  RETURN doGetLastOp (b, binaryF.right) |
      lessequal       :  RETURN doGetLastOp (b, binaryF.right) |
      componentref    :  RETURN doGetLastOp (b, componentrefF.field) |
      pointerref      :  RETURN doGetLastOp (b, pointerrefF.field) |
      cast            :  RETURN doGetLastOp (b, binaryF.right) |
      val             :  RETURN doGetLastOp (b, binaryF.right) |
      plus            :  RETURN doGetLastOp (b, binaryF.right) |
      sub             :  RETURN doGetLastOp (b, binaryF.right) |
      div             :  RETURN doGetLastOp (b, binaryF.right) |
      mod             :  RETURN doGetLastOp (b, binaryF.right) |
      mult            :  RETURN doGetLastOp (b, binaryF.right) |
      divide          :  RETURN doGetLastOp (b, binaryF.right) |
      in              :  RETURN doGetLastOp (b, binaryF.right) |
      and             :  RETURN doGetLastOp (b, binaryF.right) |
      or              :  RETURN doGetLastOp (b, binaryF.right) |
      cmplx           :  RETURN doGetLastOp (b, binaryF.right) |
      literal         :  RETURN a |
      const           :  RETURN a |
      enumerationfield:  RETURN a |
      string          :  RETURN a |
      max             :  RETURN doGetLastOp (b, unaryF.arg) |
      min             :  RETURN doGetLastOp (b, unaryF.arg) |
      var             :  RETURN a |
      arrayref        :  RETURN a |
      funccall        :  RETURN a |
      procedure       :  RETURN a |
      recordfield     :  RETURN a

      END
   END
END doGetLastOp ;


(*
   getLastOp - return the right most non leaf node.
*)

PROCEDURE getLastOp (n: node) : node ;
BEGIN
   RETURN doGetLastOp (n, n)
END getLastOp ;


(*
   doComponentRefC -
*)

PROCEDURE doComponentRefC (p: pretty; l, r: node) ;
BEGIN
   doExprC (p, l) ;
   outText (p, '.') ;
   doExprC (p, r)
END doComponentRefC ;


(*
   doPointerRefC -
*)

PROCEDURE doPointerRefC (p: pretty; l, r: node) ;
BEGIN
   doExprC (p, l) ;
   outText (p, '->') ;
   doExprC (p, r)
END doPointerRefC ;


(*
   doPreBinary -
*)

PROCEDURE doPreBinary (p: pretty; op: ARRAY OF CHAR; left, right: node; l, r: BOOLEAN) ;
BEGIN
   IF l
   THEN
      setNeedSpace (p)
   END ;
   outText (p, op) ;
   IF r
   THEN
      setNeedSpace (p)
   END ;
   outText (p, '(') ;
   doExprC (p, left) ;
   outText (p, ',') ;
   setNeedSpace (p) ;
   doExprC (p, right) ;
   outText (p, ')')
END doPreBinary ;


(*
   doConstExpr -
*)

PROCEDURE doConstExpr (p: pretty; n: node) ;
BEGIN
   doFQNameC (p, n)
END doConstExpr ;


(*
   doEnumerationField -
*)

PROCEDURE doEnumerationField (p: pretty; n: node) ;
BEGIN
   doFQDNameC (p, n, FALSE)
END doEnumerationField ;


(*
   isZero - returns TRUE if node, n, is zero.
*)

PROCEDURE isZero (n: node) : BOOLEAN ;
BEGIN
   IF isConstExp (n)
   THEN
      RETURN isZero (n^.unaryF.arg)
   END ;
   RETURN getSymName (n)=makeKey ('0')
END isZero ;


(*
   doArrayRef -
*)

PROCEDURE doArrayRef (p: pretty; n: node) ;
VAR
   t   : node ;
   i, c: CARDINAL ;
BEGIN
   assert (n # NIL) ;
   assert (isArrayRef (n)) ;
   t := skipType (getType (n^.arrayrefF.array)) ;
   IF isUnbounded (t)
   THEN
      outTextN (p, getSymName (n^.arrayrefF.array))
   ELSE
      doExprC (p, n^.arrayrefF.array) ;
      assert (isArray (t)) ;
      outText (p, '.array')
   END ;
   outText (p, '[') ;
   i := 1 ;
   c := expListLen (n^.arrayrefF.index) ;
   WHILE i<=c DO
      doExprC (p, getExpList (n^.arrayrefF.index, i)) ;
      IF isUnbounded (t)
      THEN
         assert (c = 1)
      ELSE
         doSubtractC (p, getMin (t^.arrayF.subr)) ;
	 IF i<c
         THEN
            assert (isArray (t)) ;
            outText (p, '].array[') ;
            t := skipType (getType (t))
         END
      END ;
      INC (i)
   END ;
   outText (p, ']')
END doArrayRef ;


(*
   doProcedure -
*)

PROCEDURE doProcedure (p: pretty; n: node) ;
BEGIN
   assert (isProcedure (n)) ;
   doFQDNameC (p, n, TRUE)
END doProcedure ;


(*
   doRecordfield -
*)

PROCEDURE doRecordfield (p: pretty; n: node) ;
BEGIN
   doDNameC (p, n, FALSE)
END doRecordfield ;


(*
   doCastC -
*)

PROCEDURE doCastC (p: pretty; t, e: node) ;
VAR
   et: node ;
BEGIN
   outText (p, '(') ;
   doTypeNameC (p, t) ;
   outText (p, ')') ;
   setNeedSpace (p) ;
   et := skipType (getType (e)) ;
   IF (et # NIL) AND isAProcType (et) AND isAProcType (skipType (t))
   THEN
      outText (p, '{(') ;
      doFQNameC (p, t) ;
      outText (p, '_t)') ;
      setNeedSpace (p) ;
      doExprC (p, e) ;
      outText (p, '.proc}')
   ELSE
      outText (p, '(') ;
      doExprC (p, e) ;
      outText (p, ')')
   END
END doCastC ;


(*
   doSetValueC -
*)

PROCEDURE doSetValueC (p: pretty; n: node) ;
VAR
   lo  : node ;
   i, h: CARDINAL ;
BEGIN
   assert (isSetValue (n)) ;
   lo := getSetLow (n) ;
   IF n^.setvalueF.type # NIL
   THEN
      outText (p, '(') ;
      doTypeNameC (p, n^.setvalueF.type) ;
      noSpace (p) ;
      outText (p, ')') ;
      setNeedSpace (p)
   END ;
   IF HighIndice (n^.setvalueF.values) = 0
   THEN
      outText (p, '0')
   ELSE
      i := LowIndice (n^.setvalueF.values) ;
      h := HighIndice (n^.setvalueF.values) ;
      outText (p, '(') ;
      WHILE i<=h DO
         outText (p, '(1') ;
         setNeedSpace (p) ;
         outText (p, '<<') ;
         setNeedSpace (p) ;
         outText (p, '(') ;
         doExprC (p, GetIndice (n^.setvalueF.values, i)) ;
         doSubtractC (p, lo) ;
         outText (p, ')') ;
         outText (p, ')') ;
         IF i<h
         THEN
            setNeedSpace (p) ;
            outText (p, '|') ;
            setNeedSpace (p)
         END ;
         INC (i)
      END ;
      outText (p, ')')
   END
END doSetValueC ;


(*
   getSetLow - returns the low value of the set type from
               expression, n.
*)

PROCEDURE getSetLow (n: node) : node ;
VAR
   type: node ;
BEGIN
   IF getType (n) = NIL
   THEN
      RETURN makeLiteralInt (makeKey ('0'))
   ELSE
      type := skipType (getType (n)) ;
      IF isSet (type)
      THEN
         RETURN getMin (skipType (getType (type)))
      ELSE
         RETURN makeLiteralInt (makeKey ('0'))
      END
   END
END getSetLow ;


(*
   doInC - performs (((1 << (l)) & (r)) != 0)
*)

PROCEDURE doInC (p: pretty; l, r: node) ;
VAR
   lo: node ;
BEGIN
   lo := getSetLow (r) ;
   outText (p, '(((1') ;
   setNeedSpace (p) ;
   outText (p, '<<') ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   doExprC (p, l) ;
   doSubtractC (p, lo) ;
   outText (p, '))') ;
   setNeedSpace (p) ;
   outText (p, '&') ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   doExprC (p, r) ;
   outText (p, '))') ;
   setNeedSpace (p) ;
   outText (p, '!=') ;
   setNeedSpace (p) ;
   outText (p, '0)')
END doInC ;


(*
   doThrowC -
*)

PROCEDURE doThrowC (p: pretty; n: node) ;
BEGIN
   assert (isIntrinsic (n)) ;
   outText (p, "throw") ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   IF expListLen (n^.intrinsicF.args) = 1
   THEN
      doExprC (p, getExpList (n^.intrinsicF.args, 1))
   END ;
   outText (p, ')')
END doThrowC ;


(*
   doUnreachableC -
*)

PROCEDURE doUnreachableC (p: pretty; n: node) ;
BEGIN
   assert (isIntrinsic (n)) ;
   outText (p, "__builtin_unreachable") ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   assert (expListLen (n^.intrinsicF.args) = 0) ;
   outText (p, ')')
END doUnreachableC ;


(*
   outNull -
*)

PROCEDURE outNull (p: pretty) ;
BEGIN
   keyc.useNull ;
   outText (p, 'NULL')
END outNull ;


(*
   outTrue -
*)

PROCEDURE outTrue (p: pretty) ;
BEGIN
   keyc.useTrue ;
   IF useBool () AND (lang = ansiCP)
   THEN
      outText (p, 'true')
   ELSE
      outText (p, 'TRUE')
   END
END outTrue ;


(*
   outFalse -
*)

PROCEDURE outFalse (p: pretty) ;
BEGIN
   keyc.useFalse ;
   IF useBool () AND (lang = ansiCP)
   THEN
      outText (p, 'false')
   ELSE
      outText (p, 'FALSE')
   END
END outFalse ;


(*
   doExprC -
*)

PROCEDURE doExprC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (n#NIL) ;
   t := getExprType (n) ;
   WITH n^ DO
      CASE kind OF

      nil             :  outNull (p) |
      true            :  outTrue (p) |
      false           :  outFalse (p) |
      constexp        :  doUnary (p, '', unaryF.arg, unaryF.resultType, FALSE, FALSE) |
      neg             :  doUnary (p, '-', unaryF.arg, unaryF.resultType, FALSE, FALSE) |
      not             :  doUnary (p, '!', unaryF.arg, unaryF.resultType, FALSE, TRUE) |
      val             :  doValC (p, n) |
      adr             :  doAdrC (p, n) |
      size,
      tsize           :  doSizeC (p, n) |
      float           :  doConvertSC (p, n, getCRealType ()) |
      trunc           :  doConvertC (p, n, "int") |
      ord             :  doConvertC (p, n, "unsigned int") |
      chr             :  doConvertC (p, n, "char") |
      cap             :  doCapC (p, n) |
      abs             :  doAbsC (p, n) |
      high            :  doFuncHighC (p, n^.unaryF.arg) |
      length          :  doLengthC (p, n) |
      min             :  doMinC (p, n) |
      max             :  doMaxC (p, n) |
      throw           :  doThrowC (p, n) |
      unreachable     :  doUnreachableC (p, n) |
      re              :  doReC (p, n) |
      im              :  doImC (p, n) |
      cmplx           :  doCmplx (p, n) |

      deref           :  doDeRefC (p, unaryF.arg) |
      equal           :  doBinary (p, '==', binaryF.left, binaryF.right, TRUE, TRUE, TRUE) |
      notequal        :  doBinary (p, '!=', binaryF.left, binaryF.right, TRUE, TRUE, TRUE) |
      less            :  doBinary (p, '<', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      greater         :  doBinary (p, '>', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      greequal        :  doBinary (p, '>=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      lessequal       :  doBinary (p, '<=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      componentref    :  doComponentRefC (p, componentrefF.rec, componentrefF.field) |
      pointerref      :  doPointerRefC (p, pointerrefF.ptr, pointerrefF.field) |
      cast            :  doCastC (p, binaryF.left, binaryF.right) |
      plus            :  doPolyBinary (p, plus, binaryF.left, binaryF.right, FALSE, FALSE) |
      sub             :  doPolyBinary (p, sub, binaryF.left, binaryF.right, FALSE, FALSE) |
      div             :  doBinary (p, '/', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      mod             :  doBinary (p, '%', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      mult            :  doPolyBinary (p, mult, binaryF.left, binaryF.right, FALSE, FALSE) |
      divide          :  doPolyBinary (p, divide, binaryF.left, binaryF.right, FALSE, FALSE) |
      in              :  doInC (p, binaryF.left, binaryF.right) |
      and             :  doBinary (p, '&&', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      or              :  doBinary (p, '||', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      literal         :  doLiteralC (p, n) |
      const           :  doConstExpr (p, n) |
      enumerationfield:  doEnumerationField (p, n) |
      string          :  doStringC (p, n) |
      var             :  doVar (p, n) |
      arrayref        :  doArrayRef (p, n) |
      funccall        :  doFuncExprC (p, n) |
      procedure       :  doProcedure (p, n) |
      recordfield     :  doRecordfield (p, n) |
      setvalue        :  doSetValueC (p, n) |
      char,
      cardinal,
      longcard,
      shortcard,
      integer,
      longint,
      shortint,
      complex,
      longcomplex,
      shortcomplex,
      real,
      longreal,
      shortreal,
      bitset,
      boolean,
      proc            :  doBaseC (p, n) |
      address,
      loc,
      byte,
      word,
      csizet,
      cssizet         :  doSystemC (p, n) |
      type            :  doTypeNameC (p, n) |
      pointer         :  doTypeNameC (p, n)

      END
   END
END doExprC ;


(*
   doExprCup -
*)

PROCEDURE doExprCup (p: pretty; n: node; unpackProc: BOOLEAN) ;
VAR
   t: node ;
BEGIN
   doExprC (p, n) ;
   IF unpackProc
   THEN
      t := skipType (getExprType (n)) ;
      IF (t # NIL) AND isAProcType (t)
      THEN
         outText (p, '.proc')
      END
   END
END doExprCup ;


(*
   doExprM2 -
*)

PROCEDURE doExprM2 (p: pretty; n: node) ;
BEGIN
   assert (n#NIL) ;
   WITH n^ DO
      CASE kind OF

      nil             :  outText (p, 'NIL') |
      true            :  outText (p, 'TRUE') |
      false           :  outText (p, 'FALSE') |
      constexp        :  doUnary (p, '', unaryF.arg, unaryF.resultType, FALSE, FALSE) |
      neg             :  doUnary (p, '-', unaryF.arg, unaryF.resultType, FALSE, FALSE) |
      not             :  doUnary (p, 'NOT', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      adr             :  doUnary (p, 'ADR', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      size            :  doUnary (p, 'SIZE', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      tsize           :  doUnary (p, 'TSIZE', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      float           :  doUnary (p, 'FLOAT', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      trunc           :  doUnary (p, 'TRUNC', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      ord             :  doUnary (p, 'ORD', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      chr             :  doUnary (p, 'CHR', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      cap             :  doUnary (p, 'CAP', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      high            :  doUnary (p, 'HIGH', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      re              :  doUnary (p, 'RE', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      im              :  doUnary (p, 'IM', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      deref           :  doPostUnary (p, '^', unaryF.arg) |
      equal           :  doBinary (p, '=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      notequal        :  doBinary (p, '#', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      less            :  doBinary (p, '<', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      greater         :  doBinary (p, '>', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      greequal        :  doBinary (p, '>=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      lessequal       :  doBinary (p, '<=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      componentref    :  doBinary (p, '.', componentrefF.rec, componentrefF.field, FALSE, FALSE, FALSE) |
      pointerref      :  doBinary (p, '^.', pointerrefF.ptr, pointerrefF.field, FALSE, FALSE, FALSE) |
      cast            :  doPreBinary (p, 'CAST', binaryF.left, binaryF.right, TRUE, TRUE) |
      val             :  doPreBinary (p, 'VAL', binaryF.left, binaryF.right, TRUE, TRUE) |
      cmplx           :  doPreBinary (p, 'CMPLX', binaryF.left, binaryF.right, TRUE, TRUE) |
      plus            :  doBinary (p, '+', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) |
      sub             :  doBinary (p, '-', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) |
      div             :  doBinary (p, 'DIV', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      mod             :  doBinary (p, 'MOD', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) |
      mult            :  doBinary (p, '*', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) |
      divide          :  doBinary (p, '/', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) |
      literal         :  doLiteral (p, n) |
      const           :  doConstExpr (p, n) |
      enumerationfield:  doEnumerationField (p, n) |
      string          :  doString (p, n) |
      max             :  doUnary (p, 'MAX', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      min             :  doUnary (p, 'MIN', unaryF.arg, unaryF.resultType, TRUE, TRUE) |
      var             :  doVar (p, n)

      END
   END
END doExprM2 ;


(*
   doVar -
*)

PROCEDURE doVar (p: pretty; n: node) ;
BEGIN
   assert (isVar (n)) ;
   IF n^.varF.isVarParameter
   THEN
      outText (p, '(*') ;
      doFQDNameC (p, n, TRUE) ;
      outText (p, ')')
   ELSE
      doFQDNameC (p, n, TRUE)
   END
END doVar ;


(*
   doLiteralC -
*)

PROCEDURE doLiteralC (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   assert (isLiteral (n)) ;
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   IF n^.literalF.type=charN
   THEN
      IF DynamicStrings.char (s, -1)='C'
      THEN
         s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) ;
	 IF DynamicStrings.char (s, 0)#'0'
         THEN
            s := DynamicStrings.ConCat (InitString('0'), DynamicStrings.Mark (s))
         END
      END ;
      outText (p, "(char)") ;
      setNeedSpace (p)
   ELSIF DynamicStrings.char (s, -1) = 'H'
   THEN
      outText (p, "0x") ;
      s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1)
   ELSIF DynamicStrings.char (s, -1) = 'B'
   THEN
      outText (p, "0") ;
      s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1)
   END ;
   outTextS (p, s) ;
   s := KillString (s)
END doLiteralC ;


(*
   doLiteral -
*)

PROCEDURE doLiteral (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   assert (isLiteral (n)) ;
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   IF n^.literalF.type=charN
   THEN
      IF DynamicStrings.char (s, -1)='C'
      THEN
         s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) ;
	 IF DynamicStrings.char (s, 0)#'0'
         THEN
            s := DynamicStrings.ConCat (InitString('0'), DynamicStrings.Mark (s))
         END
      END ;
      outText (p, "(char)") ;
      setNeedSpace (p)
   END ;
   outTextS (p, s) ;
   s := KillString (s)
END doLiteral ;


(*
   isString - returns TRUE if node, n, is a string.
*)

PROCEDURE isString (n: node) : BOOLEAN ;
BEGIN
   assert (n#NIL) ;
   RETURN n^.kind=string
END isString ;


(*
   doString -
*)

PROCEDURE doString (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   assert (isString (n)) ;
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   outTextS (p, s) ;
   s := KillString (s)
   ; HALT
   (*
   IF DynamicStrings.Index (s, '"', 0)=-1
   THEN
      outText (p, '"') ;
      outTextS (p, s) ;
      outText (p, '"')
   ELSIF DynamicStrings.Index (s, "'", 0)=-1
   THEN
      outText (p, '"') ;
      outTextS (p, s) ;
      outText (p, '"')
   ELSE
      metaError1 ('illegal string {%1k}', n)
   END
   *)
END doString ;


(*
   replaceChar - replace every occurance of, ch, by, a and return modified string, s.
*)

PROCEDURE replaceChar (s: String; ch: CHAR; a: ARRAY OF CHAR) : String ;
VAR
   i: INTEGER ;
BEGIN
   i := 0 ;
   LOOP
      i := DynamicStrings.Index (s, ch, i) ;
      IF i = 0
      THEN
         s := ConCat (InitString (a), DynamicStrings.Slice (s, 1, 0)) ;
         i := StrLen (a)
      ELSIF i > 0
      THEN
         s := ConCat (ConCat (DynamicStrings.Slice (s, 0, i), Mark (InitString (a))), DynamicStrings.Slice (s, i+1, 0)) ;
         INC (i, StrLen (a))
      ELSE
         RETURN s
      END
   END
END replaceChar ;


(*
   toCstring - translates string, n, into a C string
               and returns the new String.
*)

PROCEDURE toCstring (n: Name) : String ;
VAR
   s: String ;
BEGIN
   s := DynamicStrings.Slice (InitStringCharStar (keyToCharStar (n)), 1, -1) ;
   RETURN replaceChar (replaceChar (s, '\', '\\'), '"', '\"')
END toCstring ;


(*
   toCchar -
*)

PROCEDURE toCchar (n: Name) : String ;
VAR
   s: String ;
BEGIN
   s := DynamicStrings.Slice (InitStringCharStar (keyToCharStar (n)), 1, -1) ;
   RETURN replaceChar (replaceChar (s, '\', '\\'), "'", "\'")
END toCchar ;


(*
   countChar -
*)

PROCEDURE countChar (s: String; ch: CHAR) : CARDINAL ;
VAR
   i: INTEGER ;
   c: CARDINAL ;
BEGIN
   c := 0 ;
   i := 0 ;
   LOOP
      i := DynamicStrings.Index (s, ch, i) ;
      IF i >= 0
      THEN
         INC (i) ;
         INC (c)
      ELSE
         RETURN c
      END
   END
END countChar ;


(*
   lenCstring -
*)

PROCEDURE lenCstring (s: String) : CARDINAL ;
BEGIN
   RETURN DynamicStrings.Length (s) - countChar (s, '\')
END lenCstring ;


(*
   outCstring -
*)

PROCEDURE outCstring (p: pretty; s: node; aString: BOOLEAN) ;
BEGIN
   IF aString
   THEN
      outText (p, '"') ;
      outRawS (p, s^.stringF.cstring) ;
      outText (p, '"')
   ELSE
      outText (p, "'") ;
      outRawS (p, s^.stringF.cchar) ;
      outText (p, "'")
   END
END outCstring ;


(*
   doStringC -
*)

PROCEDURE doStringC (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   assert (isString (n)) ;
   outCstring (p, n, NOT n^.stringF.isCharCompatible)
(*
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   IF DynamicStrings.Length (s)>3
   THEN
      IF DynamicStrings.Index (s, '"', 0)=-1
      THEN
         s := DynamicStrings.Slice (s, 1, -1) ;
         outText (p, '"') ;
         outCstring (p, s) ;
         outText (p, '"')
      ELSIF DynamicStrings.Index (s, "'", 0)=-1
      THEN
         s := DynamicStrings.Slice (s, 1, -1) ;
         outText (p, '"') ;
         outCstring (p, s) ;
         outText (p, '"')
      ELSE
         metaError1 ('illegal string {%1k}', n)
      END
   ELSIF DynamicStrings.Length (s) = 3
   THEN
      s := DynamicStrings.Slice (s, 1, -1) ;
      outText (p, "'") ;
      IF DynamicStrings.char (s, 0) = "'"
      THEN
         outText (p, "\'")
      ELSIF DynamicStrings.char (s, 0) = "\"
      THEN
         outText (p, "\\")
      ELSE
         outTextS (p, s)
      END ;
      outText (p, "'")
   ELSE
      outText (p, "'\0'")
   END ;
   s := KillString (s)
*)
END doStringC ;


(*
   isPunct -
*)

PROCEDURE isPunct (ch: CHAR) : BOOLEAN ;
BEGIN
   RETURN (ch = '.') OR (ch = '(') OR (ch = ')') OR
          (ch = '^') OR (ch = ':') OR (ch = ';') OR
	  (ch = '{') OR (ch = '}') OR (ch = ',') OR
	  (ch = '*')
END isPunct ;


(*
   isWhite -
*)

PROCEDURE isWhite (ch: CHAR) : BOOLEAN ;
BEGIN
   RETURN (ch = ' ') OR (ch = tab) OR (ch = lf)
END isWhite ;


(*
   outText -
*)

PROCEDURE outText (p: pretty; a: ARRAY OF CHAR) ;
VAR
   s: String ;
BEGIN
   s := InitString (a) ;
   outTextS (p, s) ;
   s := KillString (s)
END outText ;


(*
   outRawS -
*)

PROCEDURE outRawS (p: pretty; s: String) ;
BEGIN
   raw (p, s)
END outRawS ;


(*
   outKm2 -
*)

PROCEDURE outKm2 (p: pretty; a: ARRAY OF CHAR) : pretty ;
VAR
   i: CARDINAL ;
   s: String ;
BEGIN
   IF StrEqual (a, 'RECORD')
   THEN
      p := pushPretty (p) ;
      i := getcurpos (p) ;
      setindent (p, i) ;
      outText (p, a) ;
      p := pushPretty (p) ;
      setindent (p, i + indentation)
   ELSIF StrEqual (a, 'END')
   THEN
      p := popPretty (p) ;
      outText (p, a) ;
      p := popPretty (p)
   END ;
   RETURN p
END outKm2 ;


(*
   outKc -
*)

PROCEDURE outKc (p: pretty; a: ARRAY OF CHAR) : pretty ;
VAR
   i   : INTEGER ;
   c   : CARDINAL ;
   s, t: String ;
BEGIN
   s := InitString (a) ;
   i := DynamicStrings.Index (s, '\', 0) ;
   IF i=-1
   THEN
      t := NIL
   ELSE
      t := DynamicStrings.Slice (s, i, 0) ;
      s := DynamicStrings.Slice (Mark (s), 0, i)
   END ;
   IF DynamicStrings.char (s, 0)='{'
   THEN
      p := pushPretty (p) ;
      c := getcurpos (p) ;
      setindent (p, c) ;
      outTextS (p, s) ;
      p := pushPretty (p) ;
      setindent (p, c + indentationC)
   ELSIF DynamicStrings.char (s, 0)='}'
   THEN
      p := popPretty (p) ;
      outTextS (p, s) ;
      p := popPretty (p)
   END ;
   outTextS (p, t) ;
   t := KillString (t) ;
   s := KillString (s) ;
   RETURN p
END outKc ;


(*
   outTextS -
*)

PROCEDURE outTextS (p: pretty; s: String) ;
BEGIN
   IF s # NIL
   THEN
      prints (p, s)
   END
END outTextS ;


(*
   outCard -
*)

PROCEDURE outCard (p: pretty; c: CARDINAL) ;
VAR
   s: String ;
BEGIN
   s := CardinalToString (c, 0, ' ', 10, FALSE) ;
   outTextS (p, s) ;
   s := KillString (s)
END outCard ;


(*
   outTextN -
*)

PROCEDURE outTextN (p: pretty; n: Name) ;
VAR
   s: String ;
BEGIN
   s := InitStringCharStar (keyToCharStar (n)) ;
   prints (p, s) ;
   s := KillString (s)
END outTextN ;


(*
   doTypeAliasC -
*)

PROCEDURE doTypeAliasC (p: pretty; n: node; VAR m: node) ;
BEGIN
   print (p, "typedef") ; setNeedSpace (p) ;
   IF isTypeHidden (n) AND (isDef (getMainModule ()) OR (getScope (n) # getMainModule ()))
   THEN
      outText (p, "void *")
   ELSE
      doTypeC (p, getType (n), m)
   END ;
   IF m#NIL
   THEN
      doFQNameC (p, m)
   END ;
   print (p, ';\n\n')
END doTypeAliasC ;


(*
   doEnumerationC -
*)

PROCEDURE doEnumerationC (p: pretty; n: node) ;
VAR
   i, h: CARDINAL ;
   s   : node ;
   t   : String ;
BEGIN
   outText (p, "enum {") ;
   i := LowIndice (n^.enumerationF.listOfSons) ;
   h := HighIndice (n^.enumerationF.listOfSons) ;
   WHILE i <= h DO
      s := GetIndice (n^.enumerationF.listOfSons, i) ;
      doFQDNameC (p, s, FALSE) ;
      IF i < h
      THEN
         outText (p, ",") ; setNeedSpace (p)
      END ;
      INC (i)
   END ;
   outText (p, "}")
END doEnumerationC ;


(*
   doNamesC -
*)

PROCEDURE doNamesC (p: pretty; n: Name) ;
VAR
   s: String ;
BEGIN
   s := InitStringCharStar (keyToCharStar (n)) ;
   outTextS (p, s) ;
   s := KillString (s)
END doNamesC ;


(*
   doNameC -
*)

PROCEDURE doNameC (p: pretty; n: node) ;
BEGIN
   IF (n#NIL) AND (getSymName (n)#NulName)
   THEN
      doNamesC (p, getSymName (n))
   END
END doNameC ;


(*
   initCname -
*)

PROCEDURE initCname (VAR c: cnameT) ;
BEGIN
   c.init := FALSE
END initCname ;


(*
   doCname -
*)

PROCEDURE doCname (n: Name; VAR c: cnameT; scopes: BOOLEAN) : Name ;
VAR
   s: String ;
BEGIN
   IF c.init
   THEN
      RETURN c.name
   ELSE
      c.init := TRUE ;
      s := keyc.cname (n, scopes) ;
      IF s=NIL
      THEN
         c.name := n
      ELSE
         c.name := makekey (DynamicStrings.string (s)) ;
         s := KillString (s)
      END ;
      RETURN c.name
   END
END doCname ;


(*
   getDName -
*)

PROCEDURE getDName (n: node; scopes: BOOLEAN) : Name ;
VAR
   m: Name ;
BEGIN
   m := getSymName (n) ;
   CASE n^.kind OF

   procedure       :  RETURN doCname (m, n^.procedureF.cname, scopes) |
   var             :  RETURN doCname (m, n^.varF.cname, scopes) |
   recordfield     :  RETURN doCname (m, n^.recordfieldF.cname, scopes) |
   enumerationfield:  RETURN doCname (m, n^.enumerationfieldF.cname, scopes)

   ELSE
   END ;
   RETURN m
END getDName ;


(*
   doDNameC -
*)

PROCEDURE doDNameC (p: pretty; n: node; scopes: BOOLEAN) ;
BEGIN
   IF (n#NIL) AND (getSymName (n)#NulName)
   THEN
      doNamesC (p, getDName (n, scopes))
   END
END doDNameC ;


(*
   doFQDNameC -
*)

PROCEDURE doFQDNameC (p: pretty; n: node; scopes: BOOLEAN) ;
VAR
   s: String ;
BEGIN
   s := getFQDstring (n, scopes) ;
   outTextS (p, s) ;
   s := KillString (s)
END doFQDNameC ;


(*
   doFQNameC -
*)

PROCEDURE doFQNameC (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   s := getFQstring (n) ;
   outTextS (p, s) ;
   s := KillString (s)
END doFQNameC ;


(*
   doNameM2 -
*)

PROCEDURE doNameM2 (p: pretty; n: node) ;
BEGIN
   doNameC (p, n)
END doNameM2 ;


(*
   doUsed -
*)

PROCEDURE doUsed (p: pretty; used: BOOLEAN) ;
BEGIN
   IF NOT used
   THEN
      setNeedSpace (p) ;
      outText (p, "__attribute__((unused))")
   END
END doUsed ;


(*
   doHighC -
*)

PROCEDURE doHighC (p: pretty; a: node; n: Name; isused: BOOLEAN) ;
BEGIN
   IF isArray (a) AND isUnbounded (a)
   THEN
      (* need to display high.  *)
      print (p, ",") ; setNeedSpace (p) ;
      doTypeNameC (p, cardinalN) ; setNeedSpace (p) ;
      print (p, "_") ; outTextN (p, n) ; print (p, "_high") ;
      doUsed (p, isused)
   END
END doHighC ;


(*
   doParamConstCast -
*)

PROCEDURE doParamConstCast (p: pretty; n: node) ;
VAR
   ptype: node ;
BEGIN
   ptype := getType (n) ;
   IF isArray (ptype) AND isUnbounded (ptype) AND (lang = ansiCP)
   THEN
      outText (p, "const") ;
      setNeedSpace (p)
   END
END doParamConstCast ;


(*
   getParameterVariable - returns the variable which shadows the parameter
                          named, m, in parameter block, n.
*)

PROCEDURE getParameterVariable (n: node; m: Name) : node ;
VAR
   p: node ;
BEGIN
   assert (isParam (n) OR isVarParam (n)) ;
   IF isParam (n)
   THEN
      p := n^.paramF.scope
   ELSE
      p := n^.varparamF.scope
   END ;
   assert (isProcedure (p)) ;
   RETURN lookupInScope (p, m)
END getParameterVariable ;


(*
   doParamTypeEmit - emit parameter type for C/C++.  It checks to see if the
                     parameter type is a procedure type and if it were declared
                     in a definition module for "C" and if so it uses the "C"
                     definition for a procedure type, rather than the mc
                     C++ version.
*)

PROCEDURE doParamTypeEmit (p: pretty; paramnode, paramtype: node) ;
BEGIN
   assert (isParam (paramnode) OR isVarParam (paramnode)) ;
   IF isForC (paramnode) AND isProcType (skipType (paramtype))
   THEN
      doFQNameC (p, paramtype) ;
      outText (p, "_C")
   ELSE
      doTypeNameC (p, paramtype)
   END
END doParamTypeEmit ;


(*
   doParamC - emit parameter for C/C++.
*)

PROCEDURE doParamC (p: pretty; n: node) ;
VAR
   v,
   ptype: node ;
   i    : Name ;
   c, t : CARDINAL ;
   l    : wlist ;
BEGIN
   assert (isParam (n)) ;
   ptype := getType (n) ;
   IF n^.paramF.namelist = NIL
   THEN
      doParamConstCast (p, n) ;
      doTypeNameC (p, ptype) ;
      doUsed (p, n^.paramF.isUsed) ;
      IF isArray (ptype) AND isUnbounded (ptype)
      THEN
         outText (p, ',') ; setNeedSpace (p) ;
         outText (p, 'unsigned int')
      END
   ELSE
      assert (isIdentList (n^.paramF.namelist)) ;
      l := n^.paramF.namelist^.identlistF.names ;
      IF l=NIL
      THEN
         doParamConstCast (p, n) ;
         doParamTypeEmit (p, n, ptype) ;
         IF isArray (ptype) AND isUnbounded (ptype)
         THEN
            doUsed (p, n^.paramF.isUsed) ;
            outText (p, ',') ; setNeedSpace (p) ;
            outText (p, 'unsigned int')
         END
      ELSE
         t := wlists.noOfItemsInList (l) ;
         c := 1 ;
         WHILE c <= t DO
            doParamConstCast (p, n) ;
            doParamTypeEmit (p, n, ptype) ;
            i := wlists.getItemFromList (l, c) ;
            IF isArray (ptype) AND isUnbounded (ptype)
            THEN
               noSpace (p)
            ELSE
               setNeedSpace (p)
            END ;
            v := getParameterVariable (n, i) ;
            IF v=NIL
            THEN
               doNamesC (p, keyc.cnamen (i, TRUE))
            ELSE
               doFQDNameC (p, v, TRUE)
            END ;
            IF isArray (ptype) AND isUnbounded (ptype)
            THEN
               outText (p, '_')
            END ;
            doUsed (p, n^.paramF.isUsed) ;
            doHighC (p, ptype, i, n^.paramF.isUsed) ;
            IF c<t
            THEN
               outText (p, ',') ; setNeedSpace (p)
            END ;
            INC (c)
         END
      END
   END
END doParamC ;


(*
   doVarParamC - emit a VAR parameter for C/C++.
*)

PROCEDURE doVarParamC (p: pretty; n: node) ;
VAR
   v,
   ptype: node ;
   i    : Name ;
   c, t : CARDINAL ;
   l    : wlist ;
BEGIN
   assert (isVarParam (n)) ;
   ptype := getType (n) ;
   IF n^.varparamF.namelist = NIL
   THEN
      doTypeNameC (p, ptype) ;
      (* doTypeC (p, ptype, n) ; *)
      IF NOT isArray (ptype)
      THEN
         setNeedSpace (p) ;
         outText (p, "*")
      END ;
      doUsed (p, n^.varparamF.isUsed) ;
      IF isArray (ptype) AND isUnbounded (ptype)
      THEN
         outText (p, ',') ; setNeedSpace (p) ;
         outText (p, 'unsigned int')
      END
   ELSE
      assert (isIdentList (n^.varparamF.namelist)) ;
      l := n^.varparamF.namelist^.identlistF.names ;
      IF l=NIL
      THEN
         doParamTypeEmit (p, n, ptype) ;
         doUsed (p, n^.varparamF.isUsed)
      ELSE
         t := wlists.noOfItemsInList (l) ;
         c := 1 ;
         WHILE c <= t DO
            doParamTypeEmit (p, n, ptype) ;
	    IF NOT isArray (ptype)
            THEN
               setNeedSpace (p) ;
               outText (p, "*")
            END ;
            i := wlists.getItemFromList (l, c) ;
            v := getParameterVariable (n, i) ;
            IF v=NIL
            THEN
               doNamesC (p, keyc.cnamen (i, TRUE))
            ELSE
               doFQDNameC (p, v, TRUE)
            END ;
            doUsed (p, n^.varparamF.isUsed) ;
            doHighC (p, ptype, i, n^.varparamF.isUsed) ;
            IF c<t
            THEN
               outText (p, ',') ; setNeedSpace (p)
            END ;
            INC (c)
         END
      END
   END
END doVarParamC ;


(*
   doOptargC -
*)

PROCEDURE doOptargC (p: pretty; n: node) ;
VAR
   ptype: node ;
   i    : Name ;
   t    : CARDINAL ;
   l    : wlist ;
BEGIN
   assert (isOptarg (n)) ;
   ptype := getType (n) ;
   assert (n^.optargF.namelist # NIL) ;
   assert (isIdentList (n^.paramF.namelist)) ;
   l := n^.paramF.namelist^.identlistF.names ;
   assert (l # NIL) ;
   t := wlists.noOfItemsInList (l) ;
   assert (t = 1) ;
   doTypeNameC (p, ptype) ;
   i := wlists.getItemFromList (l, 1) ;
   setNeedSpace (p) ;
   doNamesC (p, i)
END doOptargC ;


(*
   doParameterC -
*)

PROCEDURE doParameterC (p: pretty; n: node) ;
BEGIN
   IF isParam (n)
   THEN
      doParamC (p, n)
   ELSIF isVarParam (n)
   THEN
      doVarParamC (p, n)
   ELSIF isVarargs (n)
   THEN
      print (p, "...")
   ELSIF isOptarg (n)
   THEN
      doOptargC (p, n)
   END
END doParameterC ;


(*
   doProcTypeC -
*)

PROCEDURE doProcTypeC (p: pretty; t, n: node) ;
BEGIN
   assert (isType (t)) ;
   outputPartial (t) ;
   doCompletePartialProcType (p, t, n)
END doProcTypeC ;


(*
   doTypesC -
*)

PROCEDURE doTypesC (n: node) ;
VAR
   m: node ;
BEGIN
   IF isType (n)
   THEN
      m := getType (n) ;
      IF isProcType (m)
      THEN
         doProcTypeC (doP, n, m)
      ELSIF isType (m) OR isPointer (m)
      THEN
         outText (doP, "typedef") ; setNeedSpace (doP) ;
         doTypeC (doP, m, m) ;
	 IF isType (m)
         THEN
            setNeedSpace (doP)
         END ;
         doTypeNameC (doP, n) ;
         outText (doP, ";\n\n")
      ELSIF isEnumeration (m)
      THEN
         outText (doP, "typedef") ; setNeedSpace (doP) ;
         doTypeC (doP, m, m) ;
         setNeedSpace (doP) ;
	 doTypeNameC (doP, n) ;
         outText (doP, ";\n\n")
      ELSE
         outText (doP, "typedef") ; setNeedSpace (doP) ;
         doTypeC (doP, m, m) ;
	 IF isType (m)
         THEN
            setNeedSpace (doP)
         END ;
         doTypeNameC (doP, n) ;
         outText (doP, ";\n\n")
      END
   END
END doTypesC ;


(*
   doCompletePartialC -
*)

PROCEDURE doCompletePartialC (n: node) ;
VAR
   m: node ;
BEGIN
   IF isType (n)
   THEN
      m := getType (n) ;
      IF isRecord (m)
      THEN
         doCompletePartialRecord (doP, n, m)
      ELSIF isArray (m)
      THEN
         doCompletePartialArray (doP, n, m)
      ELSIF isProcType (m)
      THEN
         doCompletePartialProcType (doP, n, m)
      END
   END
END doCompletePartialC ;


(*
   doCompletePartialRecord -
*)

PROCEDURE doCompletePartialRecord (p: pretty; t, r: node) ;
VAR
   i, h: CARDINAL ;
   f   : node ;
BEGIN
   assert (isRecord (r)) ;
   assert (isType (t)) ;
   outText (p, "struct") ; setNeedSpace (p) ;
   doFQNameC (p, t) ;
   outText (p, "_r") ; setNeedSpace (p) ;
   p := outKc (p, "{\n") ;
   i := LowIndice (r^.recordF.listOfSons) ;
   h := HighIndice (r^.recordF.listOfSons) ;
   WHILE i<=h DO
      f := GetIndice (r^.recordF.listOfSons, i) ;
      IF isRecordField (f)
      THEN
         IF NOT f^.recordfieldF.tag
         THEN
            setNeedSpace (p) ;
            doRecordFieldC (p, f) ;
            outText (p, ";\n")
         END
      ELSIF isVarient (f)
      THEN
         doVarientC (p, f) ;
         outText (p, ";\n")
      ELSIF isVarientField (f)
      THEN
         doVarientFieldC (p, f)
      END ;
      INC (i)
   END ;
   p := outKc (p, "};\n\n")
END doCompletePartialRecord ;


(*
   doCompletePartialArray -
*)

PROCEDURE doCompletePartialArray (p: pretty; t, r: node) ;
VAR
   type, s: node ;
BEGIN
   assert (isArray (r)) ;
   type := r^.arrayF.type ;
   s := NIL ;
   outText (p, "struct") ; setNeedSpace (p) ;
   doFQNameC (p, t) ;
   outText (p, "_a {") ;
   setNeedSpace (p) ;
   doTypeC (p, type, s) ;
   setNeedSpace (p) ;
   outText (p, "array[") ;
   doSubrC (p, r^.arrayF.subr) ;
   outText (p, "];") ;
   setNeedSpace (p) ;
   outText (p, "};\n")
END doCompletePartialArray ;


(*
   lookupConst -
*)

PROCEDURE lookupConst (type: node; n: Name) : node ;
BEGIN
   RETURN makeLiteralInt (n)
END lookupConst ;


(*
   doMin -
*)

PROCEDURE doMin (n: node) : node ;
BEGIN
   IF n=booleanN
   THEN
      RETURN falseN
   ELSIF n=integerN
   THEN
      keyc.useIntMin ;
      RETURN lookupConst (integerN, makeKey ('INT_MIN'))
   ELSIF n=cardinalN
   THEN
      keyc.useUIntMin ;
      RETURN lookupConst (cardinalN, makeKey ('UINT_MIN'))
   ELSIF n=longintN
   THEN
      keyc.useLongMin ;
      RETURN lookupConst (longintN, makeKey ('LONG_MIN'))
   ELSIF n=longcardN
   THEN
      keyc.useULongMin ;
      RETURN lookupConst (longcardN, makeKey ('LONG_MIN'))
   ELSIF n=charN
   THEN
      keyc.useCharMin ;
      RETURN lookupConst (charN, makeKey ('CHAR_MIN'))
   ELSIF n=bitsetN
   THEN
      assert (isSubrange (bitnumN)) ;
      RETURN bitnumN^.subrangeF.low
   ELSIF n=locN
   THEN
      keyc.useUCharMin ;
      RETURN lookupConst (locN, makeKey ('UCHAR_MIN'))
   ELSIF n=byteN
   THEN
      keyc.useUCharMin ;
      RETURN lookupConst (byteN, makeKey ('UCHAR_MIN'))
   ELSIF n=wordN
   THEN
      keyc.useUIntMin ;
      RETURN lookupConst (wordN, makeKey ('UCHAR_MIN'))
   ELSIF n=addressN
   THEN
      RETURN lookupConst (addressN, makeKey ('((void *) 0)'))
   ELSE
      HALT  (* finish the cacading elsif statement.  *)
   END
END doMin ;


(*
   doMax -
*)

PROCEDURE doMax (n: node) : node ;
BEGIN
   IF n=booleanN
   THEN
      RETURN trueN
   ELSIF n=integerN
   THEN
      keyc.useIntMax ;
      RETURN lookupConst (integerN, makeKey ('INT_MAX'))
   ELSIF n=cardinalN
   THEN
      keyc.useUIntMax ;
      RETURN lookupConst (cardinalN, makeKey ('UINT_MAX'))
   ELSIF n=longintN
   THEN
      keyc.useLongMax ;
      RETURN lookupConst (longintN, makeKey ('LONG_MAX'))
   ELSIF n=longcardN
   THEN
      keyc.useULongMax ;
      RETURN lookupConst (longcardN, makeKey ('ULONG_MAX'))
   ELSIF n=charN
   THEN
      keyc.useCharMax ;
      RETURN lookupConst (charN, makeKey ('CHAR_MAX'))
   ELSIF n=bitsetN
   THEN
      assert (isSubrange (bitnumN)) ;
      RETURN bitnumN^.subrangeF.high
   ELSIF n=locN
   THEN
      keyc.useUCharMax ;
      RETURN lookupConst (locN, makeKey ('UCHAR_MAX'))
   ELSIF n=byteN
   THEN
      keyc.useUCharMax ;
      RETURN lookupConst (byteN, makeKey ('UCHAR_MAX'))
   ELSIF n=wordN
   THEN
      keyc.useUIntMax ;
      RETURN lookupConst (wordN, makeKey ('UINT_MAX'))
   ELSIF n=addressN
   THEN
      metaError1 ('trying to obtain MAX ({%1ad}) is illegal', n) ;
      RETURN NIL
   ELSE
      HALT  (* finish the cacading elsif statement.  *)
   END
END doMax ;


(*
   getMax -
*)

PROCEDURE getMax (n: node) : node ;
BEGIN
   n := skipType (n) ;
   IF isSubrange (n)
   THEN
      RETURN n^.subrangeF.high
   ELSIF isEnumeration (n)
   THEN
      RETURN n^.enumerationF.high
   ELSE
      assert (isOrdinal (n)) ;
      RETURN doMax (n)
   END
END getMax ;


(*
   getMin -
*)

PROCEDURE getMin (n: node) : node ;
BEGIN
   n := skipType (n) ;
   IF isSubrange (n)
   THEN
      RETURN n^.subrangeF.low
   ELSIF isEnumeration (n)
   THEN
      RETURN n^.enumerationF.low
   ELSE
      assert (isOrdinal (n)) ;
      RETURN doMin (n)
   END
END getMin ;


(*
   doSubtractC -
*)

PROCEDURE doSubtractC (p: pretty; s: node) ;
BEGIN
   IF NOT isZero (s)
   THEN
      outText (p, "-") ;
      doExprC (p, s)
   END
END doSubtractC ;


(*
   doSubrC -
*)

PROCEDURE doSubrC (p: pretty; s: node) ;
VAR
   low, high: node ;
BEGIN
   s := skipType (s) ;
   IF isOrdinal (s)
   THEN
      low := getMin (s) ;
      high := getMax (s) ;
      doExprC (p, high) ;
      doSubtractC (p, low) ;
      outText (p, "+1")
   ELSIF isEnumeration (s)
   THEN
      low := getMin (s) ;
      high := getMax (s) ;
      doExprC (p, high) ;
      doSubtractC (p, low) ;
      outText (p, "+1")
   ELSE
      assert (isSubrange (s)) ;
      IF (s^.subrangeF.high = NIL) OR (s^.subrangeF.low = NIL)
      THEN
         doSubrC (p, getType (s))
      ELSE
         doExprC (p, s^.subrangeF.high) ;
         doSubtractC (p, s^.subrangeF.low) ;
         outText (p, "+1")
      END
   END
END doSubrC ;


(*
   doCompletePartialProcType -
*)

PROCEDURE doCompletePartialProcType (p: pretty; t, n: node) ;
VAR
   i, h: CARDINAL ;
   v, u: node ;
BEGIN
   assert (isProcType (n)) ;
   u := NIL ;
   outText (p, "typedef") ; setNeedSpace (p) ;
   doTypeC (p, n^.proctypeF.returnType, u) ; setNeedSpace (p) ;
   outText (p, "(*") ;
   doFQNameC (p, t) ;
   outText (p, "_t) (") ;
   i := LowIndice (n^.proctypeF.parameters) ;
   h := HighIndice (n^.proctypeF.parameters) ;
   WHILE i <= h DO
      v := GetIndice (n^.proctypeF.parameters, i) ;
      doParameterC (p, v) ;
      noSpace (p) ;
      IF i < h
      THEN
         outText (p, ",") ; setNeedSpace (p)
      END ;
      INC (i)
   END ;
   IF h=0
   THEN
      outText (p, "void")
   END ;
   outText (p, ");\n") ;
   IF isDefForCNode (n)
   THEN
      (* emit a C named type which differs from the m2 proctype.  *)
      outText (p, "typedef") ; setNeedSpace (p) ;
      doFQNameC (p, t) ;
      outText (p, "_t") ; setNeedSpace (p) ;
      doFQNameC (p, t) ;
      outText (p, "_C;\n\n")
   END ;
   outText (p, "struct") ; setNeedSpace (p) ;
   doFQNameC (p, t) ;
   outText (p, "_p {") ; setNeedSpace (p) ;
   doFQNameC (p, t) ;
   outText (p, "_t proc; };\n\n")
END doCompletePartialProcType ;


(*
   isBase -
*)

PROCEDURE isBase (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   char,
   cardinal,
   longcard,
   shortcard,
   integer,
   longint,
   shortint,
   complex,
   longcomplex,
   shortcomplex,
   real,
   longreal,
   shortreal,
   bitset,
   boolean,
   proc     :  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isBase ;


(*
   doBoolC -
*)

PROCEDURE doBoolC (p: pretty) ;
BEGIN
   IF useBool ()
   THEN
      outText (p, 'bool')
   ELSE
      outText (p, 'unsigned int')
   END
END doBoolC ;


(*
   doBaseC -
*)

PROCEDURE doBaseC (p: pretty; n: node) ;
BEGIN
   CASE n^.kind OF

   char        :  outText (p, 'char') |
   cardinal    :  outText (p, 'unsigned int') |
   longcard    :  outText (p, 'long unsigned int') |
   shortcard   :  outText (p, 'short unsigned int') |
   integer     :  outText (p, 'int') |
   longint     :  outText (p, 'long int') |
   shortint    :  outText (p, 'short int') |
   complex     :  outText (p, 'double complex') |
   longcomplex :  outText (p, 'long double complex') |
   shortcomplex:  outText (p, 'float complex') |
   real        :  outTextS (p, getCRealType ()) |
   longreal    :  outTextS (p, getCLongRealType ()) |
   shortreal   :  outTextS (p, getCShortRealType ()) |
   bitset      :  outText (p, 'unsigned int') |
   boolean     :  doBoolC (p) |
   proc        :  outText (p, 'PROC')

   END ;
   setNeedSpace (p)
END doBaseC ;


(*
   isSystem -
*)

PROCEDURE isSystem (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   address:  RETURN TRUE |
   loc    :  RETURN TRUE |
   byte   :  RETURN TRUE |
   word   :  RETURN TRUE |
   csizet :  RETURN TRUE |
   cssizet:  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isSystem ;


(*
   doSystemC -
*)

PROCEDURE doSystemC (p: pretty; n: node) ;
BEGIN
   CASE n^.kind OF

   address:  outText (p, 'void *') |
   loc    :  outText (p, 'unsigned char') ; setNeedSpace (p) |
   byte   :  outText (p, 'unsigned char') ; setNeedSpace (p) |
   word   :  outText (p, 'unsigned int') ; setNeedSpace (p) |
   csizet :  outText (p, 'size_t') ; setNeedSpace (p) ; keyc.useSize_t |
   cssizet:  outText (p, 'ssize_t') ; setNeedSpace (p) ; keyc.useSSize_t

   END
END doSystemC ;


(*
   doArrayC -
*)

PROCEDURE doArrayC (p: pretty; n: node) ;
VAR
   t, s, u: node ;
BEGIN
   assert (isArray (n)) ;
   t := n^.arrayF.type ;
   s := n^.arrayF.subr ;
   u := NIL ;
   IF s=NIL
   THEN
      doTypeC (p, t, u) ;
      setNeedSpace (p) ;
      outText (p, "*")
   ELSE
      outText (p, "struct") ;
      setNeedSpace (p) ;
      outText (p, "{") ;
      setNeedSpace (p) ;
      doTypeC (p, t, u) ;
      setNeedSpace (p) ;
      outText (p, "array[") ;
      IF isZero (getMin (s))
      THEN
         doExprC (p, getMax (s))
      ELSE
         doExprC (p, getMax (s)) ;
         doSubtractC (p, getMin (s))
      END ;
      outText (p, "];") ;
      setNeedSpace (p) ;
      outText (p, "}") ;
      setNeedSpace (p)
   END
END doArrayC ;


(*
   doPointerC -
*)

PROCEDURE doPointerC (p: pretty; n: node; VAR m: node) ;
VAR
   t, s: node ;
BEGIN
   t := n^.pointerF.type ;
   s := NIL ;
   doTypeC (p, t, s) ;
   setNeedSpace (p) ;
   outText (p, "*")
END doPointerC ;


(*
   doRecordFieldC -
*)

PROCEDURE doRecordFieldC (p: pretty; f: node) ;
VAR
   m: node ;
BEGIN
   m := NIL ;
   setNeedSpace (p) ;
   doTypeC (p, f^.recordfieldF.type, m) ;
   doDNameC (p, f, FALSE)
END doRecordFieldC ;


(*
   doVarientFieldC -
*)

PROCEDURE doVarientFieldC (p: pretty; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   assert (isVarientField (n)) ;
   IF NOT n^.varientfieldF.simple
   THEN
      outText (p, "struct") ; setNeedSpace (p) ;
      p := outKc (p, "{\n")
   END ;
   i := LowIndice (n^.varientfieldF.listOfSons) ;
   t := HighIndice (n^.varientfieldF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientfieldF.listOfSons, i) ;
      IF isRecordField (q)
      THEN
         IF NOT q^.recordfieldF.tag
         THEN
            doRecordFieldC (p, q) ;
            outText (p, ";\n")
         END
      ELSIF isVarient (q)
      THEN
         doVarientC (p, q) ;
         outText (p, ";\n")
      ELSE
         HALT
      END ;
      INC (i)
   END ;
   IF NOT n^.varientfieldF.simple
   THEN
      p := outKc (p, "};\n")
   END
END doVarientFieldC ;


(*
   doVarientC -
*)

PROCEDURE doVarientC (p: pretty; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   assert (isVarient (n)) ;
   IF n^.varientF.tag # NIL
   THEN
      IF isRecordField (n^.varientF.tag)
      THEN
         doRecordFieldC (p, n^.varientF.tag) ;
	 outText (p, ";  /* case tag */\n")
      ELSIF isVarientField (n^.varientF.tag)
      THEN
         HALT
         (* doVarientFieldC (p, n^.varientF.tag) *)
      ELSE
         HALT
      END
   END ;
   outText (p, "union") ;
   setNeedSpace (p) ;
   p := outKc (p, "{\n") ;
   i := LowIndice (n^.varientF.listOfSons) ;
   t := HighIndice (n^.varientF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientF.listOfSons, i) ;
      IF isRecordField (q)
      THEN
         IF NOT q^.recordfieldF.tag
         THEN
            doRecordFieldC (p, q) ;
            outText (p, ";\n")
         END
      ELSIF isVarientField (q)
      THEN
         doVarientFieldC (p, q)
      ELSE
         HALT
      END ;
      INC (i)
   END ;
   p := outKc (p, "}")
END doVarientC ;


(*
   doRecordC -
*)

PROCEDURE doRecordC (p: pretty; n: node; VAR m: node) ;
VAR
   i, h: CARDINAL ;
   f   : node ;
BEGIN
   assert (isRecord (n)) ;
   outText (p, "struct") ;
   setNeedSpace (p) ;
   p := outKc (p, "{") ;
   i := LowIndice (n^.recordF.listOfSons) ;
   h := HighIndice (n^.recordF.listOfSons) ;
   setindent (p, getcurpos (p) + indentation) ;
   outText (p, "\n") ;
   WHILE i<=h DO
      f := GetIndice (n^.recordF.listOfSons, i) ;
      IF isRecordField (f)
      THEN
         IF NOT f^.recordfieldF.tag
         THEN
            doRecordFieldC (p, f) ;
            outText (p, ";\n")
         END
      ELSIF isVarient (f)
      THEN
         doVarientC (p, f) ;
         outText (p, ";\n")
      ELSIF isVarientField (f)
      THEN
         doVarientFieldC (p, f)
      END ;
      INC (i)
   END ;
   p := outKc (p, "}") ;
   setNeedSpace (p)
END doRecordC ;


(*
   isBitset -
*)

PROCEDURE isBitset (n: node) : BOOLEAN ;
BEGIN
   RETURN n = bitsetN
END isBitset ;


(*
   isNegative - returns TRUE if expression, n, is negative.
*)

PROCEDURE isNegative (n: node) : BOOLEAN ;
BEGIN
   (* --fixme-- needs to be completed.  *)
   RETURN FALSE
END isNegative ;


(*
   doSubrangeC -
*)

PROCEDURE doSubrangeC (p: pretty; n: node) ;
BEGIN
   assert (isSubrange (n)) ;
   IF isNegative (n^.subrangeF.low)
   THEN
      outText (p, "int") ; setNeedSpace (p)
   ELSE
      outText (p, "unsigned int") ; setNeedSpace (p)
   END
END doSubrangeC ;


(*
   doSetC - generates a C type which holds the set.
            Currently we only support sets of size WORD.
*)

PROCEDURE doSetC (p: pretty; n: node) ;
BEGIN
   assert (isSet (n)) ;
   outText (p, "unsigned int") ; setNeedSpace (p)
END doSetC ;


(*
   doTypeC -
*)

PROCEDURE doTypeC (p: pretty; n: node; VAR m: node) ;
BEGIN
   IF n=NIL
   THEN
      outText (p, "void")
   ELSIF isBase (n)
   THEN
      doBaseC (p, n)
   ELSIF isSystem (n)
   THEN
      doSystemC (p, n)
   ELSIF isEnumeration (n)
   THEN
      doEnumerationC (p, n)
   ELSIF isType (n)
   THEN
      doFQNameC (p, n) ;
      setNeedSpace (p)
      (* doTypeAliasC (p, n, n) *)  (* type, n, has a name, so we choose this over, m.  *)
(*
   ELSIF isProcType (n) OR isArray (n) OR isRecord (n)
   THEN
      HALT  (* n should have been simplified.  *)
*)
   ELSIF isProcType (n)
   THEN
      doProcTypeC (p, n, m)
   ELSIF isArray (n)
   THEN
      doArrayC (p, n)
   ELSIF isRecord (n)
   THEN
      doRecordC (p, n, m)
   ELSIF isPointer (n)
   THEN
      doPointerC (p, n, m)
   ELSIF isSubrange (n)
   THEN
      doSubrangeC (p, n)
   ELSIF isSet (n)
   THEN
      doSetC (p, n)
   ELSE
      (* --fixme--  *)
      print (p, "to do ...  typedef etc etc ") ; doFQNameC (p, n) ; print (p, ";\n") ;
      HALT
   END
END doTypeC ;


(*
   doArrayNameC - it displays the array declaration (it might be an unbounded).
*)

PROCEDURE doArrayNameC (p: pretty; n: node) ;
BEGIN
   doTypeNameC (p, getType (n)) ; setNeedSpace (p) ; outText (p, "*")
END doArrayNameC ;


(*
   doRecordNameC - emit the C/C++ record name <name of n>"_r".
*)

PROCEDURE doRecordNameC (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   s := getFQstring (n) ;
   s := ConCat (s, Mark (InitString ("_r"))) ;
   outTextS (p, s) ;
   s := KillString (s)
END doRecordNameC ;


(*
   doPointerNameC - emit the C/C++ pointer type <name of n>*.
*)

PROCEDURE doPointerNameC (p: pretty; n: node) ;
BEGIN
   doTypeNameC (p, getType (n)) ; setNeedSpace (p) ; outText (p, "*")
END doPointerNameC ;


(*
   doTypeNameC -
*)

PROCEDURE doTypeNameC (p: pretty; n: node) ;
VAR
   t: String ;
BEGIN
   IF n=NIL
   THEN
      outText (p, "void") ;
      setNeedSpace (p)
   ELSIF isBase (n)
   THEN
      doBaseC (p, n)
   ELSIF isSystem (n)
   THEN
      doSystemC (p, n)
   ELSIF isEnumeration (n)
   THEN
      print (p, "is enumeration type name required\n")
   ELSIF isType (n)
   THEN
      doFQNameC (p, n) ;
   ELSIF isProcType (n)
   THEN
      doFQNameC (p, n) ;
      outText (p, "_t")
   ELSIF isArray (n)
   THEN
      doArrayNameC (p, n)
   ELSIF isRecord (n)
   THEN
      doRecordNameC (p, n)
   ELSIF isPointer (n)
   THEN
      doPointerNameC (p, n)
   ELSIF isSubrange (n)
   THEN
      doSubrangeC (p, n)
   ELSE
      print (p, "is type unknown required\n") ;
      stop
   END
END doTypeNameC ;


(*
   isExternal - returns TRUE if symbol, n, was declared in another module.
*)

PROCEDURE isExternal (n: node) : BOOLEAN ;
VAR
   s: node ;
BEGIN
   s := getScope (n) ;
   RETURN (s # NIL) AND isDef (s) AND
           ((isImp (getMainModule ()) AND (s # lookupDef (getSymName (getMainModule ())))) OR
            isModule (getMainModule ()))
END isExternal ;


(*
   doVarC -
*)

PROCEDURE doVarC (n: node) ;
VAR
   s: node ;
BEGIN
   IF isDef (getMainModule ())
   THEN
      print (doP, "EXTERN") ; setNeedSpace (doP)
   ELSIF (NOT isExported (n)) AND (NOT isLocal (n))
   THEN
      print (doP, "static") ; setNeedSpace (doP)
   ELSIF getExtendedOpaque ()
   THEN
      IF isExternal (n)
      THEN
         (* different module declared this variable, therefore it is extern.  *)
         print (doP, "extern") ; setNeedSpace (doP)
      END
   END ;
   s := NIL ;
   doTypeC (doP, getType (n), s) ;
   setNeedSpace (doP) ;
   doFQDNameC (doP, n, FALSE) ;
   print (doP, ";\n")
END doVarC ;


(*
   doExternCP -
*)

PROCEDURE doExternCP (p: pretty) ;
BEGIN
   IF lang = ansiCP
   THEN
      outText (p, 'extern "C"') ; setNeedSpace (p)
   END
END doExternCP ;


(*
   doProcedureCommentText -
*)

PROCEDURE doProcedureCommentText (p: pretty; s: String) ;
BEGIN
   (* remove \n from the start of the comment.  *)
   WHILE (DynamicStrings.Length (s) > 0) AND (DynamicStrings.char (s, 0) = lf) DO
      s := DynamicStrings.Slice (s, 1, 0)
   END ;
   outTextS (p, s)
END doProcedureCommentText ;


(*
   doProcedureComment -
*)

PROCEDURE doProcedureComment (p: pretty; s: String) ;
BEGIN
   IF s # NIL
   THEN
      outText (p, '\n/*\n') ;
      doProcedureCommentText (p, s) ;
      outText (p, '*/\n\n')
   END
END doProcedureComment ;


(*
   doProcedureHeadingC -
*)

PROCEDURE doProcedureHeadingC (n: node; prototype: BOOLEAN) ;
VAR
   i, h: CARDINAL ;
   p, q: node ;
BEGIN
   assert (isProcedure (n)) ;
   noSpace (doP) ;
   IF isDef (getMainModule ())
   THEN
      doProcedureComment (doP, getContent (n^.procedureF.defComment)) ;
      outText (doP, "EXTERN") ; setNeedSpace (doP)
   ELSIF isExported (n)
   THEN
      doProcedureComment (doP, getContent (n^.procedureF.modComment)) ;
      doExternCP (doP)
   ELSE
      doProcedureComment (doP, getContent (n^.procedureF.modComment)) ;
      outText (doP, "static") ; setNeedSpace (doP)
   END ;
   q := NIL ;
   doTypeC (doP, n^.procedureF.returnType, q) ; setNeedSpace (doP) ;
   doFQDNameC (doP, n, FALSE) ;
   setNeedSpace (doP) ;
   outText (doP, "(") ;
   i := LowIndice (n^.procedureF.parameters) ;
   h := HighIndice (n^.procedureF.parameters) ;
   WHILE i <= h DO
      p := GetIndice (n^.procedureF.parameters, i) ;
      doParameterC (doP, p) ;
      noSpace (doP) ;
      IF i < h
      THEN
         print (doP, ",") ; setNeedSpace (doP)
      END ;
      INC (i)
   END ;
   IF h=0
   THEN
      outText (doP, "void")
   END ;
   print (doP, ")") ;
   IF n^.procedureF.noreturn AND prototype AND (NOT getSuppressNoReturn ())
   THEN
      setNeedSpace (doP) ;
      outText (doP, "__attribute__ ((noreturn))")
   END
END doProcedureHeadingC ;


(*
   checkDeclareUnboundedParamCopyC -
*)

PROCEDURE checkDeclareUnboundedParamCopyC (p: pretty; n: node) : BOOLEAN ;
VAR
   t   : node ;
   i, c: CARDINAL ;
   l   : wlist ;
   seen: BOOLEAN ;
BEGIN
   seen := FALSE ;
   t := getType (n) ;
   l := n^.paramF.namelist^.identlistF.names ;
   IF isArray (t) AND isUnbounded (t) AND (l#NIL)
   THEN
      t := getType (t) ;
      c := wlists.noOfItemsInList (l) ;
      i := 1 ;
      WHILE i <= c DO
         doTypeNameC (p, t) ;
         setNeedSpace (p) ;
         doNamesC (p, wlists.getItemFromList (l, i)) ;
         outText (p, '[_');
         doNamesC (p, wlists.getItemFromList (l, i)) ;
         outText (p, '_high+1];\n');
         seen := TRUE ;
         INC (i)
      END
   END ;
   RETURN seen
END checkDeclareUnboundedParamCopyC ;


(*
   checkUnboundedParamCopyC -
*)

PROCEDURE checkUnboundedParamCopyC (p: pretty; n: node) ;
VAR
   t, s: node ;
   i, c: CARDINAL ;
   l   : wlist ;
BEGIN
   t := getType (n) ;
   l := n^.paramF.namelist^.identlistF.names ;
   IF isArray (t) AND isUnbounded (t) AND (l#NIL)
   THEN
      c := wlists.noOfItemsInList (l) ;
      i := 1 ;
      t := getType (t) ;
      s := skipType (t) ;
      WHILE i <= c DO
         keyc.useMemcpy ;
         outText (p, 'memcpy (') ;
         doNamesC (p, wlists.getItemFromList (l, i)) ;
         outText (p, ',') ;
         setNeedSpace (p) ;
         doNamesC (p, wlists.getItemFromList (l, i)) ;
         outText (p, '_, ') ;
         IF (s = charN) OR (s = byteN) OR (s = locN)
         THEN
            outText (p, '_') ;
            doNamesC (p, wlists.getItemFromList (l, i)) ;
            outText (p, '_high+1);\n')
         ELSE
            outText (p, '(_') ;
            doNamesC (p, wlists.getItemFromList (l, i)) ;
            outText (p, '_high+1)') ;
            setNeedSpace (p) ;
            doMultiplyBySize (p, t) ;
            outText (p, ');\n')
         END ;
         INC (i)
      END
   END
END checkUnboundedParamCopyC ;


(*
   doUnboundedParamCopyC -
*)

PROCEDURE doUnboundedParamCopyC (p: pretty; n: node) ;
VAR
   i, h: CARDINAL ;
   q   : node ;
   seen: BOOLEAN ;
BEGIN
   assert (isProcedure (n)) ;
   i := LowIndice (n^.procedureF.parameters) ;
   h := HighIndice (n^.procedureF.parameters) ;
   seen := FALSE ;
   WHILE i <= h DO
      q := GetIndice (n^.procedureF.parameters, i) ;
      IF isParam (q)
      THEN
         seen := checkDeclareUnboundedParamCopyC (p, q) OR seen
      END ;
      INC (i)
   END ;
   IF seen
   THEN
      outText (p, "\n") ;
      outText (p, "/* make a local copy of each unbounded array.  */\n") ;
      i := LowIndice (n^.procedureF.parameters) ;
      WHILE i <= h DO
         q := GetIndice (n^.procedureF.parameters, i) ;
         IF isParam (q)
         THEN
            checkUnboundedParamCopyC (p, q)
         END ;
         INC (i)
      END
   END
END doUnboundedParamCopyC ;


(*
   doPrototypeC -
*)

PROCEDURE doPrototypeC (n: node) ;
BEGIN
   IF NOT isExported (n)
   THEN
      keyc.enterScope (n) ;
      doProcedureHeadingC (n, TRUE) ;
      print (doP, ";\n") ;
      keyc.leaveScope (n)
   END
END doPrototypeC ;


(*
   addTodo - adds, n, to the todo list.
*)

PROCEDURE addTodo (n: node) ;
BEGIN
   IF (n#NIL) AND
      (NOT alists.isItemInList (partialQ, n)) AND
      (NOT alists.isItemInList (doneQ, n))
   THEN
      assert (NOT isVarient (n)) ;
      assert (NOT isVarientField (n)) ;
      assert (NOT isDef (n)) ;
      alists.includeItemIntoList (todoQ, n)
   END
END addTodo ;


(*
   addVariablesTodo -
*)

PROCEDURE addVariablesTodo (n: node) ;
BEGIN
   IF isVar (n)
   THEN
      IF n^.varF.isParameter OR n^.varF.isVarParameter
      THEN
         addDone (n) ;
         addTodo (getType (n))
      ELSE
         addTodo (n)
      END
   END
END addVariablesTodo ;


(*
   addTypesTodo -
*)

PROCEDURE addTypesTodo (n: node) ;
BEGIN
   IF isUnbounded (n)
   THEN
      addDone (n)
   ELSE
      addTodo (n)
   END
END addTypesTodo ;


(*
   tempName -
*)

PROCEDURE tempName () : String ;
BEGIN
   INC (tempCount) ;
   RETURN Sprintf1 (InitString ("_T%d"), tempCount) ;
END tempName ;


(*
   makeIntermediateType -
*)

PROCEDURE makeIntermediateType (s: String; p: node) : node ;
VAR
   n: Name ;
   o: node ;
BEGIN
   n := makekey (DynamicStrings.string (s)) ;
   enterScope (getScope (p)) ;
   o := p ;
   p := makeType (makekey (DynamicStrings.string (s))) ;
   putType (p, o) ;
   putTypeInternal (p) ;
   leaveScope ;
   RETURN p
END makeIntermediateType ;


(*
   simplifyType -
*)

PROCEDURE simplifyType (l: alist; VAR p: node) ;
VAR
   s: String ;
BEGIN
   IF (p#NIL) AND (isRecord (p) OR isArray (p) OR isProcType (p)) AND (NOT isUnbounded (p))
   THEN
      s := tempName () ;
      p := makeIntermediateType (s, p) ;
      s := KillString (s) ;
      simplified := FALSE
   END ;
   simplifyNode (l, p)
END simplifyType ;


(*
   simplifyVar -
*)

PROCEDURE simplifyVar (l: alist; n: node) ;
VAR
   i, t: CARDINAL ;
   v,
   d, o: node ;
BEGIN
   assert (isVar (n)) ;
   o := n^.varF.type ;
   simplifyType (l, n^.varF.type) ;
   IF o # n^.varF.type
   THEN
      (* simplification has occurred, make sure that all other variables of this type
         use the new type.  *)
      d := n^.varF.decl ;
      assert (isVarDecl (d)) ;
      t := wlists.noOfItemsInList (d^.vardeclF.names) ;
      i := 1 ;
      WHILE i<=t DO
         v := lookupInScope (n^.varF.scope, wlists.getItemFromList (d^.vardeclF.names, i)) ;
         assert (isVar (v)) ;
         v^.varF.type := n^.varF.type ;
         INC (i)
      END
   END
END simplifyVar ;


(*
   simplifyRecord -
*)

PROCEDURE simplifyRecord (l: alist; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   i := LowIndice (n^.recordF.listOfSons) ;
   t := HighIndice (n^.recordF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.recordF.listOfSons, i) ;
      simplifyNode (l, q) ;
      INC (i)
   END
END simplifyRecord ;


(*
   simplifyVarient -
*)

PROCEDURE simplifyVarient (l: alist; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   simplifyNode (l, n^.varientF.tag) ;
   i := LowIndice (n^.varientF.listOfSons) ;
   t := HighIndice (n^.varientF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientF.listOfSons, i) ;
      simplifyNode (l, q) ;
      INC (i)
   END
END simplifyVarient ;


(*
   simplifyVarientField -
*)

PROCEDURE simplifyVarientField (l: alist; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   i := LowIndice (n^.varientfieldF.listOfSons) ;
   t := HighIndice (n^.varientfieldF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientfieldF.listOfSons, i) ;
      simplifyNode (l, q) ;
      INC (i)
   END
END simplifyVarientField ;


(*
   doSimplifyNode -
*)

PROCEDURE doSimplifyNode (l: alist; n: node) ;
BEGIN
   IF n=NIL
   THEN
      (* nothing.  *)
   ELSIF isType (n)
   THEN
      (* no need to simplify a type.  *)
      simplifyNode (l, getType (n))
   ELSIF isVar (n)
   THEN
      simplifyVar (l, n)
   ELSIF isRecord (n)
   THEN
      simplifyRecord (l, n)
   ELSIF isRecordField (n)
   THEN
      simplifyType (l, n^.recordfieldF.type)
   ELSIF isArray (n)
   THEN
      simplifyType (l, n^.arrayF.type)
   ELSIF isVarient (n)
   THEN
      simplifyVarient (l, n)
   ELSIF isVarientField (n)
   THEN
      simplifyVarientField (l, n)
   ELSIF isPointer (n)
   THEN
      simplifyType (l, n^.pointerF.type)
   END
END doSimplifyNode ;


(*
   simplifyNode -
*)

PROCEDURE simplifyNode (l: alist; n: node) ;
BEGIN
   IF NOT alists.isItemInList (l, n)
   THEN
      alists.includeItemIntoList (l, n) ;
      doSimplifyNode (l, n)
   END
END simplifyNode ;


(*
   doSimplify -
*)

PROCEDURE doSimplify (n: node) ;
VAR
   l: alist ;
BEGIN
   l := alists.initList () ;
   simplifyNode (l, n) ;
   alists.killList (l)
END doSimplify ;


(*
   simplifyTypes -
*)

PROCEDURE simplifyTypes (s: scopeT) ;
BEGIN
   REPEAT
      simplified := TRUE ;
      ForeachIndiceInIndexDo (s.types, doSimplify) ;
      ForeachIndiceInIndexDo (s.variables, doSimplify)
   UNTIL simplified
END simplifyTypes ;


(*
   outDeclsDefC -
*)

PROCEDURE outDeclsDefC (p: pretty; n: node) ;
VAR
   s: scopeT ;
BEGIN
   s := n^.defF.decls ;
   simplifyTypes (s) ;
   includeConstType (s) ;

   doP := p ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone) ;

   (* try and output types, constants before variables and procedures.  *)
   includeDefVarProcedure (n) ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone) ;

   ForeachIndiceInIndexDo (s.procedures, doPrototypeC)
END outDeclsDefC ;


(*
   includeConstType -
*)

PROCEDURE includeConstType (s: scopeT) ;
BEGIN
   ForeachIndiceInIndexDo (s.constants, addTodo) ;
   ForeachIndiceInIndexDo (s.types, addTypesTodo)
END includeConstType ;


(*
   includeVarProcedure -
*)

PROCEDURE includeVarProcedure (s: scopeT) ;
BEGIN
   ForeachIndiceInIndexDo (s.procedures, addTodo) ;
   ForeachIndiceInIndexDo (s.variables, addVariablesTodo)
END includeVarProcedure ;


(*
   includeVar -
*)

PROCEDURE includeVar (s: scopeT) ;
BEGIN
   ForeachIndiceInIndexDo (s.variables, addTodo)
END includeVar ;


(*
   includeExternals -
*)

PROCEDURE includeExternals (n: node) ;
VAR
   l: alist ;
BEGIN
   l := alists.initList () ;
   visitNode (l, n, addExported) ;
   alists.killList (l)
END includeExternals ;


(*
   checkSystemInclude -
*)

PROCEDURE checkSystemInclude (n: node) ;
BEGIN

END checkSystemInclude ;


(*
   addExported -
*)

PROCEDURE addExported (n: node) ;
VAR
   s: node ;
BEGIN
   s := getScope (n) ;
   IF (s # NIL) AND isDef (s) AND (s # defModule)
   THEN
      IF isType (n) OR isVar (n) OR isConst (n)
      THEN
         addTodo (n)
      END
   END
END addExported ;


(*
   addExternal - only adds, n, if this symbol is external to the
                 implementation module and is not a hidden type.
*)

PROCEDURE addExternal (n: node) ;
BEGIN
   IF (getScope (n) = defModule) AND isType (n) AND
      isTypeHidden (n) AND (NOT getExtendedOpaque ())
   THEN
      (* do nothing.  *)
   ELSIF NOT isDef (n)
   THEN
      addTodo (n)
   END
END addExternal ;


(*
   includeDefConstType -
*)

PROCEDURE includeDefConstType (n: node) ;
VAR
   d: node ;
BEGIN
   IF isImp (n)
   THEN
      defModule := lookupDef (getSymName (n)) ;
      IF defModule#NIL
      THEN
         simplifyTypes (defModule^.defF.decls) ;
         includeConstType (defModule^.defF.decls) ;
	 foreachNodeDo (defModule^.defF.decls.symbols, addExternal)
      END
   END
END includeDefConstType ;


(*
   runIncludeDefConstType -
*)

PROCEDURE runIncludeDefConstType (n: node) ;
VAR
   d: node ;
BEGIN
   IF isDef (n)
   THEN
      simplifyTypes (n^.defF.decls) ;
      includeConstType (n^.defF.decls) ;
      foreachNodeDo (n^.defF.decls.symbols, addExternal)
   END
END runIncludeDefConstType ;


(*
   joinProcedures - copies procedures from definition module,
                    d, into implementation module, i.
*)

PROCEDURE joinProcedures (i, d: node) ;
VAR
   h, j: CARDINAL ;
BEGIN
   assert (isDef (d)) ;
   assert (isImp (i)) ;
   j := 1 ;
   h := HighIndice (d^.defF.decls.procedures) ;
   WHILE j<=h DO
      IncludeIndiceIntoIndex (i^.impF.decls.procedures,
                              GetIndice (d^.defF.decls.procedures, j)) ;
      INC (j)
   END
END joinProcedures ;


(*
   includeDefVarProcedure -
*)

PROCEDURE includeDefVarProcedure (n: node) ;
VAR
   d: node ;
BEGIN
   IF isImp (n)
   THEN
      defModule := lookupDef (getSymName (n)) ;
      IF defModule#NIL
      THEN
(*
         includeVar (defModule^.defF.decls) ;
         simplifyTypes (defModule^.defF.decls) ;
*)
         joinProcedures (n, defModule)
      END
   ELSIF isDef (n)
   THEN
      includeVar (n^.defF.decls) ;
      simplifyTypes (n^.defF.decls)
   END
END includeDefVarProcedure ;


(*
   foreachModuleDo -
*)

PROCEDURE foreachModuleDo (n: node; p: performOperation) ;
BEGIN
   foreachDefModuleDo (p) ;
   foreachModModuleDo (p)
END foreachModuleDo ;


(*
   outDeclsImpC -
*)

PROCEDURE outDeclsImpC (p: pretty; s: scopeT) ;
BEGIN
   simplifyTypes (s) ;
   includeConstType (s) ;

   doP := p ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone) ;

   (* try and output types, constants before variables and procedures.  *)
   includeVarProcedure (s) ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone) ;

END outDeclsImpC ;


(*
   doStatementSequenceC -
*)

PROCEDURE doStatementSequenceC (p: pretty; s: node) ;
VAR
   i, h: CARDINAL ;
BEGIN
   assert (isStatementSequence (s)) ;
   h := HighIndice (s^.stmtF.statements) ;
   i := 1 ;
   WHILE i<=h DO
      doStatementsC (p, GetIndice (s^.stmtF.statements, i)) ;
      INC (i)
   END
END doStatementSequenceC ;


(*
   isStatementSequenceEmpty -
*)

PROCEDURE isStatementSequenceEmpty (s: node) : BOOLEAN ;
BEGIN
   assert (isStatementSequence (s)) ;
   RETURN HighIndice (s^.stmtF.statements) = 0
END isStatementSequenceEmpty ;


(*
   isSingleStatement - returns TRUE if the statement sequence, s, has
                       only one statement.
*)

PROCEDURE isSingleStatement (s: node) : BOOLEAN ;
VAR
   h: CARDINAL ;
BEGIN
   assert (isStatementSequence (s)) ;
   h := HighIndice (s^.stmtF.statements) ;
   IF (h = 0) OR (h > 1)
   THEN
      RETURN FALSE
   END ;
   s := GetIndice (s^.stmtF.statements, 1) ;
   RETURN (NOT isStatementSequence (s)) OR isSingleStatement (s)
END isSingleStatement ;


(*
   doCommentC -
*)

PROCEDURE doCommentC (p: pretty; s: node) ;
VAR
   c: String ;
BEGIN
   IF s # NIL
   THEN
      assert (isComment (s)) ;
      IF NOT isProcedureComment (s^.commentF.content)
      THEN
         IF isAfterComment (s^.commentF.content)
         THEN
            setNeedSpace (p) ;
            outText (p, " /* ")
         ELSE
            outText (p, "/* ")
         END ;
         c := getContent (s^.commentF.content) ;
         c := RemoveWhitePrefix (RemoveWhitePostfix (c)) ;
         outTextS (p, c) ;
         outText (p, "  */\n")
      END
   END
END doCommentC ;


(*
   doAfterCommentC - emit an after comment, c, or a newline if, c, is empty.
*)

PROCEDURE doAfterCommentC (p: pretty; c: node) ;
BEGIN
   IF c = NIL
   THEN
      outText (p, "\n")
   ELSE
      doCommentC (p, c)
   END
END doAfterCommentC ;


(*
   doReturnC - issue a return statement and also place in an after comment if one exists.
*)

PROCEDURE doReturnC (p: pretty; s: node) ;
BEGIN
   assert (isReturn (s)) ;
   doCommentC (p, s^.returnF.returnComment.body) ;
   outText (p, "return") ;
   IF s^.returnF.scope#NIL
   THEN
      setNeedSpace (p) ;
      IF (NOT isProcedure (s^.returnF.scope)) OR (getType (s^.returnF.scope)=NIL)
      THEN
         metaError1 ('{%1DMad} has no return type', s^.returnF.scope) ;
      ELSE
         doExprCastC (p, s^.returnF.exp, getType (s^.returnF.scope))
      END
   END ;
   outText (p, ";") ;
   doAfterCommentC (p, s^.returnF.returnComment.after)
END doReturnC ;


(*
   isZtypeEquivalent -
*)

PROCEDURE isZtypeEquivalent (type: node) : BOOLEAN ;
BEGIN
   CASE type^.kind OF

   cardinal,
   longcard,
   shortcard,
   integer,
   longint,
   shortint,
   ztype    :  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isZtypeEquivalent ;


(*
   isEquivalentType - returns TRUE if type1 and type2 are equivalent.
*)

PROCEDURE isEquivalentType (type1, type2: node) : BOOLEAN ;
BEGIN
   type1 := skipType (type1) ;
   type2 := skipType (type2) ;
   RETURN ((type1 = type2) OR
           (isZtypeEquivalent (type1) AND isZtypeEquivalent (type2)))
END isEquivalentType ;


(*
   doExprCastC - build a cast if necessary.
*)

PROCEDURE doExprCastC (p: pretty; e, type: node) ;
VAR
   stype: node ;
BEGIN
   stype := skipType (type) ;
   IF (NOT isEquivalentType (type, getExprType (e))) AND
      (NOT ((e^.kind = nil) AND (isPointer (stype) OR (stype^.kind = address))))
   THEN
      IF lang = ansiCP
      THEN
         (* potentially a cast is required.  *)
         IF isPointer (type) OR (type = addressN)
         THEN
            outText (p, 'reinterpret_cast<') ;
            doTypeNameC (p, type) ;
            noSpace (p) ;
            outText (p, '> (') ;
            doExprC (p, e) ;
	    outText (p, ')') ;
            RETURN
         ELSE
            outText (p, 'static_cast<') ;
            IF isProcType (skipType (type))
            THEN
               doTypeNameC (p, type) ;
               outText (p, "_t")
            ELSE
               doTypeNameC (p, type)
            END ;
            noSpace (p) ;
            outText (p, '> (') ;
            doExprC (p, e) ;
	    outText (p, ')') ;
            RETURN
         END
      END
   END ;
   doExprC (p, e)
END doExprCastC ;


(*
   requiresUnpackProc - returns TRUE if either the expr is a procedure or the proctypes differ.
*)

PROCEDURE requiresUnpackProc (s: node) : BOOLEAN ;
BEGIN
   assert (isAssignment (s)) ;
   RETURN isProcedure (s^.assignmentF.expr) OR
          (skipType (getType (s^.assignmentF.des)) # skipType (getType (s^.assignmentF.expr)))
END requiresUnpackProc ;


(*
   doAssignmentC -
*)

PROCEDURE doAssignmentC (p: pretty; s: node) ;
BEGIN
   assert (isAssignment (s)) ;
   doCommentC (p, s^.assignmentF.assignComment.body) ;
   doExprCup (p, s^.assignmentF.des, requiresUnpackProc (s)) ;
   setNeedSpace (p) ;
   outText (p, "=") ;
   setNeedSpace (p) ;
   doExprCastC (p, s^.assignmentF.expr, getType (s^.assignmentF.des)) ;
   outText (p, ";") ;
   doAfterCommentC (p, s^.assignmentF.assignComment.after)
END doAssignmentC ;


(*
   containsStatement -
*)

PROCEDURE containsStatement (s: node) : BOOLEAN ;
BEGIN
   RETURN (s # NIL) AND isStatementSequence (s) AND (NOT isStatementSequenceEmpty (s))
END containsStatement ;


(*
   doCompoundStmt -
*)

PROCEDURE doCompoundStmt (p: pretty; s: node) ;
BEGIN
   IF (s = NIL) OR (isStatementSequence (s) AND isStatementSequenceEmpty (s))
   THEN
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "{}  /* empty.  */\n") ;
      p := popPretty (p)
   ELSIF isStatementSequence (s) AND isSingleStatement (s) AND (NOT forceCompoundStatement)
   THEN
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      doStatementSequenceC (p, s) ;
      p := popPretty (p)
   ELSE
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "{\n") ;
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      doStatementSequenceC (p, s) ;
      p := popPretty (p) ;
      outText (p, "}\n") ;
      p := popPretty (p)
   END
END doCompoundStmt ;


(*
   doElsifC -
*)

PROCEDURE doElsifC (p: pretty; s: node) ;
BEGIN
   assert (isElsif (s)) ;
   outText (p, "else if") ;
   setNeedSpace (p) ;
   outText (p, "(") ;
   doExprC (p, s^.elsifF.expr) ;
   outText (p, ")\n") ;
   assert ((s^.elsifF.else = NIL) OR (s^.elsifF.elsif = NIL)) ;
   IF forceCompoundStatement OR
      (hasIfAndNoElse (s^.elsifF.then) AND
       ((s^.elsifF.else # NIL) OR (s^.elsifF.elsif # NIL)))
   THEN
      (* avoid dangling else.  *)
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "{\n") ;
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "/* avoid dangling else.  */\n") ;
      doStatementSequenceC (p, s^.elsifF.then) ;
      p := popPretty (p) ;
      outText (p, "}\n") ;
      p := popPretty (p)
   ELSE
      doCompoundStmt (p, s^.elsifF.then)
   END ;
   IF containsStatement (s^.elsifF.else)
   THEN
      outText (p, "else\n") ;
      IF forceCompoundStatement
      THEN
         (* avoid dangling else.  *)
         p := pushPretty (p) ;
         setindent (p, getindent (p) + indentationC) ;
         outText (p, "{\n") ;
         p := pushPretty (p) ;
         setindent (p, getindent (p) + indentationC) ;
         outText (p, "/* avoid dangling else.  */\n") ;
         doStatementSequenceC (p, s^.elsifF.else) ;
         p := popPretty (p) ;
         outText (p, "}\n") ;
         p := popPretty (p)
      ELSE
         doCompoundStmt (p, s^.elsifF.else)
      END
   ELSIF (s^.elsifF.elsif#NIL) AND isElsif (s^.elsifF.elsif)
   THEN
      doElsifC (p, s^.elsifF.elsif)
   END
END doElsifC ;


(*
   noIfElse -
*)

PROCEDURE noIfElse (n: node) : BOOLEAN ;
BEGIN
   RETURN (n # NIL) AND isIf (n) AND (n^.ifF.else = NIL) AND (n^.ifF.elsif = NIL)
END noIfElse ;


(*
   noIfElseChained - returns TRUE if, n, is an IF statement which
                     has no associated ELSE statement.  An IF with an
                     ELSIF is also checked for no ELSE and will result
                     in a return value of TRUE.
*)

PROCEDURE noIfElseChained (n: node) : BOOLEAN ;
VAR
   e: node ;
BEGIN
   IF n # NIL
   THEN
      IF isIf (n)
      THEN
         IF n^.ifF.else # NIL
         THEN
            (* we do have an else, continue to check this statement.  *)
            RETURN hasIfAndNoElse (n^.ifF.else)
         ELSIF n^.ifF.elsif = NIL
         THEN
            (* neither else or elsif.  *)
            RETURN TRUE
         ELSE
            (* test elsif for lack of else.  *)
            e := n^.ifF.elsif ;
	    assert (isElsif (e)) ;
            RETURN noIfElseChained (e)
         END
      ELSIF isElsif (n)
      THEN
         IF n^.elsifF.else # NIL
         THEN
            (* we do have an else, continue to check this statement.  *)
            RETURN hasIfAndNoElse (n^.elsifF.else)
         ELSIF n^.elsifF.elsif = NIL
         THEN
            (* neither else or elsif.  *)
            RETURN TRUE
         ELSE
            (* test elsif for lack of else.  *)
            e := n^.elsifF.elsif ;
	    assert (isElsif (e)) ;
            RETURN noIfElseChained (e)
         END
      END
   END ;
   RETURN FALSE
END noIfElseChained ;


(*
   hasIfElse -
*)

PROCEDURE hasIfElse (n: node) : BOOLEAN ;
BEGIN
   IF n # NIL
   THEN
      IF isStatementSequence (n)
      THEN
         IF isStatementSequenceEmpty (n)
         THEN
            RETURN FALSE
         ELSIF isSingleStatement (n)
         THEN
            n := GetIndice (n^.stmtF.statements, 1) ;
	    RETURN isIfElse (n)
         END
      END
   END ;
   RETURN FALSE
END hasIfElse ;


(*
   isIfElse -
*)

PROCEDURE isIfElse (n: node) : BOOLEAN ;
BEGIN
   RETURN (n # NIL) AND isIf (n) AND ((n^.ifF.else # NIL) OR (n^.ifF.elsif # NIL))
END isIfElse ;


(*
   hasIfAndNoElse - returns TRUE if statement, n, is a single statement
                    which is an IF and it has no else statement.
*)

PROCEDURE hasIfAndNoElse (n: node) : BOOLEAN ;
BEGIN
   IF n # NIL
   THEN
      IF isStatementSequence (n)
      THEN
         IF isStatementSequenceEmpty (n)
         THEN
            RETURN FALSE
         ELSIF isSingleStatement (n)
         THEN
            n := GetIndice (n^.stmtF.statements, 1) ;
	    RETURN hasIfAndNoElse (n)
         ELSE
            n := GetIndice (n^.stmtF.statements, HighIndice (n^.stmtF.statements)) ;
	    RETURN hasIfAndNoElse (n)
         END
      ELSIF isElsif (n) OR isIf (n)
      THEN
         RETURN noIfElseChained (n)
      END
   END ;
   RETURN FALSE
END hasIfAndNoElse ;


(*
   doIfC - issue an if statement and also place in an after comment if one exists.
           The if statement might contain an else or elsif which are also handled.
*)

PROCEDURE doIfC (p: pretty; s: node) ;
BEGIN
   assert (isIf (s)) ;
   doCommentC (p, s^.ifF.ifComment.body) ;
   outText (p, "if") ;
   setNeedSpace (p) ;
   outText (p, "(") ;
   doExprC (p, s^.ifF.expr) ;
   outText (p, ")") ;
   doAfterCommentC (p, s^.ifF.ifComment.after) ;
   IF hasIfAndNoElse (s^.ifF.then) AND
      ((s^.ifF.else # NIL) OR (s^.ifF.elsif # NIL))
   THEN
      (* avoid dangling else.  *)
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "{\n") ;
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "/* avoid dangling else.  */\n") ;
      doStatementSequenceC (p, s^.ifF.then) ;
      p := popPretty (p) ;
      outText (p, "}\n") ;
      p := popPretty (p)
   ELSIF noIfElse (s) AND hasIfElse (s^.ifF.then)
   THEN
      (* gcc does not like legal non dangling else, as it is poor style.
         So we will avoid getting a warning.  *)
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "{\n") ;
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      outText (p, "/* avoid gcc warning by using compound statement even if not strictly necessary.  */\n") ;
      doStatementSequenceC (p, s^.ifF.then) ;
      p := popPretty (p) ;
      outText (p, "}\n") ;
      p := popPretty (p)
   ELSE
      doCompoundStmt (p, s^.ifF.then)
   END ;
   assert ((s^.ifF.else = NIL) OR (s^.ifF.elsif = NIL)) ;
   IF containsStatement (s^.ifF.else)
   THEN
      doCommentC (p, s^.ifF.elseComment.body) ;
      outText (p, "else") ;
      doAfterCommentC (p, s^.ifF.elseComment.after) ;
      doCompoundStmt (p, s^.ifF.else)
   ELSIF (s^.ifF.elsif#NIL) AND isElsif (s^.ifF.elsif)
   THEN
      doCommentC (p, s^.ifF.elseComment.body) ;
      doCommentC (p, s^.ifF.elseComment.after) ;
      doElsifC (p, s^.ifF.elsif)
   END ;
   doCommentC (p, s^.ifF.endComment.after) ;
   doCommentC (p, s^.ifF.endComment.body)
END doIfC ;


(*
   doForIncCP -
*)

PROCEDURE doForIncCP (p: pretty; s: node) ;
VAR
   t: node ;
BEGIN
   assert (isFor (s)) ;
   t := skipType (getType (s^.forF.des)) ;
   IF isEnumeration (t)
   THEN
      IF s^.forF.increment = NIL
      THEN
         doExprC (p, s^.forF.des) ;
         outText (p, "= static_cast<") ;
         doTypeNameC (p, getType (s^.forF.des)) ;
	 noSpace (p) ;
         outText (p, ">(static_cast<int>(") ;
         doExprC (p, s^.forF.des) ;
         outText (p, "+1))")
      ELSE
         doExprC (p, s^.forF.des) ;
         outText (p, "= static_cast<") ;
         doTypeNameC (p, getType (s^.forF.des)) ;
         noSpace (p) ;
         outText (p, ">(static_cast<int>(") ;
         doExprC (p, s^.forF.des) ;
         outText (p, "+") ;
         doExprC (p, s^.forF.increment) ;
         outText (p, "))")
      END
   ELSE
      doForIncC (p, s)
   END
END doForIncCP ;


(*
   doForIncC -
*)

PROCEDURE doForIncC (p: pretty; s: node) ;
BEGIN
   IF s^.forF.increment = NIL
   THEN
      doExprC (p, s^.forF.des) ;
      outText (p, "++")
   ELSE
      doExprC (p, s^.forF.des) ;
      outText (p, "=") ;
      doExprC (p, s^.forF.des) ;
      outText (p, "+") ;
      doExprC (p, s^.forF.increment)
   END
END doForIncC ;


(*
   doForInc -
*)

PROCEDURE doForInc (p: pretty; s: node) ;
BEGIN
   IF lang = ansiCP
   THEN
      doForIncCP (p, s)
   ELSE
      doForIncC (p, s)
   END
END doForInc ;


(*
   doForC -
*)

PROCEDURE doForC (p: pretty; s: node) ;
BEGIN
   assert (isFor (s)) ;
   outText (p, "for (") ;
   doExprC (p, s^.forF.des) ;
   outText (p, "=") ;
   doExprC (p, s^.forF.start) ;
   outText (p, ";") ;
   setNeedSpace (p) ;
   doExprC (p, s^.forF.des) ;
   outText (p, "<=") ;
   doExprC (p, s^.forF.end) ;
   outText (p, ";") ;
   setNeedSpace (p) ;
   doForInc (p, s) ;
   outText (p, ")\n") ;
   doCompoundStmt (p, s^.forF.statements)
END doForC ;


(*
   doRepeatC -
*)

PROCEDURE doRepeatC (p: pretty; s: node) ;
BEGIN
   assert (isRepeat (s)) ;
   doCommentC (p, s^.repeatF.repeatComment.body) ;
   outText (p, "do {") ;
   doAfterCommentC (p, s^.repeatF.repeatComment.after) ;
   p := pushPretty (p) ;
   setindent (p, getindent (p) + indentationC) ;
   doStatementSequenceC (p, s^.repeatF.statements) ;
   doCommentC (p, s^.repeatF.untilComment.body) ;
   p := popPretty (p) ;
   outText (p, "} while (! (") ;
   doExprC (p, s^.repeatF.expr) ;
   outText (p, "));") ;
   doAfterCommentC (p, s^.repeatF.untilComment.after)
END doRepeatC ;


(*
   doWhileC -
*)

PROCEDURE doWhileC (p: pretty; s: node) ;
BEGIN
   assert (isWhile (s)) ;
   doCommentC (p, s^.whileF.doComment.body) ;
   outText (p, "while (") ;
   doExprC (p, s^.whileF.expr) ;
   outText (p, ")") ;
   doAfterCommentC (p, s^.whileF.doComment.after) ;
   doCompoundStmt (p, s^.whileF.statements) ;
   doCommentC (p, s^.whileF.endComment.body) ;
   doCommentC (p, s^.whileF.endComment.after)
END doWhileC ;


(*
   doFuncHighC -
*)

PROCEDURE doFuncHighC (p: pretty; a: node) ;
VAR
   s, n: node ;
BEGIN
   IF isLiteral (a) AND (getType (a) = charN)
   THEN
      outCard (p, 0)
   ELSIF isString (a)
   THEN
      outCard (p, a^.stringF.length-2)
   ELSIF isConst (a) AND isString (a^.constF.value)
   THEN
      doFuncHighC (p, a^.constF.value)
   ELSIF isUnbounded (getType (a))
   THEN
      outText (p, '_') ;
      outTextN (p, getSymName (a)) ;
      outText (p, '_high')
   ELSIF isArray (skipType (getType (a)))
   THEN
      n := skipType (getType (a)) ;
      s := n^.arrayF.subr ;
      IF isZero (getMin (s))
      THEN
         doExprC (p, getMax (s))
      ELSE
         outText (p, '(') ;
         doExprC (p, getMax (s)) ;
         doSubtractC (p, getMin (s)) ;
         outText (p, ')')
      END
   ELSE
      (* output sizeof (a) in bytes for the high.  *)
      outText (p, '(sizeof') ;
      setNeedSpace (p) ;
      outText (p, '(') ;
      doExprC (p, a) ;
      outText (p, ')-1)')
   END
END doFuncHighC ;


(*
   doMultiplyBySize -
*)

PROCEDURE doMultiplyBySize (p: pretty; a: node) ;
BEGIN
   IF (a # charN) AND (a # byteN) AND (a # locN)
   THEN
      setNeedSpace (p) ;
      outText (p, '* sizeof (') ;
      doTypeNameC (p, a) ;
      noSpace (p) ;
      outText (p, ')')
   END
END doMultiplyBySize ;


(*
   doTotype -
*)

PROCEDURE doTotype (p: pretty; a, t: node) ;
BEGIN
   IF (NOT isString (a)) AND (NOT isLiteral (a))
   THEN
      IF isVar (a)
      THEN
         IF (a^.varF.isParameter OR a^.varF.isVarParameter) AND
	    isUnbounded (getType (a)) AND (skipType (getType (getType (a))) = skipType (getType (t)))
         THEN
            (* do not multiply by size as the existing high value is correct.  *)
            RETURN
         END ;
         a := getType (a) ;
         IF isArray (a)
         THEN
            doMultiplyBySize (p, skipType (getType (a)))
         END
      END
   END ;
   IF t = wordN
   THEN
      setNeedSpace (p) ;
      outText (p, '/ sizeof (') ;
      doTypeNameC (p, wordN) ;
      noSpace (p) ;
      outText (p, ')')
   END
END doTotype ;


(*
   doFuncUnbounded -
*)

PROCEDURE doFuncUnbounded (p: pretty; actual, formalParam, formal, func: node) ;
VAR
   h: node ;
   s: String ;
BEGIN
   assert (isUnbounded (formal)) ;
   outText (p, '(') ;
   IF (lang = ansiCP) AND isParam (formalParam)
   THEN
      outText (p, "const") ;
      setNeedSpace (p)
   END ;
   doTypeC (p, getType (formal), formal) ;
   setNeedSpace (p) ;
   outText (p, '*)') ;
   setNeedSpace (p) ;
   IF isLiteral (actual) AND (getType (actual) = charN)
   THEN
      outText (p, '"\0') ;
      s := InitStringCharStar (keyToCharStar (actual^.literalF.name)) ;
      s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) ;
      outTextS (p, s) ;
      outText (p, '"') ;
      s := KillString (s)
   ELSIF isString (actual)
   THEN
      outCstring (p, actual, TRUE)
   ELSIF isConst (actual)
   THEN
      actual := resolveString (actual) ;
      assert (isString (actual)) ;
      outCstring (p, actual, TRUE)
   ELSIF isFuncCall (actual)
   THEN
      IF getExprType (actual) = NIL
      THEN
         metaError3 ('there is no return type to the procedure function {%3ad} which is being passed as the parameter {%1ad} to {%2ad}', formal, func, actual)
      ELSE
         outText (p, '&') ;
         doExprC (p, actual)
      END
   ELSIF isUnbounded (getType (actual))
   THEN
      doFQNameC (p, actual)
      (* doExprC (p, actual).  *)
   ELSE
      outText (p, '&') ;
      doExprC (p, actual) ;
      IF isArray (skipType (getType (actual)))
      THEN
         outText (p, '.array[0]')
      END
   END ;
   IF NOT (enableDefForCStrings AND isDefForC (getScope (func)))
   THEN
      outText (p, ',') ;
      setNeedSpace (p) ;
      doFuncHighC (p, actual) ;
      doTotype (p, actual, formal)
   END
END doFuncUnbounded ;


(*
   doProcedureParamC -
*)

PROCEDURE doProcedureParamC (p: pretty; actual, formal: node) ;
BEGIN
   IF isForC (formal)
   THEN
      outText (p, '(') ;
      doFQNameC (p, getType (formal)) ;
      outText (p, "_C") ;
      outText (p, ')') ;
      setNeedSpace (p) ;
      doExprC (p, actual)
   ELSE
      outText (p, '(') ;
      doTypeNameC (p, getType (formal)) ;
      outText (p, ')') ;
      setNeedSpace (p) ;
      outText (p, '{') ;
      outText (p, '(') ;
      doFQNameC (p, getType (formal)) ;
      outText (p, '_t)') ;
      setNeedSpace (p) ;
      doExprC (p, actual) ;
      outText (p, '}')
    END
END doProcedureParamC ;


(*
   doAdrExprC -
*)

PROCEDURE doAdrExprC (p: pretty; n: node) ;
BEGIN
   IF isDeref (n)
   THEN
      (* (* no point in issuing & ( * n )  *) *)
      doExprC (p, n^.unaryF.arg)
   ELSIF isVar (n) AND n^.varF.isVarParameter
   THEN
      (* (* no point in issuing & ( * n )  *) *)
      doFQNameC (p, n)
   ELSE
      outText (p, '&') ;
      doExprC (p, n)
   END
END doAdrExprC ;


(*
   typePair -
*)

PROCEDURE typePair (a, b, x, y: node) : BOOLEAN ;
BEGIN
   RETURN ((a = x) AND (b = y)) OR ((a = y) AND (b = x))
END typePair ;


(*
   needsCast - return TRUE if the actual type parameter needs to be cast to
               the formal type.
*)

PROCEDURE needsCast (at, ft: node) : BOOLEAN ;
BEGIN
   at := skipType (at) ;
   ft := skipType (ft) ;
   IF (at = nilN) OR (at^.kind = nil) OR
      (at = ft) OR
      typePair (at, ft, cardinalN, wordN) OR
      typePair (at, ft, cardinalN, ztypeN) OR
      typePair (at, ft, integerN, ztypeN) OR
      typePair (at, ft, longcardN, ztypeN) OR
      typePair (at, ft, shortcardN, ztypeN) OR
      typePair (at, ft, longintN, ztypeN) OR
      typePair (at, ft, shortintN, ztypeN) OR
      typePair (at, ft, realN, rtypeN) OR
      typePair (at, ft, longrealN, rtypeN) OR
      typePair (at, ft, shortrealN, rtypeN)
   THEN
      RETURN FALSE
   ELSE
      RETURN TRUE
   END
END needsCast ;


(*
   checkSystemCast - checks to see if we are passing to/from
                     a system generic type (WORD, BYTE, ADDRESS)
                     and if so emit a cast.  It returns the number of
                     open parenthesis.
*)

PROCEDURE checkSystemCast (p: pretty; actual, formal: node) : CARDINAL ;
VAR
   at, ft: node ;
BEGIN
   at := getExprType (actual) ;
   ft := getType (formal) ;
   IF needsCast (at, ft)
   THEN
      IF lang = ansiCP
      THEN
         IF isString (actual) AND (skipType (ft) = addressN)
         THEN
            outText (p, "const_cast<void*> (reinterpret_cast<const void*> (") ;
	    RETURN 2
         ELSIF isPointer (skipType (ft)) OR (skipType (ft) = addressN)
         THEN
            IF actual = nilN
            THEN
               IF isVarParam (formal)
               THEN
                  metaError1 ('NIL is being passed to a VAR parameter {%1DMad}', formal)
               END ;
               (* NULL is compatible with pointers/address.  *)
               RETURN 0
            ELSE
               outText (p, 'reinterpret_cast<') ;
               doTypeNameC (p, ft) ;
               IF isVarParam (formal)
               THEN
                  outText (p, '*')
               END ;
               noSpace (p) ;
               outText (p, '> (')
            END
         ELSE
            outText (p, 'static_cast<') ;
            doTypeNameC (p, ft) ;
            IF isVarParam (formal)
            THEN
               outText (p, '*')
            END ;
            noSpace (p) ;
            outText (p, '> (')
         END ;
         RETURN 1
      ELSE
         outText (p, '(') ;
         doTypeNameC (p, ft) ;
	 IF isVarParam (formal)
         THEN
            outText (p, '*')
         END ;
         noSpace (p) ;
         outText (p, ')') ;
         setNeedSpace (p)
      END
   END ;
   RETURN 0
END checkSystemCast ;


(*
   emitN -
*)

PROCEDURE emitN (p: pretty; a: ARRAY OF CHAR; n: CARDINAL) ;
BEGIN
   WHILE n>0 DO
      outText (p, a) ;
      DEC (n)
   END
END emitN ;


(*
   isForC - return true if node n is a varparam, param or procedure
            which was declared inside a definition module for "C".
*)

PROCEDURE isForC (n: node) : BOOLEAN ;
BEGIN
   IF isVarParam (n)
   THEN
      RETURN n^.varparamF.isForC
   ELSIF isParam (n)
   THEN
      RETURN n^.paramF.isForC
   ELSIF isProcedure (n)
   THEN
      RETURN n^.procedureF.isForC
   END ;
   RETURN FALSE
END isForC ;


(*
   isDefForCNode - return TRUE if node n was declared inside a definition module for "C".
*)

PROCEDURE isDefForCNode (n: node) : BOOLEAN ;
VAR
   name: Name ;
BEGIN
   WHILE (n # NIL) AND (NOT (isImp (n) OR isDef (n) OR isModule (n))) DO
      n := getScope (n)
   END ;
   IF (n # NIL) AND isImp (n)
   THEN
      name := getSymName (n) ;
      n := lookupDef (name) ;
   END ;
   RETURN (n # NIL) AND isDef (n) AND isDefForC (n)
END isDefForCNode ;


(*
   doFuncParamC -
*)

PROCEDURE doFuncParamC (p: pretty; actual, formal, func: node) ;
VAR
   ft, at: node ;
   lbr   : CARDINAL ;
BEGIN
   IF formal = NIL
   THEN
      doExprC (p, actual)
   ELSE
      ft := skipType (getType (formal)) ;
      IF isUnbounded (ft)
      THEN
         doFuncUnbounded (p, actual, formal, ft, func)
      ELSE
         IF isAProcType (ft) AND isProcedure (actual)
         THEN
            IF isVarParam (formal)
            THEN
               metaError1 ('{%1MDad} cannot be passed as a VAR parameter', actual)
            ELSE
               doProcedureParamC (p, actual, formal)
            END
         ELSIF (getType (actual) # NIL) AND isProcType (skipType (getType (actual))) AND isAProcType (ft) AND isForC (formal)
         THEN
            IF isVarParam (formal)
            THEN
               metaError2 ('{%1MDad} cannot be passed as a VAR parameter to the definition for C module as the parameter requires a cast to the formal type {%2MDtad}',
                           actual, formal)
            ELSE
               outText (p, '(') ;
               doFQNameC (p, getType (formal)) ;
               outText (p, "_C") ;
               outText (p, ')') ;
               setNeedSpace (p) ;
               doExprC (p, actual) ;
               outText (p, ".proc")
            END
         ELSIF (getType (actual) # NIL) AND isProcType (skipType (getType (actual))) AND (getType (actual) # getType (formal))
         THEN
            IF isVarParam (formal)
            THEN
               metaError2 ('{%1MDad} cannot be passed as a VAR parameter as the parameter requires a cast to the formal type {%2MDtad}',
                           actual, formal)
            ELSE
               doCastC (p, getType (formal), actual)
            END
         ELSE
            lbr := checkSystemCast (p, actual, formal) ;
            IF isVarParam (formal)
            THEN
               doAdrExprC (p, actual)
            ELSE
               doExprC (p, actual)
            END ;
            emitN (p, ")", lbr)
         END
      END
   END
END doFuncParamC ;


(*
   getNthParamType - return the type of parameter, i, in list, l.
                     If the parameter is a vararg NIL is returned.
*)

PROCEDURE getNthParamType (l: Index; i: CARDINAL) : node ;
VAR
   p: node ;
BEGIN
   p := getNthParam (l, i) ;
   IF p # NIL
   THEN
      RETURN getType (p)
   END ;
   RETURN NIL
END getNthParamType ;


(*
   getNthParam - return the parameter, i, in list, l.
                 If the parameter is a vararg NIL is returned.
*)

PROCEDURE getNthParam (l: Index; i: CARDINAL) : node ;
VAR
   p      : node ;
   j, k, h: CARDINAL ;
BEGIN
   IF l # NIL
   THEN
      j := LowIndice (l) ;
      h := HighIndice (l) ;
      WHILE j <= h DO
         p := GetIndice (l, j) ;
         IF isParam (p)
         THEN
            k := identListLen (p^.paramF.namelist)
         ELSIF isVarParam (p)
         THEN
            k := identListLen (p^.varparamF.namelist)
         ELSE
            assert (isVarargs (p)) ;
            RETURN NIL
         END ;
         IF i <= k
         THEN
            RETURN p
         ELSE
            DEC (i, k) ;
            INC (j)
         END
      END
   END ;
   RETURN NIL
END getNthParam ;


(*
   doFuncArgsC -
*)

PROCEDURE doFuncArgsC (p: pretty; s: node; l: Index; needParen: BOOLEAN) ;
VAR
   actual, formal: node ;
   i, n          : CARDINAL ;
BEGIN
   IF needParen
   THEN
      outText (p, "(")
   END ;
   IF s^.funccallF.args # NIL
   THEN
      i := 1 ;
      n := expListLen (s^.funccallF.args) ;
      WHILE i<=n DO
         actual := getExpList (s^.funccallF.args, i) ;
         formal := getNthParam (l, i) ;
         doFuncParamC (p, actual, formal, s^.funccallF.function) ;
         IF i<n
         THEN
            outText (p, ",") ;
            setNeedSpace (p)
         END ;
         INC (i)
      END
   END ;
   IF needParen
   THEN
      noSpace (p) ;
      outText (p, ")")
   END
END doFuncArgsC ;


(*
   doProcTypeArgsC -
*)

PROCEDURE doProcTypeArgsC (p: pretty; s: node; args: Index; needParen: BOOLEAN) ;
VAR
   a, b: node ;
   i, n: CARDINAL ;
BEGIN
   IF needParen
   THEN
      outText (p, "(")
   END ;
   IF s^.funccallF.args # NIL
   THEN
      i := 1 ;
      n := expListLen (s^.funccallF.args) ;
      WHILE i<=n DO
         a := getExpList (s^.funccallF.args, i) ;
         b := GetIndice (args, i) ;
         doFuncParamC (p, a, b, s^.funccallF.function) ;
         IF i<n
         THEN
            outText (p, ",") ;
            setNeedSpace (p)
         END ;
         INC (i)
      END
   END ;
   IF needParen
   THEN
      noSpace (p) ;
      outText (p, ")")
   END
END doProcTypeArgsC ;


(*
   doAdrArgC -
*)

PROCEDURE doAdrArgC (p: pretty; n: node) ;
BEGIN
   IF isDeref (n)
   THEN
      (* & and * cancel each other out.  *)
      doExprC (p, n^.unaryF.arg)
   ELSIF isVar (n) AND (n^.varF.isVarParameter)
   THEN
      (* & and * cancel each other out.  *)
      outTextN (p, getSymName (n))   (* --fixme-- does the caller need to cast it?  *)
   ELSE
      IF isString (n)
      THEN
         IF lang = ansiCP
         THEN
            outText (p, "const_cast<void*> (reinterpret_cast<const void*>") ;
            outText (p, "(") ;
            doExprC (p, n) ;
            outText (p, "))")
         ELSE
            doExprC (p, n)
         END
      ELSE
         outText (p, "&") ;
         doExprC (p, n)
      END
   END
END doAdrArgC ;


(*
   doAdrC -
*)

PROCEDURE doAdrC (p: pretty; n: node) ;
BEGIN
   assert (isUnary (n)) ;
   doAdrArgC (p, n^.unaryF.arg)
END doAdrC ;


(*
   doInc -
*)

PROCEDURE doInc (p: pretty; n: node) ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF lang = ansiCP
   THEN
      doIncDecCP (p, n, "+")
   ELSE
      doIncDecC (p, n, "+=")
   END
END doInc ;


(*
   doDec -
*)

PROCEDURE doDec (p: pretty; n: node) ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF lang = ansiCP
   THEN
      doIncDecCP (p, n, "-")
   ELSE
      doIncDecC (p, n, "-=")
   END
END doDec ;


(*
   doIncDecC -
*)

PROCEDURE doIncDecC (p: pretty; n: node; op: ARRAY OF CHAR) ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF n^.intrinsicF.args # NIL
   THEN
      doExprC (p, getExpList (n^.intrinsicF.args, 1)) ;
      setNeedSpace (p) ;
      outText (p, op) ;
      setNeedSpace (p) ;
      IF expListLen (n^.intrinsicF.args) = 1
      THEN
         outText (p, '1')
      ELSE
         doExprC (p, getExpList (n^.intrinsicF.args, 2))
      END
   END
END doIncDecC ;


(*
   doIncDecCP -
*)

PROCEDURE doIncDecCP (p: pretty; n: node; op: ARRAY OF CHAR) ;
VAR
   lhs,
   type: node ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF n^.intrinsicF.args # NIL
   THEN
      lhs := getExpList (n^.intrinsicF.args, 1) ;
      doExprC (p, lhs) ;
      setNeedSpace (p) ;
      type := getType (lhs) ;
      IF isPointer (type) OR (type = addressN)
      THEN
         (* cast to (char * ) and then back again after the arithmetic is complete.  *)
         outText (p, "=") ;
	 setNeedSpace (p) ;
         outText (p, 'reinterpret_cast<') ;
         doTypeNameC (p, type) ;
         noSpace (p) ;
         outText (p, '> (reinterpret_cast<char *> (') ;
         doExprC (p, lhs) ;
         noSpace (p) ;
         outText (p, ')') ;
         outText (p, op) ;
         IF expListLen (n^.intrinsicF.args) = 1
         THEN
            outText (p, '1')
         ELSE
            doExprC (p, getExpList (n^.intrinsicF.args, 2))
         END ;
         outText (p, ')')
      ELSIF isEnumeration (skipType (type))
      THEN
         outText (p, "= static_cast<") ;
         doTypeNameC (p, type) ;
         noSpace (p) ;
         outText (p, ">(static_cast<int>(") ;
         doExprC (p, lhs) ;
         outText (p, ")") ;
         outText (p, op) ;
         IF expListLen (n^.intrinsicF.args) = 1
         THEN
            outText (p, '1')
         ELSE
            doExprC (p, getExpList (n^.intrinsicF.args, 2))
         END ;
         outText (p, ")")
      ELSE
         outText (p, op) ;
         outText (p, "=") ;
         setNeedSpace (p) ;
         IF expListLen (n^.intrinsicF.args) = 1
         THEN
            outText (p, '1')
         ELSE
            doExprC (p, getExpList (n^.intrinsicF.args, 2))
         END
      END
   END
END doIncDecCP ;


(*
   doInclC -
*)

PROCEDURE doInclC (p: pretty; n: node) ;
VAR
   lo: node ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF n^.intrinsicF.args # NIL
   THEN
      IF expListLen (n^.intrinsicF.args) = 2
      THEN
         doExprC (p, getExpList (n^.intrinsicF.args, 1)) ;
         lo := getSetLow (getExpList (n^.intrinsicF.args, 1)) ;
         setNeedSpace (p) ;
         outText (p, '|=') ;
         setNeedSpace (p) ;
         outText (p, '(1') ;
         setNeedSpace (p) ;
         outText (p, '<<') ;
         setNeedSpace (p) ;
         outText (p, '(') ;
         doExprC (p, getExpList (n^.intrinsicF.args, 2)) ;
         doSubtractC (p, lo) ;
         setNeedSpace (p) ;
         outText (p, '))')
      ELSE
         HALT (* metaError0 ('expecting two parameters to INCL') *)
      END
   END
END doInclC ;


(*
   doExclC -
*)

PROCEDURE doExclC (p: pretty; n: node) ;
VAR
   lo: node ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF n^.intrinsicF.args # NIL
   THEN
      IF expListLen (n^.intrinsicF.args) = 2
      THEN
         doExprC (p, getExpList (n^.intrinsicF.args, 1)) ;
         lo := getSetLow (getExpList (n^.intrinsicF.args, 1)) ;
         setNeedSpace (p) ;
         outText (p, '&=') ;
         setNeedSpace (p) ;
         outText (p, '(~(1') ;
         setNeedSpace (p) ;
         outText (p, '<<') ;
         setNeedSpace (p) ;
         outText (p, '(') ;
         doExprC (p, getExpList (n^.intrinsicF.args, 2)) ;
         doSubtractC (p, lo) ;
         setNeedSpace (p) ;
         outText (p, ')))')
      ELSE
         HALT (* metaError0 ('expecting two parameters to EXCL') *)
      END
   END
END doExclC ;


(*
   doNewC -
*)

PROCEDURE doNewC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF n^.intrinsicF.args = NIL
   THEN
      HALT
   ELSE
      IF expListLen (n^.intrinsicF.args) = 1
      THEN
         keyc.useStorage ;
         outText (p, 'Storage_ALLOCATE') ;
         setNeedSpace (p) ;
         outText (p, '((void **)') ;
         setNeedSpace (p) ;
         outText (p, '&') ;
         doExprC (p, getExpList (n^.intrinsicF.args, 1)) ;
         outText (p, ',') ;
         setNeedSpace (p) ;
         t := skipType (getType (getExpList (n^.intrinsicF.args, 1))) ;
         IF isPointer (t)
         THEN
            t := getType (t) ;
            outText (p, 'sizeof') ;
            setNeedSpace (p) ;
            outText (p, '(') ;
            doTypeNameC (p, t) ;
            noSpace (p) ;
            outText (p, '))')
         ELSE
            metaError1 ('expecting a pointer type variable as the argument to NEW, rather than {%1ad}', t)
         END
      END
   END
END doNewC ;


(*
   doDisposeC -
*)

PROCEDURE doDisposeC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (isIntrinsic (n)) ;
   IF n^.intrinsicF.args = NIL
   THEN
      HALT
   ELSE
      IF expListLen (n^.intrinsicF.args) = 1
      THEN
         keyc.useStorage ;
         outText (p, 'Storage_DEALLOCATE') ;
         setNeedSpace (p) ;
         outText (p, '((void **)') ;
         setNeedSpace (p) ;
         outText (p, '&') ;
         doExprC (p, getExpList (n^.intrinsicF.args, 1)) ;
         outText (p, ',') ;
         setNeedSpace (p) ;
         t := skipType (getType (getExpList (n^.intrinsicF.args, 1))) ;
         IF isPointer (t)
         THEN
            t := getType (t) ;
            outText (p, 'sizeof') ;
            setNeedSpace (p) ;
            outText (p, '(') ;
            doTypeNameC (p, t) ;
            noSpace (p) ;
            outText (p, '))')
         ELSE
            metaError1 ('expecting a pointer type variable as the argument to DISPOSE, rather than {%1ad}', t)
         END
      ELSE
         HALT (* metaError0 ('expecting a single parameter to DISPOSE') *)
      END
   END
END doDisposeC ;


(*
   doCapC -
*)

PROCEDURE doCapC (p: pretty; n: node) ;
BEGIN
   assert (isUnary (n)) ;
   IF n^.unaryF.arg = NIL
   THEN
      HALT (* metaError0 ('expecting a single parameter to CAP') *)
   ELSE
      keyc.useCtype ;
      IF getGccConfigSystem ()
      THEN
         outText (p, 'TOUPPER')
      ELSE
         outText (p, 'toupper')
      END ;
      setNeedSpace (p) ;
      outText (p, '(') ;
      doExprC (p, n^.unaryF.arg) ;
      outText (p, ')')
   END
END doCapC ;


(*
   doLengthC -
*)

PROCEDURE doLengthC (p: pretty; n: node) ;
BEGIN
   assert (isUnary (n)) ;
   IF n^.unaryF.arg = NIL
   THEN
      HALT (* metaError0 ('expecting a single parameter to LENGTH') *)
   ELSE
      keyc.useM2RTS ;
      outText (p, 'M2RTS_Length') ;
      setNeedSpace (p) ;
      outText (p, '(') ;
      doExprC (p, n^.unaryF.arg) ;
      outText (p, ',') ;
      setNeedSpace (p) ;
      doFuncHighC (p, n^.unaryF.arg) ;
      outText (p, ')')
   END
END doLengthC ;


(*
   doAbsC -
*)

PROCEDURE doAbsC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (isUnary (n)) ;
   IF n^.unaryF.arg = NIL
   THEN
      HALT
   ELSE
      t := getExprType (n)
   END ;
   IF t = longintN
   THEN
      keyc.useLabs ;
      outText (p, "labs")
   ELSIF t = integerN
   THEN
      keyc.useAbs ;
      outText (p, "abs")
   ELSIF t = realN
   THEN
      keyc.useFabs ;
      outText (p, "fabs")
   ELSIF t = longrealN
   THEN
      keyc.useFabsl ;
      outText (p, "fabsl")
   ELSIF t = cardinalN
   THEN
      (* do nothing.  *)
   ELSE
      HALT
   END ;
   setNeedSpace (p) ;
   outText (p, "(") ;
   doExprC (p, n^.unaryF.arg) ;
   outText (p, ")")
END doAbsC ;


(*
   doValC -
*)

PROCEDURE doValC (p: pretty; n: node) ;
BEGIN
   assert (isBinary (n)) ;
   outText (p, '(') ;
   doTypeNameC (p, n^.binaryF.left) ;
   outText (p, ')') ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   doExprC (p, n^.binaryF.right) ;
   outText (p, ')')
END doValC ;


(*
   doMinC -
*)

PROCEDURE doMinC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (isUnary (n)) ;
   t := getExprType (n^.unaryF.arg) ;
   doExprC (p, getMin (t)) ;
END doMinC ;


(*
   doMaxC -
*)

PROCEDURE doMaxC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (isUnary (n)) ;
   t := getExprType (n^.unaryF.arg) ;
   doExprC (p, getMax (t)) ;
END doMaxC ;


(*
   isIntrinsic - returns if, n, is an intrinsic procedure.
                 The intrinsic functions are represented as unary and binary nodes.
*)

PROCEDURE isIntrinsic (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   unreachable,
   throw,
   inc,
   dec,
   incl,
   excl,
   new,
   dispose,
   halt   :  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isIntrinsic ;


(*
   doHalt -
*)

PROCEDURE doHalt (p: pretty; n: node) ;
BEGIN
   assert (n^.kind = halt) ;
   IF (n^.intrinsicF.args = NIL) OR (expListLen (n^.intrinsicF.args) = 0)
   THEN
      outText (p, 'M2RTS_HALT') ;
      setNeedSpace (p) ;
      outText (p, '(-1)')
   ELSIF expListLen (n^.intrinsicF.args) = 1
   THEN
      outText (p, 'M2RTS_HALT') ;
      setNeedSpace (p) ;
      outText (p, '(') ;
      doExprC (p, getExpList (n^.intrinsicF.args, 1)) ;
      outText (p, ')')
   END
END doHalt ;


(*
   doCreal - emit the appropriate creal function.
*)

PROCEDURE doCreal (p: pretty; t: node) ;
BEGIN
   CASE t^.kind OF

   complex     :  keyc.useComplex ;
                  outText (p, "creal") |
   longcomplex :  keyc.useComplex ;
                  outText (p, "creall") |
   shortcomplex:  keyc.useComplex ;
                  outText (p, "crealf")

   END
END doCreal ;


(*
   doCimag - emit the appropriate cimag function.
*)

PROCEDURE doCimag (p: pretty; t: node) ;
BEGIN
   CASE t^.kind OF

   complex     :  keyc.useComplex ;
                  outText (p, "cimag") |
   longcomplex :  keyc.useComplex ;
                  outText (p, "cimagl") |
   shortcomplex:  keyc.useComplex ;
                  outText (p, "cimagf")

   END
END doCimag ;


(*
   doReC -
*)

PROCEDURE doReC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (n^.kind = re) ;
   IF n^.unaryF.arg # NIL
   THEN
      t := getExprType (n^.unaryF.arg)
   ELSE
      HALT
   END ;
   doCreal (p, t) ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   doExprC (p, n^.unaryF.arg) ;
   outText (p, ')')
END doReC ;


(*
   doImC -
*)

PROCEDURE doImC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (n^.kind = im) ;
   IF n^.unaryF.arg # NIL
   THEN
      t := getExprType (n^.unaryF.arg)
   ELSE
      HALT
   END ;
   doCimag (p, t) ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   doExprC (p, n^.unaryF.arg) ;
   outText (p, ')')
END doImC ;


(*
   doCmplx -
*)

PROCEDURE doCmplx (p: pretty; n: node) ;
BEGIN
   assert (isBinary (n)) ;
   keyc.useComplex ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   doExprC (p, n^.binaryF.left) ;
   outText (p, ')') ;
   setNeedSpace (p) ;
   outText (p, '+') ;
   setNeedSpace (p) ;
   outText (p, '(') ;
   doExprC (p, n^.binaryF.right) ;
   setNeedSpace (p) ;
   outText (p, '*') ;
   setNeedSpace (p) ;
   outText (p, 'I') ;
   outText (p, ')')
END doCmplx ;


(*
   doIntrinsicC -
*)

PROCEDURE doIntrinsicC (p: pretty; n: node) ;
BEGIN
   assert (isIntrinsic (n)) ;
   doCommentC (p, n^.intrinsicF.intrinsicComment.body) ;
   CASE n^.kind OF

   unreachable: doUnreachableC (p, n) |
   throw      : doThrowC (p, n) |
   halt       : doHalt (p, n) |
   inc        : doInc (p, n) |
   dec        : doDec (p, n) |
   incl       : doInclC (p, n) |
   excl       : doExclC (p, n) |
   new        : doNewC (p, n) |
   dispose    : doDisposeC (p, n)

   END ;
   outText (p, ";") ;
   doAfterCommentC (p, n^.intrinsicF.intrinsicComment.after)
END doIntrinsicC ;


(*
   isIntrinsicFunction - returns true if, n, is an instrinsic function.
*)

PROCEDURE isIntrinsicFunction (n: node) : BOOLEAN ;
BEGIN
   CASE n^.kind OF

   val,
   adr,
   size,
   tsize,
   float,
   trunc,
   ord,
   chr,
   cap,
   abs,
   high,
   length,
   min,
   max,
   re,
   im,
   cmplx:  RETURN TRUE

   ELSE
      RETURN FALSE
   END
END isIntrinsicFunction ;


(*
   doSizeC -
*)

PROCEDURE doSizeC (p: pretty; n: node) ;
BEGIN
   assert (isUnary (n)) ;
   outText (p, "sizeof (") ;
   doExprC (p, n^.unaryF.arg) ;
   outText (p, ")")
END doSizeC ;


(*
   doConvertC -
*)

PROCEDURE doConvertC (p: pretty; n: node; conversion: ARRAY OF CHAR) ;
VAR
   s: String ;
BEGIN
   s := InitString (conversion) ;
   doConvertSC (p, n, s) ;
   s := KillString (s)
END doConvertC ;


(*
   doConvertSC -
*)

PROCEDURE doConvertSC (p: pretty; n: node; conversion: String) ;
BEGIN
   assert (isUnary (n)) ;
   setNeedSpace (p) ;
   outText (p, "((") ;
   outTextS (p, conversion) ;
   outText (p, ")") ;
   setNeedSpace (p) ;
   outText (p, "(") ;
   doExprC (p, n^.unaryF.arg) ;
   outText (p, "))")
END doConvertSC ;


(*  not needed?
   val:     doValC (p, n) |
   adr:     doAdrC (p, n) |
   size,
   tsize:   doSizeC (p, n) |
   float:   doConvertC (p, n, "(double)") |
   trunc:   doConvertC (p, n, "(int)") |
   ord:     doConvertC (p, n, "(unsigned int)") |
   chr:     doConvertC (p, n, "(char)") |
   cap:     doCapC (p, n) |
   abs:     doAbsC (p, n) |
   high:    doFuncHighC (p, n^.unaryF.arg, 1)) |
   length:  doLengthC (p, n) |
   min:     doMinC (p, n) |
   max:     doMaxC (p, n) |
   throw:   doThrowC (p, n) |
   re:      doReC (p, n) |
   im:      doImC (p, n) |
   cmplx:   doCmplx (p, n)
*)


(*
   getFuncFromExpr -
*)

PROCEDURE getFuncFromExpr (n: node) : node ;
BEGIN
   n := skipType (getType (n)) ;
   WHILE (n # procN) AND (NOT isProcType (n)) DO
      n := skipType (getType (n))
   END ;
   RETURN n
END getFuncFromExpr ;


(*
   doFuncExprC -
*)

PROCEDURE doFuncExprC (p: pretty; n: node) ;
VAR
   t: node ;
BEGIN
   assert (isFuncCall (n)) ;
   IF isProcedure (n^.funccallF.function)
   THEN
      doFQDNameC (p, n^.funccallF.function, TRUE) ;
      setNeedSpace (p) ;
      doFuncArgsC (p, n, n^.funccallF.function^.procedureF.parameters, TRUE)
   ELSE
      outText (p, "(*") ;
      doExprC (p, n^.funccallF.function) ;
      outText (p, ".proc") ;
      outText (p, ")") ;
      t := getFuncFromExpr (n^.funccallF.function) ;
      setNeedSpace (p) ;
      IF t = procN
      THEN
         doProcTypeArgsC (p, n, NIL, TRUE)
      ELSE
         assert (isProcType (t)) ;
         doProcTypeArgsC (p, n, t^.proctypeF.parameters, TRUE)
      END
   END
END doFuncExprC ;


(*
   doFuncCallC -
*)

PROCEDURE doFuncCallC (p: pretty; n: node) ;
BEGIN
   doCommentC (p, n^.funccallF.funccallComment.body) ;
   doFuncExprC (p, n) ;
   outText (p, ";") ;
   doAfterCommentC (p, n^.funccallF.funccallComment.after)
END doFuncCallC ;


(*
   doCaseStatementC -
*)

PROCEDURE doCaseStatementC (p: pretty; n: node; needBreak: BOOLEAN) ;
BEGIN
   p := pushPretty (p) ;
   setindent (p, getindent (p) + indentationC) ;
   doStatementSequenceC (p, n) ;
   IF needBreak
   THEN
      outText (p, "break;\n")
   END ;
   p := popPretty (p)
END doCaseStatementC ;


(*
   doExceptionC -
*)

PROCEDURE doExceptionC (p: pretty; a: ARRAY OF CHAR; n: node) ;
VAR
   w: CARDINAL ;
BEGIN
   w := getDeclaredMod (n) ;
   outText (p, a) ;
   setNeedSpace (p) ;
   outText (p, '("') ;
   outTextS (p, findFileNameFromToken (w, 0)) ;
   outText (p, '",') ;
   setNeedSpace (p) ;
   outCard (p, tokenToLineNo (w, 0)) ;
   outText (p, ',') ;
   setNeedSpace (p) ;
   outCard (p, tokenToColumnNo (w, 0)) ;
   outText (p, ');\n') ;
   outText (p, '__builtin_unreachable ();\n')
END doExceptionC ;


(*
   doExceptionCP -
*)

PROCEDURE doExceptionCP (p: pretty; a: ARRAY OF CHAR; n: node) ;
VAR
   w: CARDINAL ;
BEGIN
   w := getDeclaredMod (n) ;
   outText (p, a) ;
   setNeedSpace (p) ;
   outText (p, '("') ;
   outTextS (p, findFileNameFromToken (w, 0)) ;
   outText (p, '",') ;
   setNeedSpace (p) ;
   outCard (p, tokenToLineNo (w, 0)) ;
   outText (p, ',') ;
   setNeedSpace (p) ;
   outCard (p, tokenToColumnNo (w, 0)) ;
   outText (p, ');\n') ;
   outText (p, '__builtin_unreachable ();\n')
END doExceptionCP ;


(*
   doException -
*)

PROCEDURE doException (p: pretty; a: ARRAY OF CHAR; n: node) ;
BEGIN
   keyc.useException ;
   IF lang = ansiCP
   THEN
      doExceptionCP (p, a, n)
   ELSE
      doExceptionC (p, a, n)
   END
END doException ;


(*
   doRangeListC -
*)

PROCEDURE doRangeListC (p: pretty; c: node) ;
VAR
   r   : node ;
   i, h: CARDINAL ;
BEGIN
   assert (isCaseList (c)) ;
   i := 1 ;
   h := HighIndice (c^.caselistF.rangePairs) ;
   WHILE i<=h DO
      r := GetIndice (c^.caselistF.rangePairs, i) ;
      assert ((r^.rangeF.hi = NIL) OR (r^.rangeF.lo = r^.rangeF.hi)) ;
      outText (p, "case") ;
      setNeedSpace (p) ;
      doExprC (p, r^.rangeF.lo) ;
      outText (p, ":\n") ;
      INC (i)
   END
END doRangeListC ;


(*
   doRangeIfListC -
*)

PROCEDURE doRangeIfListC (p: pretty; e, c: node) ;
VAR
   r   : node ;
   i, h: CARDINAL ;
BEGIN
   assert (isCaseList (c)) ;
   i := 1 ;
   h := HighIndice (c^.caselistF.rangePairs) ;
   WHILE i<=h DO
      r := GetIndice (c^.caselistF.rangePairs, i) ;
      IF (r^.rangeF.lo # r^.rangeF.hi) AND (r^.rangeF.hi # NIL)
      THEN
         outText (p, "((") ;
         doExprC (p, e) ;
         outText (p, ")") ;
         setNeedSpace (p) ;
         outText (p, ">=") ;
         setNeedSpace (p) ;
         doExprC (p, r^.rangeF.lo) ;
         outText (p, ")") ;
         setNeedSpace (p) ;
         outText (p, "&&") ;
         setNeedSpace (p) ;
         outText (p, "((") ;
         doExprC (p, e) ;
         outText (p, ")") ;
         setNeedSpace (p) ;
         outText (p, "<=") ;
         setNeedSpace (p) ;
         doExprC (p, r^.rangeF.hi) ;
         outText (p, ")")
      ELSE
         outText (p, "((") ;
         doExprC (p, e) ;
         outText (p, ")") ;
         setNeedSpace (p) ;
         outText (p, "==") ;
         setNeedSpace (p) ;
         doExprC (p, r^.rangeF.lo) ;
         outText (p, ")")
      END ;
      IF i<h
      THEN
         setNeedSpace (p) ;
         outText (p, "||") ;
         setNeedSpace (p)
      END ;
      INC (i)
   END
END doRangeIfListC ;


(*
   doCaseLabels -
*)

PROCEDURE doCaseLabels (p: pretty; n: node; needBreak: BOOLEAN) ;
BEGIN
   assert (isCaseLabelList (n)) ;
   doRangeListC (p, n^.caselabellistF.caseList) ;
   p := pushPretty (p) ;
   setindent (p, getindent (p) + indentationC) ;
   doStatementSequenceC (p, n^.caselabellistF.statements) ;
   IF needBreak
   THEN
      outText (p, "break;\n\n")
   END ;
   p := popPretty (p)
END doCaseLabels ;


(*
   doCaseLabelListC -
*)

PROCEDURE doCaseLabelListC (p: pretty; n: node; haveElse: BOOLEAN) ;
VAR
   i, h: CARDINAL ;
   c   : node ;
BEGIN
   assert (isCase (n)) ;
   i := 1 ;
   h := HighIndice (n^.caseF.caseLabelList) ;
   WHILE i<=h DO
      c := GetIndice (n^.caseF.caseLabelList, i) ;
      doCaseLabels (p, c, (i<h) OR haveElse OR caseException) ;
      INC (i)
   END
END doCaseLabelListC ;


(*
   doCaseIfLabels -
*)

PROCEDURE doCaseIfLabels (p: pretty; e, n: node;
                          i, h: CARDINAL) ;
BEGIN
   assert (isCaseLabelList (n)) ;
   IF i > 1
   THEN
      outText (p, "else") ;
      setNeedSpace (p) ;
   END ;
   outText (p, "if") ;
   setNeedSpace (p) ;
   outText (p, "(") ;
   doRangeIfListC (p, e, n^.caselabellistF.caseList) ;
   outText (p, ")\n") ;
   IF h = 1
   THEN
      doCompoundStmt (p, n^.caselabellistF.statements)
   ELSE
      outText (p, "{\n") ;
      doStatementSequenceC (p, n^.caselabellistF.statements) ;
      outText (p, "}\n")
   END
END doCaseIfLabels ;


(*
   doCaseIfLabelListC -
*)

PROCEDURE doCaseIfLabelListC (p: pretty; n: node) ;
VAR
   i, h: CARDINAL ;
   c   : node ;
BEGIN
   assert (isCase (n)) ;
   i := 1 ;
   h := HighIndice (n^.caseF.caseLabelList) ;
   WHILE i<=h DO
      c := GetIndice (n^.caseF.caseLabelList, i) ;
      doCaseIfLabels (p, n^.caseF.expression, c, i, h) ;
      INC (i)
   END
END doCaseIfLabelListC ;


(*
   doCaseElseC -
*)

PROCEDURE doCaseElseC (p: pretty; n: node) ;
BEGIN
   assert (isCase (n)) ;
   IF n^.caseF.else = NIL
   THEN
      IF caseException
      THEN
         outText (p, "\ndefault:\n") ;
         p := pushPretty (p) ;
         setindent (p, getindent (p) + indentationC) ;
         doException (p, 'CaseException', n) ;
         p := popPretty (p)
      END
   ELSE
      outText (p, "\ndefault:\n") ;
      doCaseStatementC (p, n^.caseF.else, TRUE)
   END
END doCaseElseC ;


(*
   doCaseIfElseC -
*)

PROCEDURE doCaseIfElseC (p: pretty; n: node) ;
BEGIN
   assert (isCase (n)) ;
   IF n^.caseF.else = NIL
   THEN
      IF TRUE
      THEN
         outText (p, "\n") ;
         outText (p, "else {\n") ;
         p := pushPretty (p) ;
         setindent (p, getindent (p) + indentationC) ;
         doException (p, 'CaseException', n) ;
         p := popPretty (p) ;
         outText (p, "}\n")
      END
   ELSE
      outText (p, "\n") ;
      outText (p, "else {\n") ;
      doCaseStatementC (p, n^.caseF.else, FALSE) ;
      outText (p, "}\n")
   END
END doCaseIfElseC ;


(*
   canUseSwitchCaseLabels - returns TRUE if all the case labels are
                            single values and not ranges.
*)

PROCEDURE canUseSwitchCaseLabels (n: node) : BOOLEAN ;
VAR
   i, h: CARDINAL ;
   r, l: node ;
BEGIN
   assert (isCaseLabelList (n)) ;
   l := n^.caselabellistF.caseList ;
   i := 1 ;
   h := HighIndice (l^.caselistF.rangePairs) ;
   WHILE i<=h DO
      r := GetIndice (l^.caselistF.rangePairs, i) ;
      IF (r^.rangeF.hi # NIL) AND (r^.rangeF.lo # r^.rangeF.hi)
      THEN
         RETURN FALSE
      END ;
      INC (i)
   END ;
   RETURN TRUE
END canUseSwitchCaseLabels ;


(*
   canUseSwitch - returns TRUE if the case statement can be implement
                  by a switch statement.  This will be TRUE if all case
                  selectors are single values rather than ranges.
*)

PROCEDURE canUseSwitch (n: node) : BOOLEAN ;
VAR
   i, h: CARDINAL ;
   c   : node ;
BEGIN
   assert (isCase (n)) ;
   i := 1 ;
   h := HighIndice (n^.caseF.caseLabelList) ;
   WHILE i<=h DO
      c := GetIndice (n^.caseF.caseLabelList, i) ;
      IF NOT canUseSwitchCaseLabels (c)
      THEN
         RETURN FALSE
      END ;
      INC (i)
   END ;
   RETURN TRUE
END canUseSwitch ;


(*
   doCaseC -
*)

PROCEDURE doCaseC (p: pretty; n: node) ;
VAR
   i: CARDINAL ;
BEGIN
   assert (isCase (n)) ;
   IF canUseSwitch (n)
   THEN
      i := getindent (p) ;
      outText (p, "switch") ;
      setNeedSpace (p) ;
      outText (p, "(") ;
      doExprC (p, n^.caseF.expression) ;
      p := pushPretty (p) ;
      outText (p, ")") ;
      setindent (p, i + indentationC) ;
      outText (p, "\n{\n") ;
      p := pushPretty (p) ;
      setindent (p, getindent (p) + indentationC) ;
      doCaseLabelListC (p, n, n^.caseF.else # NIL) ;
      doCaseElseC (p, n) ;
      p := popPretty (p) ;
      outText (p, "}\n") ;
      p := popPretty (p)
   ELSE
      doCaseIfLabelListC (p, n) ;
      doCaseIfElseC (p, n)
   END
END doCaseC ;


(*
   doLoopC -
*)

PROCEDURE doLoopC (p: pretty; s: node) ;
BEGIN
   assert (isLoop (s)) ;
   outText (p, 'for (;;)\n') ;
   outText (p, "{\n") ;
   p := pushPretty (p) ;
   setindent (p, getindent (p) + indentationC) ;
   doStatementSequenceC (p, s^.loopF.statements) ;
   p := popPretty (p) ;
   outText (p, "}\n")
END doLoopC ;


(*
   doExitC -
*)

PROCEDURE doExitC (p: pretty; s: node) ;
BEGIN
   assert (isExit (s)) ;
   outText (p, "/* exit.  */\n")
END doExitC ;


(*
   doStatementsC -
*)

PROCEDURE doStatementsC (p: pretty; s: node) ;
BEGIN
   IF s = NIL
   THEN
      (* do nothing.  *)
   ELSIF isStatementSequence (s)
   THEN
      doStatementSequenceC (p, s)
   ELSIF isComment (s)
   THEN
      doCommentC (p, s)
   ELSIF isExit (s)
   THEN
      doExitC (p, s)
   ELSIF isReturn (s)
   THEN
      doReturnC (p, s)
   ELSIF isAssignment (s)
   THEN
      doAssignmentC (p, s)
   ELSIF isIf (s)
   THEN
      doIfC (p, s)
   ELSIF isFor (s)
   THEN
      doForC (p, s)
   ELSIF isRepeat (s)
   THEN
      doRepeatC (p, s)
   ELSIF isWhile (s)
   THEN
      doWhileC (p, s)
   ELSIF isIntrinsic (s)
   THEN
      doIntrinsicC (p, s)
   ELSIF isFuncCall (s)
   THEN
      doFuncCallC (p, s)
   ELSIF isCase (s)
   THEN
      doCaseC (p, s)
   ELSIF isLoop (s)
   THEN
      doLoopC (p, s)
   ELSIF isExit (s)
   THEN
      doExitC (p, s)
   ELSE
      HALT  (* need to handle another s^.kind.  *)
   END
END doStatementsC ;


PROCEDURE stop ; END stop ;

(*
   doLocalVarC -
*)

PROCEDURE doLocalVarC (p: pretty; s: scopeT) ;
BEGIN
   includeVarProcedure (s) ;
   debugLists ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone)
END doLocalVarC ;


(*
   doLocalConstTypesC -
*)

PROCEDURE doLocalConstTypesC (p: pretty; s: scopeT) ;
BEGIN
   simplifyTypes (s) ;
   includeConstType (s) ;

   doP := p ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone) ;

END doLocalConstTypesC ;


(*
   addParamDone -
*)

PROCEDURE addParamDone (n: node) ;
BEGIN
   IF isVar (n) AND n^.varF.isParameter
   THEN
      addDone (n) ;
      addDone (getType (n))
   END
END addParamDone ;


(*
   includeParameters -
*)

PROCEDURE includeParameters (n: node) ;
BEGIN
   assert (isProcedure (n)) ;
   ForeachIndiceInIndexDo (n^.procedureF.decls.variables, addParamDone)
END includeParameters ;


(*
   isHalt -
*)

PROCEDURE isHalt (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = halt
END isHalt ;


(*
   isReturnOrHalt -
*)

PROCEDURE isReturnOrHalt (n: node) : BOOLEAN ;
BEGIN
   RETURN isHalt (n) OR isReturn (n)
END isReturnOrHalt ;


(*
   isLastStatementReturn -
*)

PROCEDURE isLastStatementReturn (n: node) : BOOLEAN ;
BEGIN
   RETURN isLastStatement (n, isReturnOrHalt)
END isLastStatementReturn ;


(*
   isLastStatementSequence -
*)

PROCEDURE isLastStatementSequence (n: node; q: isNodeF) : BOOLEAN ;
VAR
   h  : CARDINAL ;
BEGIN
   assert (isStatementSequence (n)) ;
   h := HighIndice (n^.stmtF.statements) ;
   IF h > 0
   THEN
      RETURN isLastStatement (GetIndice (n^.stmtF.statements, h), q)
   END ;
   RETURN FALSE
END isLastStatementSequence ;


(*
   isLastStatementIf -
*)

PROCEDURE isLastStatementIf (n: node; q: isNodeF) : BOOLEAN ;
VAR
   ret: BOOLEAN ;
BEGIN
   assert (isIf (n)) ;
   ret := TRUE ;
   IF (n^.ifF.elsif # NIL) AND ret
   THEN
      ret := isLastStatement (n^.ifF.elsif, q)
   END ;
   IF (n^.ifF.then # NIL) AND ret
   THEN
      ret := isLastStatement (n^.ifF.then, q)
   END ;
   IF (n^.ifF.else # NIL) AND ret
   THEN
      ret := isLastStatement (n^.ifF.else, q)
   END ;
   RETURN ret
END isLastStatementIf ;


(*
   isLastStatementElsif -
*)

PROCEDURE isLastStatementElsif (n: node; q: isNodeF) : BOOLEAN ;
VAR
   ret: BOOLEAN ;
BEGIN
   assert (isElsif (n)) ;
   ret := TRUE ;
   IF (n^.elsifF.elsif # NIL) AND ret
   THEN
      ret := isLastStatement (n^.elsifF.elsif, q)
   END ;
   IF (n^.elsifF.then # NIL) AND ret
   THEN
      ret := isLastStatement (n^.elsifF.then, q)
   END ;
   IF (n^.elsifF.else # NIL) AND ret
   THEN
      ret := isLastStatement (n^.elsifF.else, q)
   END ;
   RETURN ret
END isLastStatementElsif ;


(*
   isLastStatementCase -
*)

PROCEDURE isLastStatementCase (n: node; q: isNodeF) : BOOLEAN ;
VAR
   ret : BOOLEAN ;
   i, h: CARDINAL ;
   c   : node ;
BEGIN
   ret := TRUE ;
   assert (isCase (n)) ;
   i := 1 ;
   h := HighIndice (n^.caseF.caseLabelList) ;
   WHILE i<=h DO
      c := GetIndice (n^.caseF.caseLabelList, i) ;
      assert (isCaseLabelList (c)) ;
      ret := ret AND isLastStatement (c^.caselabellistF.statements, q) ;
      INC (i)
   END ;
   IF n^.caseF.else # NIL
   THEN
      ret := ret AND isLastStatement (n^.caseF.else, q)
   END ;
   RETURN ret
END isLastStatementCase ;


(*
   isLastStatement - returns TRUE if the last statement in, n, is, q.
*)

PROCEDURE isLastStatement (n: node; q: isNodeF) : BOOLEAN ;
VAR
   ret: BOOLEAN ;
BEGIN
   IF n = NIL
   THEN
      RETURN FALSE
   ELSIF isStatementSequence (n)
   THEN
      RETURN isLastStatementSequence (n, q)
   ELSIF isProcedure (n)
   THEN
      assert (isProcedure (n)) ;
      RETURN isLastStatement (n^.procedureF.beginStatements, q)
   ELSIF isIf (n)
   THEN
      RETURN isLastStatementIf (n, q)
   ELSIF isElsif (n)
   THEN
      RETURN isLastStatementElsif (n, q)
   ELSIF isCase (n)
   THEN
      RETURN isLastStatementCase (n, q)
   ELSIF q (n)
   THEN
      RETURN TRUE
   END ;
   RETURN FALSE
END isLastStatement ;


(*
   doProcedureC -
*)

PROCEDURE doProcedureC (n: node) ;
VAR
   s: CARDINAL ;
BEGIN
   outText (doP, "\n") ;
   includeParameters (n) ;

   keyc.enterScope (n) ;

   doProcedureHeadingC (n, FALSE) ;
   outText (doP, "\n") ;
   doP := outKc (doP, "{\n") ;
   s := getcurline (doP) ;
   doLocalConstTypesC (doP, n^.procedureF.decls) ;
   doLocalVarC (doP, n^.procedureF.decls) ;
   doUnboundedParamCopyC (doP, n) ;

   IF s # getcurline (doP)
   THEN
      outText (doP, "\n")
   END ;

   doStatementsC (doP, n^.procedureF.beginStatements) ;
   IF n^.procedureF.returnType # NIL
   THEN
      IF returnException
      THEN
         IF isLastStatementReturn (n)
	 THEN
            outText (doP, "/* static analysis guarentees a RETURN statement will be used before here.  */\n") ;
            outText (doP, "__builtin_unreachable ();\n") ;
         ELSE
            doException (doP, 'ReturnException', n)
         END
      END
   END ;
   doP := outKc (doP, "}\n") ;
   keyc.leaveScope (n)
END doProcedureC ;


(*
   outProceduresC -
*)

PROCEDURE outProceduresC (p: pretty; s: scopeT) ;
BEGIN
   doP := p ;
   IF debugDecl
   THEN
      printf ("seen %d procedures\n", HighIndice (s.procedures))
   END ;

   ForeachIndiceInIndexDo (s.procedures, doProcedureC)
END outProceduresC ;


(*
   output -
*)

PROCEDURE output (n: node; c, t, v: nodeProcedure) ;
BEGIN
   IF isConst (n)
   THEN
      c (n)
   ELSIF isVar (n)
   THEN
      v (n)
   ELSE
      t (n)
   END
END output ;


(*
   allDependants -
*)

PROCEDURE allDependants (n: node) : dependentState ;
VAR
   l: alist ;
   s: dependentState ;
BEGIN
   l := alists.initList () ;
   s := walkDependants (l, n) ;
   alists.killList (l) ;
   RETURN s
END allDependants ;


(*
   walkDependants -
*)

PROCEDURE walkDependants (l: alist; n: node) : dependentState ;
BEGIN
   IF (n=NIL) OR alists.isItemInList (doneQ, n)
   THEN
      RETURN completed
   ELSIF alists.isItemInList (l, n)
   THEN
      RETURN recursive
   ELSE
      alists.includeItemIntoList (l, n) ;
      RETURN doDependants (l, n)
   END
END walkDependants ;


(*
   walkType -
*)

PROCEDURE walkType (l: alist; n: node) : dependentState ;
VAR
   t: node ;
BEGIN
   t := getType (n) ;
   IF alists.isItemInList (doneQ, t)
   THEN
      RETURN completed
   ELSIF alists.isItemInList (partialQ, t)
   THEN
      RETURN blocked
   ELSE
      queueBlocked (t) ;
      RETURN blocked
   END
END walkType ;


(*
   db -
*)

PROCEDURE db (a: ARRAY OF CHAR; n: node) ;
BEGIN
   IF getDebugTopological ()
   THEN
      outText (doP, a) ;
      IF n#NIL
      THEN
         outTextS (doP, gen (n))
      END
   END
END db ;


(*
   dbt -
*)

PROCEDURE dbt (a: ARRAY OF CHAR) ;
BEGIN
   IF getDebugTopological ()
   THEN
      outText (doP, a)
   END
END dbt ;


(*
   dbs -
*)

PROCEDURE dbs (s: dependentState; n: node) ;
BEGIN
   IF getDebugTopological ()
   THEN
      CASE s OF

      completed:  outText (doP, '{completed ') |
      blocked  :  outText (doP, '{blocked ') |
      partial  :  outText (doP, '{partial ') |
      recursive:  outText (doP, '{recursive ')

      END ;
      IF n#NIL
      THEN
         outTextS (doP, gen (n))
      END ;
      outText (doP, '}\n')
   END
END dbs ;


(*
   dbq -
*)

PROCEDURE dbq (n: node) ;
BEGIN
   IF getDebugTopological ()
   THEN
      IF alists.isItemInList (todoQ, n)
      THEN
         db ('{T', n) ; outText (doP, '}')
      ELSIF alists.isItemInList (partialQ, n)
      THEN
         db ('{P', n) ; outText (doP, '}')
      ELSIF alists.isItemInList (doneQ, n)
      THEN
         db ('{D', n) ; outText (doP, '}')
      END
   END
END dbq ;


(*
   walkRecord -
*)

PROCEDURE walkRecord (l: alist; n: node) : dependentState ;
VAR
   s   : dependentState ;
   o,
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   i := LowIndice (n^.recordF.listOfSons) ;
   t := HighIndice (n^.recordF.listOfSons) ;
   db ('\nwalking ', n) ; o := getindent (doP) ; setindent (doP, getcurpos (doP)+3) ;
   dbq (n) ;
   WHILE i<=t DO
      q := GetIndice (n^.recordF.listOfSons, i) ;
      db ('', q) ;
      IF isRecordField (q) AND q^.recordfieldF.tag
      THEN
         (* do nothing as it is a tag selector processed in the varient.  *)
      ELSE
         s := walkDependants (l, q) ;
         IF s#completed
         THEN
            dbs (s, q) ;
            addTodo (n) ;
            dbq (n) ;
            db ('\n', NIL) ;
            setindent (doP, o) ;
            RETURN s
         END
      END ;
      INC (i)
   END ;
   db ('{completed', n) ; dbt ('}\n') ;
   setindent (doP, o) ;
   RETURN completed
END walkRecord ;


(*
   walkVarient -
*)

PROCEDURE walkVarient (l: alist; n: node) : dependentState ;
VAR
   s   : dependentState ;
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   db ('\nwalking', n) ;
   s := walkDependants (l, n^.varientF.tag) ;
   IF s#completed
   THEN
      dbs (s, n^.varientF.tag) ;
      dbq (n^.varientF.tag) ;
      db ('\n', NIL) ;
      RETURN s
   END ;
   i := LowIndice (n^.varientF.listOfSons) ;
   t := HighIndice (n^.varientF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientF.listOfSons, i) ;
      db ('', q) ;
      s := walkDependants (l, q) ;
      IF s#completed
      THEN
         dbs (s, q) ;
         db ('\n', NIL) ;
         RETURN s
      END ;
      INC (i)
   END ;
   db ('{completed', n) ; dbt ('}\n') ;
   RETURN completed
END walkVarient ;


(*
   queueBlocked -
*)

PROCEDURE queueBlocked (n: node) ;
BEGIN
   IF NOT (alists.isItemInList (doneQ, n) OR alists.isItemInList (partialQ, n))
   THEN
      addTodo (n)
   END
END queueBlocked ;


(*
   walkVar -
*)

PROCEDURE walkVar (l: alist; n: node) : dependentState ;
VAR
   t: node ;
BEGIN
   t := getType (n) ;
   IF alists.isItemInList (doneQ, t)
   THEN
      RETURN completed
   ELSE
      queueBlocked (t) ;
      RETURN blocked
   END
END walkVar ;


(*
   walkEnumeration -
*)

PROCEDURE walkEnumeration (l: alist; n: node) : dependentState ;
VAR
   s   : dependentState ;
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   i := LowIndice (n^.enumerationF.listOfSons) ;
   t := HighIndice (n^.enumerationF.listOfSons) ;
   s := completed ;
   WHILE i<=t DO
      q := GetIndice (n^.enumerationF.listOfSons, i) ;
      s := walkDependants (l, q) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      INC (i)
   END ;
   RETURN s
END walkEnumeration ;


(*
   walkSubrange -
*)

PROCEDURE walkSubrange (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.subrangeF DO
      s := walkDependants (l, low) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      s := walkDependants (l, high) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      s := walkDependants (l, type) ;
      IF s#completed
      THEN
         RETURN s
      END
   END ;
   RETURN completed
END walkSubrange ;


(*
   walkSubscript -
*)

PROCEDURE walkSubscript (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.subscriptF DO
      s := walkDependants (l, expr) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      s := walkDependants (l, type) ;
      IF s#completed
      THEN
         RETURN s
      END
   END ;
   RETURN completed
END walkSubscript ;


(*
   walkPointer -
*)

PROCEDURE walkPointer (l: alist; n: node) : dependentState ;
VAR
   t: node ;
BEGIN
   (* if the type of, n, is done or partial then we can output pointer.  *)
   t := getType (n) ;
   IF alists.isItemInList (partialQ, t) OR alists.isItemInList (doneQ, t)
   THEN
      (* pointer to partial can always generate a complete type.  *)
      RETURN completed
   END ;
   RETURN walkType (l, n)
END walkPointer ;


(*
   walkArray -
*)

PROCEDURE walkArray (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.arrayF DO
(*
      s := walkDependants (l, type) ;
      IF s#completed
      THEN
         RETURN s
      END ;
*)
      (* an array can only be declared if its data type has already been emitted.  *)
      IF NOT alists.isItemInList (doneQ, type)
      THEN
         s := walkDependants (l, type) ;
         queueBlocked (type) ;
         IF s=completed
         THEN
            (* downgrade the completed to partial as it has not yet been written.  *)
            RETURN partial
         ELSE
            RETURN s
         END
      END ;
      RETURN walkDependants (l, subr)
   END
END walkArray ;


(*
   walkConst -
*)

PROCEDURE walkConst (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.constF DO
      s := walkDependants (l, type) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      s := walkDependants (l, value) ;
      IF s#completed
      THEN
         RETURN s
      END
   END ;
   RETURN completed
END walkConst ;


(*
   walkVarParam -
*)

PROCEDURE walkVarParam (l: alist; n: node) : dependentState ;
VAR
   t: node ;
BEGIN
   t := getType (n) ;
   IF alists.isItemInList (partialQ, t)
   THEN
      (* parameter can be issued from a partial.  *)
      RETURN completed
   END ;
   RETURN walkDependants (l, t)
END walkVarParam ;


(*
   walkParam -
*)

PROCEDURE walkParam (l: alist; n: node) : dependentState ;
VAR
   t: node ;
BEGIN
   t := getType (n) ;
   IF alists.isItemInList (partialQ, t)
   THEN
      (* parameter can be issued from a partial.  *)
      RETURN completed
   END ;
   RETURN walkDependants (l, t)
END walkParam ;


(*
   walkOptarg -
*)

PROCEDURE walkOptarg (l: alist; n: node) : dependentState ;
VAR
   t: node ;
BEGIN
   t := getType (n) ;
   IF alists.isItemInList (partialQ, t)
   THEN
      (* parameter can be issued from a partial.  *)
      RETURN completed
   END ;
   RETURN walkDependants (l, t)
END walkOptarg ;


(*
   walkRecordField -
*)

PROCEDURE walkRecordField (l: alist; n: node) : dependentState ;
VAR
   t: node ;
   s: dependentState ;
BEGIN
   assert (isRecordField (n)) ;
   t := getType (n) ;
   IF alists.isItemInList (partialQ, t)
   THEN
      dbs (partial, n) ;
      RETURN partial
   ELSIF alists.isItemInList (doneQ, t)
   THEN
      dbs (completed, n) ;
      RETURN completed
   ELSE
      addTodo (t) ;
      dbs (blocked, n) ;
      dbq (n) ;
      dbq (t) ;
      (*  s := walkDependants (l, t) *)
      RETURN blocked
   END
END walkRecordField ;


(*
   walkVarientField -
*)

PROCEDURE walkVarientField (l: alist; n: node) : dependentState ;
VAR
   s   : dependentState ;
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   i := LowIndice (n^.varientfieldF.listOfSons) ;
   t := HighIndice (n^.varientfieldF.listOfSons) ;
   s := completed ;
   WHILE i<=t DO
      q := GetIndice (n^.varientfieldF.listOfSons, i) ;
      s := walkDependants (l, q) ;
      IF s#completed
      THEN
         dbs (s, n) ;
         RETURN s
      END ;
      INC (i)
   END ;
   n^.varientfieldF.simple := (t <= 1) ;
   dbs (s, n) ;
   RETURN s
END walkVarientField ;


(*
   walkEnumerationField -
*)

PROCEDURE walkEnumerationField (l: alist; n: node) : dependentState ;
BEGIN
   RETURN completed
END walkEnumerationField ;


(*
   walkSet -
*)

PROCEDURE walkSet (l: alist; n: node) : dependentState ;
BEGIN
   RETURN walkDependants (l, getType (n))
END walkSet ;


(*
   walkProcType -
*)

PROCEDURE walkProcType (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
   t: node ;
BEGIN
   t := getType (n) ;
   IF alists.isItemInList (partialQ, t)
   THEN
      (* proctype can be generated from partial types.  *)
   ELSE
      s := walkDependants (l, t) ;
      IF s#completed
      THEN
         RETURN s
      END
   END ;
   RETURN walkParameters (l, n^.proctypeF.parameters)
END walkProcType ;


(*
   walkProcedure -
*)

PROCEDURE walkProcedure (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   s := walkDependants (l, getType (n)) ;
   IF s#completed
   THEN
      RETURN s
   END ;
   RETURN walkParameters (l, n^.procedureF.parameters)
END walkProcedure ;


(*
   walkParameters -
*)

PROCEDURE walkParameters (l: alist; p: Index) : dependentState ;
VAR
   s   : dependentState ;
   i, h: CARDINAL ;
   q   : node ;
BEGIN
   i := LowIndice (p) ;
   h := HighIndice (p) ;
   WHILE i<=h DO
      q := GetIndice (p, i) ;
      s := walkDependants (l, q) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      INC (i)
   END ;
   RETURN completed
END walkParameters ;


(*
   walkFuncCall -
*)

PROCEDURE walkFuncCall (l: alist; n: node) : dependentState ;
BEGIN
   RETURN completed
END walkFuncCall ;


(*
   walkUnary -
*)

PROCEDURE walkUnary (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.unaryF DO
      s := walkDependants (l, arg) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      RETURN walkDependants (l, resultType)
   END
END walkUnary ;


(*
   walkBinary -
*)

PROCEDURE walkBinary (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.binaryF DO
      s := walkDependants (l, left) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      s := walkDependants (l, right) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      RETURN walkDependants (l, resultType)
   END
END walkBinary ;


(*
   walkComponentRef -
*)

PROCEDURE walkComponentRef (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.componentrefF DO
      s := walkDependants (l, rec) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      s := walkDependants (l, field) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      RETURN walkDependants (l, resultType)
   END
END walkComponentRef ;


(*
   walkPointerRef -
*)

PROCEDURE walkPointerRef (l: alist; n: node) : dependentState ;
VAR
   s: dependentState ;
BEGIN
   WITH n^.pointerrefF DO
      s := walkDependants (l, ptr) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      s := walkDependants (l, field) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      RETURN walkDependants (l, resultType)
   END
END walkPointerRef ;


(*
   walkSetValue -
*)

PROCEDURE walkSetValue (l: alist; n: node) : dependentState ;
VAR
   s   : dependentState ;
   i, j: CARDINAL ;
BEGIN
   assert (isSetValue (n)) ;
   WITH n^.setvalueF DO
      s := walkDependants (l, type) ;
      IF s#completed
      THEN
         RETURN s
      END ;
      i := LowIndice (values) ;
      j := HighIndice (values) ;
      WHILE  i <= j DO
         s := walkDependants (l, GetIndice (values, i)) ;
	 IF s#completed
         THEN
            RETURN s
         END ;
         INC (i)
      END
   END ;
   RETURN completed
END walkSetValue ;


(*
   doDependants - return the dependentState depending upon whether
                  all dependants have been declared.
*)

PROCEDURE doDependants (l: alist; n: node) : dependentState ;
BEGIN
   WITH n^ DO
      CASE kind OF

      throw,          (* --fixme--  *)
      varargs,
      address,
      loc,
      byte,
      word,
      csizet,
      cssizet,
      (* base types.  *)
      boolean,
      char,
      cardinal,
      longcard,
      shortcard,
      integer,
      longint,
      shortint,
      real,
      longreal,
      shortreal,
      bitset,
      ztype,
      rtype,
      complex,
      longcomplex,
      shortcomplex,
      proc            :  RETURN completed |
      (* language features and compound type attributes.  *)
      type            :  RETURN walkType (l, n) |
      record          :  RETURN walkRecord (l, n) |
      varient         :  RETURN walkVarient (l, n) |
      var             :  RETURN walkVar (l, n) |
      enumeration     :  RETURN walkEnumeration (l, n) |
      subrange        :  RETURN walkSubrange (l, n) |
      pointer         :  RETURN walkPointer (l, n) |
      array           :  RETURN walkArray (l, n) |
      string          :  RETURN completed |
      const           :  RETURN walkConst (l, n) |
      literal         :  RETURN completed |
      varparam        :  RETURN walkVarParam (l, n) |
      param           :  RETURN walkParam (l, n) |
      optarg          :  RETURN walkOptarg (l, n) |
      recordfield     :  RETURN walkRecordField (l, n) |
      varientfield    :  RETURN walkVarientField (l, n) |
      enumerationfield:  RETURN walkEnumerationField (l, n) |
      set             :  RETURN walkSet (l, n) |
      proctype        :  RETURN walkProcType (l, n) |
      subscript       :  RETURN walkSubscript (l, n) |
      (* blocks.  *)
      procedure       :  RETURN walkProcedure (l, n) |
      def,
      imp,
      module,
      (* statements.  *)
      loop,
      while,
      for,
      repeat,
      if,
      elsif,
      assignment      :  HALT |
      (* expressions.  *)
      componentref    :  RETURN walkComponentRef (l, n) |
      pointerref      :  RETURN walkPointerRef (l, n) |
      not,
      abs,
      min,
      max,
      chr,
      cap,
      ord,
      float,
      trunc,
      high            :  RETURN walkUnary (l, n) |
      cast,
      val,
      plus,
      sub,
      div,
      mod,
      mult,
      divide          :  RETURN walkBinary (l, n) |
      constexp,
      neg,
      adr,
      size,
      tsize,
      deref           :  RETURN walkUnary (l, n) |
      equal,
      notequal,
      less,
      greater,
      greequal,
      lessequal       :  RETURN walkBinary (l, n) |
      funccall        :  RETURN walkFuncCall (l, n) |
      setvalue        :  RETURN walkSetValue (l, n)

      END
   END
END doDependants ;


(*
   tryComplete - returns TRUE if node, n, can be and was completed.
*)

PROCEDURE tryComplete (n: node; c, t, v: nodeProcedure) : BOOLEAN ;
BEGIN
   IF isEnumeration (n)
   THEN
      (* can always emit enumerated types.  *)
      output (n, c, t, v) ;
      RETURN TRUE
   ELSIF isType (n) AND isTypeHidden (n) AND (getType (n)=NIL)
   THEN
      (* can always emit hidden types.  *)
      outputHidden (n) ;
      RETURN TRUE
   ELSIF allDependants (n) = completed
   THEN
      output (n, c, t, v) ;
      RETURN TRUE
   END ;
   RETURN FALSE
END tryComplete ;


(*
   tryCompleteFromPartial -
*)

PROCEDURE tryCompleteFromPartial (n: node; t: nodeProcedure) : BOOLEAN ;
BEGIN
   IF isType (n) AND (getType (n)#NIL) AND isPointer (getType (n)) AND (allDependants (getType (n)) = completed)
   THEN
      (* alists.includeItemIntoList (partialQ, getType (n)) ; *)
      outputHiddenComplete (n) ;
      RETURN TRUE
   ELSIF allDependants (n) = completed
   THEN
      t (n) ;
      RETURN TRUE
   END ;
   RETURN FALSE
END tryCompleteFromPartial ;


(*
   visitIntrinsicFunction -
*)

PROCEDURE visitIntrinsicFunction (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isIntrinsicFunction (n)) ;
   CASE n^.kind OF

   val,
   cmplx:  WITH n^.binaryF DO
             visitNode (v, left, p) ;
             visitNode (v, right, p) ;
             visitNode (v, resultType, p)
           END |
   length,
   adr,
   size,
   tsize,
   float,
   trunc,
   ord,
   chr,
   cap,
   abs,
   high,
   min,
   max,
   re,
   im   : WITH n^.unaryF DO
             visitNode (v, arg, p) ;
             visitNode (v, resultType, p)
          END

   END
END visitIntrinsicFunction ;


(*
   visitUnary -
*)

PROCEDURE visitUnary (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isUnary (n)) ;
   WITH n^.unaryF DO
      visitNode (v, arg, p) ;
      visitNode (v, resultType, p)
   END
END visitUnary ;


(*
   visitBinary -
*)

PROCEDURE visitBinary (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   WITH n^.binaryF DO
      visitNode (v, left, p) ;
      visitNode (v, right, p) ;
      visitNode (v, resultType, p)
   END
END visitBinary ;


(*
   visitBoolean -
*)

PROCEDURE visitBoolean (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   visitNode (v, falseN, p) ;
   visitNode (v, trueN, p)
END visitBoolean ;


(*
   visitScope -
*)

PROCEDURE visitScope (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   IF mustVisitScope
   THEN
      visitNode (v, n, p)
   END
END visitScope ;


(*
   visitType -
*)

PROCEDURE visitType (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isType (n)) ;
   visitNode (v, n^.typeF.type, p) ;
   visitScope (v, n^.typeF.scope, p)
END visitType ;


(*
   visitIndex -
*)

PROCEDURE visitIndex (v: alist; i: Index; p: nodeProcedure) ;
VAR
   j, h: CARDINAL ;
BEGIN
   j := 1 ;
   h := HighIndice (i) ;
   WHILE j <= h DO
      visitNode (v, GetIndice (i, j), p) ;
      INC (j)
   END
END visitIndex ;


(*
   visitRecord -
*)

PROCEDURE visitRecord (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isRecord (n)) ;
   visitScope (v, n^.recordF.scope, p) ;
   visitIndex (v, n^.recordF.listOfSons, p)
END visitRecord ;


(*
   visitVarient -
*)

PROCEDURE visitVarient (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isVarient (n)) ;
   visitIndex (v, n^.varientF.listOfSons, p) ;
   visitNode (v, n^.varientF.varient, p) ;
   visitNode (v, n^.varientF.tag, p) ;
   visitScope (v, n^.varientF.scope, p)
END visitVarient ;


(*
   visitVar -
*)

PROCEDURE visitVar (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isVar (n)) ;
   visitNode (v, n^.varF.type, p) ;
   visitNode (v, n^.varF.decl, p) ;
   visitScope (v, n^.varF.scope, p)
END visitVar ;


(*
   visitEnumeration -
*)

PROCEDURE visitEnumeration (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isEnumeration (n)) ;
   visitIndex (v, n^.enumerationF.listOfSons, p) ;
   visitScope (v, n^.enumerationF.scope, p)
END visitEnumeration ;


(*
   visitSubrange -
*)

PROCEDURE visitSubrange (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isSubrange (n)) ;
   visitNode (v, n^.subrangeF.low, p) ;
   visitNode (v, n^.subrangeF.high, p) ;
   visitNode (v, n^.subrangeF.type, p) ;
   visitScope (v, n^.subrangeF.scope, p)
END visitSubrange ;


(*
   visitPointer -
*)

PROCEDURE visitPointer (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isPointer (n)) ;
   visitNode (v, n^.pointerF.type, p) ;
   visitScope (v, n^.pointerF.scope, p)
END visitPointer ;


(*
   visitArray -
*)

PROCEDURE visitArray (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isArray (n)) ;
   visitNode (v, n^.arrayF.subr, p) ;
   visitNode (v, n^.arrayF.type, p) ;
   visitScope (v, n^.arrayF.scope, p)
END visitArray ;


(*
   visitConst -
*)

PROCEDURE visitConst (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isConst (n)) ;
   visitNode (v, n^.constF.type, p) ;
   visitNode (v, n^.constF.value, p) ;
   visitScope (v, n^.constF.scope, p)
END visitConst ;


(*
   visitVarParam -
*)

PROCEDURE visitVarParam (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isVarParam (n)) ;
   visitNode (v, n^.varparamF.namelist, p) ;
   visitNode (v, n^.varparamF.type, p) ;
   visitScope (v, n^.varparamF.scope, p)
END visitVarParam ;


(*
   visitParam -
*)

PROCEDURE visitParam (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isParam (n)) ;
   visitNode (v, n^.paramF.namelist, p) ;
   visitNode (v, n^.paramF.type, p) ;
   visitScope (v, n^.paramF.scope, p)
END visitParam ;


(*
   visitOptarg -
*)

PROCEDURE visitOptarg (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isOptarg (n)) ;
   visitNode (v, n^.optargF.namelist, p) ;
   visitNode (v, n^.optargF.type, p) ;
   visitNode (v, n^.optargF.init, p) ;
   visitScope (v, n^.optargF.scope, p)
END visitOptarg ;


(*
   visitRecordField -
*)

PROCEDURE visitRecordField (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isRecordField (n)) ;
   visitNode (v, n^.recordfieldF.type, p) ;
   visitNode (v, n^.recordfieldF.parent, p) ;
   visitNode (v, n^.recordfieldF.varient, p) ;
   visitScope (v, n^.recordfieldF.scope, p)
END visitRecordField ;


(*
   visitVarientField -
*)

PROCEDURE visitVarientField (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isVarientField (n)) ;
   visitNode (v, n^.varientfieldF.parent, p) ;
   visitNode (v, n^.varientfieldF.varient, p) ;
   visitIndex (v, n^.varientfieldF.listOfSons, p) ;
   visitScope (v, n^.varientfieldF.scope, p)
END visitVarientField ;


(*
   visitEnumerationField -
*)

PROCEDURE visitEnumerationField (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isEnumerationField (n)) ;
   visitNode (v, n^.enumerationfieldF.type, p) ;
   visitScope (v, n^.enumerationfieldF.scope, p)
END visitEnumerationField ;


(*
   visitSet -
*)

PROCEDURE visitSet (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isSet (n)) ;
   visitNode (v, n^.setF.type, p) ;
   visitScope (v, n^.setF.scope, p)
END visitSet ;


(*
   visitProcType -
*)

PROCEDURE visitProcType (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isProcType (n)) ;
   visitIndex (v, n^.proctypeF.parameters, p) ;
   visitNode (v, n^.proctypeF.optarg, p) ;
   visitNode (v, n^.proctypeF.returnType, p) ;
   visitScope (v, n^.proctypeF.scope, p)
END visitProcType ;


(*
   visitSubscript -
*)

PROCEDURE visitSubscript (v: alist; n: node; p: nodeProcedure) ;
BEGIN
(*
   assert (isSubscript (n)) ;
   visitNode (v, n^.subscriptF.type, p) ;
   visitNode (v, n^.subscriptF.expr, p)
*)
END visitSubscript ;


(*
   visitDecls -
*)

PROCEDURE visitDecls (v: alist; s: scopeT; p: nodeProcedure) ;
BEGIN
   visitIndex (v, s.constants, p) ;
   visitIndex (v, s.types, p) ;
   visitIndex (v, s.procedures, p) ;
   visitIndex (v, s.variables, p)
END visitDecls ;


(*
   visitProcedure -
*)

PROCEDURE visitProcedure (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isProcedure (n)) ;
   visitDecls (v, n^.procedureF.decls, p) ;
   visitScope (v, n^.procedureF.scope, p) ;
   visitIndex (v, n^.procedureF.parameters, p) ;
   visitNode (v, n^.procedureF.optarg, p) ;
   visitNode (v, n^.procedureF.returnType, p) ;
   visitNode (v, n^.procedureF.beginStatements, p)
END visitProcedure ;


(*
   visitDef -
*)

PROCEDURE visitDef (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isDef (n)) ;
   visitDecls (v, n^.defF.decls, p)
END visitDef ;


(*
   visitImp -
*)

PROCEDURE visitImp (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isImp (n)) ;
   visitDecls (v, n^.impF.decls, p) ;
   visitNode (v, n^.impF.beginStatements, p) ;
   visitNode (v, n^.impF.finallyStatements, p)
   (* --fixme-- do we need to visit definitionModule?  *)
END visitImp ;


(*
   visitModule -
*)

PROCEDURE visitModule (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isModule (n)) ;
   visitDecls (v, n^.moduleF.decls, p) ;
   visitNode (v, n^.moduleF.beginStatements, p) ;
   visitNode (v, n^.moduleF.finallyStatements, p)
END visitModule ;


(*
   visitLoop -
*)

PROCEDURE visitLoop (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isLoop (n)) ;
   visitNode (v, n^.loopF.statements, p)
END visitLoop ;


(*
   visitWhile -
*)

PROCEDURE visitWhile (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isWhile (n)) ;
   visitNode (v, n^.whileF.expr, p) ;
   visitNode (v, n^.whileF.statements, p)
END visitWhile ;


(*
   visitRepeat -
*)

PROCEDURE visitRepeat (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isRepeat (n)) ;
   visitNode (v, n^.repeatF.expr, p) ;
   visitNode (v, n^.repeatF.statements, p)
END visitRepeat ;


(*
   visitCase -
*)

PROCEDURE visitCase (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isCase (n)) ;
   visitNode (v, n^.caseF.expression, p) ;
   visitIndex (v, n^.caseF.caseLabelList, p) ;
   visitNode (v, n^.caseF.else, p)
END visitCase ;


(*
   visitCaseLabelList -
*)

PROCEDURE visitCaseLabelList (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isCaseLabelList (n)) ;
   visitNode (v, n^.caselabellistF.caseList, p) ;
   visitNode (v, n^.caselabellistF.statements, p)
END visitCaseLabelList ;


(*
   visitCaseList -
*)

PROCEDURE visitCaseList (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isCaseList (n)) ;
   visitIndex (v, n^.caselistF.rangePairs, p)
END visitCaseList ;


(*
   visitRange -
*)

PROCEDURE visitRange (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isRange (n)) ;
   visitNode (v, n^.rangeF.lo, p) ;
   visitNode (v, n^.rangeF.hi, p)
END visitRange ;


(*
   visitIf -
*)

PROCEDURE visitIf (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isIf (n)) ;
   visitNode (v, n^.ifF.expr, p) ;
   visitNode (v, n^.ifF.elsif, p) ;
   visitNode (v, n^.ifF.then, p) ;
   visitNode (v, n^.ifF.else, p)
END visitIf ;


(*
   visitElsif -
*)

PROCEDURE visitElsif (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isElsif (n)) ;
   visitNode (v, n^.elsifF.expr, p) ;
   visitNode (v, n^.elsifF.elsif, p) ;
   visitNode (v, n^.elsifF.then, p) ;
   visitNode (v, n^.elsifF.else, p)
END visitElsif ;


(*
   visitFor -
*)

PROCEDURE visitFor (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isFor (n)) ;
   visitNode (v, n^.forF.des, p) ;
   visitNode (v, n^.forF.start, p) ;
   visitNode (v, n^.forF.end, p) ;
   visitNode (v, n^.forF.increment, p) ;
   visitNode (v, n^.forF.statements, p)
END visitFor ;


(*
   visitAssignment -
*)

PROCEDURE visitAssignment (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isAssignment (n)) ;
   visitNode (v, n^.assignmentF.des, p) ;
   visitNode (v, n^.assignmentF.expr, p)
END visitAssignment ;


(*
   visitComponentRef -
*)

PROCEDURE visitComponentRef (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isComponentRef (n)) ;
   visitNode (v, n^.componentrefF.rec, p) ;
   visitNode (v, n^.componentrefF.field, p) ;
   visitNode (v, n^.componentrefF.resultType, p)
END visitComponentRef ;


(*
   visitPointerRef -
*)

PROCEDURE visitPointerRef (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isPointerRef (n)) ;
   visitNode (v, n^.pointerrefF.ptr, p) ;
   visitNode (v, n^.pointerrefF.field, p) ;
   visitNode (v, n^.pointerrefF.resultType, p)
END visitPointerRef ;


(*
   visitArrayRef -
*)

PROCEDURE visitArrayRef (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isArrayRef (n)) ;
   visitNode (v, n^.arrayrefF.array, p) ;
   visitNode (v, n^.arrayrefF.index, p) ;
   visitNode (v, n^.arrayrefF.resultType, p)
END visitArrayRef ;


(*
   visitFunccall -
*)

PROCEDURE visitFunccall (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isFuncCall (n)) ;
   visitNode (v, n^.funccallF.function, p) ;
   visitNode (v, n^.funccallF.args, p) ;
   visitNode (v, n^.funccallF.type, p)
END visitFunccall ;


(*
   visitVarDecl -
*)

PROCEDURE visitVarDecl (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isVarDecl (n)) ;
   visitNode (v, n^.vardeclF.type, p) ;
   visitScope (v, n^.vardeclF.scope, p)
END visitVarDecl ;


(*
   visitExplist -
*)

PROCEDURE visitExplist (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isExpList (n)) ;
   visitIndex (v, n^.explistF.exp, p)
END visitExplist ;


(*
   visitExit -
*)

PROCEDURE visitExit (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isExit (n)) ;
   visitNode (v, n^.exitF.loop, p)
END visitExit ;


(*
   visitReturn -
*)

PROCEDURE visitReturn (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isReturn (n)) ;
   visitNode (v, n^.returnF.exp, p)
END visitReturn ;


(*
   visitStmtSeq -
*)

PROCEDURE visitStmtSeq (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isStatementSequence (n)) ;
   visitIndex (v, n^.stmtF.statements, p)
END visitStmtSeq ;


(*
   visitVarargs -
*)

PROCEDURE visitVarargs (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isVarargs (n)) ;
   visitScope (v, n^.varargsF.scope, p)
END visitVarargs ;


(*
   visitSetValue -
*)

PROCEDURE visitSetValue (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isSetValue (n)) ;
   visitNode (v, n^.setvalueF.type, p) ;
   visitIndex (v, n^.setvalueF.values, p)
END visitSetValue ;


(*
   visitIntrinsic -
*)

PROCEDURE visitIntrinsic (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (isIntrinsic (n)) ;
   visitNode (v, n^.intrinsicF.args, p)
END visitIntrinsic ;


(*
   visitDependants - helper procedure function called from visitNode.
                     node n has just been visited, this procedure will
                     visit node, n, dependants.
*)

PROCEDURE visitDependants (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   assert (n # NIL) ;
   assert (alists.isItemInList (v, n)) ;
   CASE n^.kind OF

   explist         :  visitExplist (v, n, p) |
   funccall        :  visitFunccall (v, n, p) |
   exit            :  visitExit (v, n, p) |
   return          :  visitReturn (v, n, p) |
   stmtseq         :  visitStmtSeq (v, n, p) |
   comment         :  |
   length          :  visitIntrinsicFunction (v, n, p) |
   unreachable,
   throw,
   halt,
   new,
   dispose,
   inc,
   dec,
   incl,
   excl            :  visitIntrinsic (v, n, p) |
   boolean         :  visitBoolean (v, n, p) |
   nil,
   false,
   true            :  |
   varargs         :  visitVarargs (v, n, p) |
   address,
   loc,
   byte,
   word,
   csizet,
   cssizet,
   (* base types.  *)
   char,
   cardinal,
   longcard,
   shortcard,
   integer,
   longint,
   shortint,
   real,
   longreal,
   shortreal,
   bitset,
   ztype,
   rtype,
   complex,
   longcomplex,
   shortcomplex,
   proc            :  |
   (* language features and compound type attributes.  *)
   type            :  visitType (v, n, p) |
   record          :  visitRecord (v, n, p) |
   varient         :  visitVarient (v, n, p) |
   var             :  visitVar (v, n, p) |
   enumeration     :  visitEnumeration (v, n, p) |
   subrange        :  visitSubrange (v, n, p) |
   pointer         :  visitPointer (v, n, p) |
   array           :  visitArray (v, n, p) |
   string          :  |
   const           :  visitConst (v, n, p) |
   literal         :  |
   varparam        :  visitVarParam (v, n, p) |
   param           :  visitParam (v, n, p) |
   optarg          :  visitOptarg (v, n, p) |
   recordfield     :  visitRecordField (v, n, p) |
   varientfield    :  visitVarientField (v, n, p) |
   enumerationfield:  visitEnumerationField (v, n, p) |
   set             :  visitSet (v, n, p) |
   proctype        :  visitProcType (v, n, p) |
   subscript       :  visitSubscript (v, n, p) |
   (* blocks.  *)
   procedure       :  visitProcedure (v, n, p) |
   def             :  visitDef (v, n, p) |
   imp             :  visitImp (v, n, p) |
   module          :  visitModule (v, n, p) |
   (* statements.  *)
   loop            :  visitLoop (v, n, p) |
   while           :  visitWhile (v, n, p) |
   for             :  visitFor (v, n, p) |
   repeat          :  visitRepeat (v, n, p) |
   case            :  visitCase (v, n, p) |
   caselabellist   :  visitCaseLabelList (v, n, p) |
   caselist        :  visitCaseList (v, n, p) |
   range           :  visitRange (v, n, p) |
   if              :  visitIf (v, n, p) |
   elsif           :  visitElsif (v, n, p) |
   assignment      :  visitAssignment (v, n, p) |
   (* expressions.  *)
   componentref    :  visitComponentRef (v, n, p) |
   pointerref      :  visitPointerRef (v, n, p) |
   arrayref        :  visitArrayRef (v, n, p) |
   cmplx,
   equal,
   notequal,
   less,
   greater,
   greequal,
   lessequal,
   and,
   or,
   in,
   cast,
   val,
   plus,
   sub,
   div,
   mod,
   mult,
   divide         :  visitBinary (v, n, p) |
   re             :  visitUnary (v, n, p) |
   im             :  visitUnary (v, n, p) |
   abs            :  visitUnary (v, n, p) |
   chr            :  visitUnary (v, n, p) |
   cap            :  visitUnary (v, n, p) |
   high           :  visitUnary (v, n, p) |
   ord            :  visitUnary (v, n, p) |
   float          :  visitUnary (v, n, p) |
   trunc          :  visitUnary (v, n, p) |
   not            :  visitUnary (v, n, p) |
   neg            :  visitUnary (v, n, p) |
   adr            :  visitUnary (v, n, p) |
   size           :  visitUnary (v, n, p) |
   tsize          :  visitUnary (v, n, p) |
   min            :  visitUnary (v, n, p) |
   max            :  visitUnary (v, n, p) |
   constexp       :  visitUnary (v, n, p) |
   deref          :  visitUnary (v, n, p) |
   identlist      :  |
   vardecl        :  visitVarDecl (v, n, p) |
   setvalue       :  visitSetValue (v, n, p)

   END
END visitDependants ;


(*
   visitNode - visits node, n, if it is not already in the alist, v.
               It calls p(n) if the node is unvisited.
*)

PROCEDURE visitNode (v: alist; n: node; p: nodeProcedure) ;
BEGIN
   IF (n#NIL) AND (NOT alists.isItemInList (v, n))
   THEN
      alists.includeItemIntoList (v, n) ;
      p (n) ;
      visitDependants (v, n, p)
   END
END visitNode ;


(*
   genKind - returns a string depending upon the kind of node, n.
*)

PROCEDURE genKind (n: node) : String ;
BEGIN
   CASE n^.kind OF

   (* types, no need to generate a kind string as it it contained in the name.  *)
   nil,
   true,
   false,
   address,
   loc,
   byte,
   word,
   csizet,
   cssizet,
   char,
   cardinal,
   longcard,
   shortcard,
   integer,
   longint,
   shortint,
   real,
   longreal,
   shortreal,
   bitset,
   boolean,
   proc,
   ztype,
   rtype,
   complex,
   longcomplex,
   shortcomplex    :  RETURN NIL |

   (* language features and compound type attributes.  *)
   type            :  RETURN InitString ('type') |
   record          :  RETURN InitString ('record') |
   varient         :  RETURN InitString ('varient') |
   var             :  RETURN InitString ('var') |
   enumeration     :  RETURN InitString ('enumeration') |
   subrange        :  RETURN InitString ('subrange') |
   array           :  RETURN InitString ('array') |
   subscript       :  RETURN InitString ('subscript') |
   string          :  RETURN InitString ('string') |
   const           :  RETURN InitString ('const') |
   literal         :  RETURN InitString ('literal') |
   varparam        :  RETURN InitString ('varparam') |
   param           :  RETURN InitString ('param') |
   varargs         :  RETURN InitString ('varargs') |
   pointer         :  RETURN InitString ('pointer') |
   recordfield     :  RETURN InitString ('recordfield') |
   varientfield    :  RETURN InitString ('varientfield') |
   enumerationfield:  RETURN InitString ('enumerationfield') |
   set             :  RETURN InitString ('set') |
   proctype        :  RETURN InitString ('proctype') |
   (* blocks.  *)
   procedure       :  RETURN InitString ('procedure') |
   def             :  RETURN InitString ('def') |
   imp             :  RETURN InitString ('imp') |
   module          :  RETURN InitString ('module') |
   (* statements.  *)
   loop            :  RETURN InitString ('loop') |
   while           :  RETURN InitString ('while') |
   for             :  RETURN InitString ('for') |
   repeat          :  RETURN InitString ('repeat') |
   assignment      :  RETURN InitString ('assignment') |
   if              :  RETURN InitString ('if') |
   elsif           :  RETURN InitString ('elsif') |
   (* expressions.  *)
   constexp        :  RETURN InitString ('constexp') |
   neg             :  RETURN InitString ('neg') |
   cast            :  RETURN InitString ('cast') |
   val             :  RETURN InitString ('val') |
   plus            :  RETURN InitString ('plus') |
   sub             :  RETURN InitString ('sub') |
   div             :  RETURN InitString ('div') |
   mod             :  RETURN InitString ('mod') |
   mult            :  RETURN InitString ('mult') |
   divide          :  RETURN InitString ('divide') |
   adr             :  RETURN InitString ('adr') |
   size            :  RETURN InitString ('size') |
   tsize           :  RETURN InitString ('tsize') |
   chr             :  RETURN InitString ('chr') |
   ord             :  RETURN InitString ('ord') |
   float           :  RETURN InitString ('float') |
   trunc           :  RETURN InitString ('trunc') |
   high            :  RETURN InitString ('high') |
   componentref    :  RETURN InitString ('componentref') |
   pointerref      :  RETURN InitString ('pointerref') |
   arrayref        :  RETURN InitString ('arrayref') |
   deref           :  RETURN InitString ('deref') |
   equal           :  RETURN InitString ('equal') |
   notequal        :  RETURN InitString ('notequal') |
   less            :  RETURN InitString ('less') |
   greater         :  RETURN InitString ('greater') |
   greequal        :  RETURN InitString ('greequal') |
   lessequal       :  RETURN InitString ('lessequal') |
   lsl             :  RETURN InitString ('lsl') |
   lsr             :  RETURN InitString ('lsr') |
   lor             :  RETURN InitString ('lor') |
   land            :  RETURN InitString ('land') |
   lnot            :  RETURN InitString ('lnot') |
   lxor            :  RETURN InitString ('lxor') |
   and             :  RETURN InitString ('and') |
   or              :  RETURN InitString ('or') |
   not             :  RETURN InitString ('not') |
   identlist       :  RETURN InitString ('identlist') |
   vardecl         :  RETURN InitString ('vardecl')

   END ;
   HALT
END genKind ;


(*
   gen - generate a small string describing node, n.
*)

PROCEDURE gen (n: node) : String ;
VAR
   s: String ;
   d: CARDINAL ;
BEGIN
   d := VAL (CARDINAL, VAL (LONGCARD, n)) ;
   s := Sprintf1 (InitString ('< %d '), d) ;  (* use 0x%x once FormatStrings has been released.  *)
   s := ConCat (s, genKind (n)) ;
   s := ConCat (s, InitString (' ')) ;
   s := ConCat (s, getFQstring (n)) ;
   s := ConCat (s, InitString (' >')) ;
   RETURN s
END gen ;


(*
   dumpQ -
*)

PROCEDURE dumpQ (q: ARRAY OF CHAR; l: alist) ;
VAR
   m   : String ;
   n   : node ;
   d,
   h, i: CARDINAL ;
BEGIN
   m := Sprintf0 (InitString ('Queue ')) ;
   m := KillString (WriteS (StdOut, m)) ;
   m := Sprintf0 (InitString (q)) ;
   m := KillString (WriteS (StdOut, m)) ;
   m := Sprintf0 (InitString ('\n')) ;
   m := KillString (WriteS (StdOut, m)) ;
   i := 1 ;
   h := alists.noOfItemsInList (l) ;
   WHILE i<=h DO
      n := alists.getItemFromList (l, i) ;
      m := KillString (WriteS (StdOut, gen (n))) ;
      INC (i)
   END ;
   m := Sprintf0 (InitString ('\n')) ;
   m := KillString (WriteS (StdOut, m))
END dumpQ ;


(*
   dumpLists -
*)

PROCEDURE dumpLists ;
VAR
   m: String ;
BEGIN
   IF getDebugTopological ()
   THEN
      m := Sprintf0 (InitString ('\n')) ;
      m := KillString (WriteS (StdOut, m)) ;
      dumpQ ('todo', todoQ) ;
      dumpQ ('partial', partialQ) ;
      dumpQ ('done', doneQ)
   END
END dumpLists ;


(*
   outputHidden -
*)

PROCEDURE outputHidden (n: node) ;
BEGIN
   outText (doP, "#if !defined (") ; doFQNameC (doP, n) ; outText (doP, "_D)\n") ;
   outText (doP, "#  define ") ; doFQNameC (doP, n) ; outText (doP, "_D\n") ;
   outText (doP, "   typedef void *") ; doFQNameC (doP, n) ; outText (doP, ";\n") ;
   outText (doP, "#endif\n\n")
END outputHidden ;


(*
   outputHiddenComplete -
*)

PROCEDURE outputHiddenComplete (n: node) ;
VAR
   t: node ;
BEGIN
   assert (isType (n)) ;
   t := getType (n) ;
   assert (isPointer (t)) ;
   outText (doP, "#define ") ; doFQNameC (doP, n) ; outText (doP, "_D\n") ;
   outText (doP, "typedef ") ; doTypeNameC (doP, getType (t)) ;
   setNeedSpace (doP) ; outText (doP, "*") ; doFQNameC (doP, n) ; outText (doP, ";\n")
END outputHiddenComplete ;


(*
   tryPartial -
*)
(*
PROCEDURE tryPartial (n: node; pt: nodeProcedure) : BOOLEAN ;
VAR
   q          : node ;
   seenPointer: BOOLEAN ;
BEGIN
   IF (n#NIL) AND isType (n)
   THEN
      seenPointer := FALSE ;
      q := getType (n) ;
      WHILE isPointer (q) DO
         seenPointer := TRUE ;
         q := getType (q)
      END ;
      IF q # NIL
      THEN
         IF isRecord (q) OR isProcType (q)
         THEN
            pt (n) ;
            addTodo (q) ;
            RETURN TRUE
         ELSIF isArray (q) AND (seenPointer OR alists.isItemInList (doneQ, getType (q)))
         THEN
            pt (n) ;
            addTodo (q) ;
            RETURN TRUE
         ELSIF isType (q) AND seenPointer
         THEN
            pt (n) ;
            addTodo (q) ;
            RETURN TRUE
         END
      END
   END ;
   RETURN FALSE
END tryPartial ;
*)


(*
   tryPartial -
*)

PROCEDURE tryPartial (n: node; pt: nodeProcedure) : BOOLEAN ;
VAR
   q: node ;
BEGIN
   IF (n#NIL) AND isType (n)
   THEN
      q := getType (n) ;
      WHILE isPointer (q) DO
         q := getType (q)
      END ;
      IF q # NIL
      THEN
         IF isRecord (q) OR isProcType (q)
         THEN
            pt (n) ;
            addTodo (q) ;
            RETURN TRUE
         ELSIF isArray (q)
         THEN
            pt (n) ;
            addTodo (q) ;
            RETURN TRUE
         END
      END
   END ;
   RETURN FALSE
END tryPartial ;


(*
   outputPartialRecordArrayProcType -
*)

PROCEDURE outputPartialRecordArrayProcType (n, q: node; indirection: CARDINAL) ;
VAR
   s: String ;
BEGIN
   outText (doP, "typedef struct") ; setNeedSpace (doP) ;
   s := getFQstring (n) ;
   IF isRecord (q)
   THEN
      s := ConCat (s, Mark (InitString ("_r")))
   ELSIF isArray (q)
   THEN
      s := ConCat (s, Mark (InitString ("_a")))
   ELSIF isProcType (q)
   THEN
      s := ConCat (s, Mark (InitString ("_p")))
   END ;
   outTextS (doP, s) ;
   setNeedSpace (doP) ;
   s := KillString (s) ;
   WHILE indirection>0 DO
      outText (doP, "*") ;
      DEC (indirection)
   END ;
   doFQNameC (doP, n) ;
   outText (doP, ";\n\n")
END outputPartialRecordArrayProcType ;


(*
   outputPartial -
*)

PROCEDURE outputPartial (n: node) ;
VAR
   q          : node ;
   indirection: CARDINAL ;
BEGIN
   q := getType (n) ;
   indirection := 0 ;
   WHILE isPointer (q) DO
      q := getType (q) ;
      INC (indirection)
   END ;
   outputPartialRecordArrayProcType (n, q, indirection)
END outputPartial ;


(*
   tryOutputTodo -
*)

PROCEDURE tryOutputTodo (c, t, v, pt: nodeProcedure) ;
VAR
   i, n: CARDINAL ;
   d   : node ;
BEGIN
   i := 1 ;
   n := alists.noOfItemsInList (todoQ) ;
   WHILE i<=n DO
      d := alists.getItemFromList (todoQ, i) ;
      IF tryComplete (d, c, t, v)
      THEN
         alists.removeItemFromList (todoQ, d) ;
	 alists.includeItemIntoList (doneQ, d) ;
         i := 1
      ELSIF tryPartial (d, pt)
      THEN
         alists.removeItemFromList (todoQ, d) ;
         alists.includeItemIntoList (partialQ, d) ;
         i := 1
      ELSE
         INC (i)
      END ;
      n := alists.noOfItemsInList (todoQ)
   END
END tryOutputTodo ;


(*
   tryOutputPartial -
*)

PROCEDURE tryOutputPartial (t: nodeProcedure) ;
VAR
   i, n: CARDINAL ;
   d   : node ;
BEGIN
   i := 1 ;
   n := alists.noOfItemsInList (partialQ) ;
   WHILE i<=n DO
      d := alists.getItemFromList (partialQ, i) ;
      IF tryCompleteFromPartial (d, t)
      THEN
         alists.removeItemFromList (partialQ, d) ;
         alists.includeItemIntoList (doneQ, d) ;
         i := 1 ;
         DEC (n)
      ELSE
         INC (i)
      END
   END
END tryOutputPartial ;


(*
   debugList -
*)

PROCEDURE debugList (a: ARRAY OF CHAR; l: alist) ;
VAR
   i, h: CARDINAL ;
   n   : node ;
BEGIN
   h := alists.noOfItemsInList (l) ;
   IF h>0
   THEN
      outText (doP, a) ;
      outText (doP, ' still contains node(s)\n') ;
      i := 1 ;
      REPEAT
         n := alists.getItemFromList (l, i) ;
         dbg (n) ;
         INC (i)
      UNTIL i > h
   END
END debugList ;


(*
   debugLists -
*)

PROCEDURE debugLists ;
BEGIN
   IF getDebugTopological ()
   THEN
      debugList ('todo', todoQ) ;
      debugList ('partial', partialQ)
   END
END debugLists ;


(*
   addEnumConst -
*)

PROCEDURE addEnumConst (n: node) ;
VAR
   s: String ;
BEGIN
   IF isConst (n) OR isEnumeration (n)
   THEN
      addTodo (n)
   END
END addEnumConst ;


(*
   populateTodo -
*)

PROCEDURE populateTodo (p: nodeProcedure) ;
VAR
   n   : node ;
   i, h: CARDINAL ;
   l   : alist ;
BEGIN
   h := alists.noOfItemsInList (todoQ) ;
   i := 1 ;
   WHILE i <= h DO
      n := alists.getItemFromList (todoQ, i) ;
      l := alists.initList () ;
      visitNode (l, n, p) ;
      alists.killList (l) ;
      h := alists.noOfItemsInList (todoQ) ;
      INC (i)
   END
END populateTodo ;


(*
   topologicallyOut -
*)

PROCEDURE topologicallyOut (c, t, v, tp,
                            pc, pt, pv: nodeProcedure) ;
VAR
   tol, pal,
   to,  pa : CARDINAL ;
BEGIN
   populateTodo (addEnumConst) ;
   tol := 0 ;
   pal := 0 ;
   to := alists.noOfItemsInList (todoQ) ;
   pa := alists.noOfItemsInList (partialQ) ;
   WHILE (tol#to) OR (pal#pa) DO
      dumpLists ;
      tryOutputTodo (c, t, v, tp) ;
      dumpLists ;
      tryOutputPartial (pt) ;
      tol := to ;
      pal := pa ;
      to := alists.noOfItemsInList (todoQ) ;
      pa := alists.noOfItemsInList (partialQ)
   END ;
   dumpLists ;
   debugLists
END topologicallyOut ;


(*
   scaffoldStatic -
*)

PROCEDURE scaffoldStatic (p: pretty; n: node) ;
BEGIN
   outText (p, "\n") ;
   doExternCP (p) ;
   outText (p, "void") ;
   setNeedSpace (p) ;
   outText (p, "_M2_") ;
   doFQNameC (p, n) ;
   outText (p, "_init") ;
   setNeedSpace (p) ;
   outText (p, "(__attribute__((unused)) int argc") ;
   outText (p, ",__attribute__((unused)) char *argv[]") ;
   outText (p, ",__attribute__((unused)) char *envp[])\n");
   p := outKc (p, "{\n") ;
   doStatementsC (p, n^.impF.beginStatements) ;
   p := outKc (p, "}\n") ;
   outText (p, "\n") ;
   doExternCP (p) ;
   outText (p, "void") ;
   setNeedSpace (p) ;
   outText (p, "_M2_") ;
   doFQNameC (p, n) ;
   outText (p, "_fini") ;
   setNeedSpace (p) ;
   outText (p, "(__attribute__((unused)) int argc") ;
   outText (p, ",__attribute__((unused)) char *argv[]") ;
   outText (p, ",__attribute__((unused)) char *envp[])\n");
   p := outKc (p, "{\n") ;
   doStatementsC (p, n^.impF.finallyStatements) ;
   p := outKc (p, "}\n")
END scaffoldStatic ;


(*
   emitCtor -
*)

PROCEDURE emitCtor (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   outText (p, "\n") ;
   outText (p, "static void") ;
   setNeedSpace (p) ;
   outText (p, "ctorFunction ()\n") ;
   doFQNameC (p, n) ;
   p := outKc (p, "{\n") ;
   outText (p, 'M2RTS_RegisterModule ("') ;
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   prints (p, s) ;
   outText (p, '",\n') ;
   outText (p, 'init, fini, dependencies);\n') ;
   p := outKc (p, "}\n\n") ;
   p := outKc (p, "struct ") ;
   prints (p, s) ;
   p := outKc (p, "_module_m2 { ") ;
   prints (p, s) ;
   p := outKc (p, "_module_m2 (); ~") ;
   prints (p, s) ;
   p := outKc (p, "_module_m2 (); } global_module_") ;
   prints (p, s) ;
   outText (p, ';\n\n') ;
   prints (p, s) ;
   p := outKc (p, "_module_m2::") ;
   prints (p, s) ;
   p := outKc (p, "_module_m2 ()\n") ;
   p := outKc (p, "{\n") ;
   outText (p, 'M2RTS_RegisterModule ("') ;
   prints (p, s) ;
   outText (p, '", init, fini, dependencies);') ;
   p := outKc (p, "}\n") ;
   prints (p, s) ;
   p := outKc (p, "_module_m2::~") ;
   prints (p, s) ;
   p := outKc (p, "_module_m2 ()\n") ;
   p := outKc (p, "{\n") ;
   p := outKc (p, "}\n") ;
   s := KillString (s)
END emitCtor ;


(*
   scaffoldDynamic -
*)

PROCEDURE scaffoldDynamic (p: pretty; n: node) ;
BEGIN
   outText (p, "\n") ;
   doExternCP (p) ;
   outText (p, "void") ;
   setNeedSpace (p) ;
   outText (p, "_M2_") ;
   doFQNameC (p, n) ;
   outText (p, "_init") ;
   setNeedSpace (p) ;
   outText (p, "(__attribute__((unused)) int argc,") ;
   outText (p, " __attribute__((unused)) char *argv[]") ;
   outText (p, " __attribute__((unused)) char *envp[])\n") ;
   p := outKc (p, "{\n") ;
   doStatementsC (p, n^.impF.beginStatements) ;
   p := outKc (p, "}\n") ;
   outText (p, "\n") ;
   doExternCP (p) ;
   outText (p, "void") ;
   setNeedSpace (p) ;
   outText (p, "_M2_") ;
   doFQNameC (p, n) ;
   outText (p, "_fini") ;
   setNeedSpace (p) ;
   outText (p, "(__attribute__((unused)) int argc,") ;
   outText (p, " __attribute__((unused)) char *argv[]") ;
   outText (p, " __attribute__((unused)) char *envp[])\n") ;
   p := outKc (p, "{\n") ;
   doStatementsC (p, n^.impF.finallyStatements) ;
   p := outKc (p, "}\n") ;
   emitCtor (p, n)
END scaffoldDynamic ;


(*
   scaffoldMain -
*)

PROCEDURE scaffoldMain (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   outText (p, "int\n") ;
   outText (p, "main") ;
   setNeedSpace (p) ;
   outText (p, "(int argc, char *argv[], char *envp[])\n") ;
   p := outKc (p, "{\n") ;
   outText (p, "M2RTS_ConstructModules (") ;
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   prints (p, s) ;
   outText (p, ", argc, argv, envp);\n");
   outText (p, "M2RTS_DeconstructModules (") ;
   prints (p, s) ;
   outText (p, ", argc, argv, envp);\n");
   outText (p, "return 0;") ;
   p := outKc (p, "}\n") ;
   s := KillString (s)
END scaffoldMain ;


(*
   outImpInitC - emit the init/fini functions and main function if required.
*)

PROCEDURE outImpInitC (p: pretty; n: node) ;
BEGIN
   IF getScaffoldDynamic ()
   THEN
      scaffoldDynamic (p, n)
   ELSE
      scaffoldStatic (p, n)
   END ;
   IF getScaffoldMain ()
   THEN
      scaffoldMain (p, n)
   END
END outImpInitC ;


(*
   runSimplifyTypes -
*)

PROCEDURE runSimplifyTypes (n: node) ;
BEGIN
   IF isImp (n)
   THEN
      simplifyTypes (n^.impF.decls)
   ELSIF isModule (n)
   THEN
      simplifyTypes (n^.moduleF.decls)
   ELSIF isDef (n)
   THEN
      simplifyTypes (n^.defF.decls)
   END
END runSimplifyTypes ;


(*
   outDefC -
*)

PROCEDURE outDefC (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   assert (isDef (n)) ;
   outputFile := mcStream.openFrag (1) ;  (* first fragment.  *)
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   print (p, "/* do not edit automatically generated by mc from ") ;
   prints (p, s) ; print (p, ".  */\n") ;
   writeGPLheader (outputFile) ;
   doCommentC (p, n^.defF.com.body) ;
   print (p, "\n\n#if !defined (_") ; prints (p, s) ; print (p, "_H)\n") ;
   print (p, "#   define _") ; prints (p, s) ; print (p, "_H\n\n") ;

   keyc.genConfigSystem (p) ;

   print (p, "#   ifdef __cplusplus\n") ;
   print (p, 'extern "C" {\n') ;
   print (p, "#   endif\n") ;

   outputFile := mcStream.openFrag (3) ;  (* third fragment.  *)

   doP := p ;
   ForeachIndiceInIndexDo (n^.defF.importedModules, doIncludeC) ;

   print (p, "\n") ;
   print (p, "#   if defined (_") ; prints (p, s) ; print (p, "_C)\n") ;
   print (p, "#      define EXTERN\n") ;
   print (p, "#   else\n") ;
   print (p, '#      define EXTERN extern\n') ;
   print (p, "#   endif\n\n") ;

   outDeclsDefC (p, n) ;
   runPrototypeDefC (n) ;

   print (p, "#   ifdef __cplusplus\n") ;
   print (p, "}\n") ;
   print (p, "#   endif\n") ;

   print (p, "\n") ;
   print (p, "#   undef EXTERN\n") ;
   print (p, "#endif\n") ;

   outputFile := mcStream.openFrag (2) ;  (* second fragment.  *)
   keyc.genDefs (p) ;

   s := KillString (s)
END outDefC ;


(*
   runPrototypeExported -
*)

PROCEDURE runPrototypeExported (n: node) ;
BEGIN
   IF isExported (n)
   THEN
      keyc.enterScope (n) ;
      doProcedureHeadingC (n, TRUE) ;
      print (doP, ";\n") ;
      keyc.leaveScope (n)
   END
END runPrototypeExported ;


(*
   runPrototypeDefC -
*)

PROCEDURE runPrototypeDefC (n: node) ;
BEGIN
   IF isDef (n)
   THEN
      ForeachIndiceInIndexDo (n^.defF.decls.procedures, runPrototypeExported)
   END
END runPrototypeDefC ;


(*
   outImpC -
*)

PROCEDURE outImpC (p: pretty; n: node) ;
VAR
   s        : String ;
   defModule: node ;
BEGIN
   assert (isImp (n)) ;
   outputFile := mcStream.openFrag (1) ;  (* first fragment.  *)
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   print (p, "/* do not edit automatically generated by mc from ") ;
   prints (p, s) ; print (p, ".  */\n") ;
   writeGPLheader (outputFile) ;
   doCommentC (p, n^.impF.com.body) ;
   outText (p, "\n") ;
   outputFile := mcStream.openFrag (3) ;  (* third fragment.  *)
   IF getExtendedOpaque ()
   THEN
      doP := p ;
      (* ForeachIndiceInIndexDo (n^.impF.importedModules, doIncludeC) ; *)

      includeExternals (n) ;
      foreachModuleDo (n, runSimplifyTypes) ;
      printf ("/*  --extended-opaque seen therefore no #include will be used and everything will be declared in full.  */\n") ;
      foreachDefModuleDo (runIncludeDefConstType) ;
      includeDefVarProcedure (n) ;
      outDeclsImpC (p, n^.impF.decls) ;
      foreachDefModuleDo (runPrototypeDefC)
   ELSE
      s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
      (* we don't want to include the .h file for this implementation module.  *)
      print (p, "#define _") ; prints (p, s) ; print (p, "_H\n") ;
      print (p, "#define _") ; prints (p, s) ; print (p, "_C\n\n") ;
      s := KillString (s) ;

      doP := p ;
      ForeachIndiceInIndexDo (n^.impF.importedModules, doIncludeC) ;
      print (p, "\n") ;
      includeDefConstType (n) ;
      includeDefVarProcedure (n) ;
      outDeclsImpC (p, n^.impF.decls) ;

      defModule := lookupDef (getSymName (n)) ;
      IF defModule # NIL
      THEN
         runPrototypeDefC (defModule)
      END
   END ;

   ForeachIndiceInIndexDo (n^.impF.decls.procedures, doPrototypeC) ;

   outProceduresC (p, n^.impF.decls) ;
   outImpInitC (p, n) ;

   outputFile := mcStream.openFrag (2) ;  (* second fragment.  *)
   keyc.genConfigSystem (p) ;
   keyc.genDefs (p)
END outImpC ;


(*
   outDeclsModuleC -
*)

PROCEDURE outDeclsModuleC (p: pretty; s: scopeT) ;
BEGIN
   simplifyTypes (s) ;
   includeConstType (s) ;

   doP := p ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone) ;

   (* try and output types, constants before variables and procedures.  *)
   includeVarProcedure (s) ;

   topologicallyOut (doConstC, doTypesC, doVarC,
                     outputPartial,
                     doNone, doCompletePartialC, doNone) ;

   ForeachIndiceInIndexDo (s.procedures, doPrototypeC)
END outDeclsModuleC ;


(*
   outModuleInitC -
*)

PROCEDURE outModuleInitC (p: pretty; n: node) ;
BEGIN
   outText (p, "\n") ;
   doExternCP (p) ;
   outText (p, "void") ;
   setNeedSpace (p) ;
   outText (p, "_M2_") ;
   doFQNameC (p, n) ;
   outText (p, "_init") ;
   setNeedSpace (p) ;
   outText (p, "(__attribute__((unused)) int argc") ;
   outText (p, ",__attribute__((unused)) char *argv[]") ;
   outText (p, ",__attribute__((unused)) char *envp[])\n");
   p := outKc (p, "{\n") ;
   doStatementsC (p, n^.moduleF.beginStatements) ;
   p := outKc (p, "}\n") ;
   outText (p, "\n") ;
   doExternCP (p) ;
   outText (p, "void") ;
   setNeedSpace (p) ;
   outText (p, "_M2_") ;
   doFQNameC (p, n) ;
   outText (p, "_fini") ;
   setNeedSpace (p) ;
   outText (p, "(__attribute__((unused)) int argc") ;
   outText (p, ",__attribute__((unused)) char *argv[]") ;
   outText (p, ",__attribute__((unused)) char *envp[])\n");
   p := outKc (p, "{\n") ;
   doStatementsC (p, n^.moduleF.finallyStatements) ;
   p := outKc (p, "}\n")
END outModuleInitC ;


(*
   outModuleC -
*)

PROCEDURE outModuleC (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   assert (isModule (n)) ;
   outputFile := mcStream.openFrag (1) ;  (* first fragment.  *)
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   print (p, "/* do not edit automatically generated by mc from ") ;
   prints (p, s) ; print (p, ".  */\n") ;
   writeGPLheader (outputFile) ;
   doCommentC (p, n^.moduleF.com.body) ;
   outText (p, "\n") ;
   outputFile := mcStream.openFrag (3) ;  (* third fragment.  *)
   IF getExtendedOpaque ()
   THEN
      doP := p ;
      includeExternals (n) ;
      foreachModuleDo (n, runSimplifyTypes) ;
      printf ("/*  --extended-opaque seen therefore no #include will be used and everything will be declared in full.  */\n") ;
      foreachDefModuleDo (runIncludeDefConstType) ;
      outDeclsModuleC (p, n^.moduleF.decls) ;
      foreachDefModuleDo (runPrototypeDefC)
   ELSE
      doP := p ;
      ForeachIndiceInIndexDo (n^.moduleF.importedModules, doIncludeC) ;
      print (p, "\n") ;
      outDeclsModuleC (p, n^.moduleF.decls)
   END ;

   ForeachIndiceInIndexDo (n^.moduleF.decls.procedures, doPrototypeC) ;

   outProceduresC (p, n^.moduleF.decls) ;
   outModuleInitC (p, n) ;

   outputFile := mcStream.openFrag (2) ;  (* second fragment.  *)
   keyc.genConfigSystem (p) ;
   keyc.genDefs (p)
END outModuleC ;


(*
   outC -
*)

PROCEDURE outC (p: pretty; n: node) ;
BEGIN
   keyc.enterScope (n) ;
   IF isDef (n)
   THEN
      outDefC (p, n)
   ELSIF isImp (n)
   THEN
      outImpC (p, n)
   ELSIF isModule (n)
   THEN
      outModuleC (p, n)
   ELSE
      HALT
   END ;
   keyc.leaveScope (n)
END outC ;


(*
   doIncludeM2 - include modules in module, n.
*)

PROCEDURE doIncludeM2 (n: node) ;
VAR
   s: String ;
BEGIN
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   print (doP, 'IMPORT ') ;
   prints (doP, s) ;
   print (doP, ' ;\n') ;
   s := KillString (s) ;

   IF isDef (n)
   THEN
      foreachNodeDo (n^.defF.decls.symbols, addDone)
   ELSIF isImp (n)
   THEN
      foreachNodeDo (n^.impF.decls.symbols, addDone)
   ELSIF isModule (n)
   THEN
      foreachNodeDo (n^.moduleF.decls.symbols, addDone)
   END
END doIncludeM2 ;


(*
   doConstM2 -
*)

PROCEDURE doConstM2 (n: node) ;
BEGIN
   print (doP, "CONST\n") ;
   doFQNameC (doP, n) ;
   setNeedSpace (doP) ;
   doExprC (doP, n^.constF.value) ;
   print (doP, '\n')
END doConstM2 ;


(*
   doProcTypeM2 -
*)

PROCEDURE doProcTypeM2 (p: pretty; n: node) ;
BEGIN
   outText (p, "proc type to do..")
END doProcTypeM2 ;


(*
   doRecordFieldM2 -
*)

PROCEDURE doRecordFieldM2 (p: pretty; f: node) ;
BEGIN
   doNameM2 (p, f) ;
   outText (p, ":") ;
   setNeedSpace (p) ;
   doTypeM2 (p, getType (f)) ;
   setNeedSpace (p)
END doRecordFieldM2 ;


(*
   doVarientFieldM2 -
*)

PROCEDURE doVarientFieldM2 (p: pretty; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   assert (isVarientField (n)) ;
   doNameM2 (p, n) ;
   outText (p, ":") ;
   setNeedSpace (p) ;
   i := LowIndice (n^.varientfieldF.listOfSons) ;
   t := HighIndice (n^.varientfieldF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientfieldF.listOfSons, i) ;
      IF isRecordField (q)
      THEN
         doRecordFieldM2 (p, q) ;
         outText (p, ";\n")
      ELSIF isVarient (q)
      THEN
         doVarientM2 (p, q) ;
         outText (p, ";\n")
      ELSE
         HALT
      END ;
      INC (i)
   END
END doVarientFieldM2 ;


(*
   doVarientM2 -
*)

PROCEDURE doVarientM2 (p: pretty; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   assert (isVarient (n)) ;
   outText (p, "CASE") ; setNeedSpace (p) ;
   IF n^.varientF.tag # NIL
   THEN
      IF isRecordField (n^.varientF.tag)
      THEN
         doRecordFieldM2 (p, n^.varientF.tag)
      ELSIF isVarientField (n^.varientF.tag)
      THEN
         doVarientFieldM2 (p, n^.varientF.tag)
      ELSE
         HALT
      END
   END ;
   setNeedSpace (p) ;
   outText (p, "OF\n") ;
   i := LowIndice (n^.varientF.listOfSons) ;
   t := HighIndice (n^.varientF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientF.listOfSons, i) ;
      IF isRecordField (q)
      THEN
         IF NOT q^.recordfieldF.tag
         THEN
            doRecordFieldM2 (p, q) ;
            outText (p, ";\n")
         END
      ELSIF isVarientField (q)
      THEN
         doVarientFieldM2 (p, q)
      ELSE
         HALT
      END ;
      INC (i)
   END ;
   outText (p, "END") ; setNeedSpace (p)
END doVarientM2 ;


(*
   doRecordM2 -
*)

PROCEDURE doRecordM2 (p: pretty; n: node) ;
VAR
   i, h: CARDINAL ;
   f   : node ;
BEGIN
   assert (isRecord (n)) ;
   p := outKm2 (p, "RECORD") ;
   i := LowIndice (n^.recordF.listOfSons) ;
   h := HighIndice (n^.recordF.listOfSons) ;
   outText (p, "\n") ;
   WHILE i<=h DO
      f := GetIndice (n^.recordF.listOfSons, i) ;
      IF isRecordField (f)
      THEN
         IF NOT f^.recordfieldF.tag
         THEN
            doRecordFieldM2 (p, f) ;
            outText (p, ";\n")
         END
      ELSIF isVarient (f)
      THEN
         doVarientM2 (p, f) ;
         outText (p, ";\n")
      ELSIF isVarientField (f)
      THEN
         doVarientFieldM2 (p, f)
      END ;
      INC (i)
   END ;
   p := outKm2 (p, "END") ; setNeedSpace (p)
END doRecordM2 ;


(*
   doPointerM2 -
*)

PROCEDURE doPointerM2 (p: pretty; n: node) ;
BEGIN
   outText (p, "POINTER TO") ;
   setNeedSpace (doP) ;
   doTypeM2 (p, getType (n)) ;
   setNeedSpace (p) ;
   outText (p, ";\n")
END doPointerM2 ;


(*
   doTypeAliasM2 -
*)

PROCEDURE doTypeAliasM2 (p: pretty; n: node) ;
BEGIN
   doTypeNameC (p, n) ;
   setNeedSpace (p) ;
   outText (doP, "=") ;
   setNeedSpace (p) ;
   doTypeM2 (p, getType (n)) ;
   setNeedSpace (p) ;
   outText (p, "\n")
END doTypeAliasM2 ;


(*
   doEnumerationM2 -
*)

PROCEDURE doEnumerationM2 (p: pretty; n: node) ;
VAR
   i, h: CARDINAL ;
   s   : node ;
   t   : String ;
BEGIN
   outText (p, "(") ;
   i := LowIndice (n^.enumerationF.listOfSons) ;
   h := HighIndice (n^.enumerationF.listOfSons) ;
   WHILE i <= h DO
      s := GetIndice (n^.enumerationF.listOfSons, i) ;
      doFQNameC (p, s) ;
      IF i < h
      THEN
         outText (p, ",") ; setNeedSpace (p)
      END ;
      INC (i)
   END ;
   outText (p, ")")
END doEnumerationM2 ;


(*
   doBaseM2 -
*)

PROCEDURE doBaseM2 (p: pretty; n: node) ;
BEGIN
   CASE n^.kind OF

   char,
   cardinal,
   longcard,
   shortcard,
   integer,
   longint,
   shortint,
   complex,
   longcomplex,
   shortcomplex,
   real,
   longreal,
   shortreal,
   bitset,
   boolean,
   proc        :  doNameM2 (p, n)

   END ;
   setNeedSpace (p)
END doBaseM2 ;


(*
   doSystemM2 -
*)

PROCEDURE doSystemM2 (p: pretty; n: node) ;
BEGIN
   CASE n^.kind OF

   address,
   loc,
   byte   ,
   word   ,
   csizet ,
   cssizet:  doNameM2 (p, n)

   END
END doSystemM2 ;


(*
   doTypeM2 -
*)

PROCEDURE doTypeM2 (p: pretty; n: node) ;
BEGIN
   IF isBase (n)
   THEN
      doBaseM2 (p, n)
   ELSIF isSystem (n)
   THEN
      doSystemM2 (p, n)
   ELSIF isType (n)
   THEN
      doTypeAliasM2 (p, n)
   ELSIF isProcType (n)
   THEN
      doProcTypeM2 (p, n)
   ELSIF isPointer (n)
   THEN
      doPointerM2 (p, n)
   ELSIF isEnumeration (n)
   THEN
      doEnumerationM2 (p, n)
   ELSIF isRecord (n)
   THEN
      doRecordM2 (p, n)
   END
END doTypeM2 ;


(*
   doTypesM2 -
*)

PROCEDURE doTypesM2 (n: node) ;
VAR
   m: node ;
BEGIN
   outText (doP, "TYPE\n") ;
   doTypeM2 (doP, n)
END doTypesM2 ;


(*
   doVarM2 -
*)

PROCEDURE doVarM2 (n: node) ;
BEGIN
   assert (isVar (n)) ;
   doNameC (doP, n) ;
   outText (doP, ":") ;
   setNeedSpace (doP) ;
   doTypeM2 (doP, getType (n)) ;
   setNeedSpace (doP) ;
   outText (doP, ";\n")
END doVarM2 ;


(*
   doVarsM2 -
*)

PROCEDURE doVarsM2 (n: node) ;
VAR
   m: node ;
BEGIN
   outText (doP, "VAR\n") ;
   doVarM2 (n)
END doVarsM2 ;


(*
   doTypeNameM2 -
*)

PROCEDURE doTypeNameM2 (p: pretty; n: node) ;
BEGIN
   doNameM2 (p, n)
END doTypeNameM2 ;


(*
   doParamM2 -
*)

PROCEDURE doParamM2 (p: pretty; n: node) ;
VAR
   ptype: node ;
   i    : Name ;
   c, t : CARDINAL ;
   l    : wlist ;
BEGIN
   assert (isParam (n)) ;
   ptype := getType (n) ;
   IF n^.paramF.namelist = NIL
   THEN
      doTypeNameM2 (p, ptype)
   ELSE
      assert (isIdentList (n^.paramF.namelist)) ;
      l := n^.paramF.namelist^.identlistF.names ;
      IF l=NIL
      THEN
         doTypeNameM2 (p, ptype)
      ELSE
         t := wlists.noOfItemsInList (l) ;
         c := 1 ;
         WHILE c <= t DO
            i := wlists.getItemFromList (l, c) ;
            setNeedSpace (p) ;
            doNamesC (p, i) ;
            IF c<t
            THEN
               outText (p, ',') ; setNeedSpace (p)
            END ;
            INC (c)
         END ;
         outText (p, ':') ; setNeedSpace (p) ;
         doTypeNameM2 (p, ptype)
      END
   END
END doParamM2 ;


(*
   doVarParamM2 -
*)

PROCEDURE doVarParamM2 (p: pretty; n: node) ;
VAR
   ptype: node ;
   i    : Name ;
   c, t : CARDINAL ;
   l    : wlist ;
BEGIN
   assert (isVarParam (n)) ;
   outText (p, 'VAR') ; setNeedSpace (p) ;
   ptype := getType (n) ;
   IF n^.varparamF.namelist = NIL
   THEN
      doTypeNameM2 (p, ptype)
   ELSE
      assert (isIdentList (n^.varparamF.namelist)) ;
      l := n^.varparamF.namelist^.identlistF.names ;
      IF l=NIL
      THEN
         doTypeNameM2 (p, ptype)
      ELSE
         t := wlists.noOfItemsInList (l) ;
         c := 1 ;
         WHILE c <= t DO
            i := wlists.getItemFromList (l, c) ;
            setNeedSpace (p) ;
            doNamesC (p, i) ;
            IF c<t
            THEN
               outText (p, ',') ; setNeedSpace (p)
            END ;
            INC (c)
         END ;
         outText (p, ':') ; setNeedSpace (p) ;
         doTypeNameM2 (p, ptype)
      END
   END
END doVarParamM2 ;


(*
   doParameterM2 -
*)

PROCEDURE doParameterM2 (p: pretty; n: node) ;
BEGIN
   IF isParam (n)
   THEN
      doParamM2 (p, n)
   ELSIF isVarParam (n)
   THEN
      doVarParamM2 (p, n)
   ELSIF isVarargs (n)
   THEN
      print (p, "...")
   END
END doParameterM2 ;


(*
   doPrototypeM2 -
*)

PROCEDURE doPrototypeM2 (n: node) ;
VAR
   i, h: CARDINAL ;
   p   : node ;
BEGIN
   assert (isProcedure (n)) ;
   noSpace (doP) ;

   doNameM2 (doP, n) ;
   setNeedSpace (doP) ;
   outText (doP, "(") ;
   i := LowIndice (n^.procedureF.parameters) ;
   h := HighIndice (n^.procedureF.parameters) ;
   WHILE i <= h DO
      p := GetIndice (n^.procedureF.parameters, i) ;
      doParameterM2 (doP, p) ;
      noSpace (doP) ;
      IF i < h
      THEN
         print (doP, ";") ; setNeedSpace (doP)
      END ;
      INC (i)
   END ;
   outText (doP, ")") ;
   IF n^.procedureF.returnType#NIL
   THEN
      setNeedSpace (doP) ;
      outText (doP, ":") ;
      doTypeM2 (doP, n^.procedureF.returnType) ; setNeedSpace (doP)
   END ;
   outText (doP, ";\n")
END doPrototypeM2 ;


(*
   outputPartialM2 - just writes out record, array, and proctypes.
                     No need for forward declarations in Modula-2
                     but we need to keep topological sort happy.
                     So when asked to output partial we emit the
                     full type for these types and then do nothing
                     when trying to complete partial to full.
*)

PROCEDURE outputPartialM2 (n: node) ;
VAR
   q: node ;
BEGIN
   q := getType (n) ;
   IF isRecord (q)
   THEN
      doTypeM2 (doP, n)
   ELSIF isArray (q)
   THEN
      doTypeM2 (doP, n)
   ELSIF isProcType (q)
   THEN
      doTypeM2 (doP, n)
   END
END outputPartialM2 ;


(*
   outDeclsDefM2 -
*)

PROCEDURE outDeclsDefM2 (p: pretty; s: scopeT) ;
BEGIN
   simplifyTypes (s) ;
   includeConstType (s) ;

   doP := p ;

   topologicallyOut (doConstM2, doTypesM2, doVarsM2,
                     outputPartialM2,
                     doNothing, doNothing, doNothing) ;

   includeVarProcedure (s) ;

   topologicallyOut (doConstM2, doTypesM2, doVarsM2,
                     outputPartialM2,
                     doNothing, doNothing, doNothing) ;

   ForeachIndiceInIndexDo (s.procedures, doPrototypeM2)
END outDeclsDefM2 ;


(*
   outDefM2 -
*)

PROCEDURE outDefM2 (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   s := InitStringCharStar (keyToCharStar (getSource (n))) ;
   print (p, "(* automatically created by mc from ") ; prints (p, s) ; print (p, ".  *)\n\n") ;
   s := KillString (s) ;
   s := InitStringCharStar (keyToCharStar (getSymName (n))) ;
   print (p, "DEFINITION MODULE ") ; prints (p, s) ; print (p, " ;\n\n") ;

   doP := p ;
   ForeachIndiceInIndexDo (n^.defF.importedModules, doIncludeM2) ;

   print (p, "\n") ;

   outDeclsDefM2 (p, n^.defF.decls) ;

   print (p, "\n") ;
   print (p, "END ") ;
   prints (p, s) ;
   print (p, ".\n") ;
   s := KillString (s)
END outDefM2 ;


(*
   outDeclsImpM2 -
*)

PROCEDURE outDeclsImpM2 (p: pretty; s: scopeT) ;
BEGIN
   simplifyTypes (s) ;
   includeConstType (s) ;

   doP := p ;

   topologicallyOut (doConstM2, doTypesM2, doVarM2,
                     outputPartialM2,
                     doNothing, doNothing, doNothing) ;

   includeVarProcedure (s) ;

   topologicallyOut (doConstM2, doTypesM2, doVarsM2,
                     outputPartialM2,
                     doNothing, doNothing, doNothing) ;

   outText (p, "\n") ;
   ForeachIndiceInIndexDo (s.procedures, doPrototypeC)
END outDeclsImpM2 ;


(*
   outImpM2 -
*)

PROCEDURE outImpM2 (p: pretty; n: node) ;
VAR
   s: String ;
BEGIN
   s := InitStringCharStar (keyToCharStar (getSource (n))) ;
   print (p, "(* automatically created by mc from ") ; prints (p, s) ; print (p, ".  *)\n\n") ;
   print (p, "IMPLEMENTATION MODULE ") ; prints (p, s) ; print (p, " ;\n\n") ;

   doP := p ;
   ForeachIndiceInIndexDo (n^.impF.importedModules, doIncludeM2) ;
   print (p, "\n") ;

   includeDefConstType (n) ;
   outDeclsImpM2 (p, n^.impF.decls) ;

   print (p, "\n") ;
   print (p, "END ") ;
   prints (p, s) ;
   print (p, ".\n") ;

   s := KillString (s)
END outImpM2 ;


(*
   outModuleM2 -
*)

PROCEDURE outModuleM2 (p: pretty; n: node) ;
BEGIN

END outModuleM2 ;


(*
   outM2 -
*)

PROCEDURE outM2 (p: pretty; n: node) ;
BEGIN
   IF isDef (n)
   THEN
      outDefM2 (p, n)
   ELSIF isImp (n)
   THEN
      outImpM2 (p, n)
   ELSIF isModule (n)
   THEN
      outModuleM2 (p, n)
   ELSE
      HALT
   END
END outM2 ;


(*
   out - walks the tree of node declarations for the main module
         and writes the output to the outputFile specified in
         mcOptions.  It outputs the declarations in the language
         specified above.
*)

PROCEDURE out ;
VAR
   p: pretty ;
BEGIN
   openOutput ;
   p := initPretty (write, writeln) ;
   CASE lang OF

   ansiC :  outC (p, getMainModule ()) |
   ansiCP:  outC (p, getMainModule ()) |
   pim4  :  outM2 (p, getMainModule ())

   END ;
   closeOutput
END out ;


(*
   setLangC -
*)

PROCEDURE setLangC ;
BEGIN
   lang := ansiC
END setLangC ;


(*
   setLangCP -
*)

PROCEDURE setLangCP ;
BEGIN
   lang := ansiCP ;
   keyc.cp
END setLangCP ;


(*
   setLangM2 -
*)

PROCEDURE setLangM2 ;
BEGIN
   lang := pim4
END setLangM2 ;


(*
   addDone - adds node, n, to the doneQ.
*)

PROCEDURE addDone (n: node) ;
BEGIN
   alists.includeItemIntoList (doneQ, n)
END addDone ;


(*
   addDoneDef - adds node, n, to the doneQ providing
                it is not an opaque of the main module we are compiling.
*)

PROCEDURE addDoneDef (n: node) ;
BEGIN
   IF isDef (n)
   THEN
      addDone (n) ;
      RETURN
   END ;
   IF (NOT isDef (n)) AND (lookupImp (getSymName (getScope (n))) = getMainModule ())
   THEN
      metaError1 ('cyclic dependancy found between another module using {%1ad} from the definition module of the implementation main being compiled, use the --extended-opaque option to compile', n) ;
      flushErrors ;
      errorAbort0 ('terminating compilation')
   ELSE
      addDone (n)
   END
END addDoneDef ;


(*
   dbgAdd -
*)

PROCEDURE dbgAdd (l: alist; n: node) : node ;
BEGIN
   IF n#NIL
   THEN
      alists.includeItemIntoList (l, n)
   END ;
   RETURN n
END dbgAdd ;


(*
   dbgType -
*)

PROCEDURE dbgType (l: alist; n: node) ;
VAR
   t: node ;
BEGIN
   t := dbgAdd (l, getType (n)) ;
   out1 ("<%s type", n) ;
   IF t = NIL
   THEN
      out0 (", type = NIL\n")
   ELSE
      out1 (", type = %s>\n", t)
   END
END dbgType ;


(*
   dbgPointer -
*)

PROCEDURE dbgPointer (l: alist; n: node) ;
VAR
   t: node ;
BEGIN
   t := dbgAdd (l, getType (n)) ;
   out1 ("<%s pointer", n) ;
   out1 (" to %s>\n", t)
END dbgPointer ;


(*
   dbgRecord -
*)

PROCEDURE dbgRecord (l: alist; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   out1 ("<%s record:\n", n) ;
   i := LowIndice (n^.recordF.listOfSons) ;
   t := HighIndice (n^.recordF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.recordF.listOfSons, i) ;
      IF isRecordField (q)
      THEN
         out1 (" <recordfield %s", q)
      ELSIF isVarientField (q)
      THEN
         out1 (" <varientfield %s", q)
      ELSIF isVarient (q)
      THEN
         out1 (" <varient %s", q)
      ELSE
         HALT
      END ;
      q := dbgAdd (l, getType (q)) ;
      out1 (": %s>\n", q) ;
      INC (i)
   END ;
   outText (doP, ">\n")
END dbgRecord ;


(*
   dbgVarient -
*)

PROCEDURE dbgVarient (l: alist; n: node) ;
VAR
   i, t: CARDINAL ;
   q   : node ;
BEGIN
   out1 ("<%s varient: ", n) ;
   out1 ("tag %s", n^.varientF.tag) ;
   q := getType (n^.varientF.tag) ;
   IF q=NIL
   THEN
      outText (doP, "\n")
   ELSE
      out1 (": %s\n", q) ;
      q := dbgAdd (l, q)
   END ;
   i := LowIndice (n^.varientF.listOfSons) ;
   t := HighIndice (n^.varientF.listOfSons) ;
   WHILE i<=t DO
      q := GetIndice (n^.varientF.listOfSons, i) ;
      IF isRecordField (q)
      THEN
         out1 (" <recordfield %s", q)
      ELSIF isVarientField (q)
      THEN
         out1 (" <varientfield %s", q)
      ELSIF isVarient (q)
      THEN
         out1 (" <varient %s", q)
      ELSE
         HALT
      END ;
      q := dbgAdd (l, getType (q)) ;
      out1 (": %s>\n", q) ;
      INC (i)
   END ;
   outText (doP, ">\n")
END dbgVarient ;


(*
   dbgEnumeration -
*)

PROCEDURE dbgEnumeration (l: alist; n: node) ;
VAR
   e   : node ;
   i, h: CARDINAL ;
BEGIN
   outText (doP, "< enumeration ") ;
   i := LowIndice (n^.enumerationF.listOfSons) ;
   h := HighIndice (n^.enumerationF.listOfSons) ;
   WHILE i<=h DO
      e := GetIndice (n^.enumerationF.listOfSons, i) ;
      out1 ("%s, ", e) ;
      INC (i)
   END ;
   outText (doP, ">\n")
END dbgEnumeration ;


(*
   dbgVar -
*)

PROCEDURE dbgVar (l: alist; n: node) ;
VAR
   t: node ;
BEGIN
   t := dbgAdd (l, getType (n)) ;
   out1 ("<%s var", n) ;
   out1 (", type = %s>\n", t)
END dbgVar ;


(*
   dbgSubrange -
*)

PROCEDURE dbgSubrange (l: alist; n: node) ;
BEGIN
   IF n^.subrangeF.low = NIL
   THEN
      out1 ('%s', n^.subrangeF.type)
   ELSE
      out1 ('[%s', n^.subrangeF.low) ;
      out1 ('..%s]', n^.subrangeF.high)
   END
END dbgSubrange ;


(*
   dbgArray -
*)

PROCEDURE dbgArray (l: alist; n: node) ;
VAR
   t: node ;
BEGIN
   t := dbgAdd (l, getType (n)) ;
   out1 ("<%s array ", n) ;
   IF n^.arrayF.subr # NIL
   THEN
      dbgSubrange (l, n^.arrayF.subr)
   END ;
   out1 (" of %s>\n", t)
END dbgArray ;


(*
   doDbg -
*)

PROCEDURE doDbg (l: alist; n: node) ;
BEGIN
   IF n=NIL
   THEN
      (* do nothing.  *)
   ELSIF isSubrange (n)
   THEN
      dbgSubrange (l, n)
   ELSIF isType (n)
   THEN
      dbgType (l, n)
   ELSIF isRecord (n)
   THEN
      dbgRecord (l, n)
   ELSIF isVarient (n)
   THEN
      dbgVarient (l, n)
   ELSIF isEnumeration (n)
   THEN
      dbgEnumeration (l, n)
   ELSIF isPointer (n)
   THEN
      dbgPointer (l, n)
   ELSIF isArray (n)
   THEN
      dbgArray (l, n)
   ELSIF isVar (n)
   THEN
      dbgVar (l, n)
   END
END doDbg ;


(*
   dbg -
*)

PROCEDURE dbg (n: node) ;
VAR
   l: alist ;
   o: pretty ;
   f: File ;
   s: String ;
   i: CARDINAL ;
BEGIN
   o := doP ;
   f := outputFile ;
   outputFile := StdOut ;
   doP := initPretty (write, writeln) ;

   l := alists.initList () ;
   alists.includeItemIntoList (l, n) ;
   i := 1 ;
   out1 ("dbg (%s)\n", n) ;
   REPEAT
      n := alists.getItemFromList (l, i) ;
      doDbg (l, n) ;
      INC (i)
   UNTIL i>alists.noOfItemsInList (l) ;
   doP := o ;
   outputFile := f
END dbg ;


(*
   makeStatementSequence - create and return a statement sequence node.
*)

PROCEDURE makeStatementSequence () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (stmtseq) ;
   n^.stmtF.statements := InitIndex (1) ;
   RETURN n
END makeStatementSequence ;


(*
   addStatement - adds node, n, as a statement to statememt sequence, s.
*)

PROCEDURE addStatement (s: node; n: node) ;
BEGIN
   IF n#NIL
   THEN
      assert (isStatementSequence (s)) ;
      PutIndice (s^.stmtF.statements, HighIndice (s^.stmtF.statements) + 1, n) ;
      IF isIntrinsic (n) AND (n^.intrinsicF.postUnreachable)
      THEN
         n^.intrinsicF.postUnreachable := FALSE ;
         addStatement (s, makeIntrinsicProc (unreachable, 0, NIL))
      END
   END
END addStatement ;


(*
   isStatementSequence - returns TRUE if node, n, is a statement sequence.
*)

PROCEDURE isStatementSequence (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = stmtseq
END isStatementSequence ;


(*
   addGenericBody - adds comment node to funccall, return, assignment
                    nodes.
*)

PROCEDURE addGenericBody (n, c: node);
BEGIN
   CASE n^.kind OF

   unreachable,
   throw,
   halt,
   new,
   dispose,
   inc,
   dec,
   incl,
   excl      :  n^.intrinsicF.intrinsicComment.body := c |
   funccall  :  n^.funccallF.funccallComment.body := c |
   return    :  n^.returnF.returnComment.body := c |
   assignment:  n^.assignmentF.assignComment.body := c |
   module    :  n^.moduleF.com.body := c |
   def       :  n^.defF.com.body := c |
   imp       :  n^.impF.com.body := c

   ELSE
   END
END addGenericBody;


(*
   addGenericAfter - adds comment node to funccall, return, assignment
                     nodes.
*)

PROCEDURE addGenericAfter (n, c: node);
BEGIN
   CASE n^.kind OF

   unreachable,
   throw,
   halt,
   new,
   dispose,
   inc,
   dec,
   incl,
   excl      :  n^.intrinsicF.intrinsicComment.after := c |
   funccall  :  n^.funccallF.funccallComment.after := c |
   return    :  n^.returnF.returnComment.after := c |
   assignment:  n^.assignmentF.assignComment.after := c |
   module    :  n^.moduleF.com.after := c |
   def       :  n^.defF.com.after := c |
   imp       :  n^.impF.com.after := c

   ELSE
   END
END addGenericAfter ;


(*
   addCommentBody - adds a body comment to a statement sequence node.
*)

PROCEDURE addCommentBody (n: node) ;
VAR
   b: commentDesc ;
BEGIN
   IF n # NIL
   THEN
      b := getBodyComment () ;
      IF b # NIL
      THEN
         addGenericBody (n, makeCommentS (b))
      END
   END
END addCommentBody ;


(*
   addCommentAfter - adds an after comment to a statement sequence node.
*)

PROCEDURE addCommentAfter (n: node) ;
VAR
   a: commentDesc ;
BEGIN
   IF n # NIL
   THEN
      a := getAfterComment () ;
      IF a # NIL
      THEN
         addGenericAfter (n, makeCommentS (a))
      END
   END
END addCommentAfter ;


(*
   addIfComments - adds the, body, and, after, comments to if node, n.
*)

PROCEDURE addIfComments (n: node; body, after: node) ;
BEGIN
   assert (isIf (n)) ;
   n^.ifF.ifComment.after := after ;
   n^.ifF.ifComment.body := body
END addIfComments ;


(*
   addElseComments - adds the, body, and, after, comments to an, if, or an elsif, node, n.
*)

PROCEDURE addElseComments (n: node; body, after: node) ;
BEGIN
   assert (isIf (n) OR isElsif (n)) ;
   IF isIf (n)
   THEN
      n^.ifF.elseComment.after := after ;
      n^.ifF.elseComment.body := body
   ELSE
      n^.elsifF.elseComment.after := after ;
      n^.elsifF.elseComment.body := body
   END
END addElseComments ;


(*
   addIfEndComments - adds the, body, and, after, comments to an, if, node, n.
*)

PROCEDURE addIfEndComments (n: node; body, after: node) ;
BEGIN
   assert (isIf (n)) ;
   n^.ifF.endComment.after := after ;
   n^.ifF.endComment.body := body
END addIfEndComments ;


(*
   makeReturn - creates and returns a return node.
*)

PROCEDURE makeReturn () : node ;
VAR
   type,
   n   : node ;
BEGIN
   n := newNode (return) ;
   n^.returnF.exp := NIL ;
   IF isProcedure (getDeclScope ())
   THEN
      n^.returnF.scope := getDeclScope ()
   ELSE
      n^.returnF.scope := NIL
   END ;
   initPair (n^.returnF.returnComment) ;
   RETURN n
END makeReturn ;


(*
   isReturn - returns TRUE if node, n, is a return.
*)

PROCEDURE isReturn (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = return
END isReturn ;


(*
   putReturn - assigns node, e, as the expression on the return node.
*)

PROCEDURE putReturn (n: node; e: node) ;
BEGIN
   assert (isReturn (n)) ;
   n^.returnF.exp := e
END putReturn ;


(*
   makeWhile - creates and returns a while node.
*)

PROCEDURE makeWhile () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (while) ;
   n^.whileF.expr := NIL ;
   n^.whileF.statements := NIL ;
   initPair (n^.whileF.doComment) ;
   initPair (n^.whileF.endComment) ;
   RETURN n
END makeWhile ;


(*
   putWhile - places an expression, e, and statement sequence, s, into the while
              node, n.
*)

PROCEDURE putWhile (n: node; e, s: node) ;
BEGIN
   assert (isWhile (n)) ;
   n^.whileF.expr := e ;
   n^.whileF.statements := s
END putWhile ;


(*
   isWhile - returns TRUE if node, n, is a while.
*)

PROCEDURE isWhile (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = while
END isWhile ;


(*
   addWhileDoComment - adds body and after comments to while node, w.
*)

PROCEDURE addWhileDoComment (w: node; body, after: node) ;
BEGIN
   assert (isWhile (w)) ;
   w^.whileF.doComment.after := after ;
   w^.whileF.doComment.body := body
END addWhileDoComment ;


(*
   addWhileEndComment - adds body and after comments to the end of a while node, w.
*)

PROCEDURE addWhileEndComment (w: node; body, after: node) ;
BEGIN
   assert (isWhile (w)) ;
   w^.whileF.endComment.after := after ;
   w^.whileF.endComment.body := body
END addWhileEndComment ;


(*
   makeAssignment - creates and returns an assignment node.
                    The designator is, d, and expression, e.
*)

PROCEDURE makeAssignment (d, e: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (assignment) ;
   n^.assignmentF.des := d ;
   n^.assignmentF.expr := e ;
   initPair (n^.assignmentF.assignComment) ;
   RETURN n
END makeAssignment ;


(*
   isAssignment -
*)

PROCEDURE isAssignment (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = assignment
END isAssignment ;


(*
   putBegin - assigns statements, s, to be the normal part in
              block, b.  The block may be a procedure or module,
              or implementation node.
*)

PROCEDURE putBegin (b: node; s: node) ;
BEGIN
   assert (isImp (b) OR isProcedure (b) OR isModule (b)) ;
   CASE b^.kind OF

   imp      :  b^.impF.beginStatements := s |
   module   :  b^.moduleF.beginStatements := s |
   procedure:  b^.procedureF.beginStatements := s

   END
END putBegin ;


(*
   putFinally - assigns statements, s, to be the final part in
                block, b.  The block may be a module
                or implementation node.
*)

PROCEDURE putFinally (b: node; s: node) ;
BEGIN
   assert (isImp (b) OR isProcedure (b) OR isModule (b)) ;
   CASE b^.kind OF

   imp      :  b^.impF.finallyStatements := s |
   module   :  b^.moduleF.finallyStatements := s

   END
END putFinally ;


(*
   makeExit - creates and returns an exit node.
*)

PROCEDURE makeExit (l: node; n: CARDINAL) : node ;
VAR
   e: node ;
BEGIN
   assert (isLoop (l)) ;
   e := newNode (exit) ;
   e^.exitF.loop := l ;
   l^.loopF.labelno := n ;
   RETURN e
END makeExit ;


(*
   isExit - returns TRUE if node, n, is an exit.
*)

PROCEDURE isExit (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = exit
END isExit ;


(*
   makeLoop - creates and returns a loop node.
*)

PROCEDURE makeLoop () : node ;
VAR
   l: node ;
BEGIN
   l := newNode (loop) ;
   l^.loopF.statements := NIL ;
   l^.loopF.labelno := 0 ;
   RETURN l
END makeLoop ;


(*
   putLoop - places statement sequence, s, into loop, l.
*)

PROCEDURE putLoop (l, s: node) ;
BEGIN
   assert (isLoop (l)) ;
   l^.loopF.statements := s
END putLoop ;


(*
   isLoop - returns TRUE if, n, is a loop node.
*)

PROCEDURE isLoop (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = loop
END isLoop ;


(*
   makeComment - creates and returns a comment node.
*)

PROCEDURE makeComment (a: ARRAY OF CHAR) : node ;
VAR
   c: commentDesc ;
   s: String ;
BEGIN
   c := initComment (TRUE) ;
   s := InitString (a) ;
   addText (c, DynamicStrings.string (s)) ;
   s := KillString (s) ;
   RETURN makeCommentS (c)
END makeComment ;


(*
   makeCommentS - creates and returns a comment node.
*)

PROCEDURE makeCommentS (c: commentDesc) : node ;
VAR
   n: node ;
BEGIN
   IF c = NIL
   THEN
      RETURN NIL
   ELSE
      n := newNode (comment) ;
      n^.commentF.content := c ;
      RETURN n
   END
END makeCommentS ;


(*
   isComment - returns TRUE if node, n, is a comment.
*)

PROCEDURE isComment (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = comment
END isComment ;


(*
   initPair - initialise the commentPair, c.
*)

PROCEDURE initPair (VAR c: commentPair) ;
BEGIN
   c.after := NIL ;
   c.body := NIL
END initPair ;


(*
   makeIf - creates and returns an if node.  The if node
            will have expression, e, and statement sequence, s,
            as the then component.
*)

PROCEDURE makeIf (e, s: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (if) ;
   n^.ifF.expr := e ;
   n^.ifF.then := s ;
   n^.ifF.else := NIL ;
   n^.ifF.elsif := NIL ;
   initPair (n^.ifF.ifComment) ;
   initPair (n^.ifF.elseComment) ;
   initPair (n^.ifF.endComment) ;
   RETURN n
END makeIf ;


(*
   isIf - returns TRUE if, n, is an if node.
*)

PROCEDURE isIf (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = if
END isIf ;


(*
   makeElsif - creates and returns an elsif node.
               This node has an expression, e, and statement
               sequence, s.
*)

PROCEDURE makeElsif (i, e, s: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (elsif) ;
   n^.elsifF.expr := e ;
   n^.elsifF.then := s ;
   n^.elsifF.elsif := NIL ;
   n^.elsifF.else := NIL ;
   initPair (n^.elsifF.elseComment) ;
   assert (isIf (i) OR isElsif (i)) ;
   IF isIf (i)
   THEN
      i^.ifF.elsif := n ;
      assert (i^.ifF.else = NIL)
   ELSE
      i^.elsifF.elsif := n ;
      assert (i^.elsifF.else = NIL)
   END ;
   RETURN n
END makeElsif ;


(*
   isElsif - returns TRUE if node, n, is an elsif node.
*)

PROCEDURE isElsif (n: node) : BOOLEAN ;
BEGIN
   RETURN n^.kind = elsif
END isElsif ;


(*
   putElse - the else is grafted onto the if/elsif node, i,
             and the statement sequence will be, s.
*)

PROCEDURE putElse (i, s: node) ;
BEGIN
   assert (isIf (i) OR isElsif (i)) ;
   IF isIf (i)
   THEN
      assert (i^.ifF.elsif = NIL) ;
      assert (i^.ifF.else = NIL) ;
      i^.ifF.else := s
   ELSE
      assert (i^.elsifF.elsif = NIL) ;
      assert (i^.elsifF.else = NIL) ;
      i^.elsifF.else := s
   END
END putElse ;


(*
   makeFor - creates and returns a for node.
*)

PROCEDURE makeFor () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (for) ;
   n^.forF.des := NIL ;
   n^.forF.start := NIL ;
   n^.forF.end := NIL ;
   n^.forF.increment := NIL ;
   n^.forF.statements := NIL ;
   RETURN n
END makeFor ;


(*
   isFor - returns TRUE if node, n, is a for node.
*)

PROCEDURE isFor (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = for
END isFor ;


(*
   putFor - assigns the fields of the for node with
            ident, i,
            start, s,
            end, e,
            increment, i,
            statements, sq.
*)

PROCEDURE putFor (f, i, s, e, b, sq: node) ;
BEGIN
   assert (isFor (f)) ;
   f^.forF.des := i ;
   f^.forF.start := s ;
   f^.forF.end := e ;
   f^.forF.increment := b ;
   f^.forF.statements := sq
END putFor ;


(*
   makeRepeat - creates and returns a repeat node.
*)

PROCEDURE makeRepeat () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (repeat) ;
   n^.repeatF.expr := NIL ;
   n^.repeatF.statements := NIL ;
   initPair (n^.repeatF.repeatComment) ;
   initPair (n^.repeatF.untilComment) ;
   RETURN n
END makeRepeat ;


(*
   isRepeat - returns TRUE if node, n, is a repeat node.
*)

PROCEDURE isRepeat (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = repeat
END isRepeat ;


(*
   putRepeat - places statements, s, and expression, e, into
               repeat statement, n.
*)

PROCEDURE putRepeat (n, s, e: node) ;
BEGIN
   n^.repeatF.expr := e ;
   n^.repeatF.statements := s
END putRepeat ;


(*
   addRepeatComment - adds body and after comments to repeat node, r.
*)

PROCEDURE addRepeatComment (r: node; body, after: node) ;
BEGIN
   assert (isRepeat (r)) ;
   r^.repeatF.repeatComment.after := after ;
   r^.repeatF.repeatComment.body := body
END addRepeatComment ;


(*
   addUntilComment - adds body and after comments to the until section of a repeat node, r.
*)

PROCEDURE addUntilComment (r: node; body, after: node) ;
BEGIN
   assert (isRepeat (r)) ;
   r^.repeatF.untilComment.after := after ;
   r^.repeatF.untilComment.body := body
END addUntilComment ;


(*
   makeCase - builds and returns a case statement node.
*)

PROCEDURE makeCase () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (case) ;
   n^.caseF.expression := NIL ;
   n^.caseF.caseLabelList := InitIndex (1) ;
   n^.caseF.else := NIL ;
   RETURN n
END makeCase ;


(*
   isCase - returns TRUE if node, n, is a case statement.
*)

PROCEDURE isCase (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = case
END isCase ;


(*
   putCaseExpression - places expression, e, into case statement, n.
                       n is returned.
*)

PROCEDURE putCaseExpression (n: node; e: node) : node ;
BEGIN
   assert (isCase (n)) ;
   n^.caseF.expression := e ;
   RETURN n
END putCaseExpression ;


(*
   putCaseElse - places else statement, e, into case statement, n.
                 n is returned.
*)

PROCEDURE putCaseElse (n: node; e: node) : node ;
BEGIN
   assert (isCase (n)) ;
   n^.caseF.else := e ;
   RETURN n
END putCaseElse ;


(*
   putCaseStatement - places a caselist, l, and associated
                      statement sequence, s, into case statement, n.
                      n is returned.
*)

PROCEDURE putCaseStatement (n: node; l: node; s: node) : node ;
BEGIN
   assert (isCase (n)) ;
   assert (isCaseList (l)) ;
   IncludeIndiceIntoIndex (n^.caseF.caseLabelList, makeCaseLabelList (l, s)) ;
   RETURN n
END putCaseStatement ;


(*
   makeCaseLabelList - creates and returns a caselabellist node.
*)

PROCEDURE makeCaseLabelList (l, s: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (caselabellist) ;
   n^.caselabellistF.caseList := l ;
   n^.caselabellistF.statements := s ;
   RETURN n
END makeCaseLabelList ;


(*
   isCaseLabelList - returns TRUE if, n, is a caselabellist.
*)

PROCEDURE isCaseLabelList (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = caselabellist
END isCaseLabelList ;


(*
   makeCaseList - creates and returns a case statement node.
*)

PROCEDURE makeCaseList () : node ;
VAR
   n: node ;
BEGIN
   n := newNode (caselist) ;
   n^.caselistF.rangePairs := InitIndex (1) ;
   RETURN n
END makeCaseList ;


(*
   isCaseList - returns TRUE if, n, is a case list.
*)

PROCEDURE isCaseList (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = caselist
END isCaseList ;


(*
   putCaseRange - places the case range lo..hi into caselist, n.
*)

PROCEDURE putCaseRange (n: node; lo, hi: node) : node ;
BEGIN
   assert (isCaseList (n)) ;
   IncludeIndiceIntoIndex (n^.caselistF.rangePairs, makeRange (lo, hi)) ;
   RETURN n
END putCaseRange ;


(*
   makeRange - creates and returns a case range.
*)

PROCEDURE makeRange (lo, hi: node) : node ;
VAR
   n: node ;
BEGIN
   n := newNode (range) ;
   n^.rangeF.lo := lo ;
   n^.rangeF.hi := hi ;
   RETURN n
END makeRange ;


(*
   isRange - returns TRUE if node, n, is a range.
*)

PROCEDURE isRange (n: node) : BOOLEAN ;
BEGIN
   assert (n # NIL) ;
   RETURN n^.kind = range
END isRange ;


(*
   dupExplist -
*)

PROCEDURE dupExplist (n: node) : node ;
VAR
   m: node ;
   i: CARDINAL ;
BEGIN
   assert (isExpList (n)) ;
   m := makeExpList () ;
   i := LowIndice (n^.explistF.exp) ;
   WHILE i <= HighIndice (n^.explistF.exp) DO
      putExpList (m, dupExpr (GetIndice (n^.explistF.exp, i))) ;
      INC (i)
   END ;
   RETURN m
END dupExplist ;


(*
   dupArrayref -
*)

PROCEDURE dupArrayref (n: node) : node ;
BEGIN
   assert (isArrayRef (n)) ;
   RETURN makeArrayRef (dupExpr (n^.arrayrefF.array), dupExpr (n^.arrayrefF.index))
END dupArrayref ;


(*
   dupPointerref -
*)

PROCEDURE dupPointerref (n: node) : node ;
BEGIN
   assert (isPointerRef (n)) ;
   RETURN makePointerRef (dupExpr (n^.pointerrefF.ptr), dupExpr (n^.pointerrefF.field))
END dupPointerref ;


(*
   dupComponentref -
*)

PROCEDURE dupComponentref (n: node) : node ;
BEGIN
   assert (isComponentRef (n)) ;
   RETURN doMakeComponentRef (dupExpr (n^.componentrefF.rec), dupExpr (n^.componentrefF.field))
END dupComponentref ;


(*
   dupBinary -
*)

PROCEDURE dupBinary (n: node) : node ;
BEGIN
   (* assert (isBinary (n)) ; *)
   RETURN makeBinary (n^.kind,
                      dupExpr (n^.binaryF.left), dupExpr (n^.binaryF.right),
                      n^.binaryF.resultType)
END dupBinary ;


(*
   dupUnary -
*)

PROCEDURE dupUnary (n: node) : node ;
BEGIN
   (* assert (isUnary (n)) ; *)
   RETURN makeUnary (n^.kind, dupExpr (n^.unaryF.arg), n^.unaryF.resultType)
END dupUnary ;


(*
   dupFunccall -
*)

PROCEDURE dupFunccall (n: node) : node ;
VAR
   m: node ;
BEGIN
   assert (isFuncCall (n)) ;
   m := makeFuncCall (dupExpr (n^.funccallF.function), dupExpr (n^.funccallF.args)) ;
   m^.funccallF.type := n^.funccallF.type ;
   RETURN m
END dupFunccall ;


(*
   dupSetValue -
*)

PROCEDURE dupSetValue (n: node) : node ;
VAR
   m: node ;
   i: CARDINAL ;
BEGIN
   m := newNode (setvalue) ;
   m^.setvalueF.type := n^.setvalueF.type ;
   i := LowIndice (n^.setvalueF.values) ;
   WHILE i <= HighIndice (n^.setvalueF.values) DO
      m := putSetValue (m, dupExpr (GetIndice (n^.setvalueF.values, i))) ;
      INC (i)
   END ;
   RETURN m
END dupSetValue ;


(*
   dupExpr - duplicate the expression nodes, it does not duplicate
             variables, literals, constants but only the expression
             operators (including function calls and parameter lists).
*)

PROCEDURE dupExpr (n: node) : node ;
BEGIN
   IF n = NIL
   THEN
      RETURN NIL
   ELSE
      RETURN doDupExpr (n)
   END
END dupExpr ;


(*
   doDupExpr -
*)

PROCEDURE doDupExpr (n: node) : node ;
BEGIN
   assert (n # NIL) ;
   CASE n^.kind OF

   explist         : RETURN dupExplist (n) |
   exit,
   return,
   stmtseq,
   comment         : HALT |  (* should not be duplicating code.  *)
   length          : HALT |  (* length should have been converted into unary.  *)
   (* base constants.  *)
   nil,
   true,
   false,
   (* system types.  *)
   address,
   loc,
   byte,
   word,
   csizet,
   cssizet,
   (* base types.  *)
   boolean,
   proc,
   char,
   integer,
   cardinal,
   longcard,
   shortcard,
   longint,
   shortint,
   real,
   longreal,
   shortreal,
   bitset,
   ztype,
   rtype,
   complex,
   longcomplex,
   shortcomplex     :  RETURN n |
   (* language features and compound type attributes.  *)
   type,
   record,
   varient,
   var,
   enumeration,
   subrange,
   subscript,
   array,
   string,
   const,
   literal,
   varparam,
   param,
   varargs,
   optarg,
   pointer,
   recordfield,
   varientfield,
   enumerationfield,
   set,
   proctype        :  RETURN n |
   (* blocks.  *)
   procedure,
   def,
   imp,
   module          :  RETURN n |
   (* statements.  *)
   loop,
   while,
   for,
   repeat,
   case,
   caselabellist,
   caselist,
   range,
   if,
   elsif,
   assignment      :  RETURN n |
   (* expressions.  *)
   arrayref        :  RETURN dupArrayref (n) |
   pointerref      :  RETURN dupPointerref (n) |
   componentref    :  RETURN dupComponentref (n) |
   cmplx,
   and,
   or,
   equal,
   notequal,
   less,
   greater,
   greequal,
   lessequal,
   cast,
   val,
   plus,
   sub,
   div,
   mod,
   mult,
   divide,
   in              :  RETURN dupBinary (n) |
   re,
   im,
   constexp,
   deref,
   abs,
   chr,
   cap,
   high,
   float,
   trunc,
   ord,
   not,
   neg,
   adr,
   size,
   tsize,
   min,
   max             :  RETURN dupUnary (n) |
   identlist       :  RETURN n |
   vardecl         :  RETURN n |
   funccall        :  RETURN dupFunccall (n) |
   setvalue        :  RETURN dupSetValue (n)

   END
END doDupExpr ;


(*
   setNoReturn - sets noreturn field inside procedure.
*)

PROCEDURE setNoReturn (n: node; value: BOOLEAN) ;
BEGIN
   assert (n#NIL) ;
   assert (isProcedure (n)) ;
   IF n^.procedureF.noreturnused AND (n^.procedureF.noreturn # value)
   THEN
      metaError1 ('{%1DMad} definition module and implementation module have different <* noreturn *> attributes', n) ;
   END ;
   n^.procedureF.noreturn := value ;
   n^.procedureF.noreturnused := TRUE
END setNoReturn ;


(*
   makeSystem -
*)

PROCEDURE makeSystem ;
BEGIN
   systemN := lookupDef (makeKey ('SYSTEM')) ;

   addressN := makeBase (address) ;
   locN := makeBase (loc) ;
   byteN := makeBase (byte) ;
   wordN := makeBase (word) ;
   csizetN := makeBase (csizet) ;
   cssizetN := makeBase (cssizet) ;

   adrN := makeBase (adr) ;
   tsizeN := makeBase (tsize) ;
   throwN := makeBase (throw) ;

   enterScope (systemN) ;
   addressN := addToScope (addressN) ;
   locN := addToScope (locN) ;
   byteN := addToScope (byteN) ;
   wordN := addToScope (wordN) ;
   csizetN := addToScope (csizetN) ;
   cssizetN := addToScope (cssizetN) ;
   adrN := addToScope (adrN) ;
   tsizeN := addToScope (tsizeN) ;
   throwN := addToScope (throwN) ;

   assert (sizeN#NIL) ;  (* assumed to be built already.  *)
   sizeN := addToScope (sizeN) ;  (* also export size from system.  *)
   leaveScope ;

   addDone (addressN) ;
   addDone (locN) ;
   addDone (byteN) ;
   addDone (wordN) ;
   addDone (csizetN) ;
   addDone (cssizetN)
END makeSystem ;


(*
   makeM2rts -
*)

PROCEDURE makeM2rts ;
BEGIN
   m2rtsN := lookupDef (makeKey ('M2RTS'))
END makeM2rts ;


(*
   makeBitnum -
*)

PROCEDURE makeBitnum () : node ;
VAR
   b: node ;
BEGIN
   b := newNode (subrange) ;
   b^.subrangeF.type := NIL ;
   b^.subrangeF.scope := NIL ;
   b^.subrangeF.low := lookupConst (b, makeKey ('0')) ;
   b^.subrangeF.high := lookupConst (b, makeKey ('31')) ;
   RETURN b
END makeBitnum ;


(*
   makeBaseSymbols -
*)

PROCEDURE makeBaseSymbols ;
BEGIN
   baseSymbols := initTree () ;

   booleanN := makeBase (boolean) ;
   charN := makeBase (char) ;
   procN := makeBase (proc) ;
   cardinalN := makeBase (cardinal) ;
   longcardN := makeBase (longcard) ;
   shortcardN := makeBase (shortcard) ;
   integerN := makeBase (integer) ;
   longintN := makeBase (longint) ;
   shortintN := makeBase (shortint) ;
   bitsetN := makeBase (bitset) ;
   bitnumN := makeBitnum () ;
   ztypeN := makeBase (ztype) ;
   rtypeN := makeBase (rtype) ;
   complexN := makeBase (complex) ;
   longcomplexN := makeBase (longcomplex) ;
   shortcomplexN := makeBase (shortcomplex) ;
   realN := makeBase (real) ;
   longrealN := makeBase (longreal) ;
   shortrealN := makeBase (shortreal) ;

   nilN := makeBase (nil) ;
   trueN := makeBase (true) ;
   falseN := makeBase (false) ;

   sizeN := makeBase (size) ;
   minN := makeBase (min) ;
   maxN := makeBase (max) ;
   floatN := makeBase (float) ;
   truncN := makeBase (trunc) ;
   ordN := makeBase (ord) ;
   valN := makeBase (val) ;
   chrN := makeBase (chr) ;
   capN := makeBase (cap) ;
   absN := makeBase (abs) ;
   newN := makeBase (new) ;
   disposeN := makeBase (dispose) ;
   lengthN := makeBase (length) ;
   incN := makeBase (inc) ;
   decN := makeBase (dec) ;
   inclN := makeBase (incl) ;
   exclN := makeBase (excl) ;
   highN := makeBase (high) ;
   imN := makeBase (im) ;
   reN := makeBase (re) ;
   cmplxN := makeBase (cmplx) ;

   putSymKey (baseSymbols, makeKey ('BOOLEAN'), booleanN) ;
   putSymKey (baseSymbols, makeKey ('PROC'), procN) ;
   putSymKey (baseSymbols, makeKey ('CHAR'), charN) ;
   putSymKey (baseSymbols, makeKey ('CARDINAL'), cardinalN) ;
   putSymKey (baseSymbols, makeKey ('SHORTCARD'), shortcardN) ;
   putSymKey (baseSymbols, makeKey ('LONGCARD'), longcardN) ;
   putSymKey (baseSymbols, makeKey ('INTEGER'), integerN) ;
   putSymKey (baseSymbols, makeKey ('LONGINT'), longintN) ;
   putSymKey (baseSymbols, makeKey ('SHORTINT'), shortintN) ;
   putSymKey (baseSymbols, makeKey ('BITSET'), bitsetN) ;
   putSymKey (baseSymbols, makeKey ('REAL'), realN) ;
   putSymKey (baseSymbols, makeKey ('SHORTREAL'), shortrealN) ;
   putSymKey (baseSymbols, makeKey ('LONGREAL'), longrealN) ;
   putSymKey (baseSymbols, makeKey ('COMPLEX'), complexN) ;
   putSymKey (baseSymbols, makeKey ('LONGCOMPLEX'), longcomplexN) ;
   putSymKey (baseSymbols, makeKey ('SHORTCOMPLEX'), shortcomplexN) ;

   putSymKey (baseSymbols, makeKey ('NIL'), nilN) ;
   putSymKey (baseSymbols, makeKey ('TRUE'), trueN) ;
   putSymKey (baseSymbols, makeKey ('FALSE'), falseN) ;
   putSymKey (baseSymbols, makeKey ('SIZE'), sizeN) ;
   putSymKey (baseSymbols, makeKey ('MIN'), minN) ;
   putSymKey (baseSymbols, makeKey ('MAX'), maxN) ;
   putSymKey (baseSymbols, makeKey ('FLOAT'), floatN) ;
   putSymKey (baseSymbols, makeKey ('TRUNC'), truncN) ;
   putSymKey (baseSymbols, makeKey ('ORD'), ordN) ;
   putSymKey (baseSymbols, makeKey ('VAL'), valN) ;
   putSymKey (baseSymbols, makeKey ('CHR'), chrN) ;
   putSymKey (baseSymbols, makeKey ('CAP'), capN) ;
   putSymKey (baseSymbols, makeKey ('ABS'), absN) ;
   putSymKey (baseSymbols, makeKey ('NEW'), newN) ;
   putSymKey (baseSymbols, makeKey ('DISPOSE'), disposeN) ;
   putSymKey (baseSymbols, makeKey ('LENGTH'), lengthN) ;
   putSymKey (baseSymbols, makeKey ('INC'), incN) ;
   putSymKey (baseSymbols, makeKey ('DEC'), decN) ;
   putSymKey (baseSymbols, makeKey ('INCL'), inclN) ;
   putSymKey (baseSymbols, makeKey ('EXCL'), exclN) ;
   putSymKey (baseSymbols, makeKey ('HIGH'), highN) ;
   putSymKey (baseSymbols, makeKey ('CMPLX'), cmplxN) ;
   putSymKey (baseSymbols, makeKey ('RE'), reN) ;
   putSymKey (baseSymbols, makeKey ('IM'), imN) ;

   addDone (booleanN) ;
   addDone (charN) ;
   addDone (cardinalN) ;
   addDone (longcardN) ;
   addDone (shortcardN) ;
   addDone (integerN) ;
   addDone (longintN) ;
   addDone (shortintN) ;
   addDone (bitsetN) ;
   addDone (bitnumN) ;
   addDone (ztypeN) ;
   addDone (rtypeN) ;
   addDone (realN) ;
   addDone (longrealN) ;
   addDone (shortrealN) ;
   addDone (complexN) ;
   addDone (longcomplexN) ;
   addDone (shortcomplexN) ;
   addDone (procN) ;
   addDone (nilN) ;
   addDone (trueN) ;
   addDone (falseN)

END makeBaseSymbols ;


(*
   makeBuiltins -
*)

PROCEDURE makeBuiltins ;
BEGIN
   bitsperunitN := makeLiteralInt (makeKey ('8')) ;
   bitsperwordN := makeLiteralInt (makeKey ('32')) ;
   bitspercharN := makeLiteralInt (makeKey ('8')) ;
   unitsperwordN := makeLiteralInt (makeKey ('4')) ;

   addDone (bitsperunitN) ;
   addDone (bitsperwordN) ;
   addDone (bitspercharN) ;
   addDone (unitsperwordN)
END makeBuiltins ;


(*
   init -
*)

PROCEDURE init ;
BEGIN
   lang := ansiC ;
   outputFile := StdOut ;
   doP := initPretty (write, writeln) ;
   todoQ := alists.initList () ;
   partialQ := alists.initList () ;
   doneQ := alists.initList () ;
   modUniverse := initTree () ;
   defUniverse := initTree () ;
   modUniverseI := InitIndex (1) ;
   defUniverseI := InitIndex (1) ;
   scopeStack := InitIndex (1) ;
   makeBaseSymbols ;
   makeSystem ;
   makeBuiltins ;
   makeM2rts ;
   outputState := punct ;
   tempCount := 0 ;
   mustVisitScope := FALSE
END init ;


BEGIN
   init
END decl.