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

Copyright (C) 2015-2026 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 ;
   debugOpaque     = FALSE ;

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, cofft,
            cardinal64,
            (* 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, opaquecast) ;

    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,
                         cofft,
                         cardinal64      : |
                         (* 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 |
                         opaquecast      :  opaquecastF      : opaquecastT

                         END ;
                         at: where ;
                      END ;

       opaqueCastState = RECORD
                            opaque,
                            voidStar: BOOLEAN ;
                         END ;

       opaquecastT = RECORD
                        (* Describes the cast of the opaque.  *)
                        exp        : node ;
                        opaqueState: opaqueCastState ;
                     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 ;
                      opaqueState    : opaqueCastState ;
                   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 ;
                  isOpaque,
		  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 ;
                 opaqueState   :  opaqueCastState ;
              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 ;
                   opaqueState:  opaqueCastState ;
                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 ;
                      opaqueState:  opaqueCastState ;
                   END ;

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

       varargsT = RECORD
                     scope    :  node ;
                  END ;

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

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

       recordfieldT = RECORD
                         name       :  Name ;
			 type       :  node ;
			 tag        :  BOOLEAN ;
			 parent     :  node ;
			 varient    :  node ;
			 scope      :  node ;
			 cname      :  cnameT ;
                         opaqueState:  opaqueCastState ;
                      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 ;
                          opaqueState:  opaqueCastState ;
                       END ;

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

       arrayrefT = RECORD
                      array      :  node ;
                      index      :  node ;
                      resultType :  node ;
                      opaqueState:  opaqueCastState ;
                   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 ;
                       opaqueState    :  opaqueCastState ;
                    END ;

       proctypeT = RECORD
                      parameters :  Index ;
                      returnopt,
                      vararg     :  BOOLEAN ;
                      optarg     :  node ;
		      scope      :  node ;
                      returnType :  node ;
                      opaqueState:  opaqueCastState ;
                   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 ;
                 unqualified,
		 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 ;

       group = POINTER TO RECORD
                             todoQ,
                             partialQ,
                             doneQ   : alist ;
                             next    : group ;
                          END ;


VAR
   freeGroup,
   globalGroup   : group ;    (* The global group of all alists.  *)
   outputFile    : File ;
   lang          : language ;
   charStarN,
   constCharStarN,
   bitsperunitN,
   bitsperwordN,
   bitspercharN,
   unitsperwordN,
   mainModule,
   currentModule,
   defModule,
   systemN,
   addressN,
   locN,
   byteN,
   wordN,
   csizetN,
   cssizetN,
   cofftN,
   cardinal64N,
   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 ;
   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 ;


(*
   newGroup -
*)

PROCEDURE newGroup (VAR g: group) ;
BEGIN
   IF freeGroup = NIL
   THEN
      NEW (g)
   ELSE
      g := freeGroup ;
      freeGroup := freeGroup^.next
   END
END newGroup ;


(*
   initGroup - returns a group which with all lists initialized.
*)

PROCEDURE initGroup () : group ;
VAR
   g: group ;
BEGIN
   newGroup (g) ;
   WITH g^ DO
      todoQ := alists.initList () ;
      partialQ := alists.initList () ;
      doneQ := alists.initList () ;
      next := NIL
   END ;
   RETURN g
END initGroup ;


(*
   killGroup - deallocate the group and place the group record into the freeGroup list.
*)

PROCEDURE killGroup (VAR g: group) ;
BEGIN
   alists.killList (g^.todoQ) ;
   alists.killList (g^.partialQ) ;
   alists.killList (g^.doneQ) ;
   g^.next := freeGroup ;
   freeGroup := g ;
END killGroup ;


(*
   dupGroup - If g is not NIL then destroy g.
              Return a duplicate of GlobalGroup (not g).
*)

PROCEDURE dupGroup (g: group) : group ;
BEGIN
   IF g # NIL
   THEN
      (* Kill old group.  *)
      killGroup (g)
   END ;
   newGroup (g) ;
   WITH g^ DO
      (* Copy all lists.  *)
      todoQ := alists.duplicateList (globalGroup^.todoQ) ;
      partialQ := alists.duplicateList (globalGroup^.partialQ) ;
      doneQ := alists.duplicateList (globalGroup^.doneQ) ;
      next := NIL
   END ;
   RETURN g
END dupGroup ;


(*
   equalGroup - return TRUE if group left = right.
*)

PROCEDURE equalGroup (left, right: group) : BOOLEAN ;
BEGIN
   RETURN ((left = right) OR
           (alists.equalList (left^.todoQ, right^.todoQ) AND
            alists.equalList (left^.partialQ, right^.partialQ) AND
            alists.equalList (left^.doneQ, right^.doneQ)))
END equalGroup ;


(*
   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 ;


(*
   checkGccType - check to see if node n is gcc tree or location_t
                  and record its use in keyc.
*)

PROCEDURE checkGccType (n: node) ;
BEGIN
   IF getGccConfigSystem () AND (getScope (n) # NIL) AND
      (getSymName (getScope (n)) = makeKey ('gcctypes'))
   THEN
      IF getSymName (n) = makeKey ('location_t')
      THEN
         keyc.useGccLocation
      ELSIF getSymName (n) = makeKey ('tree')
      THEN
         keyc.useGccTree
      END
   END
END checkGccType ;


(*
   checkCDataTypes - check to see if node n is CharStar or ConstCharStar
                  and if necessary assign n to the global variable.
*)

PROCEDURE checkCDataTypes (n: node) ;
BEGIN
   IF (getScope (n) # NIL) AND (getSymName (getScope (n)) = makeKey ('CDataTypes'))
   THEN
      IF getSymName (n) = makeKey ('CharStar')
      THEN
         charStarN := n
      ELSIF getSymName (n) = makeKey ('ConstCharStar')
      THEN
         constCharStarN := n
      END
   END
END checkCDataTypes ;


(*
   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) ;
   checkGccType (n) ;
   checkCDataTypes (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 ;


(*
   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.unqualified := 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 ;


(*
   putDefUnqualified - the definition module uses unqualified.
*)

PROCEDURE putDefUnqualified (n: node) ;
BEGIN
   assert (isDef (n)) ;
   (* Currently (and this is a temporary development restriction to
      reduce any search space for bugs) the only module which can be
      export unqualified is gcctypes.  *)
   IF n^.defF.name = makeKey ('gcctypes')
   THEN
      n^.defF.unqualified := TRUE
   END
END putDefUnqualified ;


(*
   isDefUnqualified - returns TRUE if the definition module uses unqualified.
*)

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


(*
   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.isOpaque := FALSE ;
      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.isOpaque := FALSE ;
         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 ;
   initNodeOpaqueState (var) ;
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 ;
   initNodeOpaqueState (proc)
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 ;
   initNodeOpaqueState (d) ;
   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 ;
   initNodeOpaqueState (proc)
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 ;
   initNodeOpaqueState (d) ;
   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 ;
   initNodeOpaqueState (d) ;
   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 ;
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)
      ELSE
         assert (isModule (currentModule)) ;
         RETURN getNextFixup (moduleF.constFixup)
      END
   END
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 := getType (c) ;
      initPair (f^.funccallF.funccallComment) ;
      initNodeOpaqueState (f)
   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 ;


(*
   putTypeOpaque - marks type, des, as being an opaque type.
                   TYPE des ;
*)

PROCEDURE putTypeOpaque (des: node) ;
VAR
   s: node ;
BEGIN
   assert (des#NIL) ;
   assert (isType (des)) ;
   des^.typeF.isOpaque := TRUE
END putTypeOpaque ;


(*
   isTypeOpaque - returns TRUE if type, n, is an opaque type.
*)

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


(*
   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') |
      cofft           :  RETURN makeKey ('COFF_T') |
      cardinal64      :  RETURN makeKey ('CARDINAL64') |

      (* 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 ;


(*
   getStringChar - if the string is delimited by single
                   or double quotes then strip both
                   quotes from the string.
*)

PROCEDURE getStringChar (n: node) : String ;
VAR
   s: String ;
BEGIN
   s := getString (n) ;
   IF (DynamicStrings.char (s, 0) = "'") AND (DynamicStrings.char (s, -1) = "'")
   THEN
      s := DynamicStrings.Slice (s, 1, -1)
   ELSIF (DynamicStrings.char (s, 0) = '"') AND (DynamicStrings.char (s, -1) = '"')
   THEN
      s := DynamicStrings.Slice (s, 1, -1)
   END ;
   RETURN s
END getStringChar ;


(*
   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 getStringChar (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 ;


(*
   addQuotes - adds delimiter quote char to string.
*)

PROCEDURE addQuotes (s: String; quote: CHAR) : String ;
VAR
   qs: String ;
BEGIN
   s := DynamicStrings.ConCatChar (s, quote) ;
   qs := DynamicStrings.InitStringChar (quote) ;
   qs := DynamicStrings.ConCat (qs, DynamicStrings.Mark (s)) ;
   RETURN qs
END addQuotes ;


(*
   foldBinary - attempt to fold binary + for string constants.
*)

PROCEDURE foldBinary (k: nodeT; l, r: node; res: node) : node ;
VAR
   qc: CHAR ;
   n : node ;
   ls,
   rs: String ;
BEGIN
   n := NIL ;
   IF (k = plus) AND isLeafString (l) AND isLeafString (r)
   THEN
      ls := getStringContents (l) ;
      rs := getStringContents (r) ;
      qc := "'" ;
      (* Add unquoted contents.  *)
      ls := DynamicStrings.Add (ls, rs) ;
      (* Add quote.  *)
      ls := addQuotes (ls, qc) ;
      (* Build new string.  *)
      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) ;
   initNodeOpaqueState (n) ;
   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) ;
      initNodeOpaqueState (rec) ;
      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) ;
   initNodeOpaqueState (n) ;
   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,
      cofft,
      cardinal64,
      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,
   cofft,
   cardinal64,
   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 |
      cofft           :  RETURN n |
      cardinal64      :  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 ;
VAR
   result: node ;
BEGIN
   assert (isFuncCall (n)) ;
   result := doSetExprType (n^.funccallF.type, getType (n^.funccallF.function)) ;
   initNodeOpaqueState (n) ;  (* Update now that the return type is known.  *)
   RETURN result
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 |
      cofft           :  RETURN n |
      cardinal64      :  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) AND (NOT isCDataType (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,
      cofft,
      cardinal64      : 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) OR (isDefUnqualified (getScope (n)))
   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 () OR (isDefUnqualified (getScope (n)))
   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) OR (isDefUnqualified (getScope (n)))
   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 () OR (isDefUnqualified (getScope (n)))
   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 (globalGroup^.doneQ, n)
   THEN
      print (doP, "#   define ") ;
      doFQNameC (doP, n) ;
      setNeedSpace (doP) ;
      doExprC (doP, n^.constF.value) ;
      print (doP, '\n') ;
      alists.includeItemIntoList (globalGroup^.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, '(') ;
      left := doExprCup (p, left, unpackProc, FALSE) ;
      outText (p, ')')
   ELSE
      left := doExprCup (p, left, unpackProc, FALSE)
   END ;
   IF l
   THEN
      setNeedSpace (p)
   END ;
   outText (p, op) ;
   IF r
   THEN
      setNeedSpace (p)
   END ;
   IF needsParen (right)
   THEN
      outText (p, '(') ;
      right := doExprCup (p, right, unpackProc, FALSE) ;
      outText (p, ')')
   ELSE
      right := doExprCup (p, right, unpackProc, FALSE)
   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) : node ;
BEGIN
   outText (p, '(*') ;
   expr := castOpaque (p, expr, FALSE) ;
   outText (p, ')') ;
   RETURN expr
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
   flushOpaque (p, l, FALSE) ;
   outText (p, '.') ;
   doExprC (p, r)
END doComponentRefC ;


(*
   doPointerRefC -
*)

PROCEDURE doPointerRefC (p: pretty; l, r: node) ;
BEGIN
   flushOpaque (p, l, FALSE) ;
   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 - perform an array reference.  If constCast
                then an unbounded array access will be const_cast
                (the constCast should be TRUE if an assignment to
                the array is required).
*)

PROCEDURE doArrayRef (p: pretty; n: node; constCast: BOOLEAN) ;
VAR
   type,
   v   : node ;
   i, c: CARDINAL ;
BEGIN
   assert (n # NIL) ;
   assert (isArrayRef (n)) ;
   type := skipType (getType (n^.arrayrefF.array)) ;
   IF isUnbounded (type)
   THEN
      v := n^.arrayrefF.array ;
      IF constCast AND isVar (n^.arrayrefF.array) AND
         (v^.varF.isParameter OR v^.varF.isVarParameter)
      THEN
         outText (p, "const_cast<") ;
         doTypeNameC (p, getType (v)) ;
         outText (p, ">(") ;
         outTextN (p, getSymName (n^.arrayrefF.array)) ;
         outText (p, ")")
      ELSE
         outTextN (p, getSymName (n^.arrayrefF.array))
      END
   ELSE
      doExprC (p, n^.arrayrefF.array) ;
      assert (isArray (type)) ;
      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 (type)
      THEN
         assert (c = 1)
      ELSE
         doSubtractC (p, getMin (type^.arrayF.subr)) ;
	 IF i<c
         THEN
            assert (isArray (type)) ;
            outText (p, '].array[') ;
            type := skipType (getType (type))
         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           :  unaryF.arg := 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, FALSE) |
      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,
      cofft,
      cardinal64      :  doSystemC (p, n) |
      type            :  doTypeNameC (p, n) |
      pointer         :  doTypeNameC (p, n)

      END
   END
END doExprC ;


(*
   doExprCup -
*)

PROCEDURE doExprCup (p: pretty; n: node;
                     unpackProc, uncastConst: BOOLEAN) : node ;
VAR
   type: node ;
BEGIN
   IF uncastConst AND isArrayRef (n)
   THEN
      doArrayRef (p, n, TRUE)
   ELSE
      doExprC (p, n) ;
      IF unpackProc
      THEN
         type := skipType (getExprType (n)) ;
         IF (type # NIL) AND isAProcType (type)
         THEN
            outText (p, '.proc')
         END
      END
   END ;
   RETURN n
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 ;


(*
   outputEnumerationC -
*)

PROCEDURE outputEnumerationC (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 outputEnumerationC ;


(*
   isDeclType - return TRUE if the current module should declare type.
*)

PROCEDURE isDeclType (type: node) : BOOLEAN ;
VAR
   n,
   def : node ;
   name: Name ;
BEGIN
   IF isImp (currentModule)
   THEN
      name := getSymName (type) ;
      IF name # NulName
      THEN
         (* Lookup the matching .def module.  *)
         def := lookupDef (getSymName (currentModule)) ;
         IF def # NIL
         THEN
            (* Return TRUE if the symbol has not already been declared in the .def.  *)
            RETURN lookupExported (def, name) = NIL
         END
      END
   END ;
   RETURN TRUE
END isDeclType ;


(*
   doEnumerationC -
*)

PROCEDURE doEnumerationC (p: pretty; n: node) ;
BEGIN
   IF isDeclType (n)
   THEN
      outputEnumerationC (p, n)
   END
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) ;
      doOpaqueModifier (p, paramnode) ;
      (*
      IF nodeUsesOpaque (paramnode) AND (NOT getNodeOpaqueVoidStar (paramnode))
      THEN
         outText (p, '__opaque')
      END
      *)
   END
END doParamTypeEmit ;


(*
   doParamTypeNameModifier - Add an _ to an unbounded parameter which is non var.
*)

PROCEDURE doParamTypeNameModifier (p: pretty; ptype: node; varparam: BOOLEAN) ;
BEGIN
   IF (NOT varparam) AND isArray (ptype) AND isUnbounded (ptype)
   THEN
      outText (p, '_')
   END
END doParamTypeNameModifier ;


(*
   initOpaqueCastState - assign fields opaque and voidstar in opaquestate.
*)

PROCEDURE initOpaqueCastState (VAR opaquestate: opaqueCastState; opaque, voidstar: BOOLEAN) ;
BEGIN
   opaquestate.opaque := opaque ;
   opaquestate.voidStar := voidstar
END initOpaqueCastState ;


(*
   initNodeOpaqueCastState - assign opaque and currentvoidstar
*)

PROCEDURE initNodeOpaqueCastState (n: node; opaque, voidstar: BOOLEAN) ;
BEGIN
   CASE n^.kind OF

   opaquecast  :  initOpaqueCastState (n^.opaquecastF.opaqueState, opaque, voidstar) |
   funccall    :  initOpaqueCastState (n^.funccallF.opaqueState, opaque, voidstar) |
   var         :  initOpaqueCastState (n^.varF.opaqueState, opaque, voidstar) |
   array       :  initOpaqueCastState (n^.arrayF.opaqueState, opaque, voidstar) |
   varparam    :  initOpaqueCastState (n^.varparamF.opaqueState, opaque, voidstar) |
   param       :  initOpaqueCastState (n^.paramF.opaqueState, opaque, voidstar) |
   pointer     :  initOpaqueCastState (n^.pointerF.opaqueState, opaque, voidstar) |
   recordfield :  initOpaqueCastState (n^.recordfieldF.opaqueState, opaque, voidstar) |
   componentref:  initOpaqueCastState (n^.componentrefF.opaqueState, opaque, voidstar) |
   pointerref  :  initOpaqueCastState (n^.pointerrefF.opaqueState, opaque, voidstar) |
   arrayref    :  initOpaqueCastState (n^.arrayrefF.opaqueState, opaque, voidstar) |
   procedure   :  initOpaqueCastState (n^.procedureF.opaqueState, opaque, voidstar) |
   proctype    :  initOpaqueCastState (n^.proctypeF.opaqueState, opaque, voidstar)

   ELSE
      HALT
   END
END initNodeOpaqueCastState ;


(*
   setOpaqueCastState - set the voidStar field in opaquestate.
*)

PROCEDURE setOpaqueCastState (VAR opaquestate: opaqueCastState; voidstar: BOOLEAN) ;
BEGIN
   opaquestate.voidStar := voidstar
END setOpaqueCastState ;


(*
   setNodeOpaqueVoidStar - sets the voidStar field in node to voidstar.
*)

PROCEDURE setNodeOpaqueVoidStar (n: node; voidstar: BOOLEAN) ;
BEGIN
   assert (nodeUsesOpaque (n)) ;
   CASE n^.kind OF

   opaquecast  :  setOpaqueCastState (n^.opaquecastF.opaqueState, voidstar) |
   funccall    :  setOpaqueCastState (n^.funccallF.opaqueState, voidstar) |
   var         :  setOpaqueCastState (n^.varF.opaqueState, voidstar) |
   array       :  setOpaqueCastState (n^.arrayF.opaqueState, voidstar) |
   varparam    :  setOpaqueCastState (n^.varparamF.opaqueState, voidstar) |
   param       :  setOpaqueCastState (n^.paramF.opaqueState, voidstar) |
   pointer     :  setOpaqueCastState (n^.pointerF.opaqueState, voidstar) |
   recordfield :  setOpaqueCastState (n^.recordfieldF.opaqueState, voidstar) |
   componentref:  assert (NOT voidstar) ;
                  setOpaqueCastState (n^.componentrefF.opaqueState, voidstar) |
   pointerref  :  assert (NOT voidstar) ;
                  setOpaqueCastState (n^.pointerrefF.opaqueState, voidstar) |
   arrayref    :  setOpaqueCastState (n^.arrayrefF.opaqueState, voidstar) |
   procedure   :  setOpaqueCastState (n^.procedureF.opaqueState, voidstar) |
   proctype    :  setOpaqueCastState (n^.proctypeF.opaqueState, voidstar)

   ELSE
      HALT
   END
END setNodeOpaqueVoidStar ;


(*
   nodeUsesOpaque - return TRUE if node n uses an opaque type.
*)

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

   opaquecast  :  RETURN n^.opaquecastF.opaqueState.opaque |
   funccall    :  RETURN n^.funccallF.opaqueState.opaque |
   var         :  RETURN n^.varF.opaqueState.opaque |
   array       :  RETURN n^.arrayF.opaqueState.opaque |
   varparam    :  RETURN n^.varparamF.opaqueState.opaque |
   param       :  RETURN n^.paramF.opaqueState.opaque |
   pointer     :  RETURN n^.pointerF.opaqueState.opaque |
   recordfield :  RETURN n^.recordfieldF.opaqueState.opaque |
   componentref:  RETURN n^.componentrefF.opaqueState.opaque |
   pointerref  :  RETURN n^.pointerrefF.opaqueState.opaque |
   arrayref    :  RETURN n^.arrayrefF.opaqueState.opaque |
   procedure   :  RETURN n^.procedureF.opaqueState.opaque |
   proctype    :  RETURN n^.proctypeF.opaqueState.opaque |
   deref       :  RETURN nodeUsesOpaque (n^.unaryF.arg)

   ELSE
      RETURN FALSE
   END
END nodeUsesOpaque ;


(*
   getNodeOpaqueVoidStar - return TRUE if the opaque type used by node n is a void *.
*)

PROCEDURE getNodeOpaqueVoidStar (n: node) : BOOLEAN ;
BEGIN
   assert (nodeUsesOpaque (n)) ;
   CASE n^.kind OF

   opaquecast  :  RETURN n^.opaquecastF.opaqueState.voidStar |
   funccall    :  RETURN n^.funccallF.opaqueState.voidStar |
   var         :  RETURN n^.varF.opaqueState.voidStar |
   array       :  RETURN n^.arrayF.opaqueState.voidStar |
   varparam    :  RETURN n^.varparamF.opaqueState.voidStar |
   param       :  RETURN n^.paramF.opaqueState.voidStar |
   pointer     :  RETURN n^.pointerF.opaqueState.voidStar |
   recordfield :  RETURN n^.recordfieldF.opaqueState.voidStar |
   componentref:  RETURN n^.componentrefF.opaqueState.voidStar |
   pointerref  :  RETURN n^.pointerrefF.opaqueState.voidStar |
   arrayref    :  RETURN n^.arrayrefF.opaqueState.voidStar |
   procedure   :  RETURN n^.procedureF.opaqueState.voidStar |
   proctype    :  RETURN n^.proctypeF.opaqueState.voidStar |
   deref       :  RETURN FALSE

   ELSE
      HALT
   END
END getNodeOpaqueVoidStar ;


(*
   getOpaqueFlushNecessary - return TRUE if the value next differs from the opaque state.
*)

PROCEDURE getOpaqueFlushNecessary (state: opaqueCastState; next: BOOLEAN) : BOOLEAN ;
BEGIN
   RETURN state.opaque AND (state.voidStar # next)
END getOpaqueFlushNecessary ;


(*
   getNodeOpaqueFlushNecessary - return TRUE if the value of next requires a cast.
*)

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

   opaquecast  :  RETURN getOpaqueFlushNecessary (n^.opaquecastF.opaqueState, next) |
   funccall    :  RETURN getOpaqueFlushNecessary (n^.funccallF.opaqueState, next) |
   var         :  RETURN getOpaqueFlushNecessary (n^.varF.opaqueState, next) |
   array       :  RETURN getOpaqueFlushNecessary (n^.arrayF.opaqueState, next) |
   varparam    :  RETURN getOpaqueFlushNecessary (n^.varparamF.opaqueState, next) |
   param       :  RETURN getOpaqueFlushNecessary (n^.paramF.opaqueState, next) |
   pointer     :  RETURN getOpaqueFlushNecessary (n^.pointerF.opaqueState, next) |
   recordfield :  RETURN getOpaqueFlushNecessary (n^.recordfieldF.opaqueState, next) |
   componentref:  RETURN getOpaqueFlushNecessary (n^.componentrefF.opaqueState, next) |
   pointerref  :  RETURN getOpaqueFlushNecessary (n^.pointerrefF.opaqueState, next) |
   arrayref    :  RETURN getOpaqueFlushNecessary (n^.arrayrefF.opaqueState, next) |
   procedure   :  RETURN getOpaqueFlushNecessary (n^.procedureF.opaqueState, next) |
   proctype    :  RETURN getOpaqueFlushNecessary (n^.proctypeF.opaqueState, next)

   ELSE
      RETURN FALSE
   END
END getNodeOpaqueFlushNecessary ;


(*
   makeOpaqueCast - wrap node n with an opaquecast node and assign
                    voidstar into the new opaque state.
*)

PROCEDURE makeOpaqueCast (n: node; voidstar: BOOLEAN) : node ;
VAR
   o: node ;
BEGIN
   o := newNode (opaquecast) ;
   WITH o^.opaquecastF DO
      exp := n ;
      initOpaqueCastState (opaqueState, TRUE, voidstar)
   END ;
   RETURN o
END makeOpaqueCast ;


(*
   flushOpaque - perform a cast to voidstar (if necessary) and ignore the new
                 node which could be created.
*)

PROCEDURE flushOpaque (p: pretty; n: node; toVoidStar: BOOLEAN) ;
VAR
   o: node ;
BEGIN
   o := castOpaque (p, n, toVoidStar)
END flushOpaque ;


(*
   castOpaque - flushes the opaque type casts if necessary and changes the
                voidstar boolean value.   If necessary it creates a opaquecast
                and returns the new node otherwise return n.
*)

PROCEDURE castOpaque (p: pretty; n: node; toVoidStar: BOOLEAN) : node ;
VAR
   type: node ;
BEGIN
   IF getNodeOpaqueFlushNecessary (n, toVoidStar)
   THEN
      type := getType (n) ;
      IF toVoidStar
      THEN
         (* next is true cast to void * opaque type.  *)
         outText (p, 'static_cast<') ;
         doTypeNameC (p, type) ;
         noSpace (p) ;
         outText (p, '> (') ;
         doExprC (p, n) ;
         outText (p, ')') ;
         RETURN makeOpaqueCast (n, TRUE)
      ELSE
         (* next is false cast to __opaque opaque type.  *)
         outText (p, 'static_cast<') ;
         doTypeNameC (p, type) ;
         outText (p, '__opaque') ;
         noSpace (p) ;
         outText (p, '> (') ;
         doExprC (p, n) ;
         outText (p, ')') ;
         RETURN makeOpaqueCast (n, FALSE)
      END
   ELSE
      IF debugOpaque
      THEN
         doP := p ;
         dumpOpaqueState (n) ;
         IF nodeUsesOpaque (n)
         THEN
            outText (p, ' /* no difference seen */ ')
         ELSE
            outText (p, ' /* no opaque used */ ')
         END
      END ;
      doExprC (p, n)
   END ;
   RETURN n
END castOpaque ;


(*
   isTypeOpaqueDefImp - returns TRUE if type is an opaque type by checking
                        the def/imp pair of modules or fall back to the
                        definition module.
*)

PROCEDURE isTypeOpaqueDefImp (type: node) : BOOLEAN ;
VAR
   scope,
   def,
   opaque: node ;
BEGIN
   IF type = NIL
   THEN
      RETURN FALSE
   ELSIF isType (type)
   THEN
      scope := getScope (type) ;
      IF isImp (scope)
      THEN
         def := lookupDef (getSymName (scope)) ;
         IF def # NIL
         THEN
            (* Lookup the type name in the matching definition module.  *)
            opaque := lookupExported (def, getSymName (type)) ;
            RETURN (opaque # NIL) AND isType (opaque) AND isTypeOpaque (opaque)
         END
      ELSE
         (* Otherwise just check the definition module.  *)
         RETURN isTypeOpaque (type)
      END
   END ;
   RETURN FALSE
END isTypeOpaqueDefImp ;


(*
   isParamVoidStar - return TRUE if the procedure or proctype opaque type
                     parameter should be implemented as a (void * ).
*)

PROCEDURE isParamVoidStar (n: node) : BOOLEAN ;
VAR
   proc,
   type: node ;
BEGIN
   proc := getScope (n) ;
   assert (isProcedure (proc) OR isProcType (proc)) ;
   type := getType (n) ;
   RETURN isReturnVoidStar (proc, type)
END isParamVoidStar ;


(*
   isRefVoidStar - returns TRUE if the ref node uses an opaque type which
                   is represented as a (void * ).
*)

PROCEDURE isRefVoidStar (n: node) : BOOLEAN ;
VAR
   type: node ;
BEGIN
   type := getType (n) ;
   IF (NOT isType (type)) OR (NOT isTypeOpaque (type))
   THEN
      (* We should finish the procedure as the ref does not use an opaque.  *)
      RETURN TRUE
   ELSE
      (* We check whether the opaque type was declared in the implementation
         module.  If it is declared in the implementation module then we
         return FALSE.  *)
      RETURN NOT isDeclInImp (type)
   END
END isRefVoidStar ;


(*
   isReturnVoidStar - return TRUE if the procedure or proctype opaque type
                      return type should be implemented as a (void * ).
*)

PROCEDURE isReturnVoidStar (proc, type: node) : BOOLEAN ;
VAR
   def : node ;
BEGIN
   assert (isProcedure (proc) OR isProcType (proc)) ;
   IF isExported (proc)
   THEN
      RETURN TRUE
   ELSE
      (* Not exported therefore local, we check whether the opaque type
         was declared in the implementation module.  *)
      IF isImp (currentModule)
      THEN
         IF isType (type)
         THEN
            RETURN NOT isDeclInImp (type)
         ELSE
            RETURN FALSE
         END
      ELSE
         (* Always use void * in .def modules.  *)
         RETURN TRUE
      END
   END
END isReturnVoidStar ;


(*
   isVarVoidStar - return TRUE if the variable using an opaque type should
                   be implemented as a (void * ).
*)

PROCEDURE isVarVoidStar (n: node) : BOOLEAN ;
VAR
   type: node ;
BEGIN
   assert (isVar (n)) ;
   type := getType (n) ;
   IF (NOT isType (type)) OR (NOT isTypeOpaque (type))
   THEN
      (* We should finish the procedure as the variable does not use an opaque.  *)
      RETURN TRUE
   ELSIF isExported (n)
   THEN
      (* Exported variables using an opaque type will always be implemented
         with a (void * ).  *)
      RETURN TRUE
   ELSE
      (* Not exported therefore static to the module (local or global non exported
         variable), we check whether the opaque type was declared in the
         implementation module.  If it is declared in the implementation module
         then we return FALSE.  *)
      RETURN NOT isDeclInImp (type)
   END
END isVarVoidStar ;


(*
   initNodeOpaqueState - initialize the node opaque state.
*)

PROCEDURE initNodeOpaqueState (n: node) ;
VAR
   type: node ;
BEGIN
   CASE n^.kind OF

   opaquecast  :  |  (* This must be done when the cast direction is known.  *)
   funccall    :  assignNodeOpaqueCastState (n, getFunction (n)) |
   var         :  type := getType (n) ;
                  IF n^.varF.isParameter OR n^.varF.isVarParameter
                  THEN
                     (* If the variable is really a parameter then it uses
                        the state of the parameter.  *)
                     initNodeOpaqueCastState (n, isTypeOpaqueDefImp (type),
                                              isParamVoidStar (n))
                  ELSE
                     initNodeOpaqueCastState (n, isTypeOpaqueDefImp (type),
                                              isVarVoidStar (n))
                  END  |
   array       :  type := getType (n) ;
                  initNodeOpaqueCastState (n, isTypeOpaqueDefImp (type),
                                           isExported (n)) |
   varparam,
   param       :  assert (isProcedure (getScope (n)) OR isProcType (getScope (n))) ;
                  type := getType (n) ;
                  initNodeOpaqueCastState (n, isTypeOpaqueDefImp (type),
                                           isParamVoidStar (n)) |
   componentref,
   pointerref,
   pointer,
   recordfield,
   arrayref    :  type := getType (n) ;
                  (* In the future this should be revisited.  *)
                  initNodeOpaqueCastState (n, isTypeOpaqueDefImp (type),
                                           isRefVoidStar (n)) |
                          (* For the moment treat as never exported.  *)
   proctype,
   procedure   :  (* We only consider the return type for a procedure or proctype.
                     The parameters and local vars are handled separately (see
                     above).  *)
                  type := getType (n) ;
                  IF type = NIL
                  THEN
                     (* No return type, therefore no opaque type used.  *)
                     initNodeOpaqueCastState (n, FALSE, FALSE)
                  ELSE
                     (* Init state from the return type.  Is type an opaque type?
                        Is the opaque type declared in this module?  *)
                     initNodeOpaqueCastState (n, isTypeOpaqueDefImp (type),
                                              isReturnVoidStar (n, type))
                  END |

   ELSE
   END ;
   IF debugOpaque
   THEN
      dumpOpaqueState (n)
   END
END initNodeOpaqueState ;


(*
   assignNodeOpaqueCastState - copy the opaqueCastState from src into dest.
*)

PROCEDURE assignNodeOpaqueCastState (dest, src: node) ;
BEGIN
   IF nodeUsesOpaque (src)
   THEN
      initNodeOpaqueCastState (dest, TRUE, getNodeOpaqueVoidStar (src))
   ELSE
      initNodeOpaqueCastState (dest, FALSE, FALSE)
   END
END assignNodeOpaqueCastState ;


(*
   assignNodeOpaqueCastFalse - assign the voidstar field of dest to false.
                               It assigns the opaque field of dest to the value
                               of the src opaque field.
*)

PROCEDURE assignNodeOpaqueCastFalse (dest, src: node) ;
BEGIN
   IF nodeUsesOpaque (src)
   THEN
      initNodeOpaqueCastState (dest, TRUE, FALSE)
   ELSE
      initNodeOpaqueCastState (dest, FALSE, FALSE)
   END
END assignNodeOpaqueCastFalse ;


(*
   dumpOpaqueState -
*)

PROCEDURE dumpOpaqueState (n: node) ;
VAR
   o: node ;
BEGIN
   CASE n^.kind OF

   opaquecast,
   funccall,
   var,
   array,
   varparam,
   param,
   pointer,
   recordfield,
   componentref,
   arrayref,
   procedure,
   proctype    :  o := n

   ELSE
      o := NIL
   END ;
   IF o # NIL
   THEN
      outText (doP, "/* ") ;
      doNameC (doP, o) ;
      outText (doP, "  ") ;
      CASE o^.kind OF

      opaquecast  :  outText (doP, "opaquecast") |
      funccall    :  outText (doP, "funccall") |
      var         :  outText (doP, "var") |
      array       :  outText (doP, "array") |
      varparam    :  outText (doP, "varparam") |
      param       :  outText (doP, "param") |
      pointer     :  outText (doP, "pointer") |
      recordfield :  outText (doP, "recordfield") |
      componentref:  outText (doP, "componentref") |
      pointerref  :  outText (doP, "pointerref") |
      arrayref    :  outText (doP, "arrayref") |
      procedure   :  outText (doP, "procedure") |
      proctype    :  outText (doP, "proctype")

      ELSE
      END ;
      IF nodeUsesOpaque (o)
      THEN
         IF getNodeOpaqueVoidStar (o)
         THEN
            outText (doP, " uses (void *) opaque")
         ELSE
            outText (doP, " uses opaque__full")
         END ;
      END ;
      outText (doP, " */ \n")
   END
END dumpOpaqueState ;


(*
   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 ;
            doParamTypeNameModifier (p, ptype, FALSE) ;
            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 ;
            doParamTypeNameModifier (p, ptype, TRUE) ;
            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)) ;
   IF isDeclType (t) AND isDeclType (n)
   THEN
      outputPartial (t) ;
      doCompletePartialProcType (p, t, n)
   END
END doProcTypeC ;


(*
   isDeclInImp - returns TRUE if node type is declared as an opaque and
                 is declared fully in the current implementation module.
                 This should only be called if isType (type).  Its purpose
                 is specific to a type checking whether it is an opaque type
                 declared in the .def/.mod pair of the current imp module.
*)

PROCEDURE isDeclInImp (type: node) : BOOLEAN ;
VAR
   scope,
   def  : node ;
   name : Name ;
BEGIN
   assert (isType (type)) ;
   scope := getScope (type) ;
   IF isTypeOpaqueDefImp (type) AND isImp (currentModule)
   THEN
      name := getSymName (type) ;
      IF name # NulName
      THEN
         (* Lookup the matching .def module.  *)
         def := lookupDef (getSymName (currentModule)) ;
         IF (def # NIL) AND ((def = scope) OR (currentModule = scope))
         THEN
            (* Return TRUE if the symbol has already been declared in the .def.  *)
            RETURN lookupExported (def, name) # NIL
         END
      END
   END ;
   RETURN FALSE
END isDeclInImp ;


(*
   doTypeNameModifier - adds the __opaque modifier to the type n provided
                        it is an opaque type which is being declared in the
                        implementation module.
*)

PROCEDURE doTypeNameModifier (p: pretty; n: node) ;
BEGIN
   IF isTypeOpaqueDefImp (n) AND isImp (currentModule)
   THEN
      outText (p, '__opaque')
   END
END doTypeNameModifier ;


(*
   isGccType - return TRUE if n is tree or location_t.
*)

PROCEDURE isGccType (n: node) : BOOLEAN ;
BEGIN
   RETURN (getGccConfigSystem () AND
           ((getSymName (n) = makeKey ('location_t')) OR
            (getSymName (n) = makeKey ('tree'))))
END isGccType ;


(*
   doGccType - record whether we are going to declare tree or location_t
               so that the appropriate gcc header can be included instead.
*)

PROCEDURE doGccType (p: pretty; n: node) ;
BEGIN
   IF getGccConfigSystem ()
   THEN
      IF getSymName (n) = makeKey ('location_t')
      THEN
         outText (p, "/* Not going to declare ") ;
         doTypeNameC (p, n) ;
         outText (p, " as it is declared in the gcc header input.h.  */\n\n") ;
         keyc.useGccLocation
      ELSIF getSymName (n) = makeKey ('tree')
      THEN
         outText (p, "/* Not going to declare ") ;
         doTypeNameC (p, n) ;
         outText (p, " as it is declared in the gcc header tree.h.  */\n\n") ;
         keyc.useGccTree
      END
   END
END doGccType ;


(*
   isCDataType - return true if n is charStar or constCharStar.
*)

PROCEDURE isCDataType (n: node) : BOOLEAN ;
BEGIN
   RETURN (n # NIL) AND ((n = charStarN) OR (n = constCharStarN))
END isCDataType ;


(*
   isCDataTypes - return TRUE if n is CharStar or ConstCharStar.
*)

PROCEDURE isCDataTypes (n: node) : BOOLEAN ;
VAR
   scope: node ;
BEGIN
   scope := getScope (n) ;
   RETURN (scope # NIL) AND (getSymName (scope) = makeKey ('CDataTypes')) AND
            ((getSymName (n) = makeKey ('CharStar')) OR
             (getSymName (n) = makeKey ('ConstCharStar')))
END isCDataTypes ;


(*
   doCDataTypes - if we are going to declare CharStar or ConstCharStar
               then generate a comment instead.
*)

PROCEDURE doCDataTypes (p: pretty; n: node) ;
BEGIN
   IF isCDataTypes (n)
   THEN
      IF getSymName (n) = makeKey ('CharStar')
      THEN
         outText (p, "/* Not going to declare ") ;
         doTypeNameC (p, n) ;
         outText (p, " as it is a C type.  */\n\n") ;
         charStarN := n
      ELSIF getSymName (n) = makeKey ('ConstCharStar')
      THEN
         outText (p, "/* Not going to declare ") ;
         doTypeNameC (p, n) ;
         outText (p, " as it is a C type.  */\n\n") ;
         constCharStarN := n
      END
   END
END doCDataTypes ;


(*
   doCDataTypesC - generate the C representation of the CDataTypes data types.
*)

PROCEDURE doCDataTypesC (p: pretty; n: node) ;
BEGIN
   IF n = charStarN
   THEN
      outText (p, "char *") ;
      setNeedSpace (p)
   ELSIF n = constCharStarN
   THEN
      outText (p, "const char *") ;
      setNeedSpace (p)
   END
END doCDataTypesC ;


(*
   doTypeOrPointer - only declare type or pointer n providing that
                     the name is not location_t or tree and
                     the --gccConfigSystem option is enabled.
*)

PROCEDURE doTypeOrPointer (p: pretty; n: node) ;
VAR
   m: node ;
BEGIN
   IF isGccType (n)
   THEN
      doGccType (p, n)
   ELSIF isCDataTypes (n)
   THEN
      doCDataTypes (p, n)
   ELSE
      m := getType (n) ;
      outText (p, "typedef") ; setNeedSpace (p) ;
      doTypeC (p, m, m) ;
      IF isType (m)
      THEN
         setNeedSpace (p)
      END ;
      doTypeNameC (p, n) ;
      doTypeNameModifier (p, n) ;
      outText (p, ";\n\n")
   END
END doTypeOrPointer ;


(*
   doTypedef - generate a typedef for n provuiding it is not
*)

PROCEDURE doTypedef (p: pretty; n: node) ;
VAR
   m: node ;
BEGIN
   IF isGccType (n)
   THEN
      doGccType (p, n)
   ELSIF isCDataTypes (n)
   THEN
      doCDataTypes (p, n)
   ELSE
      m := getType (n) ;
      outText (p, "typedef") ; setNeedSpace (p) ;
      doTypeC (p, m, m) ;
      IF isType (m)
      THEN
         setNeedSpace (p)
      END ;
      doTypeNameC (p, n) ;
      doTypeNameModifier (p, n) ;
      outText (p, ";\n\n")
   END
END doTypedef ;


(*
   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
         doTypeOrPointer (doP, n)
      ELSIF isEnumeration (m)
      THEN
         IF isDeclType (n)
         THEN
            outText (doP, "typedef") ; setNeedSpace (doP) ;
            doTypeC (doP, m, m) ;
            setNeedSpace (doP) ;
            doTypeNameC (doP, n) ;
            outText (doP, ";\n\n")
         END
      ELSE
         doTypedef (doP, 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
            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) ;
BEGIN
   IF isDeclType (t) AND isDeclType (n)
   THEN
      outputCompletePartialProcType (p, t, n)
   END
END doCompletePartialProcType ;


(*
   outputCompletePartialProcType -
*)

PROCEDURE outputCompletePartialProcType (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) ;
   doOpaqueModifier (p, n) ;
   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 outputCompletePartialProcType ;


(*
   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,
   loc,
   byte,
   word,
   csizet,
   cssizet,
   cofft,
   cardinal64: 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 |
   cofft     :  outText (p, 'off_t') ; setNeedSpace (p) |
   cardinal64:  outText (p, 'uint64_t') ; setNeedSpace (p)

   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) ;
   IF isType (f^.recordfieldF.type) AND isDeclInImp (f^.recordfieldF.type)
   THEN
      outText (p, '__opaque')
   END ;
   setNeedSpace (p) ;
   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 isCDataTypes (n)
   THEN
      doCDataTypesC (p, n)
   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)
   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)
   ELSIF isCDataTypes (n)
   THEN
      doCDataTypesC (p, n)
   ELSE
      metaError1 ('expecting a type symbol rather than a {%1DMd} {%1DMa}', n) ;
      flushErrors ;
      errorAbort0 ('terminating compilation')
   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 n = charStarN
   THEN
      outText (p, "char *") ;
      setNeedSpace (p)
   ELSIF n = constCharStarN
   THEN
      outText (p, "const char *") ;
      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")
   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 ;


(*
   doOpaqueModifier - adds postfix __opaque providing n uses an opaque type which is
                      not represented by ( void * ).  n is a non type node which might
                      be using an opaque type.  For example a var or param node.
*)

PROCEDURE doOpaqueModifier (p: pretty; n: node) ;
BEGIN
   assert (NOT isType (n)) ;
   IF isImp (getCurrentModule ()) AND nodeUsesOpaque (n) AND (NOT getNodeOpaqueVoidStar (n))
   THEN
      outText (doP, '__opaque')
   END
END doOpaqueModifier ;


(*
   doDeclareVarC -
*)

PROCEDURE doDeclareVarC (n: node) ;
VAR
   type,
   s   : node ;
BEGIN
   s := NIL ;
   type := getType (n) ;
   doTypeC (doP, type, s) ;
   doOpaqueModifier (doP, n) ;
   setNeedSpace (doP) ;
   doFQDNameC (doP, n, FALSE) ;
   print (doP, ";\n")
END doDeclareVarC ;


(*
   doVarC - output a variable declaration.  Note that we do not generate
            a declaration if we are translating the implementation module
            and a variable is exported as the variable will be in the .h
            file to avoid all -Wodr issues.
*)

PROCEDURE doVarC (n: node) ;
BEGIN
   IF isDef (getMainModule ())
   THEN
      print (doP, "EXTERN") ; setNeedSpace (doP) ;
      doDeclareVarC (n)
   ELSIF (NOT isExported (n)) AND (NOT isLocal (n))
   THEN
      print (doP, "static") ; setNeedSpace (doP) ;
      doDeclareVarC (n)
   ELSIF getExtendedOpaque ()
   THEN
      (* --fixme-- need to revisit extended opaque.  *)
      IF isExternal (n)
      THEN
         (* different module declared this variable, therefore it is extern.  *)
         print (doP, "extern") ; setNeedSpace (doP)
      END ;
      doDeclareVarC (n)
   ELSIF isLocal (n)
   THEN
      doDeclareVarC (n)
   END
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
   s   : String ;
   i, h: CARDINAL ;
   p, q: node ;
BEGIN
   assert (isProcedure (n)) ;
   s := getFQstring (n) ;
   IF EqualArray (s, 'M2Quads_BuildAssignment')
   THEN
      localstop
   END ;
   s := KillString (s) ;
   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) ;
   (*
   IF NOT isExported (n)
   THEN
      doTypeNameModifier (doP, n^.procedureF.returnType)
   END ;
   *)
   doOpaqueModifier (doP, n) ;
   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 (globalGroup^.partialQ, n)) AND
      (NOT alists.isItemInList (globalGroup^.doneQ, n))
   THEN
      assert (NOT isVarient (n)) ;
      assert (NOT isVarientField (n)) ;
      assert (NOT isDef (n)) ;
      alists.includeItemIntoList (globalGroup^.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) ;
VAR
   type: node ;
BEGIN
   assert (isReturn (s)) ;
   doCommentC (p, s^.returnF.returnComment.body) ;
   outText (p, "return") ;
   IF (s^.returnF.scope#NIL) AND (s^.returnF.exp#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
         IF isProcedure (s^.returnF.scope) AND nodeUsesOpaque (s^.returnF.scope)
         THEN
            forceCastOpaque (p, s^.returnF.scope, s^.returnF.exp,
                             getNodeOpaqueVoidStar (s^.returnF.scope))
         ELSE
            doExprCastC (p, s^.returnF.exp, getType (s^.returnF.scope))
         END
      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, 'static_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 ;


(*
   forceCastOpaque -
*)

PROCEDURE forceCastOpaque (p: pretty; des, expr: node; toVoidStar: BOOLEAN) ;
BEGIN
   IF nodeUsesOpaque (expr)
   THEN
      flushOpaque (p, expr, getNodeOpaqueVoidStar (des))
   ELSE
      forceReintCastOpaque (p, des, expr, toVoidStar)
   END
END forceCastOpaque ;


(*
   forceReintCastOpaque -
*)

PROCEDURE forceReintCastOpaque (p: pretty; des, expr: node; toVoidStar: BOOLEAN) ;
VAR
   type: node ;
BEGIN
   type := getType (des) ;
   IF toVoidStar
   THEN
      (* next is true cast to void * opaque type.  *)
      outText (p, 'static_cast<') ;
      doTypeNameC (p, type) ;
      noSpace (p) ;
      outText (p, '> (') ;
      doExprC (p, expr) ;
      outText (p, ')')
   ELSE
      (* next is false cast to __opaque opaque type.  *)
      outText (p, 'static_cast<') ;
      doTypeNameC (p, type) ;
      outText (p, '__opaque') ;
      noSpace (p) ;
      outText (p, '> (') ;
      doExprC (p, expr) ;
      outText (p, ')') ;
   END
END forceReintCastOpaque ;


(*
   doUnConstCastUnbounded - if node n type is an unbounded array then
                            use const_cast to remove the const parameter
                            to allow the unbounded array to be modified.
*)

PROCEDURE doUnConstCastUnbounded (p: pretty; n: node) ;
VAR
   type, v: node ;
BEGIN
   IF isArrayRef (n)
   THEN
      IF isVar (n^.arrayrefF.array)
      THEN
         v := n^.arrayrefF.array ;
         IF (v^.varF.isParameter OR v^.varF.isVarParameter) AND
	    isUnbounded (getType (v))
         THEN
            type := getType (v) ;
            outText (p, " /* const_cast<") ;
            doTypeNameC (p, type) ;
            outText (p, "> is needed */ ") ;
         END
      END
   END
END doUnConstCastUnbounded ;


(*
   doAssignmentC -
*)

PROCEDURE doAssignmentC (p: pretty; s: node) ;
BEGIN
   assert (isAssignment (s)) ;
   doCommentC (p, s^.assignmentF.assignComment.body) ;
   IF debugOpaque
   THEN
      outText (p, " /* des: */ ") ;
      dumpOpaqueState (s^.assignmentF.des) ;
      outText (p, " /* expr: */ ") ;
      dumpOpaqueState (s^.assignmentF.expr)
   END ;
   s^.assignmentF.des := doExprCup (p, s^.assignmentF.des,
                                    requiresUnpackProc (s), TRUE) ;
   IF debugOpaque
   THEN
      outText (p, "\n /* after doExprCup des: */ ") ;
      dumpOpaqueState (s^.assignmentF.des) ;
      outText (p, "\n")
   END ;
   setNeedSpace (p) ;
   outText (p, "=") ;
   setNeedSpace (p) ;
   IF nodeUsesOpaque (s^.assignmentF.des)
   THEN
      forceCastOpaque (p, s^.assignmentF.des, s^.assignmentF.expr,
                       getNodeOpaqueVoidStar (s^.assignmentF.des))
   ELSE
      IF debugOpaque
      THEN
         outText (p, " /* no opaque des seen */ ")
      END ;
      doExprCastC (p, s^.assignmentF.expr, getType (s^.assignmentF.des))
   END ;
   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 ;


(*
   castDestType - emit the destination type ft
*)

PROCEDURE castDestType (p: pretty; formal, ft: node) ;
BEGIN
   doTypeNameC (p, ft) ;
   IF isVarParam (formal)
   THEN
      outText (p, '*')
   END
END castDestType ;


(*
   identifyPointer -
*)

PROCEDURE identifyPointer (type: node) : node ;
BEGIN
   IF isPointer (type)
   THEN
      IF skipType (getType (type)) = charN
      THEN
         RETURN charStarN
      ELSIF (skipType (getType (type)) = byteN) OR
            (skipType (getType (type)) = locN)
      THEN
         RETURN addressN
      END
   END ;
   RETURN type
END identifyPointer ;


(*
   castPointer - provides a six way cast between ADDRESS (ie void * ),
                 char * and const char *.
*)

PROCEDURE castPointer (p: pretty; actual, formal, at, ft: node) : CARDINAL ;
VAR
   sat, sft: node ;
   parenth : CARDINAL ;
BEGIN
   parenth := 0 ;
   IF at # ft
   THEN
      sat := identifyPointer (skipType (at)) ;
      sft := identifyPointer (skipType (ft)) ;
      IF sat = addressN
      THEN
         IF sft = charStarN
         THEN
            outText (p, 'reinterpret_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '>')
         ELSIF sft = constCharStarN
         THEN
            outText (p, 'const_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '> (static_cast <') ;
            doTypeNameC (p, charStarN) ;
            outText (p, '>') ;
            INC (parenth)
         ELSE
            outText (p, 'reinterpret_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '>')
         END
      ELSIF sat = charStarN
      THEN
         IF sft = addressN
         THEN
            outText (p, 'reinterpret_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '>')
         ELSIF sft = constCharStarN
         THEN
            outText (p, 'const_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '>')
         ELSE
            outText (p, 'reinterpret_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '>')
         END
      ELSIF sat = constCharStarN
      THEN
         IF sft = addressN
         THEN
            outText (p, 'static_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '> (const_cast <') ;
            doTypeNameC (p, charStarN) ;
            outText (p, '>') ;
            INC (parenth)
         ELSIF sft = charStarN
         THEN
            outText (p, 'const_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '>')
         ELSE
            outText (p, 'reinterpret_cast <') ;
            castDestType (p, formal, ft) ;
            outText (p, '>')
         END
      ELSE
         outText (p, 'reinterpret_cast <') ;
         castDestType (p, formal, ft) ;
         outText (p, '>')
      END ;
      setNeedSpace (p) ;
      outText (p, '(') ;
      INC (parenth)
   END ;
   RETURN parenth
END castPointer ;


(*
   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 isCDataType (skipType (ft))
         THEN
            (* Nothing to do.  *)
            RETURN 0
         ELSIF isString (actual) AND (skipType (ft) = addressN)
         THEN
            outText (p, "const_cast<void*> (static_cast<const void*> (") ;
	    RETURN 2
         ELSIF isPointer (skipType (ft)) OR (skipType (ft) = addressN) OR
               isCDataType (skipType (ft))
         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
               RETURN castPointer (p, actual, formal, at, ft)
            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 ;


(*
   doFuncVarParam - detect whether the formal uses an opaque and ensure that the address of
                    the actual parameter is cast to the formal type.
*)

PROCEDURE doFuncVarParam (p: pretty; actual, formal: node) ;
VAR
   type: node ;
BEGIN
   IF nodeUsesOpaque (formal) AND
      getNodeOpaqueFlushNecessary (actual, getNodeOpaqueVoidStar (formal))
   THEN
      type := getType (formal) ;
      outText (p, 'reinterpret_cast<') ;
      IF getNodeOpaqueVoidStar (formal)
      THEN
         doTypeNameC (p, type) ;
         setNeedSpace (p) ;
         outText (p, '*> (&') ;
         doExprC (p, actual) ;
         outText (p, ')') ;
         actual := makeOpaqueCast (actual, TRUE)
      ELSE
         doTypeNameC (p, type) ;
         noSpace (p) ;
         outText (p, '__opaque *> (&') ;
         doExprC (p, actual) ;
         outText (p, ')') ;
         actual := makeOpaqueCast (actual, FALSE)
      END
   ELSE
      doAdrExprC (p, actual)
   END
END doFuncVarParam ;


(*
   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
            IF isVarParam (formal)
            THEN
               lbr := checkSystemCast (p, actual, formal) ;
               doFuncVarParam (p, actual, formal) ;
               emitN (p, ")", lbr)
            ELSE
               IF nodeUsesOpaque (formal)
               THEN
                  forceCastOpaque (p, formal, actual,
                                   getNodeOpaqueVoidStar (formal))
               ELSE
                  lbr := checkSystemCast (p, actual, formal) ;
                  doExprC (p, actual) ;
                  emitN (p, ")", lbr)
               END
            END
         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?  *)
   ELSIF isString (n) OR (isArray (getType (n)) AND isUnbounded (getType (n)))
   THEN
      IF lang = ansiCP
      THEN
         outText (p, "const_cast<void*> (static_cast<const void*>") ;
         outText (p, "(") ;
         doExprC (p, n) ;
         outText (p, "))")
      ELSE
         doExprC (p, n)
      END
   ELSE
      outText (p, "&") ;
      doExprC (p, n)
   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)
*)


(*
   getFunction - return the function associate with funccall node n.
*)

PROCEDURE getFunction (n: node) : node ;
BEGIN
   assert (isFuncCall (n)) ;
   CASE n^.kind OF

   funccall:  RETURN n^.funccallF.function

   ELSE
      HALT
   END
END getFunction ;


(*
   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 localstop ;
END localstop ;


(*
   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 (globalGroup^.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 (globalGroup^.doneQ, t)
   THEN
      RETURN completed
   ELSIF alists.isItemInList (globalGroup^.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 (globalGroup^.todoQ, n)
      THEN
         db ('{T', n) ; outText (doP, '}')
      ELSIF alists.isItemInList (globalGroup^.partialQ, n)
      THEN
         db ('{P', n) ; outText (doP, '}')
      ELSIF alists.isItemInList (globalGroup^.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 (globalGroup^.doneQ, n) OR
           alists.isItemInList (globalGroup^.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 (globalGroup^.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 (globalGroup^.partialQ, t) OR
      alists.isItemInList (globalGroup^.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 (globalGroup^.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 (globalGroup^.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 (globalGroup^.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 (globalGroup^.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 (globalGroup^.partialQ, t)
   THEN
      dbs (partial, n) ;
      RETURN partial
   ELSIF alists.isItemInList (globalGroup^.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 (globalGroup^.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,
      cofft,
      cardinal64,
      (* 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 (globalGroup^.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,
   cofft,
   cardinal64,
   (* 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,
   cofft,
   cardinal64,
   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 ;
BEGIN
   IF getDebugTopological () AND FALSE
   THEN
      dumpQ ('todo', globalGroup^.todoQ) ;
      dumpQ ('partial', globalGroup^.partialQ) ;
      dumpQ ('done', globalGroup^.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 (globalGroup^.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 (globalGroup^.todoQ) ;
   WHILE i<=n DO
      d := alists.getItemFromList (globalGroup^.todoQ, i) ;
      IF tryComplete (d, c, t, v)
      THEN
         alists.removeItemFromList (globalGroup^.todoQ, d) ;
         addDone (d) ;
         i := 1
      ELSIF tryPartial (d, pt)
      THEN
         alists.removeItemFromList (globalGroup^.todoQ, d) ;
         alists.includeItemIntoList (globalGroup^.partialQ, d) ;
         i := 1
      ELSE
         INC (i)
      END ;
      n := alists.noOfItemsInList (globalGroup^.todoQ)
   END
END tryOutputTodo ;


(*
   tryOutputPartial -
*)

PROCEDURE tryOutputPartial (t: nodeProcedure) ;
VAR
   i, n: CARDINAL ;
   d   : node ;
BEGIN
   i := 1 ;
   n := alists.noOfItemsInList (globalGroup^.partialQ) ;
   WHILE i<=n DO
      d := alists.getItemFromList (globalGroup^.partialQ, i) ;
      IF tryCompleteFromPartial (d, t)
      THEN
         alists.removeItemFromList (globalGroup^.partialQ, d) ;
         addDone (d) ;
         i := 1 ;
         DEC (n)
      ELSE
         INC (i)
      END
   END
END tryOutputPartial ;


(*
   debugList -
*)

PROCEDURE debugList (listName, symName: ARRAY OF CHAR; l: alist) ;
VAR
   i, h: CARDINAL ;
   n   : node ;
BEGIN
   h := alists.noOfItemsInList (l) ;
   IF h>0
   THEN
      i := 1 ;
      REPEAT
         n := alists.getItemFromList (l, i) ;
         dbg (listName, symName, n) ;
         INC (i)
      UNTIL i > h
   END
END debugList ;


(*
   debugLists -
*)

PROCEDURE debugLists ;
BEGIN
   IF getDebugTopological ()
   THEN
      debugList ('todo', 'decl_node', globalGroup^.todoQ) ;
      debugList ('partial', 'decl_node', globalGroup^.partialQ) ;
      debugList ('done', 'decl_node', globalGroup^.doneQ)
   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 (globalGroup^.todoQ) ;
   i := 1 ;
   WHILE i <= h DO
      n := alists.getItemFromList (globalGroup^.todoQ, i) ;
      l := alists.initList () ;
      visitNode (l, n, p) ;
      alists.killList (l) ;
      h := alists.noOfItemsInList (globalGroup^.todoQ) ;
      INC (i)
   END
END populateTodo ;


(*
   topologicallyOut - keep trying to resolve the todoQ and partialQ
                      until there is no change from the global group.
*)

PROCEDURE topologicallyOut (c, t, v, tp,
                            pc, pt, pv: nodeProcedure) ;
VAR
   before: group ;
BEGIN
   populateTodo (addEnumConst) ;
   before := NIL ;
   REPEAT
      before := dupGroup (before) ;  (* Get a copy of the globalGroup and free before.  *)
      dumpLists ;
      tryOutputTodo (c, t, v, tp) ;
      dumpLists ;
      tryOutputPartial (pt)
   UNTIL equalGroup (before, globalGroup) ;
   killGroup (before) ;
   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,") ;
   setNeedSpace (p) ;
   outText (p, "__attribute__((unused)) char *argv[],") ;
   setNeedSpace (p) ;
   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,") ;
   setNeedSpace (p) ;
   outText (p, "__attribute__((unused)) char *argv[],") ;
   setNeedSpace (p) ;
   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,") ;
   setNeedSpace (p) ;
   outText (p, "__attribute__((unused)) char *argv[],") ;
   setNeedSpace (p) ;
   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,") ;
   setNeedSpace (p) ;
   outText (p, "__attribute__((unused)) char *argv[],") ;
   setNeedSpace (p) ;
   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))) ;
      (* Inform the source that this code belongs to the implementation module.  *)
      print (p, "#define _") ; prints (p, s) ; print (p, "_C\n\n") ;
      (* Include the definition module for any opaque types.  *)
      print (doP, '#include "') ;
      prints (p, getHPrefix ()) ;
      prints (p, s) ;
      print (p, '.h"\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,
   cofft,
   cardinal64:  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) ;
VAR
   s: String ;
BEGIN
   alists.includeItemIntoList (globalGroup^.doneQ, n) ;
   IF isVar (n) OR isParameter (n)
   THEN
      initNodeOpaqueState (n)
   END ;
   debugLists
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 FALSE 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')
   ELSIF isType (n) AND isDeclInImp (n)
   THEN
      (* Ignore an opaque type which is declared in this implementation module as it
         will be fully declared in C/C++ with the __opaque postfix.  Whereas the
         void * non prefixed typedef will be declared in the .h file.  *)
   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 (listName, symName: ARRAY OF CHAR; 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 ;
   REPEAT
      n := alists.getItemFromList (l, i) ;
      IF isType (n)
      THEN
         s := getFQstring (n) ;
         IF EqualArray (s, symName)
         THEN
            out0 ("list ") ;
            out0 (listName) ;
            out0 (": ") ;
            doDbg (l, n)
         END ;
         s := KillString (s)
      END ;
      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 ;
   assignNodeOpaqueCastState (m, n) ;
   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,
   cofft,
   cardinal64,
   (* 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) ;
   cofftN := makeBase (cofft) ;
   cardinal64N := makeBase (cardinal64) ;

   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) ;
   cofftN := addToScope (cofftN) ;
   cardinal64N := addToScope (cardinal64N) ;
   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) ;
   addDone (cofftN) ;
   addDone (cardinal64N)
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 ;


(*
   makeCDataTypes - assign the charStarN and constCharStarN to NIL.
*)

PROCEDURE makeCDataTypes ;
VAR
   CdatatypesN: node ;
BEGIN
   CdatatypesN := lookupDef (makeKey ('CDataTypes')) ;
   enterScope (CdatatypesN) ;
   charStarN := makePointer (charN) ;
   constCharStarN := makePointer (charN) ;
   leaveScope
END makeCDataTypes ;


(*
   init -
*)

PROCEDURE init ;
BEGIN
   lang := ansiC ;
   outputFile := StdOut ;
   doP := initPretty (write, writeln) ;
   freeGroup := NIL ;
   globalGroup := initGroup () ;
   modUniverse := initTree () ;
   defUniverse := initTree () ;
   modUniverseI := InitIndex (1) ;
   defUniverseI := InitIndex (1) ;
   scopeStack := InitIndex (1) ;
   makeBaseSymbols ;
   makeSystem ;
   makeBuiltins ;
   makeM2rts ;
   outputState := punct ;
   tempCount := 0 ;
   mustVisitScope := FALSE ;
   makeCDataTypes
END init ;


BEGIN
   init
END decl.