| (* decl.mod declaration nodes used to create the AST. |
| |
| Copyright (C) 2015-2023 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 ; |
| FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ; |
| FROM libc IMPORT printf, memset ; |
| FROM mcMetaError IMPORT metaError1, metaError2, metaError3, metaErrors1, metaErrors2 ; |
| FROM mcError IMPORT errorAbort0, flushErrors ; |
| |
| FROM mcLexBuf IMPORT findFileNameFromToken, tokenToLineNo, tokenToColumnNo, |
| getProcedureComment, getBodyComment, getAfterComment, |
| lastcomment ; |
| |
| FROM mcComment IMPORT commentDesc, isProcedureComment, isAfterComment, isBodyComment, getContent, initComment, addText ; |
| |
| FROM StrLib IMPORT StrEqual, StrLen ; |
| |
| FROM mcPretty IMPORT pretty, initPretty, dupPretty, killPretty, print, prints, raw, |
| setNeedSpace, noSpace, setindent, getindent, getcurpos, |
| getseekpos, getcurline, |
| pushPretty, popPretty ; |
| |
| FROM Indexing IMPORT Index, InitIndex, ForeachIndiceInIndexDo, |
| IncludeIndiceIntoIndex, IsIndiceInIndex, |
| HighIndice, LowIndice, GetIndice, RemoveIndiceFromIndex, |
| PutIndice, InBounds ; |
| |
| IMPORT DynamicStrings ; |
| IMPORT alists, wlists ; |
| IMPORT keyc ; |
| IMPORT mcStream ; |
| |
| FROM alists IMPORT alist ; |
| FROM wlists IMPORT wlist ; |
| |
| |
| CONST |
| indentation = 3 ; |
| indentationC = 2 ; |
| debugScopes = FALSE ; |
| debugDecl = FALSE ; |
| caseException = TRUE ; |
| returnException = TRUE ; |
| (* this is a work around to avoid ever having to handle dangling else. *) |
| forceCompoundStatement = TRUE ; (* TRUE will avoid dangling else, by always using {}. *) |
| enableDefForCStrings = FALSE ; (* currently disabled. *) |
| enableMemsetOnAllocation = TRUE ; (* Should we memset (..., 0, ...) the allocated mem? *) |
| forceQualified = TRUE ; |
| |
| TYPE |
| language = (ansiC, ansiCP, pim4) ; |
| |
| nodeT = (explist, funccall, |
| exit, return, stmtseq, comment, halt, |
| new, dispose, inc, dec, incl, excl, |
| length, |
| (* base constants. *) |
| nil, true, false, |
| (* system types. *) |
| address, loc, byte, word, |
| csizet, cssizet, |
| (* base types. *) |
| char, |
| cardinal, longcard, shortcard, |
| integer, longint, shortint, |
| real, longreal, shortreal, |
| bitset, boolean, proc, |
| ztype, rtype, |
| complex, longcomplex, shortcomplex, |
| (* language features and compound type attributes. *) |
| type, record, varient, var, enumeration, |
| subrange, array, subscript, |
| string, const, literal, varparam, param, varargs, optarg, |
| pointer, recordfield, varientfield, enumerationfield, |
| set, proctype, |
| (* blocks. *) |
| procedure, def, imp, module, |
| (* statements. *) |
| loop, while, for, repeat, |
| case, caselabellist, caselist, range, |
| assignment, |
| if, elsif, |
| (* expressions. *) |
| constexp, |
| neg, |
| cast, val, |
| plus, sub, div, mod, mult, divide, in, |
| adr, size, tsize, ord, float, trunc, chr, abs, cap, |
| high, throw, unreachable, |
| cmplx, re, im, |
| min, max, |
| componentref, pointerref, arrayref, deref, |
| equal, notequal, less, greater, greequal, lessequal, |
| lsl, lsr, lor, land, lnot, lxor, |
| and, or, not, identlist, vardecl, setvalue) ; |
| |
| node = POINTER TO nodeRec ; |
| |
| nodeRec = RECORD |
| CASE kind: nodeT OF |
| |
| unreachable, |
| throw, |
| new, |
| dispose, |
| inc, |
| dec, |
| incl, |
| excl, |
| halt : intrinsicF: intrinsicT | |
| explist : explistF: explistT | |
| exit : exitF : exitT | |
| return : returnF : returnT | |
| stmtseq : stmtF : stmtT | |
| comment : commentF: commentT | |
| (* base constants. *) |
| nil, |
| true, |
| false, |
| (* system types. *) |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet : | |
| (* base types. *) |
| boolean, |
| proc, |
| char, |
| integer, |
| cardinal, |
| longcard, |
| shortcard, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| ztype, |
| rtype, |
| complex, |
| longcomplex, |
| shortcomplex : | |
| (* language features and compound type attributes. *) |
| type : typeF : typeT | |
| record : recordF : recordT | |
| varient : varientF : varientT | |
| var : varF : varT | |
| enumeration : enumerationF : enumerationT | |
| subrange : subrangeF : subrangeT | |
| subscript : subscriptF : subscriptT | |
| array : arrayF : arrayT | |
| string : stringF : stringT | |
| const : constF : constT | |
| literal : literalF : literalT | |
| varparam : varparamF : varparamT | |
| param : paramF : paramT | |
| varargs : varargsF : varargsT | |
| optarg : optargF : optargT | |
| pointer : pointerF : pointerT | |
| recordfield : recordfieldF : recordfieldT | |
| varientfield : varientfieldF : varientfieldT | |
| enumerationfield: enumerationfieldF: enumerationfieldT | |
| set : setF : setT | |
| proctype : proctypeF : proctypeT | |
| (* blocks. *) |
| procedure : procedureF : procedureT | |
| def : defF : defT | |
| imp : impF : impT | |
| module : moduleF : moduleT | |
| (* statements. *) |
| loop : loopF : loopT | |
| while : whileF : whileT | |
| for : forF : forT | |
| repeat : repeatF : repeatT | |
| case : caseF : caseT | |
| caselabellist : caselabellistF : caselabellistT | |
| caselist : caselistF : caselistT | |
| range : rangeF : rangeT | |
| if : ifF : ifT | |
| elsif : elsifF : elsifT | |
| assignment : assignmentF : assignmentT | |
| (* expressions. *) |
| arrayref : arrayrefF : arrayrefT | |
| pointerref : pointerrefF : pointerrefT | |
| componentref : componentrefF : componentrefT | |
| cmplx, |
| and, |
| or, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal, |
| val, |
| cast, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide, |
| in : binaryF : binaryT | |
| constexp, |
| deref, |
| abs, |
| chr, |
| cap, |
| high, |
| ord, |
| float, |
| trunc, |
| re, |
| im, |
| not, |
| neg, |
| adr, |
| size, |
| tsize, |
| min, |
| max : unaryF : unaryT | |
| identlist : identlistF : identlistT | |
| vardecl : vardeclF : vardeclT | |
| funccall : funccallF : funccallT | |
| setvalue : setvalueF : setvalueT |
| |
| END ; |
| at: where ; |
| END ; |
| |
| intrinsicT = RECORD |
| args : node ; |
| noArgs : CARDINAL ; |
| type : node ; |
| intrinsicComment: commentPair ; |
| postUnreachable : BOOLEAN ; |
| END ; |
| |
| fixupInfo = RECORD |
| count: CARDINAL ; |
| info : Index ; |
| END ; |
| |
| explistT = RECORD |
| exp: Index ; |
| END ; |
| |
| setvalueT = RECORD |
| type: node ; |
| values: Index ; |
| END ; |
| |
| identlistT = RECORD |
| names : wlist ; |
| cnamed: BOOLEAN ; |
| END ; |
| |
| funccallT = RECORD |
| function : node ; |
| args : node ; |
| type : node ; |
| funccallComment: commentPair ; |
| END ; |
| |
| commentT = RECORD |
| content: commentDesc ; |
| END ; |
| |
| stmtT = RECORD |
| statements: Index ; |
| END ; |
| |
| returnT = RECORD |
| exp : node ; |
| scope : node ; |
| returnComment: commentPair ; |
| END ; |
| |
| exitT = RECORD |
| loop: node ; |
| END ; |
| |
| vardeclT = RECORD |
| names: wlist ; |
| type : node ; |
| scope: node ; |
| END ; |
| |
| typeT = RECORD |
| name : Name ; |
| type : node ; |
| scope : node ; |
| isHidden, |
| isInternal: BOOLEAN ; |
| END ; |
| |
| recordT = RECORD |
| localSymbols: symbolTree ; |
| listOfSons : Index ; |
| scope : node ; |
| END ; |
| |
| varientT = RECORD |
| listOfSons: Index ; |
| varient : node ; |
| tag : node ; |
| scope : node ; |
| END ; |
| |
| varT = RECORD |
| name : Name ; |
| type : node ; |
| decl : node ; |
| scope : node ; |
| isInitialised, |
| isParameter, |
| isVarParameter, |
| isUsed : BOOLEAN ; |
| cname : cnameT ; |
| END ; |
| |
| enumerationT = RECORD |
| noOfElements: CARDINAL ; |
| localSymbols: symbolTree ; |
| listOfSons : Index ; |
| low, high : node ; |
| scope : node ; |
| END ; |
| |
| subrangeT = RECORD |
| low, |
| high : node ; |
| type : node ; |
| scope: node ; |
| END ; |
| |
| subscriptT = RECORD |
| type: node ; |
| expr: node ; |
| END ; |
| |
| arrayT = RECORD |
| subr : node ; |
| type, |
| scope : node ; |
| isUnbounded: BOOLEAN ; |
| END ; |
| |
| stringT = RECORD |
| name : Name ; |
| length : CARDINAL ; |
| isCharCompatible: BOOLEAN ; |
| cstring : String ; |
| clength : CARDINAL ; |
| cchar : String ; |
| END ; |
| |
| literalT = RECORD |
| name : Name ; |
| type : node ; |
| END ; |
| |
| constT = RECORD |
| name : Name ; |
| type : node ; |
| value: node ; |
| scope: node ; |
| END ; |
| |
| varparamT = RECORD |
| namelist : node ; |
| type : node ; |
| scope : node ; |
| isUnbounded: BOOLEAN ; |
| isForC : BOOLEAN ; |
| isUsed : BOOLEAN ; |
| END ; |
| |
| paramT = RECORD |
| namelist : node ; |
| type : node ; |
| scope : node ; |
| isUnbounded: BOOLEAN ; |
| isForC : BOOLEAN ; |
| isUsed : BOOLEAN ; |
| END ; |
| |
| varargsT = RECORD |
| scope : node ; |
| END ; |
| |
| optargT = RECORD |
| namelist : node ; |
| type : node ; |
| scope : node ; |
| init : node ; |
| END ; |
| |
| pointerT = RECORD |
| type : node ; |
| scope: node ; |
| END ; |
| |
| recordfieldT = RECORD |
| name : Name ; |
| type : node ; |
| tag : BOOLEAN ; |
| parent : node ; |
| varient: node ; |
| scope : node ; |
| cname : cnameT ; |
| END ; |
| |
| varientfieldT = RECORD |
| name : Name ; |
| parent : node ; |
| varient : node ; |
| simple : BOOLEAN ; |
| listOfSons: Index ; |
| scope : node ; |
| END ; |
| |
| enumerationfieldT = RECORD |
| name : Name ; |
| type : node ; |
| scope: node ; |
| value: CARDINAL ; |
| cname: cnameT ; |
| END ; |
| |
| setT = RECORD |
| type : node ; |
| scope: node ; |
| END ; |
| |
| componentrefT = RECORD |
| rec : node ; |
| field : node ; |
| resultType: node ; |
| END ; |
| |
| pointerrefT = RECORD |
| ptr : node ; |
| field : node ; |
| resultType: node ; |
| END ; |
| |
| arrayrefT = RECORD |
| array : node ; |
| index : node ; |
| resultType: node ; |
| END ; |
| |
| commentPair = RECORD |
| after, |
| body : node ; |
| END ; |
| |
| assignmentT = RECORD |
| des, |
| expr : node ; |
| assignComment: commentPair ; |
| END ; |
| |
| ifT = RECORD |
| expr, |
| elsif, (* either else or elsif must be NIL. *) |
| then, |
| else : node ; |
| ifComment, |
| elseComment, (* used for else or elsif *) |
| endComment : commentPair ; |
| END ; |
| |
| elsifT = RECORD |
| expr, |
| elsif, (* either else or elsif must be NIL. *) |
| then, |
| else : node ; |
| elseComment: commentPair ; (* used for else or elsif *) |
| END ; |
| |
| loopT = RECORD |
| statements: node ; |
| labelno : CARDINAL ; (* 0 means no label. *) |
| END ; |
| |
| whileT = RECORD |
| expr, |
| statements: node ; |
| doComment, |
| endComment: commentPair ; |
| END ; |
| |
| repeatT = RECORD |
| expr, |
| statements : node ; |
| repeatComment, |
| untilComment : commentPair ; |
| END ; |
| |
| caseT = RECORD |
| expression : node ; |
| caseLabelList: Index ; |
| else : node ; |
| END ; |
| |
| caselabellistT = RECORD |
| caseList : node ; |
| statements: node ; |
| END ; |
| |
| caselistT = RECORD |
| rangePairs: Index ; |
| END ; |
| |
| rangeT = RECORD |
| lo, |
| hi: node ; |
| END ; |
| |
| forT = RECORD |
| des, |
| start, |
| end, |
| increment, |
| statements: node ; |
| END ; |
| |
| statementT = RECORD |
| sequence: Index ; |
| END ; |
| |
| scopeT = RECORD |
| symbols : symbolTree ; |
| constants, |
| types, |
| procedures, |
| variables : Index ; |
| END ; |
| |
| procedureT = RECORD |
| name : Name ; |
| decls : scopeT ; |
| scope : node ; |
| parameters : Index ; |
| isForC, |
| built, |
| checking, |
| returnopt, |
| vararg, |
| noreturnused, |
| noreturn : BOOLEAN ; |
| paramcount : CARDINAL ; |
| optarg : node ; |
| returnType : node ; |
| beginStatements: node ; |
| cname : cnameT ; |
| defComment, |
| modComment : commentDesc ; |
| END ; |
| |
| proctypeT = RECORD |
| parameters: Index ; |
| returnopt, |
| vararg : BOOLEAN ; |
| optarg : node ; |
| scope : node ; |
| returnType: node ; |
| END ; |
| |
| binaryT = RECORD |
| left, |
| right, |
| resultType: node ; |
| END ; |
| |
| unaryT = RECORD |
| arg, |
| resultType: node ; |
| END ; |
| |
| moduleT = RECORD |
| name : Name ; |
| source : Name ; |
| importedModules : Index ; |
| constFixup, |
| enumFixup : fixupInfo ; |
| decls : scopeT ; |
| beginStatements, |
| finallyStatements: node ; |
| enumsComplete, |
| constsComplete, |
| visited : BOOLEAN ; |
| com : commentPair ; |
| END ; |
| |
| defT = RECORD |
| name : Name ; |
| source : Name ; |
| hasHidden, |
| forC : BOOLEAN ; |
| exported, |
| importedModules : Index ; |
| constFixup, |
| enumFixup : fixupInfo ; |
| decls : scopeT ; |
| enumsComplete, |
| constsComplete, |
| visited : BOOLEAN ; |
| com : commentPair ; |
| END ; |
| |
| impT = RECORD |
| name : Name ; |
| source : Name ; |
| importedModules : Index ; |
| constFixup, |
| enumFixup : fixupInfo ; |
| beginStatements, |
| finallyStatements: node ; |
| definitionModule : node ; |
| decls : scopeT ; |
| enumsComplete, |
| constsComplete, |
| visited : BOOLEAN ; |
| com : commentPair ; |
| END ; |
| |
| where = RECORD |
| defDeclared, |
| modDeclared, |
| firstUsed : CARDINAL ; |
| END ; |
| |
| outputStates = (text, punct, space) ; |
| |
| nodeProcedure = PROCEDURE (node) ; |
| |
| dependentState = (completed, blocked, partial, recursive) ; |
| |
| cnameT = RECORD |
| name : Name ; |
| init : BOOLEAN ; |
| END ; |
| |
| VAR |
| outputFile : File ; |
| lang : language ; |
| bitsperunitN, |
| bitsperwordN, |
| bitspercharN, |
| unitsperwordN, |
| mainModule, |
| currentModule, |
| defModule, |
| systemN, |
| addressN, |
| locN, |
| byteN, |
| wordN, |
| csizetN, |
| cssizetN, |
| adrN, |
| sizeN, |
| tsizeN, |
| newN, |
| disposeN, |
| lengthN, |
| incN, |
| decN, |
| inclN, |
| exclN, |
| highN, |
| m2rtsN, |
| haltN, |
| throwN, |
| chrN, |
| capN, |
| absN, |
| floatN, |
| truncN, |
| ordN, |
| valN, |
| minN, |
| maxN, |
| booleanN, |
| procN, |
| charN, |
| integerN, |
| cardinalN, |
| longcardN, |
| shortcardN, |
| longintN, |
| shortintN, |
| bitsetN, |
| bitnumN, |
| ztypeN, |
| rtypeN, |
| complexN, |
| longcomplexN, |
| shortcomplexN, |
| cmplxN, |
| reN, |
| imN, |
| realN, |
| longrealN, |
| shortrealN, |
| nilN, |
| trueN, |
| falseN : node ; |
| scopeStack, |
| defUniverseI, |
| modUniverseI : Index ; |
| modUniverse, |
| defUniverse : symbolTree ; |
| baseSymbols : symbolTree ; |
| outputState : outputStates ; |
| doP : pretty ; |
| todoQ, |
| partialQ, |
| doneQ : alist ; |
| mustVisitScope, |
| simplified : BOOLEAN ; |
| tempCount : CARDINAL ; |
| |
| |
| (* |
| newNode - create and return a new node of kind k. |
| *) |
| |
| PROCEDURE newNode (k: nodeT) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| NEW (d) ; |
| IF enableMemsetOnAllocation |
| THEN |
| d := memset (d, 0, SIZE (d^)) |
| END ; |
| IF d=NIL |
| THEN |
| HALT |
| ELSE |
| d^.kind := k ; |
| d^.at.defDeclared := 0 ; |
| d^.at.modDeclared := 0 ; |
| d^.at.firstUsed := 0 ; |
| RETURN d |
| END |
| END newNode ; |
| |
| |
| (* |
| disposeNode - dispose node, n. |
| *) |
| |
| PROCEDURE disposeNode (VAR n: node) ; |
| BEGIN |
| DISPOSE (n) ; |
| n := NIL |
| END disposeNode ; |
| |
| |
| (* |
| getDeclaredDef - returns the token number associated with the nodes declaration |
| in the definition module. |
| *) |
| |
| PROCEDURE getDeclaredDef (n: node) : CARDINAL ; |
| BEGIN |
| RETURN n^.at.defDeclared |
| END getDeclaredDef ; |
| |
| |
| (* |
| getDeclaredMod - returns the token number associated with the nodes declaration |
| in the implementation or program module. |
| *) |
| |
| PROCEDURE getDeclaredMod (n: node) : CARDINAL ; |
| BEGIN |
| RETURN n^.at.modDeclared |
| END getDeclaredMod ; |
| |
| |
| (* |
| getFirstUsed - returns the token number associated with the first use of |
| node, n. |
| *) |
| |
| PROCEDURE getFirstUsed (n: node) : CARDINAL ; |
| BEGIN |
| RETURN n^.at.firstUsed |
| END getFirstUsed ; |
| |
| |
| (* |
| setVisited - set the visited flag on a def/imp/module node. |
| *) |
| |
| PROCEDURE setVisited (n: node) ; |
| BEGIN |
| CASE n^.kind OF |
| |
| def : n^.defF.visited := TRUE | |
| imp : n^.impF.visited := TRUE | |
| module: n^.moduleF.visited := TRUE |
| |
| END |
| END setVisited ; |
| |
| |
| (* |
| unsetVisited - unset the visited flag on a def/imp/module node. |
| *) |
| |
| PROCEDURE unsetVisited (n: node) ; |
| BEGIN |
| CASE n^.kind OF |
| |
| def : n^.defF.visited := FALSE | |
| imp : n^.impF.visited := FALSE | |
| module: n^.moduleF.visited := FALSE |
| |
| END |
| END unsetVisited ; |
| |
| |
| (* |
| isVisited - returns TRUE if the node was visited. |
| *) |
| |
| PROCEDURE isVisited (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| def : RETURN n^.defF.visited | |
| imp : RETURN n^.impF.visited | |
| module: RETURN n^.moduleF.visited |
| |
| END |
| END isVisited ; |
| |
| |
| (* |
| isDef - return TRUE if node, n, is a definition module. |
| *) |
| |
| PROCEDURE isDef (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = def |
| END isDef ; |
| |
| |
| (* |
| isImp - return TRUE if node, n, is an implementation module. |
| *) |
| |
| PROCEDURE isImp (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = imp |
| END isImp ; |
| |
| |
| (* |
| isModule - return TRUE if node, n, is a program module. |
| *) |
| |
| PROCEDURE isModule (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = module |
| END isModule ; |
| |
| |
| (* |
| isImpOrModule - returns TRUE if, n, is a program module or implementation module. |
| *) |
| |
| PROCEDURE isImpOrModule (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN isImp (n) OR isModule (n) |
| END isImpOrModule ; |
| |
| |
| (* |
| isProcedure - returns TRUE if node, n, is a procedure. |
| *) |
| |
| PROCEDURE isProcedure (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = procedure |
| END isProcedure ; |
| |
| |
| (* |
| isConst - returns TRUE if node, n, is a const. |
| *) |
| |
| PROCEDURE isConst (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = const |
| END isConst ; |
| |
| |
| (* |
| isType - returns TRUE if node, n, is a type. |
| *) |
| |
| PROCEDURE isType (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = type |
| END isType ; |
| |
| |
| (* |
| isVar - returns TRUE if node, n, is a type. |
| *) |
| |
| PROCEDURE isVar (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = var |
| END isVar ; |
| |
| |
| (* |
| isTemporary - returns TRUE if node, n, is a variable and temporary. |
| *) |
| |
| PROCEDURE isTemporary (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN FALSE |
| END isTemporary ; |
| |
| |
| (* |
| isExported - returns TRUE if symbol, n, is exported from |
| the definition module. |
| *) |
| |
| PROCEDURE isExported (n: node) : BOOLEAN ; |
| VAR |
| s: node ; |
| BEGIN |
| s := getScope (n) ; |
| IF s#NIL |
| THEN |
| CASE s^.kind OF |
| |
| def: RETURN IsIndiceInIndex (s^.defF.exported, n) |
| |
| ELSE |
| RETURN FALSE |
| END |
| END ; |
| RETURN FALSE |
| END isExported ; |
| |
| |
| (* |
| isLocal - returns TRUE if symbol, n, is locally declared in a procedure. |
| *) |
| |
| PROCEDURE isLocal (n: node) : BOOLEAN ; |
| VAR |
| s: node ; |
| BEGIN |
| s := getScope (n) ; |
| IF s#NIL |
| THEN |
| RETURN isProcedure (s) |
| END ; |
| RETURN FALSE |
| END isLocal ; |
| |
| |
| (* |
| lookupExported - attempts to lookup a node named, i, from definition |
| module, n. The node is returned if found. |
| NIL is returned if not found. |
| *) |
| |
| PROCEDURE lookupExported (n: node; i: Name) : node ; |
| VAR |
| r: node ; |
| BEGIN |
| assert (isDef (n)) ; |
| r := getSymKey (n^.defF.decls.symbols, i) ; |
| IF (r#NIL) AND isExported (r) |
| THEN |
| RETURN r |
| END ; |
| RETURN NIL |
| END lookupExported ; |
| |
| |
| (* |
| importEnumFields - if, n, is an enumeration type import the all fields into module, m. |
| *) |
| |
| PROCEDURE importEnumFields (m, n: node) ; |
| VAR |
| r, e: node ; |
| i, h: CARDINAL ; |
| BEGIN |
| assert (isDef (m) OR isModule (m) OR isImp (m)) ; |
| n := skipType (n) ; |
| IF (n#NIL) AND isEnumeration (n) |
| THEN |
| i := LowIndice (n^.enumerationF.listOfSons) ; |
| h := HighIndice (n^.enumerationF.listOfSons) ; |
| WHILE i<=h DO |
| e := GetIndice (n^.enumerationF.listOfSons, i) ; |
| r := import (m, e) ; |
| IF e#r |
| THEN |
| metaError2 ('enumeration field {%1ad} cannot be imported implicitly into {%2d} due to a name clash', |
| e, m) |
| END ; |
| INC (i) |
| END |
| END |
| END importEnumFields ; |
| |
| |
| (* |
| import - attempts to add node, n, into the scope of module, m. |
| It might fail due to a name clash in which case the |
| previous named symbol is returned. On success, n, |
| is returned. |
| *) |
| |
| PROCEDURE import (m, n: node) : node ; |
| VAR |
| name: Name ; |
| r : node ; |
| BEGIN |
| assert (isDef (m) OR isModule (m) OR isImp (m)) ; |
| name := getSymName (n) ; |
| r := lookupInScope (m, name) ; |
| IF r=NIL |
| THEN |
| CASE m^.kind OF |
| |
| def : putSymKey (m^.defF.decls.symbols, name, n) | |
| imp : putSymKey (m^.impF.decls.symbols, name, n) | |
| module: putSymKey (m^.moduleF.decls.symbols, name, n) |
| |
| END ; |
| importEnumFields (m, n) ; |
| RETURN n |
| END ; |
| RETURN r |
| END import ; |
| |
| |
| (* |
| isZtype - returns TRUE if, n, is the Z type. |
| *) |
| |
| PROCEDURE isZtype (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n = ztypeN |
| END isZtype ; |
| |
| |
| (* |
| isRtype - returns TRUE if, n, is the R type. |
| *) |
| |
| PROCEDURE isRtype (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n = rtypeN |
| END isRtype ; |
| |
| |
| (* |
| isComplex - returns TRUE if, n, is the complex type. |
| *) |
| |
| PROCEDURE isComplex (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n = complexN |
| END isComplex ; |
| |
| |
| (* |
| isLongComplex - returns TRUE if, n, is the longcomplex type. |
| *) |
| |
| PROCEDURE isLongComplex (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n = longcomplexN |
| END isLongComplex ; |
| |
| |
| (* |
| isShortComplex - returns TRUE if, n, is the shortcomplex type. |
| *) |
| |
| PROCEDURE isShortComplex (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n = shortcomplexN |
| END isShortComplex ; |
| |
| |
| (* |
| isLiteral - returns TRUE if, n, is a literal. |
| *) |
| |
| PROCEDURE isLiteral (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = literal |
| END isLiteral ; |
| |
| |
| (* |
| isConstSet - returns TRUE if, n, is a constant set. |
| *) |
| |
| PROCEDURE isConstSet (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| IF isLiteral (n) OR isConst (n) |
| THEN |
| RETURN isSet (skipType (getType (n))) |
| END ; |
| RETURN FALSE |
| END isConstSet ; |
| |
| |
| (* |
| isEnumerationField - returns TRUE if, n, is an enumeration field. |
| *) |
| |
| PROCEDURE isEnumerationField (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = enumerationfield |
| END isEnumerationField ; |
| |
| |
| (* |
| isUnbounded - returns TRUE if, n, is an unbounded array. |
| *) |
| |
| PROCEDURE isUnbounded (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN (n^.kind = array) AND (n^.arrayF.isUnbounded) |
| END isUnbounded ; |
| |
| |
| (* |
| isParameter - returns TRUE if, n, is a parameter. |
| *) |
| |
| PROCEDURE isParameter (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN (n^.kind = param) OR (n^.kind = varparam) |
| END isParameter ; |
| |
| |
| (* |
| isVarParam - returns TRUE if, n, is a var parameter. |
| *) |
| |
| PROCEDURE isVarParam (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = varparam |
| END isVarParam ; |
| |
| |
| (* |
| isParam - returns TRUE if, n, is a non var parameter. |
| *) |
| |
| PROCEDURE isParam (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = param |
| END isParam ; |
| |
| |
| (* |
| isNonVarParam - is an alias to isParam. |
| *) |
| |
| PROCEDURE isNonVarParam (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN isParam (n) |
| END isNonVarParam ; |
| |
| |
| (* |
| isRecord - returns TRUE if, n, is a record. |
| *) |
| |
| PROCEDURE isRecord (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = record |
| END isRecord ; |
| |
| |
| (* |
| isRecordField - returns TRUE if, n, is a record field. |
| *) |
| |
| PROCEDURE isRecordField (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = recordfield |
| END isRecordField ; |
| |
| |
| (* |
| isArray - returns TRUE if, n, is an array. |
| *) |
| |
| PROCEDURE isArray (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = array |
| END isArray ; |
| |
| |
| (* |
| isProcType - returns TRUE if, n, is a procedure type. |
| *) |
| |
| PROCEDURE isProcType (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = proctype |
| END isProcType ; |
| |
| |
| (* |
| isAProcType - returns TRUE if, n, is a proctype or proc node. |
| *) |
| |
| PROCEDURE isAProcType (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN isProcType (n) OR (n = procN) |
| END isAProcType ; |
| |
| |
| (* |
| isProcedure - returns TRUE if, n, is a procedure. |
| *) |
| |
| PROCEDURE isProcedure (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = procedure |
| END isProcedure ; |
| |
| |
| (* |
| isPointer - returns TRUE if, n, is a pointer. |
| *) |
| |
| PROCEDURE isPointer (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = pointer |
| END isPointer ; |
| |
| |
| (* |
| isVarient - returns TRUE if, n, is a varient record. |
| *) |
| |
| PROCEDURE isVarient (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = varient |
| END isVarient ; |
| |
| |
| (* |
| isVarientField - returns TRUE if, n, is a varient field. |
| *) |
| |
| PROCEDURE isVarientField (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = varientfield |
| END isVarientField ; |
| |
| |
| (* |
| isSet - returns TRUE if, n, is a set type. |
| *) |
| |
| PROCEDURE isSet (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = set |
| END isSet ; |
| |
| |
| (* |
| isSubrange - returns TRUE if, n, is a subrange type. |
| *) |
| |
| PROCEDURE isSubrange (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = subrange |
| END isSubrange ; |
| |
| |
| (* |
| isMainModule - return TRUE if node, n, is the main module specified |
| by the source file. This might be a definition, |
| implementation or program module. |
| *) |
| |
| PROCEDURE isMainModule (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n = mainModule |
| END isMainModule ; |
| |
| |
| (* |
| setMainModule - sets node, n, as the main module to be compiled. |
| *) |
| |
| PROCEDURE setMainModule (n: node) ; |
| BEGIN |
| assert (n#NIL) ; |
| mainModule := n |
| END setMainModule ; |
| |
| |
| (* |
| getMainModule - returns the main module node. |
| *) |
| |
| PROCEDURE getMainModule () : node ; |
| BEGIN |
| RETURN mainModule |
| END getMainModule ; |
| |
| |
| (* |
| setCurrentModule - sets node, n, as the current module being compiled. |
| *) |
| |
| PROCEDURE setCurrentModule (n: node) ; |
| BEGIN |
| assert (n#NIL) ; |
| currentModule := n |
| END setCurrentModule ; |
| |
| |
| (* |
| getCurrentModule - returns the current module being compiled. |
| *) |
| |
| PROCEDURE getCurrentModule () : node ; |
| BEGIN |
| RETURN currentModule |
| END getCurrentModule ; |
| |
| |
| (* |
| initFixupInfo - initialize the fixupInfo record. |
| *) |
| |
| PROCEDURE initFixupInfo () : fixupInfo ; |
| VAR |
| f: fixupInfo ; |
| BEGIN |
| f.count := 0 ; |
| f.info := InitIndex (1) ; |
| RETURN f |
| END initFixupInfo ; |
| |
| |
| (* |
| makeDef - returns a definition module node named, n. |
| *) |
| |
| PROCEDURE makeDef (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (def) ; |
| WITH d^ DO |
| defF.name := n ; |
| defF.source := NulName ; |
| defF.hasHidden := FALSE ; |
| defF.forC := FALSE ; |
| defF.exported := InitIndex (1) ; |
| defF.importedModules := InitIndex (1) ; |
| defF.constFixup := initFixupInfo () ; |
| defF.enumFixup := initFixupInfo () ; |
| initDecls (defF.decls) ; |
| defF.enumsComplete := FALSE ; |
| defF.constsComplete := FALSE ; |
| defF.visited := FALSE ; |
| initPair (defF.com) |
| END ; |
| RETURN d |
| END makeDef ; |
| |
| |
| (* |
| makeImp - returns an implementation module node named, n. |
| *) |
| |
| PROCEDURE makeImp (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (imp) ; |
| WITH d^ DO |
| impF.name := n ; |
| impF.source := NulName ; |
| impF.importedModules := InitIndex (1) ; |
| impF.constFixup := initFixupInfo () ; |
| impF.enumFixup := initFixupInfo () ; |
| initDecls (impF.decls) ; |
| impF.beginStatements := NIL ; |
| impF.finallyStatements := NIL ; |
| impF.definitionModule := NIL ; |
| impF.enumsComplete := FALSE ; |
| impF.constsComplete := FALSE ; |
| impF.visited := FALSE ; |
| initPair (impF.com) |
| END ; |
| RETURN d |
| END makeImp ; |
| |
| |
| (* |
| makeModule - returns a module node named, n. |
| *) |
| |
| PROCEDURE makeModule (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (module) ; |
| WITH d^ DO |
| moduleF.name := n ; |
| moduleF.source := NulName ; |
| moduleF.importedModules := InitIndex (1) ; |
| moduleF.constFixup := initFixupInfo () ; |
| moduleF.enumFixup := initFixupInfo () ; |
| initDecls (moduleF.decls) ; |
| moduleF.beginStatements := NIL ; |
| moduleF.finallyStatements := NIL ; |
| moduleF.enumsComplete := FALSE ; |
| moduleF.constsComplete := FALSE ; |
| moduleF.visited := FALSE ; |
| initPair (moduleF.com) |
| END ; |
| RETURN d |
| END makeModule ; |
| |
| |
| (* |
| putDefForC - the definition module was defined FOR "C". |
| *) |
| |
| PROCEDURE putDefForC (n: node) ; |
| BEGIN |
| assert (isDef (n)) ; |
| n^.defF.forC := TRUE |
| END putDefForC ; |
| |
| |
| (* |
| isDefForC - returns TRUE if the definition module was defined FOR "C". |
| *) |
| |
| PROCEDURE isDefForC (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN isDef (n) AND n^.defF.forC |
| END isDefForC ; |
| |
| |
| (* |
| lookupDef - returns a definition module node named, n. |
| *) |
| |
| PROCEDURE lookupDef (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := getSymKey (defUniverse, n) ; |
| IF d=NIL |
| THEN |
| d := makeDef (n) ; |
| putSymKey (defUniverse, n, d) ; |
| IncludeIndiceIntoIndex (defUniverseI, d) |
| END ; |
| RETURN d |
| END lookupDef ; |
| |
| |
| (* |
| lookupImp - returns an implementation module node named, n. |
| *) |
| |
| PROCEDURE lookupImp (n: Name) : node ; |
| VAR |
| m: node ; |
| BEGIN |
| m := getSymKey (modUniverse, n) ; |
| IF m=NIL |
| THEN |
| m := makeImp (n) ; |
| putSymKey (modUniverse, n, m) ; |
| IncludeIndiceIntoIndex (modUniverseI, m) |
| END ; |
| assert (NOT isModule (m)) ; |
| RETURN m |
| END lookupImp ; |
| |
| |
| (* |
| lookupModule - returns a module node named, n. |
| *) |
| |
| PROCEDURE lookupModule (n: Name) : node ; |
| VAR |
| m: node ; |
| BEGIN |
| m := getSymKey (modUniverse, n) ; |
| IF m=NIL |
| THEN |
| m := makeModule (n) ; |
| putSymKey (modUniverse, n, m) ; |
| IncludeIndiceIntoIndex (modUniverseI, m) |
| END ; |
| assert (NOT isImp (m)) ; |
| RETURN m |
| END lookupModule ; |
| |
| |
| (* |
| setSource - sets the source filename for module, n, to s. |
| *) |
| |
| PROCEDURE setSource (n: node; s: Name) ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| def : defF.source := s | |
| module: moduleF.source := s | |
| imp : impF.source := s |
| |
| END |
| END |
| END setSource ; |
| |
| |
| (* |
| getSource - returns the source filename for module, n. |
| *) |
| |
| PROCEDURE getSource (n: node) : Name ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| def : RETURN defF.source | |
| module: RETURN moduleF.source | |
| imp : RETURN impF.source |
| |
| END |
| END |
| END getSource ; |
| |
| |
| (* |
| initDecls - initialize the decls, scopeT. |
| *) |
| |
| PROCEDURE initDecls (VAR decls: scopeT) ; |
| BEGIN |
| decls.symbols := initTree () ; |
| decls.constants := InitIndex (1) ; |
| decls.types := InitIndex (1) ; |
| decls.procedures := InitIndex (1) ; |
| decls.variables := InitIndex (1) |
| END initDecls ; |
| |
| |
| (* |
| enterScope - pushes symbol, n, to the scope stack. |
| *) |
| |
| PROCEDURE enterScope (n: node) ; |
| BEGIN |
| IF IsIndiceInIndex (scopeStack, n) |
| THEN |
| HALT |
| ELSE |
| IncludeIndiceIntoIndex (scopeStack, n) |
| END ; |
| IF debugScopes |
| THEN |
| printf ("enter scope\n") ; |
| dumpScopes |
| END |
| END enterScope ; |
| |
| |
| (* |
| leaveScope - removes the top level scope. |
| *) |
| |
| PROCEDURE leaveScope ; |
| VAR |
| i: CARDINAL ; |
| n: node ; |
| BEGIN |
| i := HighIndice (scopeStack) ; |
| n := GetIndice (scopeStack, i) ; |
| RemoveIndiceFromIndex (scopeStack, n) ; |
| IF debugScopes |
| THEN |
| printf ("leave scope\n") ; |
| dumpScopes |
| END |
| END leaveScope ; |
| |
| |
| (* |
| getDeclScope - returns the node representing the |
| current declaration scope. |
| *) |
| |
| PROCEDURE getDeclScope () : node ; |
| VAR |
| i: CARDINAL ; |
| BEGIN |
| i := HighIndice (scopeStack) ; |
| RETURN GetIndice (scopeStack, i) |
| END getDeclScope ; |
| |
| |
| (* |
| addTo - adds node, d, to scope decls and returns, d. |
| It stores, d, in the symbols tree associated with decls. |
| *) |
| |
| PROCEDURE addTo (VAR decls: scopeT; d: node) : node ; |
| VAR |
| n: Name ; |
| BEGIN |
| n := getSymName (d) ; |
| IF n#NulName |
| THEN |
| IF getSymKey (decls.symbols, n)=NIL |
| THEN |
| putSymKey (decls.symbols, n, d) |
| ELSE |
| metaError1 ('{%1DMad} was declared', d) ; |
| metaError1 ('{%1k} and is being declared again', n) |
| END |
| END ; |
| IF isConst (d) |
| THEN |
| IncludeIndiceIntoIndex (decls.constants, d) |
| ELSIF isVar (d) |
| THEN |
| IncludeIndiceIntoIndex (decls.variables, d) |
| ELSIF isType (d) |
| THEN |
| IncludeIndiceIntoIndex (decls.types, d) |
| ELSIF isProcedure (d) |
| THEN |
| IncludeIndiceIntoIndex (decls.procedures, d) ; |
| IF debugDecl |
| THEN |
| printf ("%d procedures on the dynamic array\n", |
| HighIndice (decls.procedures)) |
| END |
| END ; |
| RETURN d |
| END addTo ; |
| |
| |
| (* |
| export - export node, n, from definition module, d. |
| *) |
| |
| PROCEDURE export (d, n: node) ; |
| BEGIN |
| assert (isDef (d)) ; |
| IncludeIndiceIntoIndex (d^.defF.exported, n) |
| END export ; |
| |
| |
| (* |
| addToScope - adds node, n, to the current scope and returns, n. |
| *) |
| |
| PROCEDURE addToScope (n: node) : node ; |
| VAR |
| s: node ; |
| i: CARDINAL ; |
| BEGIN |
| i := HighIndice (scopeStack) ; |
| s := GetIndice (scopeStack, i) ; |
| IF isProcedure (s) |
| THEN |
| IF debugDecl |
| THEN |
| outText (doP, "adding ") ; |
| doNameC (doP, n) ; |
| outText (doP, " to procedure\n") |
| END ; |
| RETURN addTo (s^.procedureF.decls, n) |
| ELSIF isModule (s) |
| THEN |
| IF debugDecl |
| THEN |
| outText (doP, "adding ") ; |
| doNameC (doP, n) ; |
| outText (doP, " to module\n") |
| END ; |
| RETURN addTo (s^.moduleF.decls, n) |
| ELSIF isDef (s) |
| THEN |
| IF debugDecl |
| THEN |
| outText (doP, "adding ") ; |
| doNameC (doP, n) ; |
| outText (doP, " to definition module\n") |
| END ; |
| export (s, n) ; |
| RETURN addTo (s^.defF.decls, n) |
| ELSIF isImp (s) |
| THEN |
| IF debugDecl |
| THEN |
| outText (doP, "adding ") ; |
| doNameC (doP, n) ; |
| outText (doP, " to implementation module\n") |
| END ; |
| RETURN addTo (s^.impF.decls, n) |
| END ; |
| HALT |
| END addToScope ; |
| |
| |
| (* |
| addModuleToScope - adds module, i, to module, m, scope. |
| *) |
| |
| PROCEDURE addModuleToScope (m, i: node) ; |
| BEGIN |
| assert (getDeclScope () = m) ; |
| IF lookupSym (getSymName (i))=NIL |
| THEN |
| i := addToScope (i) |
| END |
| END addModuleToScope ; |
| |
| |
| (* |
| addImportedModule - add module, i, to be imported by, m. |
| If scoped then module, i, is added to the |
| module, m, scope. |
| *) |
| |
| PROCEDURE addImportedModule (m, i: node; scoped: BOOLEAN) ; |
| BEGIN |
| assert (isDef (i) OR isModule (i)) ; |
| IF isDef (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.defF.importedModules, i) |
| ELSIF isImp (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.impF.importedModules, i) |
| ELSIF isModule (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.moduleF.importedModules, i) |
| ELSE |
| HALT |
| END ; |
| IF scoped |
| THEN |
| addModuleToScope (m, i) |
| END |
| END addImportedModule ; |
| |
| |
| (* |
| completedEnum - assign boolean enumsComplete to TRUE if a definition, |
| implementation or module symbol. |
| *) |
| |
| PROCEDURE completedEnum (n: node) ; |
| BEGIN |
| assert (isDef (n) OR isImp (n) OR isModule (n)) ; |
| IF isDef (n) |
| THEN |
| n^.defF.enumsComplete := TRUE |
| ELSIF isImp (n) |
| THEN |
| n^.impF.enumsComplete := TRUE |
| ELSIF isModule (n) |
| THEN |
| n^.moduleF.enumsComplete := TRUE |
| END |
| END completedEnum ; |
| |
| |
| (* |
| setUnary - sets a unary node to contain, arg, a, and type, t. |
| *) |
| |
| PROCEDURE setUnary (u: node; k: nodeT; a, t: node) ; |
| BEGIN |
| CASE k OF |
| |
| constexp, |
| deref, |
| chr, |
| cap, |
| abs, |
| float, |
| trunc, |
| ord, |
| high, |
| throw, |
| re, |
| im, |
| not, |
| neg, |
| adr, |
| size, |
| tsize, |
| min, |
| max : u^.kind := k ; |
| u^.unaryF.arg := a ; |
| u^.unaryF.resultType := t |
| |
| END |
| END setUnary ; |
| |
| |
| (* |
| makeConst - create, initialise and return a const node. |
| *) |
| |
| PROCEDURE makeConst (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (const) ; |
| WITH d^ DO |
| constF.name := n ; |
| constF.type := NIL ; |
| constF.scope := getDeclScope () ; |
| constF.value := NIL |
| END ; |
| RETURN addToScope (d) |
| END makeConst ; |
| |
| |
| (* |
| makeType - create, initialise and return a type node. |
| *) |
| |
| PROCEDURE makeType (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (type) ; |
| WITH d^ DO |
| typeF.name := n ; |
| typeF.type := NIL ; |
| typeF.scope := getDeclScope () ; |
| typeF.isHidden := FALSE ; |
| typeF.isInternal := FALSE |
| END ; |
| RETURN addToScope (d) |
| END makeType ; |
| |
| |
| (* |
| makeTypeImp - lookup a type in the definition module |
| and return it. Otherwise create a new type. |
| *) |
| |
| PROCEDURE makeTypeImp (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := lookupSym (n) ; |
| IF d#NIL |
| THEN |
| d^.typeF.isHidden := FALSE ; |
| RETURN addToScope (d) |
| ELSE |
| d := newNode (type) ; |
| WITH d^ DO |
| typeF.name := n ; |
| typeF.type := NIL ; |
| typeF.scope := getDeclScope () ; |
| typeF.isHidden := FALSE |
| END ; |
| RETURN addToScope (d) |
| END |
| END makeTypeImp ; |
| |
| |
| (* |
| makeVar - create, initialise and return a var node. |
| *) |
| |
| PROCEDURE makeVar (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (var) ; |
| WITH d^ DO |
| varF.name := n ; |
| varF.type := NIL ; |
| varF.decl := NIL ; |
| varF.scope := getDeclScope () ; |
| varF.isInitialised := FALSE ; |
| varF.isParameter := FALSE ; |
| varF.isVarParameter := FALSE ; |
| initCname (varF.cname) |
| END ; |
| RETURN addToScope (d) |
| END makeVar ; |
| |
| |
| (* |
| putVar - places, type, as the type for var. |
| *) |
| |
| PROCEDURE putVar (var, type, decl: node) ; |
| BEGIN |
| assert (var#NIL) ; |
| assert (isVar (var)) ; |
| var^.varF.type := type ; |
| var^.varF.decl := decl |
| END putVar ; |
| |
| |
| (* |
| putVarBool - assigns the four booleans associated with a variable. |
| *) |
| |
| PROCEDURE putVarBool (v: node; init, param, isvar, isused: BOOLEAN) ; |
| BEGIN |
| assert (isVar (v)) ; |
| v^.varF.isInitialised := init ; |
| v^.varF.isParameter := param ; |
| v^.varF.isVarParameter := isvar ; |
| v^.varF.isUsed := isused |
| END putVarBool ; |
| |
| |
| (* |
| checkPtr - in C++ we need to create a typedef for a pointer |
| in case we need to use reinterpret_cast. |
| *) |
| |
| PROCEDURE checkPtr (n: node) : node ; |
| VAR |
| s: String ; |
| p: node ; |
| BEGIN |
| IF lang = ansiCP |
| THEN |
| IF isPointer (n) |
| THEN |
| s := tempName () ; |
| p := makeType (makekey (DynamicStrings.string (s))) ; |
| putType (p, n) ; |
| s := KillString (s) ; |
| RETURN p |
| END |
| END ; |
| RETURN n |
| END checkPtr ; |
| |
| |
| (* |
| makeVarDecl - create a vardecl node and create a shadow variable in the |
| current scope. |
| *) |
| |
| PROCEDURE makeVarDecl (i: node; type: node) : node ; |
| VAR |
| d, v: node ; |
| j, n: CARDINAL ; |
| BEGIN |
| type := checkPtr (type) ; |
| d := newNode (vardecl) ; |
| WITH d^ DO |
| vardeclF.names := i^.identlistF.names ; |
| vardeclF.type := type ; |
| vardeclF.scope := getDeclScope () |
| END ; |
| n := wlists.noOfItemsInList (d^.vardeclF.names) ; |
| j := 1 ; |
| WHILE j<=n DO |
| v := lookupSym (wlists.getItemFromList (d^.vardeclF.names, j)) ; |
| assert (isVar (v)) ; |
| putVar (v, type, d) ; |
| INC (j) |
| END ; |
| RETURN d |
| END makeVarDecl ; |
| |
| |
| (* |
| isVarDecl - returns TRUE if, n, is a vardecl node. |
| *) |
| |
| PROCEDURE isVarDecl (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = vardecl |
| END isVarDecl ; |
| |
| |
| (* |
| makeVariablesFromParameters - creates variables which are really parameters. |
| *) |
| |
| PROCEDURE makeVariablesFromParameters (proc, id, type: node; isvar, isused: BOOLEAN) ; |
| VAR |
| v : node ; |
| i, n: CARDINAL ; |
| m : Name ; |
| s : String ; |
| BEGIN |
| assert (isProcedure (proc)) ; |
| assert (isIdentList (id)) ; |
| i := 1 ; |
| n := wlists.noOfItemsInList (id^.identlistF.names) ; |
| WHILE i<=n DO |
| m := wlists.getItemFromList (id^.identlistF.names, i) ; |
| v := makeVar (m) ; |
| putVar (v, type, NIL) ; |
| putVarBool (v, TRUE, TRUE, isvar, isused) ; |
| IF debugScopes |
| THEN |
| printf ("adding parameter variable into top scope\n") ; |
| dumpScopes ; |
| printf (" variable name is: ") ; |
| s := InitStringCharStar (keyToCharStar (m)) ; |
| IF KillString (WriteS (StdOut, s))=NIL |
| THEN |
| END ; |
| printf ("\n") |
| END ; |
| INC (i) |
| END |
| END makeVariablesFromParameters ; |
| |
| |
| (* |
| addProcedureToScope - add a procedure name n and node d to the |
| current scope. |
| *) |
| |
| PROCEDURE addProcedureToScope (d: node; n: Name) : node ; |
| VAR |
| m: node ; |
| i: CARDINAL ; |
| BEGIN |
| i := HighIndice (scopeStack) ; |
| m := GetIndice (scopeStack, i) ; |
| IF isDef (m) AND |
| (getSymName (m) = makeKey ('M2RTS')) AND |
| (getSymName (d) = makeKey ('HALT')) |
| THEN |
| haltN := d ; |
| putSymKey (baseSymbols, n, haltN) |
| END ; |
| RETURN addToScope (d) |
| END addProcedureToScope ; |
| |
| |
| (* |
| makeProcedure - create, initialise and return a procedure node. |
| *) |
| |
| PROCEDURE makeProcedure (n: Name) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := lookupSym (n) ; |
| IF d=NIL |
| THEN |
| d := newNode (procedure) ; |
| WITH d^ DO |
| procedureF.name := n ; |
| initDecls (procedureF.decls) ; |
| procedureF.scope := getDeclScope () ; |
| procedureF.parameters := InitIndex (1) ; |
| procedureF.isForC := isDefForCNode (getDeclScope ()) ; |
| procedureF.built := FALSE ; |
| procedureF.returnopt := FALSE ; |
| procedureF.optarg := NIL ; |
| procedureF.noreturnused := FALSE ; |
| procedureF.noreturn := FALSE ; |
| procedureF.vararg := FALSE ; |
| procedureF.checking := FALSE ; |
| procedureF.paramcount := 0 ; |
| procedureF.returnType := NIL ; |
| procedureF.beginStatements := NIL ; |
| initCname (procedureF.cname) ; |
| procedureF.defComment := NIL ; |
| procedureF.modComment := NIL ; |
| END |
| END ; |
| RETURN addProcedureToScope (d, n) |
| END makeProcedure ; |
| |
| |
| (* |
| putCommentDefProcedure - remembers the procedure comment (if it exists) as a |
| definition module procedure heading. NIL is placed |
| if there is no procedure comment available. |
| *) |
| |
| PROCEDURE putCommentDefProcedure (n: node) ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| IF isProcedureComment (lastcomment) |
| THEN |
| n^.procedureF.defComment := lastcomment |
| END |
| END putCommentDefProcedure ; |
| |
| |
| (* |
| putCommentModProcedure - remembers the procedure comment (if it exists) as an |
| implementation/program module procedure heading. NIL is placed |
| if there is no procedure comment available. |
| *) |
| |
| PROCEDURE putCommentModProcedure (n: node) ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| IF isProcedureComment (lastcomment) |
| THEN |
| n^.procedureF.modComment := lastcomment |
| END |
| END putCommentModProcedure ; |
| |
| |
| (* |
| paramEnter - reset the parameter count. |
| *) |
| |
| PROCEDURE paramEnter (n: node) ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| n^.procedureF.paramcount := 0 |
| END paramEnter ; |
| |
| |
| (* |
| paramLeave - set paramater checking to TRUE from now onwards. |
| *) |
| |
| PROCEDURE paramLeave (n: node) ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| n^.procedureF.checking := TRUE ; |
| IF isImp (currentModule) OR isModule (currentModule) |
| THEN |
| n^.procedureF.built := TRUE |
| END |
| END paramLeave ; |
| |
| |
| (* |
| putReturnType - sets the return type of procedure or proctype, proc, to, type. |
| *) |
| |
| PROCEDURE putReturnType (proc, type: node) ; |
| BEGIN |
| assert (isProcedure (proc) OR isProcType (proc)) ; |
| IF isProcedure (proc) |
| THEN |
| proc^.procedureF.returnType := type |
| ELSE |
| proc^.proctypeF.returnType := type |
| END |
| END putReturnType ; |
| |
| |
| (* |
| putOptReturn - sets, proctype or procedure, proc, to have an optional return type. |
| *) |
| |
| PROCEDURE putOptReturn (proc: node) ; |
| BEGIN |
| assert (isProcedure (proc) OR isProcType (proc)) ; |
| IF isProcedure (proc) |
| THEN |
| proc^.procedureF.returnopt := TRUE |
| ELSE |
| proc^.proctypeF.returnopt := TRUE |
| END |
| END putOptReturn ; |
| |
| |
| (* |
| makeProcType - returns a proctype node. |
| *) |
| |
| PROCEDURE makeProcType () : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (proctype) ; |
| WITH d^ DO |
| proctypeF.scope := getDeclScope () ; |
| proctypeF.parameters := InitIndex (1) ; |
| proctypeF.returnopt := FALSE ; |
| proctypeF.optarg := NIL ; |
| proctypeF.vararg := FALSE ; |
| proctypeF.returnType := NIL |
| END ; |
| RETURN d |
| END makeProcType ; |
| |
| |
| (* |
| putProcTypeReturn - sets the return type of, proc, to, type. |
| *) |
| |
| PROCEDURE putProcTypeReturn (proc, type: node) ; |
| BEGIN |
| assert (isProcType (proc)) ; |
| proc^.proctypeF.returnType := type |
| END putProcTypeReturn ; |
| |
| |
| (* |
| putProcTypeOptReturn - sets, proc, to have an optional return type. |
| *) |
| |
| PROCEDURE putProcTypeOptReturn (proc: node) ; |
| BEGIN |
| assert (isProcType (proc)) ; |
| proc^.proctypeF.returnopt := TRUE |
| END putProcTypeOptReturn ; |
| |
| |
| (* |
| makeNonVarParameter - returns a non var parameter node with, name: type. |
| *) |
| |
| PROCEDURE makeNonVarParameter (l: node; type, proc: node; isused: BOOLEAN) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| assert ((l=NIL) OR isIdentList (l)) ; |
| d := newNode (param) ; |
| d^.paramF.namelist := l ; |
| d^.paramF.type := type ; |
| d^.paramF.scope := proc ; |
| d^.paramF.isUnbounded := FALSE ; |
| d^.paramF.isForC := isDefForCNode (proc) ; |
| d^.paramF.isUsed := isused ; |
| RETURN d |
| END makeNonVarParameter ; |
| |
| |
| (* |
| makeVarParameter - returns a var parameter node with, name: type. |
| *) |
| |
| PROCEDURE makeVarParameter (l: node; type, proc: node; isused: BOOLEAN) : node ; |
| VAR |
| d: node ; |
| BEGIN |
| assert ((l=NIL) OR isIdentList (l)) ; |
| d := newNode (varparam) ; |
| d^.varparamF.namelist := l ; |
| d^.varparamF.type := type ; |
| d^.varparamF.scope := proc ; |
| d^.varparamF.isUnbounded := FALSE ; |
| d^.varparamF.isForC := isDefForCNode (proc) ; |
| d^.varparamF.isUsed := isused ; |
| RETURN d |
| END makeVarParameter ; |
| |
| |
| (* |
| makeVarargs - returns a varargs node. |
| *) |
| |
| PROCEDURE makeVarargs () : node ; |
| VAR |
| d: node ; |
| BEGIN |
| d := newNode (varargs) ; |
| d^.varargsF.scope := NIL ; |
| RETURN d |
| END makeVarargs ; |
| |
| |
| (* |
| isVarargs - returns TRUE if, n, is a varargs node. |
| *) |
| |
| PROCEDURE isVarargs (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = varargs |
| END isVarargs ; |
| |
| |
| (* |
| addParameter - adds a parameter, param, to procedure or proctype, proc. |
| *) |
| |
| PROCEDURE addParameter (proc, param: node) ; |
| BEGIN |
| assert (isVarargs (param) OR isParam (param) OR isVarParam (param) OR isOptarg (param)) ; |
| CASE proc^.kind OF |
| |
| procedure: IncludeIndiceIntoIndex (proc^.procedureF.parameters, param) ; |
| IF isVarargs (param) |
| THEN |
| proc^.procedureF.vararg := TRUE |
| END ; |
| IF isOptarg (param) |
| THEN |
| proc^.procedureF.optarg := param |
| END | |
| proctype : IncludeIndiceIntoIndex (proc^.proctypeF.parameters, param) ; |
| IF isVarargs (param) |
| THEN |
| proc^.proctypeF.vararg := TRUE |
| END ; |
| IF isOptarg (param) |
| THEN |
| proc^.proctypeF.optarg := param |
| END |
| |
| END |
| END addParameter ; |
| |
| |
| (* |
| isOptarg - returns TRUE if, n, is an optarg. |
| *) |
| |
| PROCEDURE isOptarg (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = optarg |
| END isOptarg ; |
| |
| |
| (* |
| makeOptParameter - creates and returns an optarg. |
| *) |
| |
| PROCEDURE makeOptParameter (l, type, init: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (optarg) ; |
| n^.optargF.namelist := l ; |
| n^.optargF.type := type ; |
| n^.optargF.init := init ; |
| n^.optargF.scope := NIL ; |
| RETURN n |
| END makeOptParameter ; |
| |
| |
| (* |
| addOptParameter - returns an optarg which has been created and added to |
| procedure node, proc. It has a name, id, and, type, |
| and an initial value, init. |
| *) |
| |
| PROCEDURE addOptParameter (proc: node; id: Name; type, init: node) : node ; |
| VAR |
| p, l: node ; |
| BEGIN |
| assert (isProcedure (proc)) ; |
| l := makeIdentList () ; |
| assert (putIdent (l, id)) ; |
| checkMakeVariables (proc, l, type, FALSE, TRUE) ; |
| IF NOT proc^.procedureF.checking |
| THEN |
| p := makeOptParameter (l, type, init) ; |
| addParameter (proc, p) |
| END ; |
| RETURN p |
| END addOptParameter ; |
| |
| |
| VAR |
| globalNode: node ; |
| |
| |
| (* |
| setwatch - assign the globalNode to n. |
| *) |
| |
| PROCEDURE setwatch (n: node) : BOOLEAN ; |
| BEGIN |
| globalNode := n ; |
| RETURN TRUE |
| END setwatch ; |
| |
| |
| (* |
| runwatch - set the globalNode to an identlist. |
| *) |
| |
| PROCEDURE runwatch () : BOOLEAN ; |
| BEGIN |
| RETURN globalNode^.kind = identlist |
| END runwatch ; |
| |
| |
| (* |
| makeIdentList - returns a node which will be used to maintain an ident list. |
| *) |
| |
| PROCEDURE makeIdentList () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (identlist) ; |
| n^.identlistF.names := wlists.initList () ; |
| n^.identlistF.cnamed := FALSE ; |
| RETURN n |
| END makeIdentList ; |
| |
| |
| (* |
| isIdentList - returns TRUE if, n, is an identlist. |
| *) |
| |
| PROCEDURE isIdentList (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = identlist |
| END isIdentList ; |
| |
| |
| (* |
| putIdent - places ident, i, into identlist, n. It returns TRUE if |
| ident, i, is unique. |
| *) |
| |
| PROCEDURE putIdent (n: node; i: Name) : BOOLEAN ; |
| BEGIN |
| assert (isIdentList (n)) ; |
| IF wlists.isItemInList (n^.identlistF.names, i) |
| THEN |
| RETURN FALSE |
| ELSE |
| wlists.putItemIntoList (n^.identlistF.names, i) ; |
| RETURN TRUE |
| END |
| END putIdent ; |
| |
| |
| (* |
| identListLen - returns the length of identlist. |
| *) |
| |
| PROCEDURE identListLen (n: node) : CARDINAL ; |
| BEGIN |
| IF n=NIL |
| THEN |
| RETURN 0 |
| ELSE |
| assert (isIdentList (n)) ; |
| RETURN wlists.noOfItemsInList (n^.identlistF.names) |
| END |
| END identListLen ; |
| |
| |
| (* |
| checkParameters - placeholder for future parameter checking. |
| *) |
| |
| PROCEDURE checkParameters (p: node; i: node; type: node; isvar, isused: BOOLEAN) ; |
| BEGIN |
| (* do check. *) |
| disposeNode (i) |
| END checkParameters ; |
| |
| (* |
| (* |
| avoidCnames - checks each name in, n, against C reserved |
| keywords and macros. |
| *) |
| |
| PROCEDURE avoidCnames (n: node) ; |
| VAR |
| i, j: CARDINAL ; |
| BEGIN |
| assert (isIdentList (n)) ; |
| IF NOT n^.identlistF.cnamed |
| THEN |
| n^.identlistF.cnamed := TRUE ; |
| j := wlists.noOfItemsInList (n^.identlistF.names) ; |
| i := 1 ; |
| WHILE i<=j DO |
| wlists.replaceItemInList (n^.identlistF.names, |
| i, |
| keyc.cnamen (wlists.getItemFromList (n^.identlistF.names, i), FALSE)) ; |
| INC (i) |
| END |
| END |
| END avoidCnames ; |
| *) |
| |
| |
| (* |
| checkMakeVariables - create shadow local variables for parameters providing that |
| procedure n has not already been built and we are compiling |
| a module or an implementation module. |
| *) |
| |
| PROCEDURE checkMakeVariables (n, i, type: node; isvar, isused: BOOLEAN) ; |
| BEGIN |
| IF (isImp (currentModule) OR isModule (currentModule)) AND |
| (NOT n^.procedureF.built) |
| THEN |
| makeVariablesFromParameters (n, i, type, isvar, isused) |
| END ; |
| END checkMakeVariables ; |
| |
| |
| (* |
| addVarParameters - adds the identlist, i, of, type, to be VAR parameters |
| in procedure, n. |
| *) |
| |
| PROCEDURE addVarParameters (n: node; i: node; type: node; isused: BOOLEAN) ; |
| VAR |
| p: node ; |
| BEGIN |
| assert (isIdentList (i)) ; |
| assert (isProcedure (n)) ; |
| checkMakeVariables (n, i, type, TRUE, isused) ; |
| IF n^.procedureF.checking |
| THEN |
| checkParameters (n, i, type, TRUE, isused) (* will destroy, i. *) |
| ELSE |
| p := makeVarParameter (i, type, n, isused) ; |
| IncludeIndiceIntoIndex (n^.procedureF.parameters, p) ; |
| END ; |
| END addVarParameters ; |
| |
| |
| (* |
| addNonVarParameters - adds the identlist, i, of, type, to be parameters |
| in procedure, n. |
| *) |
| |
| PROCEDURE addNonVarParameters (n: node; i: node; type: node; isused: BOOLEAN) ; |
| VAR |
| p: node ; |
| BEGIN |
| assert (isIdentList (i)) ; |
| assert (isProcedure (n)) ; |
| checkMakeVariables (n, i, type, FALSE, isused) ; |
| IF n^.procedureF.checking |
| THEN |
| checkParameters (n, i, type, FALSE, isused) (* will destroy, i. *) |
| ELSE |
| p := makeNonVarParameter (i, type, n, isused) ; |
| IncludeIndiceIntoIndex (n^.procedureF.parameters, p) |
| END ; |
| END addNonVarParameters ; |
| |
| |
| (* |
| makeSubrange - returns a subrange node, built from range: low..high. |
| *) |
| |
| PROCEDURE makeSubrange (low, high: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (subrange) ; |
| n^.subrangeF.low := low ; |
| n^.subrangeF.high := high ; |
| n^.subrangeF.type := NIL ; |
| n^.subrangeF.scope := getDeclScope () ; |
| RETURN n |
| END makeSubrange ; |
| |
| |
| (* |
| putSubrangeType - assigns, type, to the subrange type, sub. |
| *) |
| |
| PROCEDURE putSubrangeType (sub, type: node) ; |
| BEGIN |
| assert (isSubrange (sub)) ; |
| sub^.subrangeF.type := type |
| END putSubrangeType ; |
| |
| |
| (* |
| makeSet - returns a set of, type, node. |
| *) |
| |
| PROCEDURE makeSet (type: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (set) ; |
| n^.setF.type := type ; |
| n^.setF.scope := getDeclScope () ; |
| RETURN n |
| END makeSet ; |
| |
| |
| (* |
| makeSetValue - creates and returns a setvalue node. |
| *) |
| |
| PROCEDURE makeSetValue () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (setvalue) ; |
| n^.setvalueF.type := bitsetN ; |
| n^.setvalueF.values := InitIndex (1) ; |
| RETURN n |
| END makeSetValue ; |
| |
| |
| (* |
| isSetValue - returns TRUE if, n, is a setvalue node. |
| *) |
| |
| PROCEDURE isSetValue (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = setvalue |
| END isSetValue ; |
| |
| |
| (* |
| putSetValue - assigns the type, t, to the set value, n. The |
| node, n, is returned. |
| *) |
| |
| PROCEDURE putSetValue (n, t: node) : node ; |
| BEGIN |
| assert (isSetValue (n)) ; |
| n^.setvalueF.type := t ; |
| RETURN n |
| END putSetValue ; |
| |
| |
| (* |
| includeSetValue - includes the range l..h into the setvalue. |
| h might be NIL indicating that a single element |
| is to be included into the set. |
| n is returned. |
| *) |
| |
| PROCEDURE includeSetValue (n: node; l, h: node) : node ; |
| BEGIN |
| assert (isSetValue (n)) ; |
| IncludeIndiceIntoIndex (n^.setvalueF.values, l) ; |
| RETURN n |
| END includeSetValue ; |
| |
| |
| (* |
| makePointer - returns a pointer of, type, node. |
| *) |
| |
| PROCEDURE makePointer (type: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (pointer) ; |
| n^.pointerF.type := type ; |
| n^.pointerF.scope := getDeclScope () ; |
| RETURN n |
| END makePointer ; |
| |
| |
| (* |
| makeArray - returns a node representing ARRAY subr OF type. |
| *) |
| |
| PROCEDURE makeArray (subr, type: node) : node ; |
| VAR |
| n, s: node ; |
| BEGIN |
| s := skipType (subr) ; |
| assert (isSubrange (s) OR isOrdinal (s) OR isEnumeration (s)) ; |
| n := newNode (array) ; |
| n^.arrayF.subr := subr ; |
| n^.arrayF.type := type ; |
| n^.arrayF.scope := getDeclScope () ; |
| n^.arrayF.isUnbounded := FALSE ; |
| RETURN n |
| END makeArray ; |
| |
| |
| (* |
| makeRecord - creates and returns a record node. |
| *) |
| |
| PROCEDURE makeRecord () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (record) ; |
| n^.recordF.localSymbols := initTree () ; |
| n^.recordF.listOfSons := InitIndex (1) ; |
| n^.recordF.scope := getDeclScope () ; |
| RETURN n |
| END makeRecord ; |
| |
| |
| (* |
| addFieldsToRecord - adds fields, i, of type, t, into a record, r. |
| It returns, r. |
| *) |
| |
| PROCEDURE addFieldsToRecord (r, v, i, t: node) : node ; |
| VAR |
| p, fj: node ; |
| j, n : CARDINAL ; |
| fn : Name ; |
| BEGIN |
| IF isRecord (r) |
| THEN |
| p := r ; |
| v := NIL |
| ELSE |
| p := getRecord (getParent (r)) ; |
| assert (isVarientField (r)) ; |
| assert (isVarient (v)) ; |
| putFieldVarient (r, v) |
| END ; |
| n := wlists.noOfItemsInList (i^.identlistF.names) ; |
| j := 1 ; |
| WHILE j<=n DO |
| fn := wlists.getItemFromList (i^.identlistF.names, j) ; |
| fj := getSymKey (p^.recordF.localSymbols, n) ; |
| IF fj=NIL |
| THEN |
| fj := putFieldRecord (r, fn, t, v) |
| ELSE |
| metaErrors2 ('record field {%1ad} has already been declared inside a {%2Dd} {%2a}', |
| 'attempting to declare a duplicate record field', fj, p) |
| END ; |
| INC (j) |
| END ; |
| RETURN r; |
| END addFieldsToRecord ; |
| |
| |
| (* |
| makeVarient - creates a new symbol, a varient symbol for record or varient field |
| symbol, r. |
| *) |
| |
| PROCEDURE makeVarient (r: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (varient) ; |
| WITH n^ DO |
| varientF.listOfSons := InitIndex (1) ; |
| (* do we need to remember our parent (r) ? *) |
| (* if so use this n^.varientF.parent := r *) |
| IF isRecord (r) |
| THEN |
| varientF.varient := NIL |
| ELSE |
| varientF.varient := r |
| END ; |
| varientF.tag := NIL ; |
| varientF.scope := getDeclScope () ; |
| END ; |
| (* now add, n, to the record/varient, r, field list *) |
| WITH r^ DO |
| CASE kind OF |
| |
| record : IncludeIndiceIntoIndex (recordF.listOfSons, n) | |
| varientfield: IncludeIndiceIntoIndex (varientfieldF.listOfSons, n) |
| |
| END |
| END ; |
| RETURN n |
| END makeVarient ; |
| |
| |
| (* |
| buildVarientFieldRecord - builds a varient field into a varient symbol, v. |
| The varient field is returned. |
| *) |
| |
| PROCEDURE buildVarientFieldRecord (v: node; p: node) : node ; |
| VAR |
| f: node ; |
| BEGIN |
| assert (isVarient (v)) ; |
| f := makeVarientField (v, p) ; |
| assert (isVarientField (f)) ; |
| putFieldVarient (f, v) ; |
| RETURN f |
| END buildVarientFieldRecord ; |
| |
| |
| (* |
| makeVarientField - create a varient field within varient, v, |
| The new varient field is returned. |
| *) |
| |
| PROCEDURE makeVarientField (v: node; p: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (varientfield) ; |
| WITH n^.varientfieldF DO |
| name := NulName ; |
| parent := p ; |
| varient := v ; |
| simple := FALSE ; |
| listOfSons := InitIndex (1) ; |
| scope := getDeclScope () |
| END ; |
| RETURN n |
| END makeVarientField ; |
| |
| |
| (* |
| putFieldVarient - places the field varient, f, as a brother to, the |
| varient symbol, v, and also tells, f, that its varient |
| parent is, v. |
| *) |
| |
| PROCEDURE putFieldVarient (f, v: node) ; |
| BEGIN |
| assert (isVarient (v)) ; |
| assert (isVarientField (f)) ; |
| WITH v^ DO |
| CASE kind OF |
| |
| varient: IncludeIndiceIntoIndex (varientF.listOfSons, f) |
| |
| END |
| END ; |
| WITH f^ DO |
| CASE kind OF |
| |
| varientfield: varientfieldF.varient := v |
| |
| END |
| END |
| END putFieldVarient ; |
| |
| |
| (* |
| putFieldRecord - create a new recordfield and place it into record r. |
| The new field has a tagname and type and can have a |
| variant field v. |
| *) |
| |
| PROCEDURE putFieldRecord (r: node; tag: Name; type, v: node) : node ; |
| VAR |
| f, n, p: node ; |
| BEGIN |
| n := newNode (recordfield) ; |
| WITH r^ DO |
| CASE kind OF |
| |
| record: IncludeIndiceIntoIndex (recordF.listOfSons, n) ; |
| (* ensure that field, n, is in the parents Local Symbols. *) |
| IF tag#NulName |
| THEN |
| IF getSymKey (recordF.localSymbols, tag) = NulKey |
| THEN |
| putSymKey (recordF.localSymbols, tag, n) |
| ELSE |
| f := getSymKey (recordF.localSymbols, tag) ; |
| metaErrors1 ('field record {%1Dad} has already been declared', |
| 'field record duplicate', f) |
| END |
| END | |
| varientfield: IncludeIndiceIntoIndex (varientfieldF.listOfSons, n) ; |
| p := getParent (r) ; |
| assert (p^.kind=record) ; |
| IF tag#NulName |
| THEN |
| putSymKey (p^.recordF.localSymbols, tag, n) |
| END |
| |
| END |
| END ; |
| (* fill in, n. *) |
| n^.recordfieldF.type := type ; |
| n^.recordfieldF.name := tag ; |
| n^.recordfieldF.parent := r ; |
| n^.recordfieldF.varient := v ; |
| n^.recordfieldF.tag := FALSE ; |
| n^.recordfieldF.scope := NIL ; |
| initCname (n^.recordfieldF.cname) ; |
| (* |
| IF r^.kind=record |
| THEN |
| doRecordM2 (doP, r) |
| END ; |
| *) |
| RETURN n |
| END putFieldRecord ; |
| |
| |
| (* |
| buildVarientSelector - builds a field of name, tag, of, type onto: |
| record or varient field, r. |
| varient, v. |
| *) |
| |
| PROCEDURE buildVarientSelector (r, v: node; tag: Name; type: node) ; |
| VAR |
| f: node ; |
| BEGIN |
| assert (isRecord (r) OR isVarientField (r)) ; |
| IF isRecord (r) OR isVarientField (r) |
| THEN |
| IF (type=NIL) AND (tag=NulName) |
| THEN |
| metaError1 ('expecting a tag field in the declaration of a varient record {%1Ua}', r) |
| ELSIF type=NIL |
| THEN |
| f := lookupSym (tag) ; |
| putVarientTag (v, f) |
| ELSE |
| f := putFieldRecord (r, tag, type, v) ; |
| assert (isRecordField (f)) ; |
| f^.recordfieldF.tag := TRUE ; |
| putVarientTag (v, f) |
| END |
| END |
| END buildVarientSelector ; |
| |
| |
| (* |
| ensureOrder - ensures that, a, and, b, exist in, i, and also |
| ensure that, a, is before, b. |
| *) |
| |
| PROCEDURE ensureOrder (i: Index; a, b: node) ; |
| BEGIN |
| assert (IsIndiceInIndex (i, a)) ; |
| assert (IsIndiceInIndex (i, b)) ; |
| RemoveIndiceFromIndex (i, a) ; |
| RemoveIndiceFromIndex (i, b) ; |
| IncludeIndiceIntoIndex (i, a) ; |
| IncludeIndiceIntoIndex (i, b) ; |
| assert (IsIndiceInIndex (i, a)) ; |
| assert (IsIndiceInIndex (i, b)) |
| END ensureOrder ; |
| |
| |
| (* |
| putVarientTag - places tag into variant v. |
| *) |
| |
| PROCEDURE putVarientTag (v: node; tag: node) ; |
| VAR |
| p: node ; |
| BEGIN |
| assert (isVarient (v)) ; |
| CASE v^.kind OF |
| |
| varient: v^.varientF.tag := tag |
| |
| END |
| END putVarientTag ; |
| |
| |
| (* |
| getParent - returns the parent field of recordfield or varientfield symbol, n. |
| *) |
| |
| PROCEDURE getParent (n: node) : node ; |
| BEGIN |
| CASE n^.kind OF |
| |
| recordfield: RETURN n^.recordfieldF.parent | |
| varientfield: RETURN n^.varientfieldF.parent |
| |
| END |
| END getParent ; |
| |
| |
| (* |
| getRecord - returns the record associated with node, n. |
| (Parental record). |
| *) |
| |
| PROCEDURE getRecord (n: node) : node ; |
| BEGIN |
| assert (n^.kind # varient) ; (* if this fails then we need to add parent field to varient. *) |
| CASE n^.kind OF |
| |
| record : RETURN n | |
| varientfield: RETURN getRecord (getParent (n)) |
| |
| END |
| END getRecord ; |
| |
| |
| (* |
| putUnbounded - sets array, n, as unbounded. |
| *) |
| |
| PROCEDURE putUnbounded (n: node) ; |
| BEGIN |
| assert (n^.kind = array) ; |
| n^.arrayF.isUnbounded := TRUE |
| END putUnbounded ; |
| |
| |
| (* |
| isConstExp - return TRUE if the node kind is a constexp. |
| *) |
| |
| PROCEDURE isConstExp (c: node) : BOOLEAN ; |
| BEGIN |
| assert (c#NIL) ; |
| RETURN c^.kind = constexp |
| END isConstExp ; |
| |
| |
| (* |
| addEnumToModule - adds enumeration type, e, into the list of enums |
| in module, m. |
| *) |
| |
| PROCEDURE addEnumToModule (m, e: node) ; |
| BEGIN |
| assert (isEnumeration (e) OR isEnumerationField (e)) ; |
| assert (isModule (m) OR isDef (m) OR isImp (m)) ; |
| IF isModule (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.moduleF.enumFixup.info, e) |
| ELSIF isDef (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.defF.enumFixup.info, e) |
| ELSIF isImp (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.impF.enumFixup.info, e) |
| END |
| END addEnumToModule ; |
| |
| |
| (* |
| getNextFixup - return the next fixup from from f. |
| *) |
| |
| PROCEDURE getNextFixup (VAR f: fixupInfo) : node ; |
| BEGIN |
| INC (f.count) ; |
| RETURN GetIndice (f.info, f.count) |
| END getNextFixup ; |
| |
| |
| (* |
| getNextEnum - returns the next enumeration node. |
| *) |
| |
| PROCEDURE getNextEnum () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := NIL ; |
| assert (isDef (currentModule) OR isImp (currentModule) OR isModule (currentModule)) ; |
| WITH currentModule^ DO |
| IF isDef (currentModule) |
| THEN |
| n := getNextFixup (defF.enumFixup) |
| ELSIF isImp (currentModule) |
| THEN |
| n := getNextFixup (impF.enumFixup) |
| ELSIF isModule (currentModule) |
| THEN |
| n := getNextFixup (moduleF.enumFixup) |
| END |
| END ; |
| assert (n # NIL) ; |
| assert (isEnumeration (n) OR isEnumerationField (n)) ; |
| RETURN n |
| END getNextEnum ; |
| |
| |
| (* |
| resetEnumPos - resets the index into the saved list of enums inside |
| module, n. |
| *) |
| |
| PROCEDURE resetEnumPos (n: node) ; |
| BEGIN |
| assert (isDef (n) OR isImp (n) OR isModule (n)) ; |
| IF isDef (n) |
| THEN |
| n^.defF.enumFixup.count := 0 |
| ELSIF isImp (n) |
| THEN |
| n^.impF.enumFixup.count := 0 |
| ELSIF isModule (n) |
| THEN |
| n^.moduleF.enumFixup.count := 0 |
| END |
| END resetEnumPos ; |
| |
| |
| (* |
| getEnumsComplete - gets the field from the def or imp or module, n. |
| *) |
| |
| PROCEDURE getEnumsComplete (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| def : RETURN n^.defF.enumsComplete | |
| imp : RETURN n^.impF.enumsComplete | |
| module: RETURN n^.moduleF.enumsComplete |
| |
| END |
| END getEnumsComplete ; |
| |
| |
| (* |
| setEnumsComplete - sets the field inside the def or imp or module, n. |
| *) |
| |
| PROCEDURE setEnumsComplete (n: node) ; |
| BEGIN |
| CASE n^.kind OF |
| |
| def : n^.defF.enumsComplete := TRUE | |
| imp : n^.impF.enumsComplete := TRUE | |
| module: n^.moduleF.enumsComplete := TRUE |
| |
| END |
| END setEnumsComplete ; |
| |
| |
| (* |
| doMakeEnum - create an enumeration type and add it to the current module. |
| *) |
| |
| PROCEDURE doMakeEnum () : node ; |
| VAR |
| e: node ; |
| BEGIN |
| e := newNode (enumeration) ; |
| WITH e^ DO |
| enumerationF.noOfElements := 0 ; |
| enumerationF.localSymbols := initTree () ; |
| enumerationF.scope := getDeclScope () ; |
| enumerationF.listOfSons := InitIndex (1) ; |
| enumerationF.low := NIL ; |
| enumerationF.high := NIL ; |
| END ; |
| addEnumToModule (currentModule, e) ; |
| RETURN e |
| END doMakeEnum ; |
| |
| |
| (* |
| makeEnum - creates an enumerated type and returns the node. |
| *) |
| |
| PROCEDURE makeEnum () : node ; |
| BEGIN |
| IF (currentModule#NIL) AND getEnumsComplete (currentModule) |
| THEN |
| RETURN getNextEnum () |
| ELSE |
| RETURN doMakeEnum () |
| END |
| END makeEnum ; |
| |
| |
| (* |
| doMakeEnumField - create an enumeration field name and add it to enumeration e. |
| Return the new field. |
| *) |
| |
| PROCEDURE doMakeEnumField (e: node; n: Name) : node ; |
| VAR |
| f: node ; |
| BEGIN |
| assert (isEnumeration (e)) ; |
| f := lookupSym (n) ; |
| IF f=NIL |
| THEN |
| f := newNode (enumerationfield) ; |
| putSymKey (e^.enumerationF.localSymbols, n, f) ; |
| IncludeIndiceIntoIndex (e^.enumerationF.listOfSons, f) ; |
| WITH f^ DO |
| enumerationfieldF.name := n ; |
| enumerationfieldF.type := e ; |
| enumerationfieldF.scope := getDeclScope () ; |
| enumerationfieldF.value := e^.enumerationF.noOfElements ; |
| initCname (enumerationfieldF.cname) |
| END ; |
| INC (e^.enumerationF.noOfElements) ; |
| assert (GetIndice (e^.enumerationF.listOfSons, e^.enumerationF.noOfElements) = f) ; |
| addEnumToModule (currentModule, f) ; |
| IF e^.enumerationF.low = NIL |
| THEN |
| e^.enumerationF.low := f |
| END ; |
| e^.enumerationF.high := f ; |
| RETURN addToScope (f) |
| ELSE |
| metaErrors2 ('cannot create enumeration field {%1k} as the name is already in use', |
| '{%2DMad} was declared elsewhere', n, f) |
| END ; |
| RETURN f |
| END doMakeEnumField ; |
| |
| |
| (* |
| makeEnumField - returns an enumeration field, named, n. |
| *) |
| |
| PROCEDURE makeEnumField (e: node; n: Name) : node ; |
| BEGIN |
| IF (currentModule#NIL) AND getEnumsComplete (currentModule) |
| THEN |
| RETURN getNextEnum () |
| ELSE |
| RETURN doMakeEnumField (e, n) |
| END |
| END makeEnumField ; |
| |
| |
| (* |
| isEnumeration - returns TRUE if node, n, is an enumeration type. |
| *) |
| |
| PROCEDURE isEnumeration (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind = enumeration |
| END isEnumeration ; |
| |
| |
| (* |
| makeExpList - creates and returns an expList node. |
| *) |
| |
| PROCEDURE makeExpList () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (explist) ; |
| n^.explistF.exp := InitIndex (1) ; |
| RETURN n |
| END makeExpList ; |
| |
| |
| (* |
| isExpList - returns TRUE if, n, is an explist node. |
| *) |
| |
| PROCEDURE isExpList (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = explist |
| END isExpList ; |
| |
| |
| (* |
| putExpList - places, expression, e, within the explist, n. |
| *) |
| |
| PROCEDURE putExpList (n: node; e: node) ; |
| BEGIN |
| assert (n # NIL) ; |
| assert (isExpList (n)) ; |
| PutIndice (n^.explistF.exp, HighIndice (n^.explistF.exp) + 1, e) |
| END putExpList ; |
| |
| |
| (* |
| getExpList - returns the, n, th argument in an explist. |
| *) |
| |
| PROCEDURE getExpList (p: node; n: CARDINAL) : node ; |
| BEGIN |
| assert (p#NIL) ; |
| assert (isExpList (p)) ; |
| assert (n <= HighIndice (p^.explistF.exp)) ; |
| RETURN GetIndice (p^.explistF.exp, n) |
| END getExpList ; |
| |
| |
| (* |
| expListLen - returns the length of explist, p. |
| *) |
| |
| PROCEDURE expListLen (p: node) : CARDINAL ; |
| BEGIN |
| IF p = NIL |
| THEN |
| RETURN 0 |
| ELSE |
| assert (isExpList (p)) ; |
| RETURN HighIndice (p^.explistF.exp) |
| END |
| END expListLen ; |
| |
| |
| (* |
| getConstExpComplete - gets the field from the def or imp or module, n. |
| *) |
| |
| PROCEDURE getConstExpComplete (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| def : RETURN n^.defF.constsComplete | |
| imp : RETURN n^.impF.constsComplete | |
| module: RETURN n^.moduleF.constsComplete |
| |
| END |
| END getConstExpComplete ; |
| |
| |
| (* |
| setConstExpComplete - sets the field inside the def or imp or module, n. |
| *) |
| |
| PROCEDURE setConstExpComplete (n: node) ; |
| BEGIN |
| CASE n^.kind OF |
| |
| def : n^.defF.constsComplete := TRUE | |
| imp : n^.impF.constsComplete := TRUE | |
| module: n^.moduleF.constsComplete := TRUE |
| |
| END |
| END setConstExpComplete ; |
| |
| |
| (* |
| getNextConstExp - returns the next constexp node. |
| *) |
| |
| PROCEDURE getNextConstExp () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| assert (isDef (currentModule) OR isImp (currentModule) OR isModule (currentModule)) ; |
| WITH currentModule^ DO |
| IF isDef (currentModule) |
| THEN |
| RETURN getNextFixup (defF.constFixup) |
| ELSIF isImp (currentModule) |
| THEN |
| RETURN getNextFixup (impF.constFixup) |
| ELSIF isModule (currentModule) |
| THEN |
| RETURN getNextFixup (moduleF.constFixup) |
| END |
| END ; |
| RETURN n |
| END getNextConstExp ; |
| |
| |
| (* |
| resetConstExpPos - resets the index into the saved list of constexps inside |
| module, n. |
| *) |
| |
| PROCEDURE resetConstExpPos (n: node) ; |
| BEGIN |
| assert (isDef (n) OR isImp (n) OR isModule (n)) ; |
| IF isDef (n) |
| THEN |
| n^.defF.constFixup.count := 0 |
| ELSIF isImp (n) |
| THEN |
| n^.impF.constFixup.count := 0 |
| ELSIF isModule (n) |
| THEN |
| n^.moduleF.constFixup.count := 0 |
| END |
| END resetConstExpPos ; |
| |
| |
| (* |
| addConstToModule - adds const exp, e, into the list of constant |
| expressions in module, m. |
| *) |
| |
| PROCEDURE addConstToModule (m, e: node) ; |
| BEGIN |
| assert (isModule (m) OR isDef (m) OR isImp (m)) ; |
| IF isModule (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.moduleF.constFixup.info, e) |
| ELSIF isDef (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.defF.constFixup.info, e) |
| ELSIF isImp (m) |
| THEN |
| IncludeIndiceIntoIndex (m^.impF.constFixup.info, e) |
| END |
| END addConstToModule ; |
| |
| |
| (* |
| doMakeConstExp - create a constexp node and add it to the current module. |
| *) |
| |
| PROCEDURE doMakeConstExp () : node ; |
| VAR |
| c: node ; |
| BEGIN |
| c := makeUnary (constexp, NIL, NIL) ; |
| addConstToModule (currentModule, c) ; |
| RETURN c |
| END doMakeConstExp ; |
| |
| |
| (* |
| makeConstExp - returns a constexp node. |
| *) |
| |
| PROCEDURE makeConstExp () : node ; |
| BEGIN |
| IF (currentModule#NIL) AND getConstExpComplete (currentModule) |
| THEN |
| RETURN getNextConstExp () |
| ELSE |
| RETURN doMakeConstExp () |
| END |
| END makeConstExp ; |
| |
| |
| (* |
| fixupConstExp - assign fixup expression, e, into the argument of, c. |
| *) |
| |
| PROCEDURE fixupConstExp (c, e: node) : node ; |
| BEGIN |
| assert (isConstExp (c)) ; |
| c^.unaryF.arg := e ; |
| RETURN c |
| END fixupConstExp ; |
| |
| |
| (* |
| isAnyType - return TRUE if node n is any type kind. |
| *) |
| |
| PROCEDURE isAnyType (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| CASE n^.kind OF |
| |
| address, |
| loc, |
| byte, |
| word, |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| complex, |
| longcomplex, |
| shortcomplex, |
| bitset, |
| boolean, |
| proc, |
| type : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isAnyType ; |
| |
| |
| (* |
| makeVal - creates a VAL (type, expression) node. |
| *) |
| |
| PROCEDURE makeVal (params: node) : node ; |
| BEGIN |
| assert (isExpList (params)) ; |
| IF expListLen (params) = 2 |
| THEN |
| RETURN makeBinary (val, |
| getExpList (params, 1), |
| getExpList (params, 2), |
| getExpList (params, 1)) |
| ELSE |
| HALT |
| END |
| END makeVal ; |
| |
| |
| (* |
| makeCast - creates a cast node TYPENAME (expr). |
| *) |
| |
| PROCEDURE makeCast (c, p: node) : node ; |
| BEGIN |
| assert (isExpList (p)) ; |
| IF expListLen (p) = 1 |
| THEN |
| RETURN makeBinary (cast, c, getExpList (p, 1), c) |
| ELSE |
| HALT |
| END |
| END makeCast ; |
| |
| |
| (* |
| makeIntrisicProc - create an intrinsic node. |
| *) |
| |
| PROCEDURE makeIntrinsicProc (k: nodeT; noArgs: CARDINAL; p: node) : node ; |
| VAR |
| f: node ; |
| BEGIN |
| f := newNode (k) ; |
| f^.intrinsicF.args := p ; |
| f^.intrinsicF.noArgs := noArgs ; |
| f^.intrinsicF.type := NIL ; |
| f^.intrinsicF.postUnreachable := (k = halt) ; |
| initPair (f^.intrinsicF.intrinsicComment) ; |
| RETURN f |
| END makeIntrinsicProc ; |
| |
| |
| (* |
| makeIntrinsicUnaryType - create an intrisic unary type. |
| *) |
| |
| PROCEDURE makeIntrinsicUnaryType (k: nodeT; paramList: node; returnType: node) : node ; |
| BEGIN |
| RETURN makeUnary (k, getExpList (paramList, 1), returnType) |
| END makeIntrinsicUnaryType ; |
| |
| |
| (* |
| makeIntrinsicBinaryType - create an intrisic binary type. |
| *) |
| |
| PROCEDURE makeIntrinsicBinaryType (k: nodeT; paramList: node; returnType: node) : node ; |
| BEGIN |
| RETURN makeBinary (k, getExpList (paramList, 1), getExpList (paramList, 2), returnType) |
| END makeIntrinsicBinaryType ; |
| |
| |
| (* |
| checkIntrinsic - checks to see if the function call to, c, with |
| parameter list, n, is really an intrinic. If it |
| is an intrinic then an intrinic node is created |
| and returned. Otherwise NIL is returned. |
| *) |
| |
| PROCEDURE checkIntrinsic (c, n: node) : node ; |
| BEGIN |
| IF isAnyType (c) |
| THEN |
| RETURN makeCast (c, n) |
| ELSIF c = maxN |
| THEN |
| RETURN makeIntrinsicUnaryType (max, n, NIL) |
| ELSIF c = minN |
| THEN |
| RETURN makeIntrinsicUnaryType (min, n, NIL) |
| ELSIF c = haltN |
| THEN |
| RETURN makeIntrinsicProc (halt, expListLen (n), n) |
| ELSIF c = valN |
| THEN |
| RETURN makeVal (n) |
| ELSIF c = adrN |
| THEN |
| RETURN makeIntrinsicUnaryType (adr, n, addressN) |
| ELSIF c = sizeN |
| THEN |
| RETURN makeIntrinsicUnaryType (size, n, cardinalN) |
| ELSIF c = tsizeN |
| THEN |
| RETURN makeIntrinsicUnaryType (tsize, n, cardinalN) |
| ELSIF c = floatN |
| THEN |
| RETURN makeIntrinsicUnaryType (float, n, realN) |
| ELSIF c = truncN |
| THEN |
| RETURN makeIntrinsicUnaryType (trunc, n, integerN) |
| ELSIF c = ordN |
| THEN |
| RETURN makeIntrinsicUnaryType (ord, n, cardinalN) |
| ELSIF c = chrN |
| THEN |
| RETURN makeIntrinsicUnaryType (chr, n, charN) |
| ELSIF c = capN |
| THEN |
| RETURN makeIntrinsicUnaryType (cap, n, charN) |
| ELSIF c = absN |
| THEN |
| RETURN makeIntrinsicUnaryType (abs, n, NIL) |
| ELSIF c = imN |
| THEN |
| RETURN makeIntrinsicUnaryType (im, n, NIL) |
| ELSIF c = reN |
| THEN |
| RETURN makeIntrinsicUnaryType (re, n, NIL) |
| ELSIF c = cmplxN |
| THEN |
| RETURN makeIntrinsicBinaryType (cmplx, n, NIL) |
| ELSIF c = highN |
| THEN |
| RETURN makeIntrinsicUnaryType (high, n, cardinalN) |
| ELSIF c = incN |
| THEN |
| RETURN makeIntrinsicProc (inc, expListLen (n), n) |
| ELSIF c = decN |
| THEN |
| RETURN makeIntrinsicProc (dec, expListLen (n), n) |
| ELSIF c = inclN |
| THEN |
| RETURN makeIntrinsicProc (incl, expListLen (n), n) |
| ELSIF c = exclN |
| THEN |
| RETURN makeIntrinsicProc (excl, expListLen (n), n) |
| ELSIF c = newN |
| THEN |
| RETURN makeIntrinsicProc (new, 1, n) |
| ELSIF c = disposeN |
| THEN |
| RETURN makeIntrinsicProc (dispose, 1, n) |
| ELSIF c = lengthN |
| THEN |
| RETURN makeIntrinsicUnaryType (length, n, cardinalN) |
| ELSIF c = throwN |
| THEN |
| keyc.useThrow ; |
| RETURN makeIntrinsicProc (throw, 1, n) |
| END ; |
| RETURN NIL |
| END checkIntrinsic ; |
| |
| |
| (* |
| checkCHeaders - check to see if the function is a C system function and |
| requires a header file included. |
| *) |
| |
| PROCEDURE checkCHeaders (c: node) ; |
| VAR |
| name: Name ; |
| s : node ; |
| BEGIN |
| IF isProcedure (c) |
| THEN |
| s := getScope (c) ; |
| IF getSymName (s) = makeKey ('libc') |
| THEN |
| name := getSymName (c) ; |
| IF (name = makeKey ('read')) OR |
| (name = makeKey ('write')) OR |
| (name = makeKey ('open')) OR |
| (name = makeKey ('close')) |
| THEN |
| keyc.useUnistd |
| END |
| END |
| END |
| END checkCHeaders ; |
| |
| |
| (* |
| makeFuncCall - builds a function call to c with param list, n. |
| *) |
| |
| PROCEDURE makeFuncCall (c, n: node) : node ; |
| VAR |
| f: node ; |
| BEGIN |
| assert ((n=NIL) OR isExpList (n)) ; |
| IF (c = haltN) AND |
| (getMainModule () # lookupDef (makeKey ('M2RTS'))) AND |
| (getMainModule () # lookupImp (makeKey ('M2RTS'))) |
| THEN |
| addImportedModule (getMainModule (), lookupDef (makeKey ('M2RTS')), FALSE) |
| END ; |
| f := checkIntrinsic (c, n) ; |
| checkCHeaders (c) ; |
| IF f = NIL |
| THEN |
| f := newNode (funccall) ; |
| f^.funccallF.function := c ; |
| f^.funccallF.args := n ; |
| f^.funccallF.type := NIL ; |
| initPair (f^.funccallF.funccallComment) |
| END ; |
| RETURN f |
| END makeFuncCall ; |
| |
| |
| (* |
| isFuncCall - returns TRUE if, n, is a function/procedure call. |
| *) |
| |
| PROCEDURE isFuncCall (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = funccall |
| END isFuncCall ; |
| |
| |
| (* |
| putType - places, exp, as the type alias to des. |
| TYPE des = exp ; |
| *) |
| |
| PROCEDURE putType (des, exp: node) ; |
| BEGIN |
| assert (des#NIL) ; |
| assert (isType (des)) ; |
| des^.typeF.type := exp |
| END putType ; |
| |
| |
| (* |
| putTypeHidden - marks type, des, as being a hidden type. |
| TYPE des ; |
| *) |
| |
| PROCEDURE putTypeHidden (des: node) ; |
| VAR |
| s: node ; |
| BEGIN |
| assert (des#NIL) ; |
| assert (isType (des)) ; |
| des^.typeF.isHidden := TRUE ; |
| s := getScope (des) ; |
| assert (isDef (s)) ; |
| s^.defF.hasHidden := TRUE |
| END putTypeHidden ; |
| |
| |
| (* |
| isTypeHidden - returns TRUE if type, n, is hidden. |
| *) |
| |
| PROCEDURE isTypeHidden (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| assert (isType (n)) ; |
| RETURN n^.typeF.isHidden |
| END isTypeHidden ; |
| |
| |
| (* |
| hasHidden - returns TRUE if module, n, has a hidden type. |
| *) |
| |
| PROCEDURE hasHidden (n: node) : BOOLEAN ; |
| BEGIN |
| assert (isDef (n)) ; |
| RETURN n^.defF.hasHidden |
| END hasHidden ; |
| |
| |
| (* |
| putTypeInternal - marks type, des, as being an internally generated type. |
| *) |
| |
| PROCEDURE putTypeInternal (des: node) ; |
| BEGIN |
| assert (des#NIL) ; |
| assert (isType (des)) ; |
| des^.typeF.isInternal := TRUE |
| END putTypeInternal ; |
| |
| |
| (* |
| isTypeInternal - returns TRUE if type, n, is internal. |
| *) |
| |
| PROCEDURE isTypeInternal (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| assert (isType (n)) ; |
| RETURN n^.typeF.isInternal |
| END isTypeInternal ; |
| |
| |
| (* |
| putConst - places value, v, into node, n. |
| *) |
| |
| PROCEDURE putConst (n: node; v: node) ; |
| BEGIN |
| assert (isConst (n)) ; |
| n^.constF.value := v |
| END putConst ; |
| |
| |
| (* |
| makeLiteralInt - creates and returns a literal node based on an integer type. |
| *) |
| |
| PROCEDURE makeLiteralInt (n: Name) : node ; |
| VAR |
| m: node ; |
| s: String ; |
| BEGIN |
| m := newNode (literal) ; |
| s := InitStringCharStar (keyToCharStar (n)) ; |
| WITH m^ DO |
| literalF.name := n ; |
| IF DynamicStrings.char (s, -1)='C' |
| THEN |
| literalF.type := charN |
| ELSE |
| literalF.type := ztypeN |
| END |
| END ; |
| s := KillString (s) ; |
| RETURN m |
| END makeLiteralInt ; |
| |
| |
| (* |
| makeLiteralReal - creates and returns a literal node based on a real type. |
| *) |
| |
| PROCEDURE makeLiteralReal (n: Name) : node ; |
| VAR |
| m: node ; |
| BEGIN |
| m := newNode (literal) ; |
| WITH m^ DO |
| literalF.name := n ; |
| literalF.type := rtypeN |
| END ; |
| RETURN m |
| END makeLiteralReal ; |
| |
| |
| (* |
| makeString - creates and returns a node containing string, n. |
| *) |
| |
| PROCEDURE makeString (n: Name) : node ; |
| VAR |
| m: node ; |
| BEGIN |
| m := newNode (string) ; |
| WITH m^ DO |
| stringF.name := n ; |
| stringF.length := lengthKey (n) ; |
| stringF.isCharCompatible := (stringF.length <= 3) ; |
| stringF.cstring := toCstring (n) ; |
| stringF.clength := lenCstring (stringF.cstring) ; |
| IF stringF.isCharCompatible |
| THEN |
| stringF.cchar := toCchar (n) |
| ELSE |
| stringF.cchar := NIL |
| END |
| END ; |
| RETURN m |
| END makeString ; |
| |
| |
| (* |
| getBuiltinConst - creates and returns a builtin const if available. |
| *) |
| |
| PROCEDURE getBuiltinConst (n: Name) : node ; |
| BEGIN |
| IF n=makeKey ('BITS_PER_UNIT') |
| THEN |
| RETURN bitsperunitN |
| ELSIF n=makeKey ('BITS_PER_WORD') |
| THEN |
| RETURN bitsperwordN |
| ELSIF n=makeKey ('BITS_PER_CHAR') |
| THEN |
| RETURN bitspercharN |
| ELSIF n=makeKey ('UNITS_PER_WORD') |
| THEN |
| RETURN unitsperwordN |
| ELSE |
| RETURN NIL |
| END |
| END getBuiltinConst ; |
| |
| |
| (* |
| lookupInScope - looks up a symbol named, n, from, scope. |
| *) |
| |
| PROCEDURE lookupInScope (scope: node; n: Name) : node ; |
| BEGIN |
| CASE scope^.kind OF |
| |
| def : RETURN getSymKey (scope^.defF.decls.symbols, n) | |
| module : RETURN getSymKey (scope^.moduleF.decls.symbols, n) | |
| imp : RETURN getSymKey (scope^.impF.decls.symbols, n) | |
| procedure: RETURN getSymKey (scope^.procedureF.decls.symbols, n) | |
| record : RETURN getSymKey (scope^.recordF.localSymbols, n) |
| |
| END |
| END lookupInScope ; |
| |
| |
| (* |
| lookupBase - return node named n from the base symbol scope. |
| *) |
| |
| PROCEDURE lookupBase (n: Name) : node ; |
| VAR |
| m: node ; |
| BEGIN |
| m := getSymKey (baseSymbols, n) ; |
| IF m=procN |
| THEN |
| keyc.useProc |
| ELSIF (m=complexN) OR (m=longcomplexN) OR (m=shortcomplexN) |
| THEN |
| keyc.useComplex |
| END ; |
| RETURN m |
| END lookupBase ; |
| |
| |
| (* |
| dumpScopes - display the names of all the scopes stacked. |
| *) |
| |
| PROCEDURE dumpScopes ; |
| VAR |
| h: CARDINAL ; |
| s: node ; |
| BEGIN |
| h := HighIndice (scopeStack) ; |
| printf ("total scopes stacked %d\n", h); |
| |
| WHILE h>=1 DO |
| s := GetIndice (scopeStack, h) ; |
| out2 (" scope [%d] is %s\n", h, s) ; |
| DEC (h) |
| END |
| END dumpScopes ; |
| |
| |
| (* |
| out0 - write string a to StdOut. |
| *) |
| |
| PROCEDURE out0 (a: ARRAY OF CHAR) ; |
| VAR |
| m: String ; |
| BEGIN |
| m := Sprintf0 (InitString (a)) ; |
| m := KillString (WriteS (StdOut, m)) |
| END out0 ; |
| |
| |
| (* |
| out1 - write string a to StdOut using format specifier a. |
| *) |
| |
| PROCEDURE out1 (a: ARRAY OF CHAR; s: node) ; |
| VAR |
| m: String ; |
| d: CARDINAL ; |
| BEGIN |
| m := getFQstring (s) ; |
| IF EqualArray (m, '') |
| THEN |
| d := VAL (CARDINAL, VAL (LONGCARD, s)) ; |
| m := KillString (m) ; |
| m := Sprintf1 (InitString ('[%d]'), d) |
| END ; |
| m := Sprintf1 (InitString (a), m) ; |
| m := KillString (WriteS (StdOut, m)) |
| END out1 ; |
| |
| |
| (* |
| out2 - write string a to StdOut using format specifier a. |
| *) |
| |
| PROCEDURE out2 (a: ARRAY OF CHAR; c: CARDINAL; s: node) ; |
| VAR |
| m, m1: String ; |
| BEGIN |
| m1 := getString (s) ; |
| m := Sprintf2 (InitString (a), c, m1) ; |
| m := KillString (WriteS (StdOut, m)) ; |
| m1 := KillString (m1) |
| END out2 ; |
| |
| |
| (* |
| out3 - write string a to StdOut using format specifier a. |
| *) |
| |
| PROCEDURE out3 (a: ARRAY OF CHAR; l: CARDINAL; n: Name; s: node) ; |
| VAR |
| m, m1, m2: String ; |
| BEGIN |
| m1 := InitStringCharStar (keyToCharStar (n)) ; |
| m2 := getString (s) ; |
| m := Sprintf3 (InitString (a), l, m1, m2) ; |
| m := KillString (WriteS (StdOut, m)) ; |
| m1 := KillString (m1) ; |
| m2 := KillString (m2) |
| END out3 ; |
| |
| |
| (* |
| lookupSym - returns the symbol named, n, from the scope stack. |
| *) |
| |
| PROCEDURE lookupSym (n: Name) : node ; |
| VAR |
| s, m: node ; |
| l, h: CARDINAL ; |
| BEGIN |
| l := LowIndice (scopeStack) ; |
| h := HighIndice (scopeStack) ; |
| |
| WHILE h>=l DO |
| s := GetIndice (scopeStack, h) ; |
| m := lookupInScope (s, n) ; |
| IF debugScopes AND (m=NIL) |
| THEN |
| out3 (" [%d] search for symbol name %s in scope %s\n", h, n, s) |
| END ; |
| IF m#NIL |
| THEN |
| IF debugScopes |
| THEN |
| out3 (" [%d] search for symbol name %s in scope %s (found)\n", h, n, s) |
| END ; |
| RETURN m |
| END ; |
| DEC (h) |
| END ; |
| RETURN lookupBase (n) |
| END lookupSym ; |
| |
| |
| (* |
| getSymName - returns the name of symbol, n. |
| *) |
| |
| PROCEDURE getSymName (n: node) : Name ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| new : RETURN makeKey ('NEW') | |
| dispose : RETURN makeKey ('DISPOSE') | |
| length : RETURN makeKey ('LENGTH') | |
| inc : RETURN makeKey ('INC') | |
| dec : RETURN makeKey ('DEC') | |
| incl : RETURN makeKey ('INCL') | |
| excl : RETURN makeKey ('EXCL') | |
| nil : RETURN makeKey ('NIL') | |
| true : RETURN makeKey ('TRUE') | |
| false : RETURN makeKey ('FALSE') | |
| address : RETURN makeKey ('ADDRESS') | |
| loc : RETURN makeKey ('LOC') | |
| byte : RETURN makeKey ('BYTE') | |
| word : RETURN makeKey ('WORD') | |
| csizet : RETURN makeKey ('CSIZE_T') | |
| cssizet : RETURN makeKey ('CSSIZE_T') | |
| (* base types. *) |
| boolean : RETURN makeKey ('BOOLEAN') | |
| proc : RETURN makeKey ('PROC') | |
| char : RETURN makeKey ('CHAR') | |
| cardinal : RETURN makeKey ('CARDINAL') | |
| longcard : RETURN makeKey ('LONGCARD') | |
| shortcard : RETURN makeKey ('SHORTCARD') | |
| integer : RETURN makeKey ('INTEGER') | |
| longint : RETURN makeKey ('LONGINT') | |
| shortint : RETURN makeKey ('SHORTINT') | |
| real : RETURN makeKey ('REAL') | |
| longreal : RETURN makeKey ('LONGREAL') | |
| shortreal : RETURN makeKey ('SHORTREAL') | |
| bitset : RETURN makeKey ('BITSET') | |
| ztype : RETURN makeKey ('_ZTYPE') | |
| rtype : RETURN makeKey ('_RTYPE') | |
| complex : RETURN makeKey ('COMPLEX') | |
| longcomplex : RETURN makeKey ('LONGCOMPLEX') | |
| shortcomplex : RETURN makeKey ('SHORTCOMPLEX') | |
| |
| (* language features and compound type attributes. *) |
| type : RETURN typeF.name | |
| record : RETURN NulName | |
| varient : RETURN NulName | |
| var : RETURN varF.name | |
| enumeration : RETURN NulName | |
| subrange : RETURN NulName | |
| pointer : RETURN NulName | |
| array : RETURN NulName | |
| string : RETURN stringF.name | |
| const : RETURN constF.name | |
| literal : RETURN literalF.name | |
| varparam : RETURN NulName | |
| param : RETURN NulName | |
| optarg : RETURN NulName | |
| recordfield : RETURN recordfieldF.name | |
| varientfield : RETURN varientfieldF.name | |
| enumerationfield: RETURN enumerationfieldF.name | |
| set : RETURN NulName | |
| proctype : RETURN NulName | |
| subscript : RETURN NulName | |
| (* blocks. *) |
| procedure : RETURN procedureF.name | |
| def : RETURN defF.name | |
| imp : RETURN impF.name | |
| module : RETURN moduleF.name | |
| (* statements. *) |
| loop, |
| while, |
| for, |
| repeat, |
| if, |
| elsif, |
| assignment : RETURN NulName | |
| (* expressions. *) |
| constexp, |
| deref, |
| arrayref, |
| componentref, |
| cast, |
| val, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide, |
| in, |
| neg, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal : RETURN NulName | |
| adr : RETURN makeKey ('ADR') | |
| size : RETURN makeKey ('SIZE') | |
| tsize : RETURN makeKey ('TSIZE') | |
| chr : RETURN makeKey ('CHR') | |
| abs : RETURN makeKey ('ABS') | |
| ord : RETURN makeKey ('ORD') | |
| float : RETURN makeKey ('FLOAT') | |
| trunc : RETURN makeKey ('TRUNC') | |
| high : RETURN makeKey ('HIGH') | |
| throw : RETURN makeKey ('THROW') | |
| unreachable : RETURN makeKey ('builtin_unreachable') | |
| cmplx : RETURN makeKey ('CMPLX') | |
| re : RETURN makeKey ('RE') | |
| im : RETURN makeKey ('IM') | |
| max : RETURN makeKey ('MAX') | |
| min : RETURN makeKey ('MIN') | |
| funccall : RETURN NulName | |
| identlist : RETURN NulName |
| |
| ELSE |
| HALT |
| END |
| END |
| END getSymName ; |
| |
| |
| (* |
| isUnary - returns TRUE if, n, is an unary node. |
| *) |
| |
| PROCEDURE isUnary (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| CASE n^.kind OF |
| |
| length, |
| re, |
| im, |
| deref, |
| high, |
| chr, |
| cap, |
| abs, |
| ord, |
| float, |
| trunc, |
| constexp, |
| not, |
| neg, |
| adr, |
| size, |
| tsize, |
| min, |
| max : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isUnary ; |
| |
| |
| (* |
| isBinary - returns TRUE if, n, is an binary node. |
| *) |
| |
| PROCEDURE isBinary (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| CASE n^.kind OF |
| |
| cmplx, |
| and, |
| or, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal, |
| val, |
| cast, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide, |
| in : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isBinary ; |
| |
| |
| (* |
| makeUnary - create a unary expression node with, e, as the argument |
| and res as the return type. |
| *) |
| |
| PROCEDURE makeUnary (k: nodeT; e: node; res: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| IF k=plus |
| THEN |
| RETURN e |
| ELSE |
| n := newNode (k) ; |
| WITH n^ DO |
| CASE kind OF |
| |
| min, |
| max, |
| throw, |
| re, |
| im, |
| deref, |
| high, |
| chr, |
| cap, |
| abs, |
| ord, |
| float, |
| trunc, |
| length, |
| constexp, |
| not, |
| neg, |
| adr, |
| size, |
| tsize: WITH unaryF DO |
| arg := e ; |
| resultType := res |
| END |
| |
| END |
| END |
| END ; |
| RETURN n |
| END makeUnary ; |
| |
| |
| (* |
| isLeafString - returns TRUE if n is a leaf node which is a string constant. |
| *) |
| |
| PROCEDURE isLeafString (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN isString (n) OR |
| (isLiteral (n) AND (getType (n) = charN)) OR |
| (isConst (n) AND (getExprType (n) = charN)) |
| END isLeafString ; |
| |
| |
| (* |
| getLiteralStringContents - return the contents of a literal node as a string. |
| *) |
| |
| PROCEDURE getLiteralStringContents (n: node) : String ; |
| VAR |
| number, |
| content, |
| s : String ; |
| BEGIN |
| assert (n^.kind = literal) ; |
| s := InitStringCharStar (keyToCharStar (n^.literalF.name)) ; |
| content := NIL ; |
| IF n^.literalF.type = charN |
| THEN |
| IF DynamicStrings.char (s, -1) = 'C' |
| THEN |
| IF DynamicStrings.Length (s) > 1 |
| THEN |
| number := DynamicStrings.Slice (s, 0, -1) ; |
| content := DynamicStrings.InitStringChar (VAL (CHAR, ostoc (number))) ; |
| number := DynamicStrings.KillString (number) |
| ELSE |
| content := DynamicStrings.InitStringChar ('C') |
| END |
| ELSE |
| content := DynamicStrings.Dup (s) |
| END |
| ELSE |
| metaError1 ('cannot obtain string contents from {%1k}', n^.literalF.name) |
| END ; |
| s := DynamicStrings.KillString (s) ; |
| RETURN content |
| END getLiteralStringContents ; |
| |
| |
| (* |
| getStringContents - return the string contents of a constant, literal, |
| string or a constexp node. |
| *) |
| |
| PROCEDURE getStringContents (n: node) : String ; |
| BEGIN |
| IF isConst (n) |
| THEN |
| RETURN getStringContents (n^.constF.value) |
| ELSIF isLiteral (n) |
| THEN |
| RETURN getLiteralStringContents (n) |
| ELSIF isString (n) |
| THEN |
| RETURN getString (n) |
| ELSIF isConstExp (n) |
| THEN |
| RETURN getStringContents (n^.unaryF.arg) |
| END ; |
| HALT |
| END getStringContents ; |
| |
| |
| (* |
| addNames - |
| *) |
| |
| PROCEDURE addNames (a, b: node) : Name ; |
| VAR |
| sa, sb: String ; |
| n : Name ; |
| BEGIN |
| sa := DynamicStrings.InitStringCharStar (keyToCharStar (getSymName (a))) ; |
| sb := DynamicStrings.InitStringCharStar (keyToCharStar (getSymName (b))) ; |
| sa := ConCat (sa, sb) ; |
| n := makekey (DynamicStrings.string (sa)) ; |
| sa := KillString (sa) ; |
| sb := KillString (sb) ; |
| RETURN n |
| END addNames ; |
| |
| |
| (* |
| resolveString - |
| *) |
| |
| PROCEDURE resolveString (n: node) : node ; |
| BEGIN |
| WHILE isConst (n) OR isConstExp (n) DO |
| IF isConst (n) |
| THEN |
| n := n^.constF.value |
| ELSE |
| n := n^.unaryF.arg |
| END |
| END ; |
| IF n^.kind = plus |
| THEN |
| n := makeString (addNames (resolveString (n^.binaryF.left), |
| resolveString (n^.binaryF.right))) |
| END ; |
| RETURN n |
| END resolveString ; |
| |
| |
| (* |
| foldBinary - |
| *) |
| |
| PROCEDURE foldBinary (k: nodeT; l, r: node; res: node) : node ; |
| VAR |
| n : node ; |
| ls, |
| rs: String ; |
| BEGIN |
| n := NIL ; |
| IF (k = plus) AND isLeafString (l) AND isLeafString (r) |
| THEN |
| ls := getStringContents (l) ; |
| rs := getStringContents (r) ; |
| ls := DynamicStrings.Add (ls, rs) ; |
| n := makeString (makekey (DynamicStrings.string (ls))) ; |
| ls := DynamicStrings.KillString (ls) ; |
| rs := DynamicStrings.KillString (rs) |
| END ; |
| RETURN n |
| END foldBinary ; |
| |
| |
| (* |
| makeBinary - create a binary node with left/right/result type: l, r and resultType. |
| *) |
| |
| PROCEDURE makeBinary (k: nodeT; l, r: node; resultType: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := foldBinary (k, l, r, resultType) ; |
| IF n = NIL |
| THEN |
| n := doMakeBinary (k, l, r, resultType) |
| END ; |
| RETURN n |
| END makeBinary ; |
| |
| |
| (* |
| doMakeBinary - returns a binary node containing left/right/result values |
| l, r, res, with a node operator, k. |
| *) |
| |
| PROCEDURE doMakeBinary (k: nodeT; l, r: node; res: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (k) ; |
| WITH n^ DO |
| CASE kind OF |
| |
| cmplx, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal, |
| and, |
| or, |
| cast, |
| val, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide, |
| in : WITH binaryF DO |
| left := l ; |
| right := r ; |
| resultType := res |
| END |
| |
| END |
| END ; |
| RETURN n |
| END doMakeBinary ; |
| |
| |
| (* |
| doMakeComponentRef - |
| *) |
| |
| PROCEDURE doMakeComponentRef (rec, field: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (componentref) ; |
| n^.componentrefF.rec := rec ; |
| n^.componentrefF.field := field ; |
| n^.componentrefF.resultType := getType (field) ; |
| RETURN n |
| END doMakeComponentRef ; |
| |
| |
| (* |
| makeComponentRef - build a componentref node which accesses, field, |
| within, record, rec. |
| *) |
| |
| PROCEDURE makeComponentRef (rec, field: node) : node ; |
| VAR |
| n, a: node ; |
| BEGIN |
| (* |
| n := getLastOp (rec) ; |
| IF (n#NIL) AND (isDeref (n) OR isPointerRef (n)) AND |
| (skipType (getType (rec)) = skipType (getType (n))) |
| THEN |
| a := n^.unaryF.arg ; |
| n^.kind := pointerref ; |
| n^.pointerrefF.ptr := a ; |
| n^.pointerrefF.field := field ; |
| n^.pointerrefF.resultType := getType (field) ; |
| RETURN n |
| ELSE |
| RETURN doMakeComponentRef (rec, field) |
| END |
| *) |
| IF isDeref (rec) |
| THEN |
| a := rec^.unaryF.arg ; |
| rec^.kind := pointerref ; |
| rec^.pointerrefF.ptr := a ; |
| rec^.pointerrefF.field := field ; |
| rec^.pointerrefF.resultType := getType (field) ; |
| RETURN rec |
| ELSE |
| RETURN doMakeComponentRef (rec, field) |
| END |
| END makeComponentRef ; |
| |
| |
| (* |
| isComponentRef - |
| *) |
| |
| PROCEDURE isComponentRef (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = componentref |
| END isComponentRef ; |
| |
| |
| (* |
| makePointerRef - build a pointerref node which accesses, field, |
| within, pointer to record, ptr. |
| *) |
| |
| PROCEDURE makePointerRef (ptr, field: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (pointerref) ; |
| n^.pointerrefF.ptr := ptr ; |
| n^.pointerrefF.field := field ; |
| n^.pointerrefF.resultType := getType (field) ; |
| RETURN n |
| END makePointerRef ; |
| |
| |
| (* |
| isPointerRef - returns TRUE if, n, is a pointerref node. |
| *) |
| |
| PROCEDURE isPointerRef (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = pointerref |
| END isPointerRef ; |
| |
| |
| (* |
| makeArrayRef - build an arrayref node which access element, |
| index, in, array. array is a variable/expression/constant |
| which has a type array. |
| *) |
| |
| PROCEDURE makeArrayRef (array, index: node) : node ; |
| VAR |
| n, t: node ; |
| i, j: CARDINAL ; |
| BEGIN |
| n := newNode (arrayref) ; |
| n^.arrayrefF.array := array ; |
| n^.arrayrefF.index := index ; |
| t := array ; |
| j := expListLen (index) ; |
| i := 1 ; |
| t := skipType (getType (t)) ; |
| REPEAT |
| IF isArray (t) |
| THEN |
| t := skipType (getType (t)) |
| ELSE |
| metaError2 ('cannot access {%1N} dimension of array {%2a}', i, t) |
| END ; |
| INC (i) |
| UNTIL i > j ; |
| n^.arrayrefF.resultType := t ; |
| RETURN n |
| END makeArrayRef ; |
| |
| |
| (* |
| isArrayRef - returns TRUE if the node was an arrayref. |
| *) |
| |
| PROCEDURE isArrayRef (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = arrayref |
| END isArrayRef ; |
| |
| |
| (* |
| makeDeRef - dereferences the pointer defined by, n. |
| *) |
| |
| PROCEDURE makeDeRef (n: node) : node ; |
| VAR |
| t: node ; |
| BEGIN |
| t := skipType (getType (n)) ; |
| assert (isPointer (t)) ; |
| RETURN makeUnary (deref, n, getType (t)) |
| END makeDeRef ; |
| |
| |
| (* |
| isDeref - returns TRUE if, n, is a deref node. |
| *) |
| |
| PROCEDURE isDeref (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = deref |
| END isDeref ; |
| |
| |
| (* |
| makeBase - create a base type or constant. |
| It only supports the base types and constants |
| enumerated below. |
| *) |
| |
| PROCEDURE makeBase (k: nodeT) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (k) ; |
| WITH n^ DO |
| CASE k OF |
| |
| new, |
| dispose, |
| length, |
| inc, |
| dec, |
| incl, |
| excl, |
| nil, |
| true, |
| false, |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet, |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| boolean, |
| proc, |
| ztype, |
| rtype, |
| complex, |
| longcomplex, |
| shortcomplex, |
| adr, |
| chr, |
| cap, |
| abs, |
| float, |
| trunc, |
| ord, |
| high, |
| throw, |
| re, |
| im, |
| cmplx, |
| size, |
| tsize, |
| val, |
| min, |
| max : (* legal kind. *) | |
| |
| ELSE |
| HALT |
| END |
| END ; |
| RETURN n |
| END makeBase ; |
| |
| |
| (* |
| makeBinaryTok - creates and returns a boolean type node with, |
| l, and, r, nodes. |
| *) |
| |
| PROCEDURE makeBinaryTok (op: toktype; l, r: node) : node ; |
| BEGIN |
| IF op=equaltok |
| THEN |
| RETURN makeBinary (equal, l, r, booleanN) |
| ELSIF (op=hashtok) OR (op=lessgreatertok) |
| THEN |
| RETURN makeBinary (notequal, l, r, booleanN) |
| ELSIF op=lesstok |
| THEN |
| RETURN makeBinary (less, l, r, booleanN) |
| ELSIF op=greatertok |
| THEN |
| RETURN makeBinary (greater, l, r, booleanN) |
| ELSIF op=greaterequaltok |
| THEN |
| RETURN makeBinary (greequal, l, r, booleanN) |
| ELSIF op=lessequaltok |
| THEN |
| RETURN makeBinary (lessequal, l, r, booleanN) |
| ELSIF op=andtok |
| THEN |
| RETURN makeBinary (and, l, r, booleanN) |
| ELSIF op=ortok |
| THEN |
| RETURN makeBinary (or, l, r, booleanN) |
| ELSIF op=plustok |
| THEN |
| RETURN makeBinary (plus, l, r, NIL) |
| ELSIF op=minustok |
| THEN |
| RETURN makeBinary (sub, l, r, NIL) |
| ELSIF op=divtok |
| THEN |
| RETURN makeBinary (div, l, r, NIL) |
| ELSIF op=timestok |
| THEN |
| RETURN makeBinary (mult, l, r, NIL) |
| ELSIF op=modtok |
| THEN |
| RETURN makeBinary (mod, l, r, NIL) |
| ELSIF op=intok |
| THEN |
| RETURN makeBinary (in, l, r, NIL) |
| ELSIF op=dividetok |
| THEN |
| RETURN makeBinary (divide, l, r, NIL) |
| ELSE |
| HALT (* most likely op needs a clause as above. *) |
| END |
| END makeBinaryTok ; |
| |
| |
| (* |
| makeUnaryTok - creates and returns a boolean type node with, |
| e, node. |
| *) |
| |
| PROCEDURE makeUnaryTok (op: toktype; e: node) : node ; |
| BEGIN |
| IF op=nottok |
| THEN |
| RETURN makeUnary (not, e, booleanN) |
| ELSIF op=plustok |
| THEN |
| RETURN makeUnary (plus, e, NIL) |
| ELSIF op=minustok |
| THEN |
| RETURN makeUnary (neg, e, NIL) |
| ELSE |
| HALT (* most likely op needs a clause as above. *) |
| END |
| END makeUnaryTok ; |
| |
| |
| (* |
| isOrdinal - returns TRUE if, n, is an ordinal type. |
| *) |
| |
| PROCEDURE isOrdinal (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet, |
| char, |
| integer, |
| longint, |
| shortint, |
| cardinal, |
| longcard, |
| shortcard, |
| bitset : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isOrdinal ; |
| |
| |
| (* |
| getType - returns the type associated with node, n. |
| *) |
| |
| PROCEDURE getType (n: node) : node ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| new, |
| dispose : RETURN NIL | |
| length : RETURN cardinalN | |
| inc, |
| dec, |
| incl, |
| excl : RETURN NIL | |
| nil : RETURN addressN | |
| true, |
| false : RETURN booleanN | |
| address : RETURN n | |
| loc : RETURN n | |
| byte : RETURN n | |
| word : RETURN n | |
| csizet : RETURN n | |
| cssizet : RETURN n | |
| (* base types. *) |
| boolean : RETURN n | |
| proc : RETURN n | |
| char : RETURN n | |
| cardinal : RETURN n | |
| longcard : RETURN n | |
| shortcard : RETURN n | |
| integer : RETURN n | |
| longint : RETURN n | |
| shortint : RETURN n | |
| real : RETURN n | |
| longreal : RETURN n | |
| shortreal : RETURN n | |
| bitset : RETURN n | |
| ztype : RETURN n | |
| rtype : RETURN n | |
| complex : RETURN n | |
| longcomplex : RETURN n | |
| shortcomplex : RETURN n | |
| |
| (* language features and compound type attributes. *) |
| type : RETURN typeF.type | |
| record : RETURN n | |
| varient : RETURN n | |
| var : RETURN varF.type | |
| enumeration : RETURN n | |
| subrange : RETURN subrangeF.type | |
| array : RETURN arrayF.type | |
| string : RETURN charN | |
| const : RETURN constF.type | |
| literal : RETURN literalF.type | |
| varparam : RETURN varparamF.type | |
| param : RETURN paramF.type | |
| optarg : RETURN optargF.type | |
| pointer : RETURN pointerF.type | |
| recordfield : RETURN recordfieldF.type | |
| varientfield : RETURN n | |
| enumerationfield: RETURN enumerationfieldF.type | |
| set : RETURN setF.type | |
| proctype : RETURN proctypeF.returnType | |
| subscript : RETURN subscriptF.type | |
| (* blocks. *) |
| procedure : RETURN procedureF.returnType | |
| throw : RETURN NIL | |
| unreachable : RETURN NIL | |
| def, |
| imp, |
| module, |
| (* statements. *) |
| loop, |
| while, |
| for, |
| repeat, |
| if, |
| elsif, |
| assignment : HALT | |
| (* expressions. *) |
| cmplx, |
| cast, |
| val, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide : RETURN binaryF.resultType | |
| in : RETURN booleanN | |
| max, |
| min, |
| re, |
| im, |
| abs, |
| constexp, |
| deref, |
| neg, |
| adr, |
| size, |
| tsize : RETURN unaryF.resultType | |
| and, |
| or, |
| not, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal : RETURN booleanN | |
| trunc : RETURN integerN | |
| float : RETURN realN | |
| high : RETURN cardinalN | |
| ord : RETURN cardinalN | |
| chr : RETURN charN | |
| cap : RETURN charN | |
| arrayref : RETURN arrayrefF.resultType | |
| componentref : RETURN componentrefF.resultType | |
| pointerref : RETURN pointerrefF.resultType | |
| funccall : RETURN funccallF.type | |
| setvalue : RETURN setvalueF.type |
| |
| END |
| END ; |
| HALT |
| END getType ; |
| |
| |
| (* |
| mixTypes - |
| *) |
| |
| PROCEDURE mixTypes (a, b: node) : node ; |
| BEGIN |
| IF (a = addressN) OR (b = addressN) |
| THEN |
| RETURN addressN |
| END ; |
| RETURN a |
| END mixTypes ; |
| |
| |
| (* |
| doSetExprType - |
| *) |
| |
| PROCEDURE doSetExprType (VAR t: node; n: node) : node ; |
| BEGIN |
| IF t = NIL |
| THEN |
| t := n |
| END ; |
| RETURN t |
| END doSetExprType ; |
| |
| |
| (* |
| getMaxMinType - |
| *) |
| |
| PROCEDURE getMaxMinType (n: node) : node ; |
| BEGIN |
| IF isVar (n) OR isConst (n) |
| THEN |
| RETURN getType (n) |
| ELSIF isConstExp (n) |
| THEN |
| n := getExprType (n^.unaryF.arg) ; |
| IF n = bitsetN |
| THEN |
| RETURN ztypeN |
| ELSE |
| RETURN n |
| END |
| ELSE |
| RETURN n |
| END |
| END getMaxMinType ; |
| |
| |
| (* |
| doGetFuncType - |
| *) |
| |
| PROCEDURE doGetFuncType (n: node) : node ; |
| BEGIN |
| assert (isFuncCall (n)) ; |
| RETURN doSetExprType (n^.funccallF.type, getType (n^.funccallF.function)) |
| END doGetFuncType ; |
| |
| |
| (* |
| doGetExprType - works out the type which is associated with node, n. |
| *) |
| |
| PROCEDURE doGetExprType (n: node) : node ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| max, |
| min : RETURN getMaxMinType (n^.unaryF.arg) | |
| cast, |
| val : RETURN doSetExprType (n^.binaryF.resultType, n^.binaryF.left) | |
| halt, |
| new, |
| dispose : RETURN NIL | |
| inc, |
| dec, |
| incl, |
| excl : RETURN NIL | |
| nil : RETURN addressN | |
| true, |
| false : RETURN booleanN | |
| address : RETURN n | |
| loc : RETURN n | |
| byte : RETURN n | |
| word : RETURN n | |
| csizet : RETURN n | |
| cssizet : RETURN n | |
| (* base types. *) |
| boolean : RETURN n | |
| proc : RETURN n | |
| char : RETURN n | |
| cardinal : RETURN n | |
| longcard : RETURN n | |
| shortcard : RETURN n | |
| integer : RETURN n | |
| longint : RETURN n | |
| shortint : RETURN n | |
| real : RETURN n | |
| longreal : RETURN n | |
| shortreal : RETURN n | |
| bitset : RETURN n | |
| ztype : RETURN n | |
| rtype : RETURN n | |
| complex : RETURN n | |
| longcomplex : RETURN n | |
| shortcomplex : RETURN n | |
| |
| (* language features and compound type attributes. *) |
| type : RETURN typeF.type | |
| record : RETURN n | |
| varient : RETURN n | |
| var : RETURN varF.type | |
| enumeration : RETURN n | |
| subrange : RETURN subrangeF.type | |
| array : RETURN arrayF.type | |
| string : RETURN charN | |
| const : RETURN doSetExprType (constF.type, getExprType (constF.value)) | |
| literal : RETURN literalF.type | |
| varparam : RETURN varparamF.type | |
| param : RETURN paramF.type | |
| optarg : RETURN optargF.type | |
| pointer : RETURN pointerF.type | |
| recordfield : RETURN recordfieldF.type | |
| varientfield : RETURN n | |
| enumerationfield: RETURN enumerationfieldF.type | |
| set : RETURN setF.type | |
| proctype : RETURN proctypeF.returnType | |
| subscript : RETURN subscriptF.type | |
| (* blocks. *) |
| procedure : RETURN procedureF.returnType | |
| throw : RETURN NIL | |
| unreachable : RETURN NIL | |
| def, |
| imp, |
| module, |
| (* statements. *) |
| loop, |
| while, |
| for, |
| repeat, |
| if, |
| elsif, |
| assignment : HALT | |
| (* expressions. *) |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide : RETURN doSetExprType (binaryF.resultType, mixTypes (getExprType (binaryF.left), getExprType (binaryF.right))) | |
| in, |
| and, |
| or, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal : RETURN doSetExprType (binaryF.resultType, booleanN) | |
| cmplx : RETURN doSetExprType (binaryF.resultType, complexN) | |
| abs, |
| constexp, |
| deref, |
| neg : RETURN doSetExprType (unaryF.resultType, getExprType (unaryF.arg)) | |
| adr : RETURN doSetExprType (unaryF.resultType, addressN) | |
| size, |
| tsize : RETURN doSetExprType (unaryF.resultType, cardinalN) | |
| high, |
| ord : RETURN doSetExprType (unaryF.resultType, cardinalN) | |
| float : RETURN doSetExprType (unaryF.resultType, realN) | |
| trunc : RETURN doSetExprType (unaryF.resultType, integerN) | |
| chr : RETURN doSetExprType (unaryF.resultType, charN) | |
| cap : RETURN doSetExprType (unaryF.resultType, charN) | |
| not : RETURN doSetExprType (unaryF.resultType, booleanN) | |
| re : RETURN doSetExprType (unaryF.resultType, realN) | |
| im : RETURN doSetExprType (unaryF.resultType, realN) | |
| arrayref : RETURN arrayrefF.resultType | |
| componentref : RETURN componentrefF.resultType | |
| pointerref : RETURN pointerrefF.resultType | |
| funccall : RETURN doSetExprType (funccallF.type, doGetFuncType (n)) | |
| setvalue : RETURN setvalueF.type |
| |
| END |
| END ; |
| HALT |
| END doGetExprType ; |
| |
| |
| (* |
| getExprType - return the expression type. |
| *) |
| |
| PROCEDURE getExprType (n: node) : node ; |
| VAR |
| t: node ; |
| BEGIN |
| IF isFuncCall (n) AND (getType (n) # NIL) AND isProcType (skipType (getType (n))) |
| THEN |
| RETURN getType (skipType (getType (n))) |
| END ; |
| t := getType (n) ; |
| IF t = NIL |
| THEN |
| t := doGetExprType (n) |
| END ; |
| RETURN t |
| END getExprType ; |
| |
| |
| (* |
| skipType - skips over type aliases. |
| *) |
| |
| PROCEDURE skipType (n: node) : node ; |
| BEGIN |
| WHILE (n#NIL) AND isType (n) DO |
| IF getType (n) = NIL |
| THEN |
| (* this will occur if, n, is an opaque type. *) |
| RETURN n |
| END ; |
| n := getType (n) |
| END ; |
| RETURN n |
| END skipType ; |
| |
| |
| (* |
| getScope - returns the scope associated with node, n. |
| *) |
| |
| PROCEDURE getScope (n: node) : node ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| stmtseq, |
| exit, |
| return, |
| comment, |
| identlist, |
| setvalue, |
| halt, |
| new, |
| dispose, |
| length, |
| inc, |
| dec, |
| incl, |
| excl, |
| nil, |
| true, |
| false : RETURN NIL | |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet : RETURN systemN | |
| (* base types. *) |
| boolean, |
| proc, |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| ztype, |
| rtype, |
| complex, |
| longcomplex, |
| shortcomplex : RETURN NIL | |
| (* language features and compound type attributes. *) |
| type : RETURN typeF.scope | |
| record : RETURN recordF.scope | |
| varient : RETURN varientF.scope | |
| var : RETURN varF.scope | |
| enumeration : RETURN enumerationF.scope | |
| subrange : RETURN subrangeF.scope | |
| array : RETURN arrayF.scope | |
| string : RETURN NIL | |
| const : RETURN constF.scope | |
| literal : RETURN NIL | |
| varparam : RETURN varparamF.scope | |
| param : RETURN paramF.scope | |
| optarg : RETURN optargF.scope | |
| pointer : RETURN pointerF.scope | |
| recordfield : RETURN recordfieldF.scope | |
| varientfield : RETURN varientfieldF.scope | |
| enumerationfield: RETURN enumerationfieldF.scope | |
| set : RETURN setF.scope | |
| proctype : RETURN proctypeF.scope | |
| subscript : RETURN NIL | |
| (* blocks. *) |
| procedure : RETURN procedureF.scope | |
| def, |
| imp, |
| module, |
| (* statements. *) |
| case, |
| loop, |
| while, |
| for, |
| repeat, |
| if, |
| elsif, |
| assignment : RETURN NIL | |
| (* expressions. *) |
| componentref, |
| pointerref, |
| arrayref, |
| chr, |
| cap, |
| ord, |
| float, |
| trunc, |
| high, |
| cast, |
| val, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide, |
| in : RETURN NIL | |
| neg : RETURN NIL | |
| lsl, |
| lsr, |
| lor, |
| land, |
| lnot, |
| lxor, |
| and, |
| or, |
| not, |
| constexp, |
| deref, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal : RETURN NIL | |
| adr, |
| size, |
| tsize, |
| throw : RETURN systemN | |
| unreachable, |
| cmplx, re, im, |
| min, |
| max : RETURN NIL | |
| vardecl : RETURN vardeclF.scope | |
| funccall : RETURN NIL | |
| explist : RETURN NIL | |
| caselabellist : RETURN NIL | |
| caselist : RETURN NIL | |
| range : RETURN NIL | |
| varargs : RETURN varargsF.scope |
| |
| END |
| END |
| END getScope ; |
| |
| |
| (* |
| foreachDefModuleDo - foreach definition node, n, in the module universe, |
| call p (n). |
| *) |
| |
| PROCEDURE foreachDefModuleDo (p: performOperation) ; |
| BEGIN |
| ForeachIndiceInIndexDo (defUniverseI, p) |
| END foreachDefModuleDo ; |
| |
| |
| (* |
| foreachModModuleDo - foreach implementation or module node, n, in the module universe, |
| call p (n). |
| *) |
| |
| PROCEDURE foreachModModuleDo (p: performOperation) ; |
| BEGIN |
| ForeachIndiceInIndexDo (modUniverseI, p) |
| END foreachModModuleDo ; |
| |
| |
| (* |
| openOutput - |
| *) |
| |
| PROCEDURE openOutput ; |
| VAR |
| s: String ; |
| BEGIN |
| s := getOutputFile () ; |
| IF EqualArray (s, '-') |
| THEN |
| outputFile := StdOut |
| ELSE |
| outputFile := OpenToWrite (s) |
| END ; |
| mcStream.setDest (outputFile) |
| END openOutput ; |
| |
| |
| (* |
| closeOutput - |
| *) |
| |
| PROCEDURE closeOutput ; |
| VAR |
| s: String ; |
| BEGIN |
| s := getOutputFile () ; |
| outputFile := mcStream.combine () ; |
| IF NOT EqualArray (s, '-') |
| THEN |
| Close (outputFile) |
| END |
| END closeOutput ; |
| |
| |
| (* |
| write - outputs a single char, ch. |
| *) |
| |
| PROCEDURE write (ch: CHAR) ; |
| BEGIN |
| WriteChar (outputFile, ch) ; |
| FlushBuffer (outputFile) |
| END write ; |
| |
| |
| (* |
| writeln - |
| *) |
| |
| PROCEDURE writeln ; |
| BEGIN |
| WriteLine (outputFile) ; |
| FlushBuffer (outputFile) |
| END writeln ; |
| |
| |
| (* |
| doIncludeC - include header file for definition module, n. |
| *) |
| |
| PROCEDURE doIncludeC (n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| IF getExtendedOpaque () |
| THEN |
| (* no include in this case. *) |
| ELSIF isDef (n) |
| THEN |
| print (doP, '# include "') ; |
| prints (doP, getHPrefix ()) ; |
| prints (doP, s) ; |
| print (doP, '.h"\n') ; |
| foreachNodeDo (n^.defF.decls.symbols, addDoneDef) |
| END ; |
| s := KillString (s) |
| END doIncludeC ; |
| |
| |
| (* |
| getSymScope - returns the scope where node, n, was declared. |
| *) |
| |
| PROCEDURE getSymScope (n: node) : node ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| const : RETURN constF.scope | |
| type : RETURN typeF.scope | |
| var : RETURN varF.scope | |
| procedure: RETURN procedureF.scope |
| |
| END |
| END ; |
| HALT |
| END getSymScope ; |
| |
| |
| (* |
| isQualifiedForced - should the node be written with a module prefix? |
| *) |
| |
| PROCEDURE isQualifiedForced (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN (forceQualified AND |
| (isType (n) OR isRecord (n) OR isArray (n) OR isEnumeration (n) OR isEnumerationField (n))) |
| END isQualifiedForced ; |
| |
| |
| (* |
| getFQstring - |
| *) |
| |
| PROCEDURE getFQstring (n: node) : String ; |
| VAR |
| i, s: String ; |
| BEGIN |
| IF getScope (n) = NIL |
| THEN |
| RETURN InitStringCharStar (keyToCharStar (getSymName (n))) |
| ELSIF isQualifiedForced (n) |
| THEN |
| i := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ; |
| RETURN Sprintf2 (InitString ("%s_%s"), s, i) |
| ELSIF (NOT isExported (n)) OR getIgnoreFQ () |
| THEN |
| RETURN InitStringCharStar (keyToCharStar (getSymName (n))) |
| ELSE |
| i := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ; |
| RETURN Sprintf2 (InitString ("%s_%s"), s, i) |
| END |
| END getFQstring ; |
| |
| |
| (* |
| getFQDstring - |
| *) |
| |
| PROCEDURE getFQDstring (n: node; scopes: BOOLEAN) : String ; |
| VAR |
| i, s: String ; |
| BEGIN |
| IF getScope (n) = NIL |
| THEN |
| RETURN InitStringCharStar (keyToCharStar (getDName (n, scopes))) |
| ELSIF isQualifiedForced (n) |
| THEN |
| (* we assume a qualified name will never conflict. *) |
| i := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ; |
| RETURN Sprintf2 (InitString ("%s_%s"), s, i) |
| ELSIF (NOT isExported (n)) OR getIgnoreFQ () |
| THEN |
| RETURN InitStringCharStar (keyToCharStar (getDName (n, scopes))) |
| ELSE |
| (* we assume a qualified name will never conflict. *) |
| i := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (getScope (n)))) ; |
| RETURN Sprintf2 (InitString ("%s_%s"), s, i) |
| END |
| END getFQDstring ; |
| |
| |
| (* |
| getString - returns the name as a string. |
| *) |
| |
| PROCEDURE getString (n: node) : String ; |
| BEGIN |
| IF getSymName (n) = NulName |
| THEN |
| RETURN InitString ('') |
| ELSE |
| RETURN InitStringCharStar (keyToCharStar (getSymName (n))) |
| END |
| END getString ; |
| |
| |
| (* |
| getCardinal - returns the cardinal type node. |
| *) |
| |
| PROCEDURE getCardinal () : node ; |
| BEGIN |
| RETURN cardinalN |
| END getCardinal ; |
| |
| |
| (* |
| doNone - call HALT. |
| *) |
| |
| PROCEDURE doNone (n: node) ; |
| BEGIN |
| HALT |
| END doNone ; |
| |
| |
| (* |
| doNothing - does nothing! |
| *) |
| |
| PROCEDURE doNothing (n: node) ; |
| BEGIN |
| END doNothing ; |
| |
| |
| (* |
| doConstC - |
| *) |
| |
| PROCEDURE doConstC (n: node) ; |
| BEGIN |
| IF NOT alists.isItemInList (doneQ, n) |
| THEN |
| print (doP, "# define ") ; |
| doFQNameC (doP, n) ; |
| setNeedSpace (doP) ; |
| doExprC (doP, n^.constF.value) ; |
| print (doP, '\n') ; |
| alists.includeItemIntoList (doneQ, n) |
| END |
| END doConstC ; |
| |
| |
| (* |
| needsParen - returns TRUE if expression, n, needs to be enclosed in (). |
| *) |
| |
| PROCEDURE needsParen (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| WITH n^ DO |
| CASE kind OF |
| |
| nil, |
| true, |
| false : RETURN FALSE | |
| constexp : RETURN needsParen (unaryF.arg) | |
| neg : RETURN needsParen (unaryF.arg) | |
| not : RETURN needsParen (unaryF.arg) | |
| adr, |
| size, |
| tsize, |
| ord, |
| float, |
| trunc, |
| chr, |
| cap, |
| high : RETURN FALSE | |
| deref : RETURN FALSE | |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal : RETURN TRUE | |
| componentref : RETURN FALSE | |
| pointerref : RETURN FALSE | |
| cast : RETURN TRUE | |
| val : RETURN TRUE | |
| abs : RETURN FALSE | |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide, |
| in : RETURN TRUE | |
| literal, |
| const, |
| enumerationfield, |
| string : RETURN FALSE | |
| max : RETURN TRUE | |
| min : RETURN TRUE | |
| var : RETURN FALSE | |
| arrayref : RETURN FALSE | |
| and, |
| or : RETURN TRUE | |
| funccall : RETURN TRUE | |
| recordfield : RETURN FALSE | |
| loc, |
| byte, |
| word, |
| type, |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| complex, |
| longcomplex, |
| shortcomplex, |
| bitset, |
| boolean, |
| proc : RETURN FALSE | |
| setvalue : RETURN FALSE | |
| address : RETURN TRUE | |
| procedure : RETURN FALSE | |
| length, |
| cmplx, re, im : RETURN TRUE |
| |
| END |
| END ; |
| RETURN TRUE |
| END needsParen ; |
| |
| |
| (* |
| doUnary - |
| *) |
| |
| PROCEDURE doUnary (p: pretty; op: ARRAY OF CHAR; expr, type: node; l, r: BOOLEAN) ; |
| BEGIN |
| IF l |
| THEN |
| setNeedSpace (p) |
| END ; |
| print (p, op) ; |
| IF r |
| THEN |
| setNeedSpace (p) |
| END ; |
| IF needsParen (expr) |
| THEN |
| outText (p, '(') ; |
| doExprC (p, expr) ; |
| outText (p, ')') |
| ELSE |
| doExprC (p, expr) |
| END |
| END doUnary ; |
| |
| |
| (* |
| doSetSub - perform l & (~ r) |
| *) |
| |
| PROCEDURE doSetSub (p: pretty; left, right: node) ; |
| BEGIN |
| IF needsParen (left) |
| THEN |
| outText (p, '(') ; |
| doExprC (p, left) ; |
| outText (p, ')') |
| ELSE |
| doExprC (p, left) |
| END ; |
| setNeedSpace (p) ; |
| outText (p, '&') ; |
| setNeedSpace (p) ; |
| IF needsParen (right) |
| THEN |
| outText (p, '(~(') ; |
| doExprC (p, right) ; |
| outText (p, '))') |
| ELSE |
| outText (p, '(~') ; |
| doExprC (p, right) ; |
| outText (p, ')') |
| END |
| END doSetSub ; |
| |
| |
| (* |
| doPolyBinary - |
| *) |
| |
| PROCEDURE doPolyBinary (p: pretty; op: nodeT; left, right: node; l, r: BOOLEAN) ; |
| VAR |
| lt, rt: node ; |
| BEGIN |
| lt := skipType (getExprType (left)) ; |
| rt := skipType (getExprType (right)) ; |
| IF ((lt # NIL) AND (isSet (lt) OR isBitset (lt))) OR |
| ((rt # NIL) AND (isSet (rt) OR isBitset (rt))) |
| THEN |
| CASE op OF |
| |
| plus : doBinary (p, '|', left, right, l, r, FALSE) | |
| sub : doSetSub (p, left, right) | |
| mult : doBinary (p, '&', left, right, l, r, FALSE) | |
| divide : doBinary (p, '^', left, right, l, r, FALSE) |
| |
| END |
| ELSE |
| CASE op OF |
| |
| plus : doBinary (p, '+', left, right, l, r, FALSE) | |
| sub : doBinary (p, '-', left, right, l, r, FALSE) | |
| mult : doBinary (p, '*', left, right, l, r, FALSE) | |
| divide : doBinary (p, '/', left, right, l, r, FALSE) |
| |
| END |
| END |
| END doPolyBinary ; |
| |
| |
| (* |
| doBinary - |
| *) |
| |
| PROCEDURE doBinary (p: pretty; op: ARRAY OF CHAR; left, right: node; l, r, unpackProc: BOOLEAN) ; |
| BEGIN |
| IF needsParen (left) |
| THEN |
| outText (p, '(') ; |
| doExprCup (p, left, unpackProc) ; |
| outText (p, ')') |
| ELSE |
| doExprCup (p, left, unpackProc) |
| END ; |
| IF l |
| THEN |
| setNeedSpace (p) |
| END ; |
| outText (p, op) ; |
| IF r |
| THEN |
| setNeedSpace (p) |
| END ; |
| IF needsParen (right) |
| THEN |
| outText (p, '(') ; |
| doExprCup (p, right, unpackProc) ; |
| outText (p, ')') |
| ELSE |
| doExprCup (p, right, unpackProc) |
| END |
| END doBinary ; |
| |
| |
| (* |
| doPostUnary - |
| *) |
| |
| PROCEDURE doPostUnary (p: pretty; op: ARRAY OF CHAR; expr: node) ; |
| BEGIN |
| doExprC (p, expr) ; |
| outText (p, op) |
| END doPostUnary ; |
| |
| |
| (* |
| doDeRefC - |
| *) |
| |
| PROCEDURE doDeRefC (p: pretty; expr: node) ; |
| BEGIN |
| outText (p, '(*') ; |
| doExprC (p, expr) ; |
| outText (p, ')') |
| END doDeRefC ; |
| |
| |
| (* |
| doGetLastOp - returns, a, if b is a terminal otherwise walk right. |
| *) |
| |
| PROCEDURE doGetLastOp (a, b: node) : node ; |
| BEGIN |
| WITH b^ DO |
| CASE kind OF |
| |
| nil : RETURN a | |
| true : RETURN a | |
| false : RETURN a | |
| constexp : RETURN doGetLastOp (b, unaryF.arg) | |
| neg : RETURN doGetLastOp (b, unaryF.arg) | |
| not : RETURN doGetLastOp (b, unaryF.arg) | |
| adr : RETURN doGetLastOp (b, unaryF.arg) | |
| size : RETURN doGetLastOp (b, unaryF.arg) | |
| tsize : RETURN doGetLastOp (b, unaryF.arg) | |
| ord : RETURN doGetLastOp (b, unaryF.arg) | |
| float, |
| trunc : RETURN doGetLastOp (b, unaryF.arg) | |
| chr : RETURN doGetLastOp (b, unaryF.arg) | |
| cap : RETURN doGetLastOp (b, unaryF.arg) | |
| high : RETURN doGetLastOp (b, unaryF.arg) | |
| deref : RETURN doGetLastOp (b, unaryF.arg) | |
| re, |
| im : RETURN doGetLastOp (b, unaryF.arg) | |
| equal : RETURN doGetLastOp (b, binaryF.right) | |
| notequal : RETURN doGetLastOp (b, binaryF.right) | |
| less : RETURN doGetLastOp (b, binaryF.right) | |
| greater : RETURN doGetLastOp (b, binaryF.right) | |
| greequal : RETURN doGetLastOp (b, binaryF.right) | |
| lessequal : RETURN doGetLastOp (b, binaryF.right) | |
| componentref : RETURN doGetLastOp (b, componentrefF.field) | |
| pointerref : RETURN doGetLastOp (b, pointerrefF.field) | |
| cast : RETURN doGetLastOp (b, binaryF.right) | |
| val : RETURN doGetLastOp (b, binaryF.right) | |
| plus : RETURN doGetLastOp (b, binaryF.right) | |
| sub : RETURN doGetLastOp (b, binaryF.right) | |
| div : RETURN doGetLastOp (b, binaryF.right) | |
| mod : RETURN doGetLastOp (b, binaryF.right) | |
| mult : RETURN doGetLastOp (b, binaryF.right) | |
| divide : RETURN doGetLastOp (b, binaryF.right) | |
| in : RETURN doGetLastOp (b, binaryF.right) | |
| and : RETURN doGetLastOp (b, binaryF.right) | |
| or : RETURN doGetLastOp (b, binaryF.right) | |
| cmplx : RETURN doGetLastOp (b, binaryF.right) | |
| literal : RETURN a | |
| const : RETURN a | |
| enumerationfield: RETURN a | |
| string : RETURN a | |
| max : RETURN doGetLastOp (b, unaryF.arg) | |
| min : RETURN doGetLastOp (b, unaryF.arg) | |
| var : RETURN a | |
| arrayref : RETURN a | |
| funccall : RETURN a | |
| procedure : RETURN a | |
| recordfield : RETURN a |
| |
| END |
| END |
| END doGetLastOp ; |
| |
| |
| (* |
| getLastOp - return the right most non leaf node. |
| *) |
| |
| PROCEDURE getLastOp (n: node) : node ; |
| BEGIN |
| RETURN doGetLastOp (n, n) |
| END getLastOp ; |
| |
| |
| (* |
| doComponentRefC - |
| *) |
| |
| PROCEDURE doComponentRefC (p: pretty; l, r: node) ; |
| BEGIN |
| doExprC (p, l) ; |
| outText (p, '.') ; |
| doExprC (p, r) |
| END doComponentRefC ; |
| |
| |
| (* |
| doPointerRefC - |
| *) |
| |
| PROCEDURE doPointerRefC (p: pretty; l, r: node) ; |
| BEGIN |
| doExprC (p, l) ; |
| outText (p, '->') ; |
| doExprC (p, r) |
| END doPointerRefC ; |
| |
| |
| (* |
| doPreBinary - |
| *) |
| |
| PROCEDURE doPreBinary (p: pretty; op: ARRAY OF CHAR; left, right: node; l, r: BOOLEAN) ; |
| BEGIN |
| IF l |
| THEN |
| setNeedSpace (p) |
| END ; |
| outText (p, op) ; |
| IF r |
| THEN |
| setNeedSpace (p) |
| END ; |
| outText (p, '(') ; |
| doExprC (p, left) ; |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| doExprC (p, right) ; |
| outText (p, ')') |
| END doPreBinary ; |
| |
| |
| (* |
| doConstExpr - |
| *) |
| |
| PROCEDURE doConstExpr (p: pretty; n: node) ; |
| BEGIN |
| doFQNameC (p, n) |
| END doConstExpr ; |
| |
| |
| (* |
| doEnumerationField - |
| *) |
| |
| PROCEDURE doEnumerationField (p: pretty; n: node) ; |
| BEGIN |
| doFQDNameC (p, n, FALSE) |
| END doEnumerationField ; |
| |
| |
| (* |
| isZero - returns TRUE if node, n, is zero. |
| *) |
| |
| PROCEDURE isZero (n: node) : BOOLEAN ; |
| BEGIN |
| IF isConstExp (n) |
| THEN |
| RETURN isZero (n^.unaryF.arg) |
| END ; |
| RETURN getSymName (n)=makeKey ('0') |
| END isZero ; |
| |
| |
| (* |
| doArrayRef - |
| *) |
| |
| PROCEDURE doArrayRef (p: pretty; n: node) ; |
| VAR |
| t : node ; |
| i, c: CARDINAL ; |
| BEGIN |
| assert (n # NIL) ; |
| assert (isArrayRef (n)) ; |
| t := skipType (getType (n^.arrayrefF.array)) ; |
| IF isUnbounded (t) |
| THEN |
| outTextN (p, getSymName (n^.arrayrefF.array)) |
| ELSE |
| doExprC (p, n^.arrayrefF.array) ; |
| assert (isArray (t)) ; |
| outText (p, '.array') |
| END ; |
| outText (p, '[') ; |
| i := 1 ; |
| c := expListLen (n^.arrayrefF.index) ; |
| WHILE i<=c DO |
| doExprC (p, getExpList (n^.arrayrefF.index, i)) ; |
| IF isUnbounded (t) |
| THEN |
| assert (c = 1) |
| ELSE |
| doSubtractC (p, getMin (t^.arrayF.subr)) ; |
| IF i<c |
| THEN |
| assert (isArray (t)) ; |
| outText (p, '].array[') ; |
| t := skipType (getType (t)) |
| END |
| END ; |
| INC (i) |
| END ; |
| outText (p, ']') |
| END doArrayRef ; |
| |
| |
| (* |
| doProcedure - |
| *) |
| |
| PROCEDURE doProcedure (p: pretty; n: node) ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| doFQDNameC (p, n, TRUE) |
| END doProcedure ; |
| |
| |
| (* |
| doRecordfield - |
| *) |
| |
| PROCEDURE doRecordfield (p: pretty; n: node) ; |
| BEGIN |
| doDNameC (p, n, FALSE) |
| END doRecordfield ; |
| |
| |
| (* |
| doCastC - |
| *) |
| |
| PROCEDURE doCastC (p: pretty; t, e: node) ; |
| VAR |
| et: node ; |
| BEGIN |
| outText (p, '(') ; |
| doTypeNameC (p, t) ; |
| outText (p, ')') ; |
| setNeedSpace (p) ; |
| et := skipType (getType (e)) ; |
| IF (et # NIL) AND isAProcType (et) AND isAProcType (skipType (t)) |
| THEN |
| outText (p, '{(') ; |
| doFQNameC (p, t) ; |
| outText (p, '_t)') ; |
| setNeedSpace (p) ; |
| doExprC (p, e) ; |
| outText (p, '.proc}') |
| ELSE |
| outText (p, '(') ; |
| doExprC (p, e) ; |
| outText (p, ')') |
| END |
| END doCastC ; |
| |
| |
| (* |
| doSetValueC - |
| *) |
| |
| PROCEDURE doSetValueC (p: pretty; n: node) ; |
| VAR |
| lo : node ; |
| i, h: CARDINAL ; |
| BEGIN |
| assert (isSetValue (n)) ; |
| lo := getSetLow (n) ; |
| IF n^.setvalueF.type # NIL |
| THEN |
| outText (p, '(') ; |
| doTypeNameC (p, n^.setvalueF.type) ; |
| noSpace (p) ; |
| outText (p, ')') ; |
| setNeedSpace (p) |
| END ; |
| IF HighIndice (n^.setvalueF.values) = 0 |
| THEN |
| outText (p, '0') |
| ELSE |
| i := LowIndice (n^.setvalueF.values) ; |
| h := HighIndice (n^.setvalueF.values) ; |
| outText (p, '(') ; |
| WHILE i<=h DO |
| outText (p, '(1') ; |
| setNeedSpace (p) ; |
| outText (p, '<<') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, GetIndice (n^.setvalueF.values, i)) ; |
| doSubtractC (p, lo) ; |
| outText (p, ')') ; |
| outText (p, ')') ; |
| IF i<h |
| THEN |
| setNeedSpace (p) ; |
| outText (p, '|') ; |
| setNeedSpace (p) |
| END ; |
| INC (i) |
| END ; |
| outText (p, ')') |
| END |
| END doSetValueC ; |
| |
| |
| (* |
| getSetLow - returns the low value of the set type from |
| expression, n. |
| *) |
| |
| PROCEDURE getSetLow (n: node) : node ; |
| VAR |
| type: node ; |
| BEGIN |
| IF getType (n) = NIL |
| THEN |
| RETURN makeLiteralInt (makeKey ('0')) |
| ELSE |
| type := skipType (getType (n)) ; |
| IF isSet (type) |
| THEN |
| RETURN getMin (skipType (getType (type))) |
| ELSE |
| RETURN makeLiteralInt (makeKey ('0')) |
| END |
| END |
| END getSetLow ; |
| |
| |
| (* |
| doInC - performs (((1 << (l)) & (r)) != 0) |
| *) |
| |
| PROCEDURE doInC (p: pretty; l, r: node) ; |
| VAR |
| lo: node ; |
| BEGIN |
| lo := getSetLow (r) ; |
| outText (p, '(((1') ; |
| setNeedSpace (p) ; |
| outText (p, '<<') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, l) ; |
| doSubtractC (p, lo) ; |
| outText (p, '))') ; |
| setNeedSpace (p) ; |
| outText (p, '&') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, r) ; |
| outText (p, '))') ; |
| setNeedSpace (p) ; |
| outText (p, '!=') ; |
| setNeedSpace (p) ; |
| outText (p, '0)') |
| END doInC ; |
| |
| |
| (* |
| doThrowC - |
| *) |
| |
| PROCEDURE doThrowC (p: pretty; n: node) ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| outText (p, "throw") ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| IF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| doExprC (p, getExpList (n^.intrinsicF.args, 1)) |
| END ; |
| outText (p, ')') |
| END doThrowC ; |
| |
| |
| (* |
| doUnreachableC - |
| *) |
| |
| PROCEDURE doUnreachableC (p: pretty; n: node) ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| outText (p, "__builtin_unreachable") ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| assert (expListLen (n^.intrinsicF.args) = 0) ; |
| outText (p, ')') |
| END doUnreachableC ; |
| |
| |
| (* |
| outNull - |
| *) |
| |
| PROCEDURE outNull (p: pretty) ; |
| BEGIN |
| keyc.useNull ; |
| outText (p, 'NULL') |
| END outNull ; |
| |
| |
| (* |
| outTrue - |
| *) |
| |
| PROCEDURE outTrue (p: pretty) ; |
| BEGIN |
| keyc.useTrue ; |
| outText (p, 'TRUE') |
| END outTrue ; |
| |
| |
| (* |
| outFalse - |
| *) |
| |
| PROCEDURE outFalse (p: pretty) ; |
| BEGIN |
| keyc.useFalse ; |
| outText (p, 'FALSE') |
| 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 : 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) | |
| length : doLengthC (p, n) | |
| min : doMinC (p, n) | |
| max : doMaxC (p, n) | |
| throw : doThrowC (p, n) | |
| unreachable : doUnreachableC (p, n) | |
| re : doReC (p, n) | |
| im : doImC (p, n) | |
| cmplx : doCmplx (p, n) | |
| |
| deref : doDeRefC (p, unaryF.arg) | |
| equal : doBinary (p, '==', binaryF.left, binaryF.right, TRUE, TRUE, TRUE) | |
| notequal : doBinary (p, '!=', binaryF.left, binaryF.right, TRUE, TRUE, TRUE) | |
| less : doBinary (p, '<', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| greater : doBinary (p, '>', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| greequal : doBinary (p, '>=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| lessequal : doBinary (p, '<=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| componentref : doComponentRefC (p, componentrefF.rec, componentrefF.field) | |
| pointerref : doPointerRefC (p, pointerrefF.ptr, pointerrefF.field) | |
| cast : doCastC (p, binaryF.left, binaryF.right) | |
| plus : doPolyBinary (p, plus, binaryF.left, binaryF.right, FALSE, FALSE) | |
| sub : doPolyBinary (p, sub, binaryF.left, binaryF.right, FALSE, FALSE) | |
| div : doBinary (p, '/', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| mod : doBinary (p, '%', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| mult : doPolyBinary (p, mult, binaryF.left, binaryF.right, FALSE, FALSE) | |
| divide : doPolyBinary (p, divide, binaryF.left, binaryF.right, FALSE, FALSE) | |
| in : doInC (p, binaryF.left, binaryF.right) | |
| and : doBinary (p, '&&', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| or : doBinary (p, '||', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| literal : doLiteralC (p, n) | |
| const : doConstExpr (p, n) | |
| enumerationfield: doEnumerationField (p, n) | |
| string : doStringC (p, n) | |
| var : doVar (p, n) | |
| arrayref : doArrayRef (p, n) | |
| funccall : doFuncExprC (p, n) | |
| procedure : doProcedure (p, n) | |
| recordfield : doRecordfield (p, n) | |
| setvalue : doSetValueC (p, n) | |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| complex, |
| longcomplex, |
| shortcomplex, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| boolean, |
| proc : doBaseC (p, n) | |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet : doSystemC (p, n) | |
| type : doTypeNameC (p, n) | |
| pointer : doTypeNameC (p, n) |
| |
| END |
| END |
| END doExprC ; |
| |
| |
| (* |
| doExprCup - |
| *) |
| |
| PROCEDURE doExprCup (p: pretty; n: node; unpackProc: BOOLEAN) ; |
| VAR |
| t: node ; |
| BEGIN |
| doExprC (p, n) ; |
| IF unpackProc |
| THEN |
| t := skipType (getExprType (n)) ; |
| IF (t # NIL) AND isAProcType (t) |
| THEN |
| outText (p, '.proc') |
| END |
| END |
| END doExprCup ; |
| |
| |
| (* |
| doExprM2 - |
| *) |
| |
| PROCEDURE doExprM2 (p: pretty; n: node) ; |
| BEGIN |
| assert (n#NIL) ; |
| WITH n^ DO |
| CASE kind OF |
| |
| nil : outText (p, 'NIL') | |
| true : outText (p, 'TRUE') | |
| false : outText (p, 'FALSE') | |
| constexp : doUnary (p, '', unaryF.arg, unaryF.resultType, FALSE, FALSE) | |
| neg : doUnary (p, '-', unaryF.arg, unaryF.resultType, FALSE, FALSE) | |
| not : doUnary (p, 'NOT', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| adr : doUnary (p, 'ADR', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| size : doUnary (p, 'SIZE', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| tsize : doUnary (p, 'TSIZE', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| float : doUnary (p, 'FLOAT', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| trunc : doUnary (p, 'TRUNC', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| ord : doUnary (p, 'ORD', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| chr : doUnary (p, 'CHR', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| cap : doUnary (p, 'CAP', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| high : doUnary (p, 'HIGH', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| re : doUnary (p, 'RE', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| im : doUnary (p, 'IM', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| deref : doPostUnary (p, '^', unaryF.arg) | |
| equal : doBinary (p, '=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| notequal : doBinary (p, '#', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| less : doBinary (p, '<', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| greater : doBinary (p, '>', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| greequal : doBinary (p, '>=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| lessequal : doBinary (p, '<=', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| componentref : doBinary (p, '.', componentrefF.rec, componentrefF.field, FALSE, FALSE, FALSE) | |
| pointerref : doBinary (p, '^.', pointerrefF.ptr, pointerrefF.field, FALSE, FALSE, FALSE) | |
| cast : doPreBinary (p, 'CAST', binaryF.left, binaryF.right, TRUE, TRUE) | |
| val : doPreBinary (p, 'VAL', binaryF.left, binaryF.right, TRUE, TRUE) | |
| cmplx : doPreBinary (p, 'CMPLX', binaryF.left, binaryF.right, TRUE, TRUE) | |
| plus : doBinary (p, '+', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) | |
| sub : doBinary (p, '-', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) | |
| div : doBinary (p, 'DIV', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| mod : doBinary (p, 'MOD', binaryF.left, binaryF.right, TRUE, TRUE, FALSE) | |
| mult : doBinary (p, '*', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) | |
| divide : doBinary (p, '/', binaryF.left, binaryF.right, FALSE, FALSE, FALSE) | |
| literal : doLiteral (p, n) | |
| const : doConstExpr (p, n) | |
| enumerationfield: doEnumerationField (p, n) | |
| string : doString (p, n) | |
| max : doUnary (p, 'MAX', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| min : doUnary (p, 'MIN', unaryF.arg, unaryF.resultType, TRUE, TRUE) | |
| var : doVar (p, n) |
| |
| END |
| END |
| END doExprM2 ; |
| |
| |
| (* |
| doVar - |
| *) |
| |
| PROCEDURE doVar (p: pretty; n: node) ; |
| BEGIN |
| assert (isVar (n)) ; |
| IF n^.varF.isVarParameter |
| THEN |
| outText (p, '(*') ; |
| doFQDNameC (p, n, TRUE) ; |
| outText (p, ')') |
| ELSE |
| doFQDNameC (p, n, TRUE) |
| END |
| END doVar ; |
| |
| |
| (* |
| doLiteralC - |
| *) |
| |
| PROCEDURE doLiteralC (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| assert (isLiteral (n)) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| IF n^.literalF.type=charN |
| THEN |
| IF DynamicStrings.char (s, -1)='C' |
| THEN |
| s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) ; |
| IF DynamicStrings.char (s, 0)#'0' |
| THEN |
| s := DynamicStrings.ConCat (InitString('0'), DynamicStrings.Mark (s)) |
| END |
| END ; |
| outText (p, "(char)") ; |
| setNeedSpace (p) |
| ELSIF DynamicStrings.char (s, -1) = 'H' |
| THEN |
| outText (p, "0x") ; |
| s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) |
| ELSIF DynamicStrings.char (s, -1) = 'B' |
| THEN |
| outText (p, "0") ; |
| s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) |
| END ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END doLiteralC ; |
| |
| |
| (* |
| doLiteral - |
| *) |
| |
| PROCEDURE doLiteral (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| assert (isLiteral (n)) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| IF n^.literalF.type=charN |
| THEN |
| IF DynamicStrings.char (s, -1)='C' |
| THEN |
| s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) ; |
| IF DynamicStrings.char (s, 0)#'0' |
| THEN |
| s := DynamicStrings.ConCat (InitString('0'), DynamicStrings.Mark (s)) |
| END |
| END ; |
| outText (p, "(char)") ; |
| setNeedSpace (p) |
| END ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END doLiteral ; |
| |
| |
| (* |
| isString - returns TRUE if node, n, is a string. |
| *) |
| |
| PROCEDURE isString (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n#NIL) ; |
| RETURN n^.kind=string |
| END isString ; |
| |
| |
| (* |
| doString - |
| *) |
| |
| PROCEDURE doString (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| assert (isString (n)) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| ; HALT |
| (* |
| IF DynamicStrings.Index (s, '"', 0)=-1 |
| THEN |
| outText (p, '"') ; |
| outTextS (p, s) ; |
| outText (p, '"') |
| ELSIF DynamicStrings.Index (s, "'", 0)=-1 |
| THEN |
| outText (p, '"') ; |
| outTextS (p, s) ; |
| outText (p, '"') |
| ELSE |
| metaError1 ('illegal string {%1k}', n) |
| END |
| *) |
| END doString ; |
| |
| |
| (* |
| replaceChar - replace every occurance of, ch, by, a and return modified string, s. |
| *) |
| |
| PROCEDURE replaceChar (s: String; ch: CHAR; a: ARRAY OF CHAR) : String ; |
| VAR |
| i: INTEGER ; |
| BEGIN |
| i := 0 ; |
| LOOP |
| i := DynamicStrings.Index (s, ch, i) ; |
| IF i = 0 |
| THEN |
| s := ConCat (InitString (a), DynamicStrings.Slice (s, 1, 0)) ; |
| i := StrLen (a) |
| ELSIF i > 0 |
| THEN |
| s := ConCat (ConCat (DynamicStrings.Slice (s, 0, i), Mark (InitString (a))), DynamicStrings.Slice (s, i+1, 0)) ; |
| INC (i, StrLen (a)) |
| ELSE |
| RETURN s |
| END |
| END |
| END replaceChar ; |
| |
| |
| (* |
| toCstring - translates string, n, into a C string |
| and returns the new String. |
| *) |
| |
| PROCEDURE toCstring (n: Name) : String ; |
| VAR |
| s: String ; |
| BEGIN |
| s := DynamicStrings.Slice (InitStringCharStar (keyToCharStar (n)), 1, -1) ; |
| RETURN replaceChar (replaceChar (s, '\', '\\'), '"', '\"') |
| END toCstring ; |
| |
| |
| (* |
| toCchar - |
| *) |
| |
| PROCEDURE toCchar (n: Name) : String ; |
| VAR |
| s: String ; |
| BEGIN |
| s := DynamicStrings.Slice (InitStringCharStar (keyToCharStar (n)), 1, -1) ; |
| RETURN replaceChar (replaceChar (s, '\', '\\'), "'", "\'") |
| END toCchar ; |
| |
| |
| (* |
| countChar - |
| *) |
| |
| PROCEDURE countChar (s: String; ch: CHAR) : CARDINAL ; |
| VAR |
| i: INTEGER ; |
| c: CARDINAL ; |
| BEGIN |
| c := 0 ; |
| i := 0 ; |
| LOOP |
| i := DynamicStrings.Index (s, ch, i) ; |
| IF i >= 0 |
| THEN |
| INC (i) ; |
| INC (c) |
| ELSE |
| RETURN c |
| END |
| END |
| END countChar ; |
| |
| |
| (* |
| lenCstring - |
| *) |
| |
| PROCEDURE lenCstring (s: String) : CARDINAL ; |
| BEGIN |
| RETURN DynamicStrings.Length (s) - countChar (s, '\') |
| END lenCstring ; |
| |
| |
| (* |
| outCstring - |
| *) |
| |
| PROCEDURE outCstring (p: pretty; s: node; aString: BOOLEAN) ; |
| BEGIN |
| IF aString |
| THEN |
| outText (p, '"') ; |
| outRawS (p, s^.stringF.cstring) ; |
| outText (p, '"') |
| ELSE |
| outText (p, "'") ; |
| outRawS (p, s^.stringF.cchar) ; |
| outText (p, "'") |
| END |
| END outCstring ; |
| |
| |
| (* |
| doStringC - |
| *) |
| |
| PROCEDURE doStringC (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| assert (isString (n)) ; |
| outCstring (p, n, NOT n^.stringF.isCharCompatible) |
| (* |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| IF DynamicStrings.Length (s)>3 |
| THEN |
| IF DynamicStrings.Index (s, '"', 0)=-1 |
| THEN |
| s := DynamicStrings.Slice (s, 1, -1) ; |
| outText (p, '"') ; |
| outCstring (p, s) ; |
| outText (p, '"') |
| ELSIF DynamicStrings.Index (s, "'", 0)=-1 |
| THEN |
| s := DynamicStrings.Slice (s, 1, -1) ; |
| outText (p, '"') ; |
| outCstring (p, s) ; |
| outText (p, '"') |
| ELSE |
| metaError1 ('illegal string {%1k}', n) |
| END |
| ELSIF DynamicStrings.Length (s) = 3 |
| THEN |
| s := DynamicStrings.Slice (s, 1, -1) ; |
| outText (p, "'") ; |
| IF DynamicStrings.char (s, 0) = "'" |
| THEN |
| outText (p, "\'") |
| ELSIF DynamicStrings.char (s, 0) = "\" |
| THEN |
| outText (p, "\\") |
| ELSE |
| outTextS (p, s) |
| END ; |
| outText (p, "'") |
| ELSE |
| outText (p, "'\0'") |
| END ; |
| s := KillString (s) |
| *) |
| END doStringC ; |
| |
| |
| (* |
| isPunct - |
| *) |
| |
| PROCEDURE isPunct (ch: CHAR) : BOOLEAN ; |
| BEGIN |
| RETURN (ch = '.') OR (ch = '(') OR (ch = ')') OR |
| (ch = '^') OR (ch = ':') OR (ch = ';') OR |
| (ch = '{') OR (ch = '}') OR (ch = ',') OR |
| (ch = '*') |
| END isPunct ; |
| |
| |
| (* |
| isWhite - |
| *) |
| |
| PROCEDURE isWhite (ch: CHAR) : BOOLEAN ; |
| BEGIN |
| RETURN (ch = ' ') OR (ch = tab) OR (ch = lf) |
| END isWhite ; |
| |
| |
| (* |
| outText - |
| *) |
| |
| PROCEDURE outText (p: pretty; a: ARRAY OF CHAR) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := InitString (a) ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END outText ; |
| |
| |
| (* |
| outRawS - |
| *) |
| |
| PROCEDURE outRawS (p: pretty; s: String) ; |
| BEGIN |
| raw (p, s) |
| END outRawS ; |
| |
| |
| (* |
| outKm2 - |
| *) |
| |
| PROCEDURE outKm2 (p: pretty; a: ARRAY OF CHAR) : pretty ; |
| VAR |
| i: CARDINAL ; |
| s: String ; |
| BEGIN |
| IF StrEqual (a, 'RECORD') |
| THEN |
| p := pushPretty (p) ; |
| i := getcurpos (p) ; |
| setindent (p, i) ; |
| outText (p, a) ; |
| p := pushPretty (p) ; |
| setindent (p, i + indentation) |
| ELSIF StrEqual (a, 'END') |
| THEN |
| p := popPretty (p) ; |
| outText (p, a) ; |
| p := popPretty (p) |
| END ; |
| RETURN p |
| END outKm2 ; |
| |
| |
| (* |
| outKc - |
| *) |
| |
| PROCEDURE outKc (p: pretty; a: ARRAY OF CHAR) : pretty ; |
| VAR |
| i : INTEGER ; |
| c : CARDINAL ; |
| s, t: String ; |
| BEGIN |
| s := InitString (a) ; |
| i := DynamicStrings.Index (s, '\', 0) ; |
| IF i=-1 |
| THEN |
| t := NIL |
| ELSE |
| t := DynamicStrings.Slice (s, i, 0) ; |
| s := DynamicStrings.Slice (Mark (s), 0, i) |
| END ; |
| IF DynamicStrings.char (s, 0)='{' |
| THEN |
| p := pushPretty (p) ; |
| c := getcurpos (p) ; |
| setindent (p, c) ; |
| outTextS (p, s) ; |
| p := pushPretty (p) ; |
| setindent (p, c + indentationC) |
| ELSIF DynamicStrings.char (s, 0)='}' |
| THEN |
| p := popPretty (p) ; |
| outTextS (p, s) ; |
| p := popPretty (p) |
| END ; |
| outTextS (p, t) ; |
| t := KillString (t) ; |
| s := KillString (s) ; |
| RETURN p |
| END outKc ; |
| |
| |
| (* |
| outTextS - |
| *) |
| |
| PROCEDURE outTextS (p: pretty; s: String) ; |
| BEGIN |
| IF s # NIL |
| THEN |
| prints (p, s) |
| END |
| END outTextS ; |
| |
| |
| (* |
| outCard - |
| *) |
| |
| PROCEDURE outCard (p: pretty; c: CARDINAL) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := CardinalToString (c, 0, ' ', 10, FALSE) ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END outCard ; |
| |
| |
| (* |
| outTextN - |
| *) |
| |
| PROCEDURE outTextN (p: pretty; n: Name) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := InitStringCharStar (keyToCharStar (n)) ; |
| prints (p, s) ; |
| s := KillString (s) |
| END outTextN ; |
| |
| |
| (* |
| doTypeAliasC - |
| *) |
| |
| PROCEDURE doTypeAliasC (p: pretty; n: node; VAR m: node) ; |
| BEGIN |
| print (p, "typedef") ; setNeedSpace (p) ; |
| IF isTypeHidden (n) AND (isDef (getMainModule ()) OR (getScope (n) # getMainModule ())) |
| THEN |
| outText (p, "void *") |
| ELSE |
| doTypeC (p, getType (n), m) |
| END ; |
| IF m#NIL |
| THEN |
| doFQNameC (p, m) |
| END ; |
| print (p, ';\n\n') |
| END doTypeAliasC ; |
| |
| |
| (* |
| doEnumerationC - |
| *) |
| |
| PROCEDURE doEnumerationC (p: pretty; n: node) ; |
| VAR |
| i, h: CARDINAL ; |
| s : node ; |
| t : String ; |
| BEGIN |
| outText (p, "enum {") ; |
| i := LowIndice (n^.enumerationF.listOfSons) ; |
| h := HighIndice (n^.enumerationF.listOfSons) ; |
| WHILE i <= h DO |
| s := GetIndice (n^.enumerationF.listOfSons, i) ; |
| doFQDNameC (p, s, FALSE) ; |
| IF i < h |
| THEN |
| outText (p, ",") ; setNeedSpace (p) |
| END ; |
| INC (i) |
| END ; |
| outText (p, "}") |
| END doEnumerationC ; |
| |
| |
| (* |
| doNamesC - |
| *) |
| |
| PROCEDURE doNamesC (p: pretty; n: Name) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := InitStringCharStar (keyToCharStar (n)) ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END doNamesC ; |
| |
| |
| (* |
| doNameC - |
| *) |
| |
| PROCEDURE doNameC (p: pretty; n: node) ; |
| BEGIN |
| IF (n#NIL) AND (getSymName (n)#NulName) |
| THEN |
| doNamesC (p, getSymName (n)) |
| END |
| END doNameC ; |
| |
| |
| (* |
| initCname - |
| *) |
| |
| PROCEDURE initCname (VAR c: cnameT) ; |
| BEGIN |
| c.init := FALSE |
| END initCname ; |
| |
| |
| (* |
| doCname - |
| *) |
| |
| PROCEDURE doCname (n: Name; VAR c: cnameT; scopes: BOOLEAN) : Name ; |
| VAR |
| s: String ; |
| BEGIN |
| IF c.init |
| THEN |
| RETURN c.name |
| ELSE |
| c.init := TRUE ; |
| s := keyc.cname (n, scopes) ; |
| IF s=NIL |
| THEN |
| c.name := n |
| ELSE |
| c.name := makekey (DynamicStrings.string (s)) ; |
| s := KillString (s) |
| END ; |
| RETURN c.name |
| END |
| END doCname ; |
| |
| |
| (* |
| getDName - |
| *) |
| |
| PROCEDURE getDName (n: node; scopes: BOOLEAN) : Name ; |
| VAR |
| m: Name ; |
| BEGIN |
| m := getSymName (n) ; |
| CASE n^.kind OF |
| |
| procedure : RETURN doCname (m, n^.procedureF.cname, scopes) | |
| var : RETURN doCname (m, n^.varF.cname, scopes) | |
| recordfield : RETURN doCname (m, n^.recordfieldF.cname, scopes) | |
| enumerationfield: RETURN doCname (m, n^.enumerationfieldF.cname, scopes) |
| |
| ELSE |
| END ; |
| RETURN m |
| END getDName ; |
| |
| |
| (* |
| doDNameC - |
| *) |
| |
| PROCEDURE doDNameC (p: pretty; n: node; scopes: BOOLEAN) ; |
| BEGIN |
| IF (n#NIL) AND (getSymName (n)#NulName) |
| THEN |
| doNamesC (p, getDName (n, scopes)) |
| END |
| END doDNameC ; |
| |
| |
| (* |
| doFQDNameC - |
| *) |
| |
| PROCEDURE doFQDNameC (p: pretty; n: node; scopes: BOOLEAN) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := getFQDstring (n, scopes) ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END doFQDNameC ; |
| |
| |
| (* |
| doFQNameC - |
| *) |
| |
| PROCEDURE doFQNameC (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := getFQstring (n) ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END doFQNameC ; |
| |
| |
| (* |
| doNameM2 - |
| *) |
| |
| PROCEDURE doNameM2 (p: pretty; n: node) ; |
| BEGIN |
| doNameC (p, n) |
| END doNameM2 ; |
| |
| |
| (* |
| doUsed - |
| *) |
| |
| PROCEDURE doUsed (p: pretty; used: BOOLEAN) ; |
| BEGIN |
| IF NOT used |
| THEN |
| setNeedSpace (p) ; |
| outText (p, "__attribute__((unused))") |
| END |
| END doUsed ; |
| |
| |
| (* |
| doHighC - |
| *) |
| |
| PROCEDURE doHighC (p: pretty; a: node; n: Name; isused: BOOLEAN) ; |
| BEGIN |
| IF isArray (a) AND isUnbounded (a) |
| THEN |
| (* need to display high. *) |
| print (p, ",") ; setNeedSpace (p) ; |
| doTypeNameC (p, cardinalN) ; setNeedSpace (p) ; |
| print (p, "_") ; outTextN (p, n) ; print (p, "_high") ; |
| doUsed (p, isused) |
| END |
| END doHighC ; |
| |
| |
| (* |
| doParamConstCast - |
| *) |
| |
| PROCEDURE doParamConstCast (p: pretty; n: node) ; |
| VAR |
| ptype: node ; |
| BEGIN |
| ptype := getType (n) ; |
| IF isArray (ptype) AND isUnbounded (ptype) AND (lang = ansiCP) |
| THEN |
| outText (p, "const") ; |
| setNeedSpace (p) |
| END |
| END doParamConstCast ; |
| |
| |
| (* |
| getParameterVariable - returns the variable which shadows the parameter |
| named, m, in parameter block, n. |
| *) |
| |
| PROCEDURE getParameterVariable (n: node; m: Name) : node ; |
| VAR |
| p: node ; |
| BEGIN |
| assert (isParam (n) OR isVarParam (n)) ; |
| IF isParam (n) |
| THEN |
| p := n^.paramF.scope |
| ELSE |
| p := n^.varparamF.scope |
| END ; |
| assert (isProcedure (p)) ; |
| RETURN lookupInScope (p, m) |
| END getParameterVariable ; |
| |
| |
| (* |
| doParamTypeEmit - emit parameter type for C/C++. It checks to see if the |
| parameter type is a procedure type and if it were declared |
| in a definition module for "C" and if so it uses the "C" |
| definition for a procedure type, rather than the mc |
| C++ version. |
| *) |
| |
| PROCEDURE doParamTypeEmit (p: pretty; paramnode, paramtype: node) ; |
| BEGIN |
| assert (isParam (paramnode) OR isVarParam (paramnode)) ; |
| IF isForC (paramnode) AND isProcType (skipType (paramtype)) |
| THEN |
| doFQNameC (p, paramtype) ; |
| outText (p, "_C") |
| ELSE |
| doTypeNameC (p, paramtype) |
| END |
| END doParamTypeEmit ; |
| |
| |
| (* |
| doParamC - emit parameter for C/C++. |
| *) |
| |
| PROCEDURE doParamC (p: pretty; n: node) ; |
| VAR |
| v, |
| ptype: node ; |
| i : Name ; |
| c, t : CARDINAL ; |
| l : wlist ; |
| BEGIN |
| assert (isParam (n)) ; |
| ptype := getType (n) ; |
| IF n^.paramF.namelist = NIL |
| THEN |
| doParamConstCast (p, n) ; |
| doTypeNameC (p, ptype) ; |
| doUsed (p, n^.paramF.isUsed) ; |
| IF isArray (ptype) AND isUnbounded (ptype) |
| THEN |
| outText (p, ',') ; setNeedSpace (p) ; |
| outText (p, 'unsigned int') |
| END |
| ELSE |
| assert (isIdentList (n^.paramF.namelist)) ; |
| l := n^.paramF.namelist^.identlistF.names ; |
| IF l=NIL |
| THEN |
| doParamConstCast (p, n) ; |
| doParamTypeEmit (p, n, ptype) ; |
| IF isArray (ptype) AND isUnbounded (ptype) |
| THEN |
| doUsed (p, n^.paramF.isUsed) ; |
| outText (p, ',') ; setNeedSpace (p) ; |
| outText (p, 'unsigned int') |
| END |
| ELSE |
| t := wlists.noOfItemsInList (l) ; |
| c := 1 ; |
| WHILE c <= t DO |
| doParamConstCast (p, n) ; |
| doParamTypeEmit (p, n, ptype) ; |
| i := wlists.getItemFromList (l, c) ; |
| IF isArray (ptype) AND isUnbounded (ptype) |
| THEN |
| noSpace (p) |
| ELSE |
| setNeedSpace (p) |
| END ; |
| v := getParameterVariable (n, i) ; |
| IF v=NIL |
| THEN |
| doNamesC (p, keyc.cnamen (i, TRUE)) |
| ELSE |
| doFQDNameC (p, v, TRUE) |
| END ; |
| IF isArray (ptype) AND isUnbounded (ptype) |
| THEN |
| outText (p, '_') |
| END ; |
| doUsed (p, n^.paramF.isUsed) ; |
| doHighC (p, ptype, i, n^.paramF.isUsed) ; |
| IF c<t |
| THEN |
| outText (p, ',') ; setNeedSpace (p) |
| END ; |
| INC (c) |
| END |
| END |
| END |
| END doParamC ; |
| |
| |
| (* |
| doVarParamC - emit a VAR parameter for C/C++. |
| *) |
| |
| PROCEDURE doVarParamC (p: pretty; n: node) ; |
| VAR |
| v, |
| ptype: node ; |
| i : Name ; |
| c, t : CARDINAL ; |
| l : wlist ; |
| BEGIN |
| assert (isVarParam (n)) ; |
| ptype := getType (n) ; |
| IF n^.varparamF.namelist = NIL |
| THEN |
| doTypeNameC (p, ptype) ; |
| (* doTypeC (p, ptype, n) ; *) |
| IF NOT isArray (ptype) |
| THEN |
| setNeedSpace (p) ; |
| outText (p, "*") |
| END ; |
| doUsed (p, n^.varparamF.isUsed) ; |
| IF isArray (ptype) AND isUnbounded (ptype) |
| THEN |
| outText (p, ',') ; setNeedSpace (p) ; |
| outText (p, 'unsigned int') |
| END |
| ELSE |
| assert (isIdentList (n^.varparamF.namelist)) ; |
| l := n^.varparamF.namelist^.identlistF.names ; |
| IF l=NIL |
| THEN |
| doParamTypeEmit (p, n, ptype) ; |
| doUsed (p, n^.varparamF.isUsed) |
| ELSE |
| t := wlists.noOfItemsInList (l) ; |
| c := 1 ; |
| WHILE c <= t DO |
| doParamTypeEmit (p, n, ptype) ; |
| IF NOT isArray (ptype) |
| THEN |
| setNeedSpace (p) ; |
| outText (p, "*") |
| END ; |
| i := wlists.getItemFromList (l, c) ; |
| v := getParameterVariable (n, i) ; |
| IF v=NIL |
| THEN |
| doNamesC (p, keyc.cnamen (i, TRUE)) |
| ELSE |
| doFQDNameC (p, v, TRUE) |
| END ; |
| doUsed (p, n^.varparamF.isUsed) ; |
| doHighC (p, ptype, i, n^.varparamF.isUsed) ; |
| IF c<t |
| THEN |
| outText (p, ',') ; setNeedSpace (p) |
| END ; |
| INC (c) |
| END |
| END |
| END |
| END doVarParamC ; |
| |
| |
| (* |
| doOptargC - |
| *) |
| |
| PROCEDURE doOptargC (p: pretty; n: node) ; |
| VAR |
| ptype: node ; |
| i : Name ; |
| t : CARDINAL ; |
| l : wlist ; |
| BEGIN |
| assert (isOptarg (n)) ; |
| ptype := getType (n) ; |
| assert (n^.optargF.namelist # NIL) ; |
| assert (isIdentList (n^.paramF.namelist)) ; |
| l := n^.paramF.namelist^.identlistF.names ; |
| assert (l # NIL) ; |
| t := wlists.noOfItemsInList (l) ; |
| assert (t = 1) ; |
| doTypeNameC (p, ptype) ; |
| i := wlists.getItemFromList (l, 1) ; |
| setNeedSpace (p) ; |
| doNamesC (p, i) |
| END doOptargC ; |
| |
| |
| (* |
| doParameterC - |
| *) |
| |
| PROCEDURE doParameterC (p: pretty; n: node) ; |
| BEGIN |
| IF isParam (n) |
| THEN |
| doParamC (p, n) |
| ELSIF isVarParam (n) |
| THEN |
| doVarParamC (p, n) |
| ELSIF isVarargs (n) |
| THEN |
| print (p, "...") |
| ELSIF isOptarg (n) |
| THEN |
| doOptargC (p, n) |
| END |
| END doParameterC ; |
| |
| |
| (* |
| doProcTypeC - |
| *) |
| |
| PROCEDURE doProcTypeC (p: pretty; t, n: node) ; |
| BEGIN |
| assert (isType (t)) ; |
| outputPartial (t) ; |
| doCompletePartialProcType (p, t, n) |
| END doProcTypeC ; |
| |
| |
| (* |
| doTypesC - |
| *) |
| |
| PROCEDURE doTypesC (n: node) ; |
| VAR |
| m: node ; |
| BEGIN |
| IF isType (n) |
| THEN |
| m := getType (n) ; |
| IF isProcType (m) |
| THEN |
| doProcTypeC (doP, n, m) |
| ELSIF isType (m) OR isPointer (m) |
| THEN |
| outText (doP, "typedef") ; setNeedSpace (doP) ; |
| doTypeC (doP, m, m) ; |
| IF isType (m) |
| THEN |
| setNeedSpace (doP) |
| END ; |
| doTypeNameC (doP, n) ; |
| outText (doP, ";\n\n") |
| ELSIF isEnumeration (m) |
| THEN |
| outText (doP, "typedef") ; setNeedSpace (doP) ; |
| doTypeC (doP, m, m) ; |
| setNeedSpace (doP) ; |
| doTypeNameC (doP, n) ; |
| outText (doP, ";\n\n") |
| ELSE |
| outText (doP, "typedef") ; setNeedSpace (doP) ; |
| doTypeC (doP, m, m) ; |
| IF isType (m) |
| THEN |
| setNeedSpace (doP) |
| END ; |
| doTypeNameC (doP, n) ; |
| outText (doP, ";\n\n") |
| END |
| END |
| END doTypesC ; |
| |
| |
| (* |
| doCompletePartialC - |
| *) |
| |
| PROCEDURE doCompletePartialC (n: node) ; |
| VAR |
| m: node ; |
| BEGIN |
| IF isType (n) |
| THEN |
| m := getType (n) ; |
| IF isRecord (m) |
| THEN |
| doCompletePartialRecord (doP, n, m) |
| ELSIF isArray (m) |
| THEN |
| doCompletePartialArray (doP, n, m) |
| ELSIF isProcType (m) |
| THEN |
| doCompletePartialProcType (doP, n, m) |
| END |
| END |
| END doCompletePartialC ; |
| |
| |
| (* |
| doCompletePartialRecord - |
| *) |
| |
| PROCEDURE doCompletePartialRecord (p: pretty; t, r: node) ; |
| VAR |
| i, h: CARDINAL ; |
| f : node ; |
| BEGIN |
| assert (isRecord (r)) ; |
| assert (isType (t)) ; |
| outText (p, "struct") ; setNeedSpace (p) ; |
| doFQNameC (p, t) ; |
| outText (p, "_r") ; setNeedSpace (p) ; |
| p := outKc (p, "{\n") ; |
| i := LowIndice (r^.recordF.listOfSons) ; |
| h := HighIndice (r^.recordF.listOfSons) ; |
| WHILE i<=h DO |
| f := GetIndice (r^.recordF.listOfSons, i) ; |
| IF isRecordField (f) |
| THEN |
| IF NOT f^.recordfieldF.tag |
| THEN |
| setNeedSpace (p) ; |
| doRecordFieldC (p, f) ; |
| outText (p, ";\n") |
| END |
| ELSIF isVarient (f) |
| THEN |
| doVarientC (p, f) ; |
| outText (p, ";\n") |
| ELSIF isVarientField (f) |
| THEN |
| doVarientFieldC (p, f) |
| END ; |
| INC (i) |
| END ; |
| p := outKc (p, "};\n\n") |
| END doCompletePartialRecord ; |
| |
| |
| (* |
| doCompletePartialArray - |
| *) |
| |
| PROCEDURE doCompletePartialArray (p: pretty; t, r: node) ; |
| VAR |
| type, s: node ; |
| BEGIN |
| assert (isArray (r)) ; |
| type := r^.arrayF.type ; |
| s := NIL ; |
| outText (p, "struct") ; setNeedSpace (p) ; |
| doFQNameC (p, t) ; |
| outText (p, "_a {") ; |
| setNeedSpace (p) ; |
| doTypeC (p, type, s) ; |
| setNeedSpace (p) ; |
| outText (p, "array[") ; |
| doSubrC (p, r^.arrayF.subr) ; |
| outText (p, "];") ; |
| setNeedSpace (p) ; |
| outText (p, "};\n") |
| END doCompletePartialArray ; |
| |
| |
| (* |
| lookupConst - |
| *) |
| |
| PROCEDURE lookupConst (type: node; n: Name) : node ; |
| BEGIN |
| RETURN makeLiteralInt (n) |
| END lookupConst ; |
| |
| |
| (* |
| doMin - |
| *) |
| |
| PROCEDURE doMin (n: node) : node ; |
| BEGIN |
| IF n=booleanN |
| THEN |
| RETURN falseN |
| ELSIF n=integerN |
| THEN |
| keyc.useIntMin ; |
| RETURN lookupConst (integerN, makeKey ('INT_MIN')) |
| ELSIF n=cardinalN |
| THEN |
| keyc.useUIntMin ; |
| RETURN lookupConst (cardinalN, makeKey ('UINT_MIN')) |
| ELSIF n=longintN |
| THEN |
| keyc.useLongMin ; |
| RETURN lookupConst (longintN, makeKey ('LONG_MIN')) |
| ELSIF n=longcardN |
| THEN |
| keyc.useULongMin ; |
| RETURN lookupConst (longcardN, makeKey ('LONG_MIN')) |
| ELSIF n=charN |
| THEN |
| keyc.useCharMin ; |
| RETURN lookupConst (charN, makeKey ('CHAR_MIN')) |
| ELSIF n=bitsetN |
| THEN |
| assert (isSubrange (bitnumN)) ; |
| RETURN bitnumN^.subrangeF.low |
| ELSIF n=locN |
| THEN |
| keyc.useUCharMin ; |
| RETURN lookupConst (locN, makeKey ('UCHAR_MIN')) |
| ELSIF n=byteN |
| THEN |
| keyc.useUCharMin ; |
| RETURN lookupConst (byteN, makeKey ('UCHAR_MIN')) |
| ELSIF n=wordN |
| THEN |
| keyc.useUIntMin ; |
| RETURN lookupConst (wordN, makeKey ('UCHAR_MIN')) |
| ELSIF n=addressN |
| THEN |
| RETURN lookupConst (addressN, makeKey ('((void *) 0)')) |
| ELSE |
| HALT (* finish the cacading elsif statement. *) |
| END |
| END doMin ; |
| |
| |
| (* |
| doMax - |
| *) |
| |
| PROCEDURE doMax (n: node) : node ; |
| BEGIN |
| IF n=booleanN |
| THEN |
| RETURN trueN |
| ELSIF n=integerN |
| THEN |
| keyc.useIntMax ; |
| RETURN lookupConst (integerN, makeKey ('INT_MAX')) |
| ELSIF n=cardinalN |
| THEN |
| keyc.useUIntMax ; |
| RETURN lookupConst (cardinalN, makeKey ('UINT_MAX')) |
| ELSIF n=longintN |
| THEN |
| keyc.useLongMax ; |
| RETURN lookupConst (longintN, makeKey ('LONG_MAX')) |
| ELSIF n=longcardN |
| THEN |
| keyc.useULongMax ; |
| RETURN lookupConst (longcardN, makeKey ('ULONG_MAX')) |
| ELSIF n=charN |
| THEN |
| keyc.useCharMax ; |
| RETURN lookupConst (charN, makeKey ('CHAR_MAX')) |
| ELSIF n=bitsetN |
| THEN |
| assert (isSubrange (bitnumN)) ; |
| RETURN bitnumN^.subrangeF.high |
| ELSIF n=locN |
| THEN |
| keyc.useUCharMax ; |
| RETURN lookupConst (locN, makeKey ('UCHAR_MAX')) |
| ELSIF n=byteN |
| THEN |
| keyc.useUCharMax ; |
| RETURN lookupConst (byteN, makeKey ('UCHAR_MAX')) |
| ELSIF n=wordN |
| THEN |
| keyc.useUIntMax ; |
| RETURN lookupConst (wordN, makeKey ('UINT_MAX')) |
| ELSIF n=addressN |
| THEN |
| metaError1 ('trying to obtain MAX ({%1ad}) is illegal', n) ; |
| RETURN NIL |
| ELSE |
| HALT (* finish the cacading elsif statement. *) |
| END |
| END doMax ; |
| |
| |
| (* |
| getMax - |
| *) |
| |
| PROCEDURE getMax (n: node) : node ; |
| BEGIN |
| n := skipType (n) ; |
| IF isSubrange (n) |
| THEN |
| RETURN n^.subrangeF.high |
| ELSIF isEnumeration (n) |
| THEN |
| RETURN n^.enumerationF.high |
| ELSE |
| assert (isOrdinal (n)) ; |
| RETURN doMax (n) |
| END |
| END getMax ; |
| |
| |
| (* |
| getMin - |
| *) |
| |
| PROCEDURE getMin (n: node) : node ; |
| BEGIN |
| n := skipType (n) ; |
| IF isSubrange (n) |
| THEN |
| RETURN n^.subrangeF.low |
| ELSIF isEnumeration (n) |
| THEN |
| RETURN n^.enumerationF.low |
| ELSE |
| assert (isOrdinal (n)) ; |
| RETURN doMin (n) |
| END |
| END getMin ; |
| |
| |
| (* |
| doSubtractC - |
| *) |
| |
| PROCEDURE doSubtractC (p: pretty; s: node) ; |
| BEGIN |
| IF NOT isZero (s) |
| THEN |
| outText (p, "-") ; |
| doExprC (p, s) |
| END |
| END doSubtractC ; |
| |
| |
| (* |
| doSubrC - |
| *) |
| |
| PROCEDURE doSubrC (p: pretty; s: node) ; |
| VAR |
| low, high: node ; |
| BEGIN |
| s := skipType (s) ; |
| IF isOrdinal (s) |
| THEN |
| low := getMin (s) ; |
| high := getMax (s) ; |
| doExprC (p, high) ; |
| doSubtractC (p, low) ; |
| outText (p, "+1") |
| ELSIF isEnumeration (s) |
| THEN |
| low := getMin (s) ; |
| high := getMax (s) ; |
| doExprC (p, high) ; |
| doSubtractC (p, low) ; |
| outText (p, "+1") |
| ELSE |
| assert (isSubrange (s)) ; |
| IF (s^.subrangeF.high = NIL) OR (s^.subrangeF.low = NIL) |
| THEN |
| doSubrC (p, getType (s)) |
| ELSE |
| doExprC (p, s^.subrangeF.high) ; |
| doSubtractC (p, s^.subrangeF.low) ; |
| outText (p, "+1") |
| END |
| END |
| END doSubrC ; |
| |
| |
| (* |
| doCompletePartialProcType - |
| *) |
| |
| PROCEDURE doCompletePartialProcType (p: pretty; t, n: node) ; |
| VAR |
| i, h: CARDINAL ; |
| v, u: node ; |
| BEGIN |
| assert (isProcType (n)) ; |
| u := NIL ; |
| outText (p, "typedef") ; setNeedSpace (p) ; |
| doTypeC (p, n^.proctypeF.returnType, u) ; setNeedSpace (p) ; |
| outText (p, "(*") ; |
| doFQNameC (p, t) ; |
| outText (p, "_t) (") ; |
| i := LowIndice (n^.proctypeF.parameters) ; |
| h := HighIndice (n^.proctypeF.parameters) ; |
| WHILE i <= h DO |
| v := GetIndice (n^.proctypeF.parameters, i) ; |
| doParameterC (p, v) ; |
| noSpace (p) ; |
| IF i < h |
| THEN |
| outText (p, ",") ; setNeedSpace (p) |
| END ; |
| INC (i) |
| END ; |
| IF h=0 |
| THEN |
| outText (p, "void") |
| END ; |
| outText (p, ");\n") ; |
| IF isDefForCNode (n) |
| THEN |
| (* emit a C named type which differs from the m2 proctype. *) |
| outText (p, "typedef") ; setNeedSpace (p) ; |
| doFQNameC (p, t) ; |
| outText (p, "_t") ; setNeedSpace (p) ; |
| doFQNameC (p, t) ; |
| outText (p, "_C;\n\n") |
| END ; |
| outText (p, "struct") ; setNeedSpace (p) ; |
| doFQNameC (p, t) ; |
| outText (p, "_p {") ; setNeedSpace (p) ; |
| doFQNameC (p, t) ; |
| outText (p, "_t proc; };\n\n") |
| END doCompletePartialProcType ; |
| |
| |
| (* |
| isBase - |
| *) |
| |
| PROCEDURE isBase (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| complex, |
| longcomplex, |
| shortcomplex, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| boolean, |
| proc : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isBase ; |
| |
| |
| (* |
| 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 : outText (p, 'double') | |
| longreal : outText (p, 'long double') | |
| shortreal : outText (p, 'float') | |
| bitset : outText (p, 'unsigned int') | |
| boolean : outText (p, 'unsigned int') | |
| proc : outText (p, 'PROC') |
| |
| END ; |
| setNeedSpace (p) |
| END doBaseC ; |
| |
| |
| (* |
| isSystem - |
| *) |
| |
| PROCEDURE isSystem (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| address: RETURN TRUE | |
| loc : RETURN TRUE | |
| byte : RETURN TRUE | |
| word : RETURN TRUE | |
| csizet : RETURN TRUE | |
| cssizet: RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isSystem ; |
| |
| |
| (* |
| doSystemC - |
| *) |
| |
| PROCEDURE doSystemC (p: pretty; n: node) ; |
| BEGIN |
| CASE n^.kind OF |
| |
| address: outText (p, 'void *') | |
| loc : outText (p, 'unsigned char') ; setNeedSpace (p) | |
| byte : outText (p, 'unsigned char') ; setNeedSpace (p) | |
| word : outText (p, 'unsigned int') ; setNeedSpace (p) | |
| csizet : outText (p, 'size_t') ; setNeedSpace (p) ; keyc.useSize_t | |
| cssizet: outText (p, 'ssize_t') ; setNeedSpace (p) ; keyc.useSSize_t |
| |
| END |
| END doSystemC ; |
| |
| |
| (* |
| doArrayC - |
| *) |
| |
| PROCEDURE doArrayC (p: pretty; n: node) ; |
| VAR |
| t, s, u: node ; |
| BEGIN |
| assert (isArray (n)) ; |
| t := n^.arrayF.type ; |
| s := n^.arrayF.subr ; |
| u := NIL ; |
| IF s=NIL |
| THEN |
| doTypeC (p, t, u) ; |
| setNeedSpace (p) ; |
| outText (p, "*") |
| ELSE |
| outText (p, "struct") ; |
| setNeedSpace (p) ; |
| outText (p, "{") ; |
| setNeedSpace (p) ; |
| doTypeC (p, t, u) ; |
| setNeedSpace (p) ; |
| outText (p, "array[") ; |
| IF isZero (getMin (s)) |
| THEN |
| doExprC (p, getMax (s)) |
| ELSE |
| doExprC (p, getMax (s)) ; |
| doSubtractC (p, getMin (s)) |
| END ; |
| outText (p, "];") ; |
| setNeedSpace (p) ; |
| outText (p, "}") ; |
| setNeedSpace (p) |
| END |
| END doArrayC ; |
| |
| |
| (* |
| doPointerC - |
| *) |
| |
| PROCEDURE doPointerC (p: pretty; n: node; VAR m: node) ; |
| VAR |
| t, s: node ; |
| BEGIN |
| t := n^.pointerF.type ; |
| s := NIL ; |
| doTypeC (p, t, s) ; |
| setNeedSpace (p) ; |
| outText (p, "*") |
| END doPointerC ; |
| |
| |
| (* |
| doRecordFieldC - |
| *) |
| |
| PROCEDURE doRecordFieldC (p: pretty; f: node) ; |
| VAR |
| m: node ; |
| BEGIN |
| m := NIL ; |
| setNeedSpace (p) ; |
| doTypeC (p, f^.recordfieldF.type, m) ; |
| doDNameC (p, f, FALSE) |
| END doRecordFieldC ; |
| |
| |
| (* |
| doVarientFieldC - |
| *) |
| |
| PROCEDURE doVarientFieldC (p: pretty; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| assert (isVarientField (n)) ; |
| IF NOT n^.varientfieldF.simple |
| THEN |
| outText (p, "struct") ; setNeedSpace (p) ; |
| p := outKc (p, "{\n") |
| END ; |
| i := LowIndice (n^.varientfieldF.listOfSons) ; |
| t := HighIndice (n^.varientfieldF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientfieldF.listOfSons, i) ; |
| IF isRecordField (q) |
| THEN |
| IF NOT q^.recordfieldF.tag |
| THEN |
| doRecordFieldC (p, q) ; |
| outText (p, ";\n") |
| END |
| ELSIF isVarient (q) |
| THEN |
| doVarientC (p, q) ; |
| outText (p, ";\n") |
| ELSE |
| HALT |
| END ; |
| INC (i) |
| END ; |
| IF NOT n^.varientfieldF.simple |
| THEN |
| p := outKc (p, "};\n") |
| END |
| END doVarientFieldC ; |
| |
| |
| (* |
| doVarientC - |
| *) |
| |
| PROCEDURE doVarientC (p: pretty; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| assert (isVarient (n)) ; |
| IF n^.varientF.tag # NIL |
| THEN |
| IF isRecordField (n^.varientF.tag) |
| THEN |
| doRecordFieldC (p, n^.varientF.tag) ; |
| outText (p, "; /* case tag */\n") |
| ELSIF isVarientField (n^.varientF.tag) |
| THEN |
| HALT |
| (* doVarientFieldC (p, n^.varientF.tag) *) |
| ELSE |
| HALT |
| END |
| END ; |
| outText (p, "union") ; |
| setNeedSpace (p) ; |
| p := outKc (p, "{\n") ; |
| i := LowIndice (n^.varientF.listOfSons) ; |
| t := HighIndice (n^.varientF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientF.listOfSons, i) ; |
| IF isRecordField (q) |
| THEN |
| IF NOT q^.recordfieldF.tag |
| THEN |
| doRecordFieldC (p, q) ; |
| outText (p, ";\n") |
| END |
| ELSIF isVarientField (q) |
| THEN |
| doVarientFieldC (p, q) |
| ELSE |
| HALT |
| END ; |
| INC (i) |
| END ; |
| p := outKc (p, "}") |
| END doVarientC ; |
| |
| |
| (* |
| doRecordC - |
| *) |
| |
| PROCEDURE doRecordC (p: pretty; n: node; VAR m: node) ; |
| VAR |
| i, h: CARDINAL ; |
| f : node ; |
| BEGIN |
| assert (isRecord (n)) ; |
| outText (p, "struct") ; |
| setNeedSpace (p) ; |
| p := outKc (p, "{") ; |
| i := LowIndice (n^.recordF.listOfSons) ; |
| h := HighIndice (n^.recordF.listOfSons) ; |
| setindent (p, getcurpos (p) + indentation) ; |
| outText (p, "\n") ; |
| WHILE i<=h DO |
| f := GetIndice (n^.recordF.listOfSons, i) ; |
| IF isRecordField (f) |
| THEN |
| IF NOT f^.recordfieldF.tag |
| THEN |
| doRecordFieldC (p, f) ; |
| outText (p, ";\n") |
| END |
| ELSIF isVarient (f) |
| THEN |
| doVarientC (p, f) ; |
| outText (p, ";\n") |
| ELSIF isVarientField (f) |
| THEN |
| doVarientFieldC (p, f) |
| END ; |
| INC (i) |
| END ; |
| p := outKc (p, "}") ; |
| setNeedSpace (p) |
| END doRecordC ; |
| |
| |
| (* |
| isBitset - |
| *) |
| |
| PROCEDURE isBitset (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n = bitsetN |
| END isBitset ; |
| |
| |
| (* |
| isNegative - returns TRUE if expression, n, is negative. |
| *) |
| |
| PROCEDURE isNegative (n: node) : BOOLEAN ; |
| BEGIN |
| (* --fixme-- needs to be completed. *) |
| RETURN FALSE |
| END isNegative ; |
| |
| |
| (* |
| doSubrangeC - |
| *) |
| |
| PROCEDURE doSubrangeC (p: pretty; n: node) ; |
| BEGIN |
| assert (isSubrange (n)) ; |
| IF isNegative (n^.subrangeF.low) |
| THEN |
| outText (p, "int") ; setNeedSpace (p) |
| ELSE |
| outText (p, "unsigned int") ; setNeedSpace (p) |
| END |
| END doSubrangeC ; |
| |
| |
| (* |
| doSetC - generates a C type which holds the set. |
| Currently we only support sets of size WORD. |
| *) |
| |
| PROCEDURE doSetC (p: pretty; n: node) ; |
| BEGIN |
| assert (isSet (n)) ; |
| outText (p, "unsigned int") ; setNeedSpace (p) |
| END doSetC ; |
| |
| |
| (* |
| doTypeC - |
| *) |
| |
| PROCEDURE doTypeC (p: pretty; n: node; VAR m: node) ; |
| BEGIN |
| IF n=NIL |
| THEN |
| outText (p, "void") |
| ELSIF isBase (n) |
| THEN |
| doBaseC (p, n) |
| ELSIF isSystem (n) |
| THEN |
| doSystemC (p, n) |
| ELSIF isEnumeration (n) |
| THEN |
| doEnumerationC (p, n) |
| ELSIF isType (n) |
| THEN |
| doFQNameC (p, n) ; |
| setNeedSpace (p) |
| (* doTypeAliasC (p, n, n) *) (* type, n, has a name, so we choose this over, m. *) |
| (* |
| ELSIF isProcType (n) OR isArray (n) OR isRecord (n) |
| THEN |
| HALT (* n should have been simplified. *) |
| *) |
| ELSIF isProcType (n) |
| THEN |
| doProcTypeC (p, n, m) |
| ELSIF isArray (n) |
| THEN |
| doArrayC (p, n) |
| ELSIF isRecord (n) |
| THEN |
| doRecordC (p, n, m) |
| ELSIF isPointer (n) |
| THEN |
| doPointerC (p, n, m) |
| ELSIF isSubrange (n) |
| THEN |
| doSubrangeC (p, n) |
| ELSIF isSet (n) |
| THEN |
| doSetC (p, n) |
| ELSE |
| (* --fixme-- *) |
| print (p, "to do ... typedef etc etc ") ; doFQNameC (p, n) ; print (p, ";\n") ; |
| HALT |
| END |
| END doTypeC ; |
| |
| |
| (* |
| doArrayNameC - it displays the array declaration (it might be an unbounded). |
| *) |
| |
| PROCEDURE doArrayNameC (p: pretty; n: node) ; |
| BEGIN |
| doTypeNameC (p, getType (n)) ; setNeedSpace (p) ; outText (p, "*") |
| END doArrayNameC ; |
| |
| |
| (* |
| doRecordNameC - emit the C/C++ record name <name of n>"_r". |
| *) |
| |
| PROCEDURE doRecordNameC (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := getFQstring (n) ; |
| s := ConCat (s, Mark (InitString ("_r"))) ; |
| outTextS (p, s) ; |
| s := KillString (s) |
| END doRecordNameC ; |
| |
| |
| (* |
| doPointerNameC - emit the C/C++ pointer type <name of n>*. |
| *) |
| |
| PROCEDURE doPointerNameC (p: pretty; n: node) ; |
| BEGIN |
| doTypeNameC (p, getType (n)) ; setNeedSpace (p) ; outText (p, "*") |
| END doPointerNameC ; |
| |
| |
| (* |
| doTypeNameC - |
| *) |
| |
| PROCEDURE doTypeNameC (p: pretty; n: node) ; |
| VAR |
| t: String ; |
| BEGIN |
| IF n=NIL |
| THEN |
| outText (p, "void") ; |
| setNeedSpace (p) |
| ELSIF isBase (n) |
| THEN |
| doBaseC (p, n) |
| ELSIF isSystem (n) |
| THEN |
| doSystemC (p, n) |
| ELSIF isEnumeration (n) |
| THEN |
| print (p, "is enumeration type name required\n") |
| ELSIF isType (n) |
| THEN |
| doFQNameC (p, n) ; |
| ELSIF isProcType (n) |
| THEN |
| doFQNameC (p, n) ; |
| outText (p, "_t") |
| ELSIF isArray (n) |
| THEN |
| doArrayNameC (p, n) |
| ELSIF isRecord (n) |
| THEN |
| doRecordNameC (p, n) |
| ELSIF isPointer (n) |
| THEN |
| doPointerNameC (p, n) |
| ELSIF isSubrange (n) |
| THEN |
| doSubrangeC (p, n) |
| ELSE |
| print (p, "is type unknown required\n") ; |
| stop |
| END |
| END doTypeNameC ; |
| |
| |
| (* |
| isExternal - returns TRUE if symbol, n, was declared in another module. |
| *) |
| |
| PROCEDURE isExternal (n: node) : BOOLEAN ; |
| VAR |
| s: node ; |
| BEGIN |
| s := getScope (n) ; |
| RETURN (s # NIL) AND isDef (s) AND |
| ((isImp (getMainModule ()) AND (s # lookupDef (getSymName (getMainModule ())))) OR |
| isModule (getMainModule ())) |
| END isExternal ; |
| |
| |
| (* |
| doVarC - |
| *) |
| |
| PROCEDURE doVarC (n: node) ; |
| VAR |
| s: node ; |
| BEGIN |
| IF isDef (getMainModule ()) |
| THEN |
| print (doP, "EXTERN") ; setNeedSpace (doP) |
| ELSIF (NOT isExported (n)) AND (NOT isLocal (n)) |
| THEN |
| print (doP, "static") ; setNeedSpace (doP) |
| ELSIF getExtendedOpaque () |
| THEN |
| IF isExternal (n) |
| THEN |
| (* different module declared this variable, therefore it is extern. *) |
| print (doP, "extern") ; setNeedSpace (doP) |
| END |
| END ; |
| s := NIL ; |
| doTypeC (doP, getType (n), s) ; |
| setNeedSpace (doP) ; |
| doFQDNameC (doP, n, FALSE) ; |
| print (doP, ";\n") |
| END doVarC ; |
| |
| |
| (* |
| doExternCP - |
| *) |
| |
| PROCEDURE doExternCP (p: pretty) ; |
| BEGIN |
| IF lang = ansiCP |
| THEN |
| outText (p, 'extern "C"') ; setNeedSpace (p) |
| END |
| END doExternCP ; |
| |
| |
| (* |
| doProcedureCommentText - |
| *) |
| |
| PROCEDURE doProcedureCommentText (p: pretty; s: String) ; |
| BEGIN |
| (* remove \n from the start of the comment. *) |
| WHILE (DynamicStrings.Length (s) > 0) AND (DynamicStrings.char (s, 0) = lf) DO |
| s := DynamicStrings.Slice (s, 1, 0) |
| END ; |
| outTextS (p, s) |
| END doProcedureCommentText ; |
| |
| |
| (* |
| doProcedureComment - |
| *) |
| |
| PROCEDURE doProcedureComment (p: pretty; s: String) ; |
| BEGIN |
| IF s # NIL |
| THEN |
| outText (p, '\n/*\n') ; |
| doProcedureCommentText (p, s) ; |
| outText (p, '*/\n\n') |
| END |
| END doProcedureComment ; |
| |
| |
| (* |
| doProcedureHeadingC - |
| *) |
| |
| PROCEDURE doProcedureHeadingC (n: node; prototype: BOOLEAN) ; |
| VAR |
| i, h: CARDINAL ; |
| p, q: node ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| noSpace (doP) ; |
| IF isDef (getMainModule ()) |
| THEN |
| doProcedureComment (doP, getContent (n^.procedureF.defComment)) ; |
| outText (doP, "EXTERN") ; setNeedSpace (doP) |
| ELSIF isExported (n) |
| THEN |
| doProcedureComment (doP, getContent (n^.procedureF.modComment)) ; |
| doExternCP (doP) |
| ELSE |
| doProcedureComment (doP, getContent (n^.procedureF.modComment)) ; |
| outText (doP, "static") ; setNeedSpace (doP) |
| END ; |
| q := NIL ; |
| doTypeC (doP, n^.procedureF.returnType, q) ; setNeedSpace (doP) ; |
| doFQDNameC (doP, n, FALSE) ; |
| setNeedSpace (doP) ; |
| outText (doP, "(") ; |
| i := LowIndice (n^.procedureF.parameters) ; |
| h := HighIndice (n^.procedureF.parameters) ; |
| WHILE i <= h DO |
| p := GetIndice (n^.procedureF.parameters, i) ; |
| doParameterC (doP, p) ; |
| noSpace (doP) ; |
| IF i < h |
| THEN |
| print (doP, ",") ; setNeedSpace (doP) |
| END ; |
| INC (i) |
| END ; |
| IF h=0 |
| THEN |
| outText (doP, "void") |
| END ; |
| print (doP, ")") ; |
| IF n^.procedureF.noreturn AND prototype |
| THEN |
| setNeedSpace (doP) ; |
| outText (doP, "__attribute__ ((noreturn))") |
| END |
| END doProcedureHeadingC ; |
| |
| |
| (* |
| checkDeclareUnboundedParamCopyC - |
| *) |
| |
| PROCEDURE checkDeclareUnboundedParamCopyC (p: pretty; n: node) : BOOLEAN ; |
| VAR |
| t : node ; |
| i, c: CARDINAL ; |
| l : wlist ; |
| seen: BOOLEAN ; |
| BEGIN |
| seen := FALSE ; |
| t := getType (n) ; |
| l := n^.paramF.namelist^.identlistF.names ; |
| IF isArray (t) AND isUnbounded (t) AND (l#NIL) |
| THEN |
| t := getType (t) ; |
| c := wlists.noOfItemsInList (l) ; |
| i := 1 ; |
| WHILE i <= c DO |
| doTypeNameC (p, t) ; |
| setNeedSpace (p) ; |
| doNamesC (p, wlists.getItemFromList (l, i)) ; |
| outText (p, '[_'); |
| doNamesC (p, wlists.getItemFromList (l, i)) ; |
| outText (p, '_high+1];\n'); |
| seen := TRUE ; |
| INC (i) |
| END |
| END ; |
| RETURN seen |
| END checkDeclareUnboundedParamCopyC ; |
| |
| |
| (* |
| checkUnboundedParamCopyC - |
| *) |
| |
| PROCEDURE checkUnboundedParamCopyC (p: pretty; n: node) ; |
| VAR |
| t, s: node ; |
| i, c: CARDINAL ; |
| l : wlist ; |
| BEGIN |
| t := getType (n) ; |
| l := n^.paramF.namelist^.identlistF.names ; |
| IF isArray (t) AND isUnbounded (t) AND (l#NIL) |
| THEN |
| c := wlists.noOfItemsInList (l) ; |
| i := 1 ; |
| t := getType (t) ; |
| s := skipType (t) ; |
| WHILE i <= c DO |
| keyc.useMemcpy ; |
| outText (p, 'memcpy (') ; |
| doNamesC (p, wlists.getItemFromList (l, i)) ; |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| doNamesC (p, wlists.getItemFromList (l, i)) ; |
| outText (p, '_, ') ; |
| IF (s = charN) OR (s = byteN) OR (s = locN) |
| THEN |
| outText (p, '_') ; |
| doNamesC (p, wlists.getItemFromList (l, i)) ; |
| outText (p, '_high+1);\n') |
| ELSE |
| outText (p, '(_') ; |
| doNamesC (p, wlists.getItemFromList (l, i)) ; |
| outText (p, '_high+1)') ; |
| setNeedSpace (p) ; |
| doMultiplyBySize (p, t) ; |
| outText (p, ');\n') |
| END ; |
| INC (i) |
| END |
| END |
| END checkUnboundedParamCopyC ; |
| |
| |
| (* |
| doUnboundedParamCopyC - |
| *) |
| |
| PROCEDURE doUnboundedParamCopyC (p: pretty; n: node) ; |
| VAR |
| i, h: CARDINAL ; |
| q : node ; |
| seen: BOOLEAN ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| i := LowIndice (n^.procedureF.parameters) ; |
| h := HighIndice (n^.procedureF.parameters) ; |
| seen := FALSE ; |
| WHILE i <= h DO |
| q := GetIndice (n^.procedureF.parameters, i) ; |
| IF isParam (q) |
| THEN |
| seen := checkDeclareUnboundedParamCopyC (p, q) OR seen |
| END ; |
| INC (i) |
| END ; |
| IF seen |
| THEN |
| outText (p, "\n") ; |
| outText (p, "/* make a local copy of each unbounded array. */\n") ; |
| i := LowIndice (n^.procedureF.parameters) ; |
| WHILE i <= h DO |
| q := GetIndice (n^.procedureF.parameters, i) ; |
| IF isParam (q) |
| THEN |
| checkUnboundedParamCopyC (p, q) |
| END ; |
| INC (i) |
| END |
| END |
| END doUnboundedParamCopyC ; |
| |
| |
| (* |
| doPrototypeC - |
| *) |
| |
| PROCEDURE doPrototypeC (n: node) ; |
| BEGIN |
| IF NOT isExported (n) |
| THEN |
| keyc.enterScope (n) ; |
| doProcedureHeadingC (n, TRUE) ; |
| print (doP, ";\n") ; |
| keyc.leaveScope (n) |
| END |
| END doPrototypeC ; |
| |
| |
| (* |
| addTodo - adds, n, to the todo list. |
| *) |
| |
| PROCEDURE addTodo (n: node) ; |
| BEGIN |
| IF (n#NIL) AND |
| (NOT alists.isItemInList (partialQ, n)) AND |
| (NOT alists.isItemInList (doneQ, n)) |
| THEN |
| assert (NOT isVarient (n)) ; |
| assert (NOT isVarientField (n)) ; |
| assert (NOT isDef (n)) ; |
| alists.includeItemIntoList (todoQ, n) |
| END |
| END addTodo ; |
| |
| |
| (* |
| addVariablesTodo - |
| *) |
| |
| PROCEDURE addVariablesTodo (n: node) ; |
| BEGIN |
| IF isVar (n) |
| THEN |
| IF n^.varF.isParameter OR n^.varF.isVarParameter |
| THEN |
| addDone (n) ; |
| addTodo (getType (n)) |
| ELSE |
| addTodo (n) |
| END |
| END |
| END addVariablesTodo ; |
| |
| |
| (* |
| addTypesTodo - |
| *) |
| |
| PROCEDURE addTypesTodo (n: node) ; |
| BEGIN |
| IF isUnbounded (n) |
| THEN |
| addDone (n) |
| ELSE |
| addTodo (n) |
| END |
| END addTypesTodo ; |
| |
| |
| (* |
| tempName - |
| *) |
| |
| PROCEDURE tempName () : String ; |
| BEGIN |
| INC (tempCount) ; |
| RETURN Sprintf1 (InitString ("_T%d"), tempCount) ; |
| END tempName ; |
| |
| |
| (* |
| makeIntermediateType - |
| *) |
| |
| PROCEDURE makeIntermediateType (s: String; p: node) : node ; |
| VAR |
| n: Name ; |
| o: node ; |
| BEGIN |
| n := makekey (DynamicStrings.string (s)) ; |
| enterScope (getScope (p)) ; |
| o := p ; |
| p := makeType (makekey (DynamicStrings.string (s))) ; |
| putType (p, o) ; |
| putTypeInternal (p) ; |
| leaveScope ; |
| RETURN p |
| END makeIntermediateType ; |
| |
| |
| (* |
| simplifyType - |
| *) |
| |
| PROCEDURE simplifyType (l: alist; VAR p: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| IF (p#NIL) AND (isRecord (p) OR isArray (p) OR isProcType (p)) AND (NOT isUnbounded (p)) |
| THEN |
| s := tempName () ; |
| p := makeIntermediateType (s, p) ; |
| s := KillString (s) ; |
| simplified := FALSE |
| END ; |
| simplifyNode (l, p) |
| END simplifyType ; |
| |
| |
| (* |
| simplifyVar - |
| *) |
| |
| PROCEDURE simplifyVar (l: alist; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| v, |
| d, o: node ; |
| BEGIN |
| assert (isVar (n)) ; |
| o := n^.varF.type ; |
| simplifyType (l, n^.varF.type) ; |
| IF o # n^.varF.type |
| THEN |
| (* simplification has occurred, make sure that all other variables of this type |
| use the new type. *) |
| d := n^.varF.decl ; |
| assert (isVarDecl (d)) ; |
| t := wlists.noOfItemsInList (d^.vardeclF.names) ; |
| i := 1 ; |
| WHILE i<=t DO |
| v := lookupInScope (n^.varF.scope, wlists.getItemFromList (d^.vardeclF.names, i)) ; |
| assert (isVar (v)) ; |
| v^.varF.type := n^.varF.type ; |
| INC (i) |
| END |
| END |
| END simplifyVar ; |
| |
| |
| (* |
| simplifyRecord - |
| *) |
| |
| PROCEDURE simplifyRecord (l: alist; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| i := LowIndice (n^.recordF.listOfSons) ; |
| t := HighIndice (n^.recordF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.recordF.listOfSons, i) ; |
| simplifyNode (l, q) ; |
| INC (i) |
| END |
| END simplifyRecord ; |
| |
| |
| (* |
| simplifyVarient - |
| *) |
| |
| PROCEDURE simplifyVarient (l: alist; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| simplifyNode (l, n^.varientF.tag) ; |
| i := LowIndice (n^.varientF.listOfSons) ; |
| t := HighIndice (n^.varientF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientF.listOfSons, i) ; |
| simplifyNode (l, q) ; |
| INC (i) |
| END |
| END simplifyVarient ; |
| |
| |
| (* |
| simplifyVarientField - |
| *) |
| |
| PROCEDURE simplifyVarientField (l: alist; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| i := LowIndice (n^.varientfieldF.listOfSons) ; |
| t := HighIndice (n^.varientfieldF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientfieldF.listOfSons, i) ; |
| simplifyNode (l, q) ; |
| INC (i) |
| END |
| END simplifyVarientField ; |
| |
| |
| (* |
| doSimplifyNode - |
| *) |
| |
| PROCEDURE doSimplifyNode (l: alist; n: node) ; |
| BEGIN |
| IF n=NIL |
| THEN |
| (* nothing. *) |
| ELSIF isType (n) |
| THEN |
| (* no need to simplify a type. *) |
| simplifyNode (l, getType (n)) |
| ELSIF isVar (n) |
| THEN |
| simplifyVar (l, n) |
| ELSIF isRecord (n) |
| THEN |
| simplifyRecord (l, n) |
| ELSIF isRecordField (n) |
| THEN |
| simplifyType (l, n^.recordfieldF.type) |
| ELSIF isArray (n) |
| THEN |
| simplifyType (l, n^.arrayF.type) |
| ELSIF isVarient (n) |
| THEN |
| simplifyVarient (l, n) |
| ELSIF isVarientField (n) |
| THEN |
| simplifyVarientField (l, n) |
| ELSIF isPointer (n) |
| THEN |
| simplifyType (l, n^.pointerF.type) |
| END |
| END doSimplifyNode ; |
| |
| |
| (* |
| simplifyNode - |
| *) |
| |
| PROCEDURE simplifyNode (l: alist; n: node) ; |
| BEGIN |
| IF NOT alists.isItemInList (l, n) |
| THEN |
| alists.includeItemIntoList (l, n) ; |
| doSimplifyNode (l, n) |
| END |
| END simplifyNode ; |
| |
| |
| (* |
| doSimplify - |
| *) |
| |
| PROCEDURE doSimplify (n: node) ; |
| VAR |
| l: alist ; |
| BEGIN |
| l := alists.initList () ; |
| simplifyNode (l, n) ; |
| alists.killList (l) |
| END doSimplify ; |
| |
| |
| (* |
| simplifyTypes - |
| *) |
| |
| PROCEDURE simplifyTypes (s: scopeT) ; |
| BEGIN |
| REPEAT |
| simplified := TRUE ; |
| ForeachIndiceInIndexDo (s.types, doSimplify) ; |
| ForeachIndiceInIndexDo (s.variables, doSimplify) |
| UNTIL simplified |
| END simplifyTypes ; |
| |
| |
| (* |
| outDeclsDefC - |
| *) |
| |
| PROCEDURE outDeclsDefC (p: pretty; n: node) ; |
| VAR |
| s: scopeT ; |
| BEGIN |
| s := n^.defF.decls ; |
| simplifyTypes (s) ; |
| includeConstType (s) ; |
| |
| doP := p ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) ; |
| |
| (* try and output types, constants before variables and procedures. *) |
| includeDefVarProcedure (n) ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) ; |
| |
| ForeachIndiceInIndexDo (s.procedures, doPrototypeC) |
| END outDeclsDefC ; |
| |
| |
| (* |
| includeConstType - |
| *) |
| |
| PROCEDURE includeConstType (s: scopeT) ; |
| BEGIN |
| ForeachIndiceInIndexDo (s.constants, addTodo) ; |
| ForeachIndiceInIndexDo (s.types, addTypesTodo) |
| END includeConstType ; |
| |
| |
| (* |
| includeVarProcedure - |
| *) |
| |
| PROCEDURE includeVarProcedure (s: scopeT) ; |
| BEGIN |
| ForeachIndiceInIndexDo (s.procedures, addTodo) ; |
| ForeachIndiceInIndexDo (s.variables, addVariablesTodo) |
| END includeVarProcedure ; |
| |
| |
| (* |
| includeVar - |
| *) |
| |
| PROCEDURE includeVar (s: scopeT) ; |
| BEGIN |
| ForeachIndiceInIndexDo (s.variables, addTodo) |
| END includeVar ; |
| |
| |
| (* |
| includeExternals - |
| *) |
| |
| PROCEDURE includeExternals (n: node) ; |
| VAR |
| l: alist ; |
| BEGIN |
| l := alists.initList () ; |
| visitNode (l, n, addExported) ; |
| alists.killList (l) |
| END includeExternals ; |
| |
| |
| (* |
| checkSystemInclude - |
| *) |
| |
| PROCEDURE checkSystemInclude (n: node) ; |
| BEGIN |
| |
| END checkSystemInclude ; |
| |
| |
| (* |
| addExported - |
| *) |
| |
| PROCEDURE addExported (n: node) ; |
| VAR |
| s: node ; |
| BEGIN |
| s := getScope (n) ; |
| IF (s # NIL) AND isDef (s) AND (s # defModule) |
| THEN |
| IF isType (n) OR isVar (n) OR isConst (n) |
| THEN |
| addTodo (n) |
| END |
| END |
| END addExported ; |
| |
| |
| (* |
| addExternal - only adds, n, if this symbol is external to the |
| implementation module and is not a hidden type. |
| *) |
| |
| PROCEDURE addExternal (n: node) ; |
| BEGIN |
| IF (getScope (n) = defModule) AND isType (n) AND |
| isTypeHidden (n) AND (NOT getExtendedOpaque ()) |
| THEN |
| (* do nothing. *) |
| ELSIF NOT isDef (n) |
| THEN |
| addTodo (n) |
| END |
| END addExternal ; |
| |
| |
| (* |
| includeDefConstType - |
| *) |
| |
| PROCEDURE includeDefConstType (n: node) ; |
| VAR |
| d: node ; |
| BEGIN |
| IF isImp (n) |
| THEN |
| defModule := lookupDef (getSymName (n)) ; |
| IF defModule#NIL |
| THEN |
| simplifyTypes (defModule^.defF.decls) ; |
| includeConstType (defModule^.defF.decls) ; |
| foreachNodeDo (defModule^.defF.decls.symbols, addExternal) |
| END |
| END |
| END includeDefConstType ; |
| |
| |
| (* |
| runIncludeDefConstType - |
| *) |
| |
| PROCEDURE runIncludeDefConstType (n: node) ; |
| VAR |
| d: node ; |
| BEGIN |
| IF isDef (n) |
| THEN |
| simplifyTypes (n^.defF.decls) ; |
| includeConstType (n^.defF.decls) ; |
| foreachNodeDo (n^.defF.decls.symbols, addExternal) |
| END |
| END runIncludeDefConstType ; |
| |
| |
| (* |
| joinProcedures - copies procedures from definition module, |
| d, into implementation module, i. |
| *) |
| |
| PROCEDURE joinProcedures (i, d: node) ; |
| VAR |
| h, j: CARDINAL ; |
| BEGIN |
| assert (isDef (d)) ; |
| assert (isImp (i)) ; |
| j := 1 ; |
| h := HighIndice (d^.defF.decls.procedures) ; |
| WHILE j<=h DO |
| IncludeIndiceIntoIndex (i^.impF.decls.procedures, |
| GetIndice (d^.defF.decls.procedures, j)) ; |
| INC (j) |
| END |
| END joinProcedures ; |
| |
| |
| (* |
| includeDefVarProcedure - |
| *) |
| |
| PROCEDURE includeDefVarProcedure (n: node) ; |
| VAR |
| d: node ; |
| BEGIN |
| IF isImp (n) |
| THEN |
| defModule := lookupDef (getSymName (n)) ; |
| IF defModule#NIL |
| THEN |
| (* |
| includeVar (defModule^.defF.decls) ; |
| simplifyTypes (defModule^.defF.decls) ; |
| *) |
| joinProcedures (n, defModule) |
| END |
| ELSIF isDef (n) |
| THEN |
| includeVar (n^.defF.decls) ; |
| simplifyTypes (n^.defF.decls) |
| END |
| END includeDefVarProcedure ; |
| |
| |
| (* |
| foreachModuleDo - |
| *) |
| |
| PROCEDURE foreachModuleDo (n: node; p: performOperation) ; |
| BEGIN |
| foreachDefModuleDo (p) ; |
| foreachModModuleDo (p) |
| END foreachModuleDo ; |
| |
| |
| (* |
| outDeclsImpC - |
| *) |
| |
| PROCEDURE outDeclsImpC (p: pretty; s: scopeT) ; |
| BEGIN |
| simplifyTypes (s) ; |
| includeConstType (s) ; |
| |
| doP := p ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) ; |
| |
| (* try and output types, constants before variables and procedures. *) |
| includeVarProcedure (s) ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) ; |
| |
| END outDeclsImpC ; |
| |
| |
| (* |
| doStatementSequenceC - |
| *) |
| |
| PROCEDURE doStatementSequenceC (p: pretty; s: node) ; |
| VAR |
| i, h: CARDINAL ; |
| BEGIN |
| assert (isStatementSequence (s)) ; |
| h := HighIndice (s^.stmtF.statements) ; |
| i := 1 ; |
| WHILE i<=h DO |
| doStatementsC (p, GetIndice (s^.stmtF.statements, i)) ; |
| INC (i) |
| END |
| END doStatementSequenceC ; |
| |
| |
| (* |
| isStatementSequenceEmpty - |
| *) |
| |
| PROCEDURE isStatementSequenceEmpty (s: node) : BOOLEAN ; |
| BEGIN |
| assert (isStatementSequence (s)) ; |
| RETURN HighIndice (s^.stmtF.statements) = 0 |
| END isStatementSequenceEmpty ; |
| |
| |
| (* |
| isSingleStatement - returns TRUE if the statement sequence, s, has |
| only one statement. |
| *) |
| |
| PROCEDURE isSingleStatement (s: node) : BOOLEAN ; |
| VAR |
| h: CARDINAL ; |
| BEGIN |
| assert (isStatementSequence (s)) ; |
| h := HighIndice (s^.stmtF.statements) ; |
| IF (h = 0) OR (h > 1) |
| THEN |
| RETURN FALSE |
| END ; |
| s := GetIndice (s^.stmtF.statements, 1) ; |
| RETURN (NOT isStatementSequence (s)) OR isSingleStatement (s) |
| END isSingleStatement ; |
| |
| |
| (* |
| doCommentC - |
| *) |
| |
| PROCEDURE doCommentC (p: pretty; s: node) ; |
| VAR |
| c: String ; |
| BEGIN |
| IF s # NIL |
| THEN |
| assert (isComment (s)) ; |
| IF NOT isProcedureComment (s^.commentF.content) |
| THEN |
| IF isAfterComment (s^.commentF.content) |
| THEN |
| setNeedSpace (p) ; |
| outText (p, " /* ") |
| ELSE |
| outText (p, "/* ") |
| END ; |
| c := getContent (s^.commentF.content) ; |
| c := RemoveWhitePrefix (RemoveWhitePostfix (c)) ; |
| outTextS (p, c) ; |
| outText (p, " */\n") |
| END |
| END |
| END doCommentC ; |
| |
| |
| (* |
| doAfterCommentC - emit an after comment, c, or a newline if, c, is empty. |
| *) |
| |
| PROCEDURE doAfterCommentC (p: pretty; c: node) ; |
| BEGIN |
| IF c = NIL |
| THEN |
| outText (p, "\n") |
| ELSE |
| doCommentC (p, c) |
| END |
| END doAfterCommentC ; |
| |
| |
| (* |
| doReturnC - issue a return statement and also place in an after comment if one exists. |
| *) |
| |
| PROCEDURE doReturnC (p: pretty; s: node) ; |
| BEGIN |
| assert (isReturn (s)) ; |
| doCommentC (p, s^.returnF.returnComment.body) ; |
| outText (p, "return") ; |
| IF s^.returnF.scope#NIL |
| THEN |
| setNeedSpace (p) ; |
| IF (NOT isProcedure (s^.returnF.scope)) OR (getType (s^.returnF.scope)=NIL) |
| THEN |
| metaError1 ('{%1DMad} has no return type', s^.returnF.scope) ; |
| ELSE |
| doExprCastC (p, s^.returnF.exp, getType (s^.returnF.scope)) |
| END |
| END ; |
| outText (p, ";") ; |
| doAfterCommentC (p, s^.returnF.returnComment.after) |
| END doReturnC ; |
| |
| |
| (* |
| isZtypeEquivalent - |
| *) |
| |
| PROCEDURE isZtypeEquivalent (type: node) : BOOLEAN ; |
| BEGIN |
| CASE type^.kind OF |
| |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| ztype : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isZtypeEquivalent ; |
| |
| |
| (* |
| isEquivalentType - returns TRUE if type1 and type2 are equivalent. |
| *) |
| |
| PROCEDURE isEquivalentType (type1, type2: node) : BOOLEAN ; |
| BEGIN |
| type1 := skipType (type1) ; |
| type2 := skipType (type2) ; |
| RETURN ((type1 = type2) OR |
| (isZtypeEquivalent (type1) AND isZtypeEquivalent (type2))) |
| END isEquivalentType ; |
| |
| |
| (* |
| doExprCastC - build a cast if necessary. |
| *) |
| |
| PROCEDURE doExprCastC (p: pretty; e, type: node) ; |
| VAR |
| stype: node ; |
| BEGIN |
| stype := skipType (type) ; |
| IF (NOT isEquivalentType (type, getExprType (e))) AND |
| (NOT ((e^.kind = nil) AND (isPointer (stype) OR (stype^.kind = address)))) |
| THEN |
| IF lang = ansiCP |
| THEN |
| (* potentially a cast is required. *) |
| IF isPointer (type) OR (type = addressN) |
| THEN |
| outText (p, 'reinterpret_cast<') ; |
| doTypeNameC (p, type) ; |
| noSpace (p) ; |
| outText (p, '> (') ; |
| doExprC (p, e) ; |
| outText (p, ')') ; |
| RETURN |
| ELSE |
| outText (p, 'static_cast<') ; |
| IF isProcType (skipType (type)) |
| THEN |
| doTypeNameC (p, type) ; |
| outText (p, "_t") |
| ELSE |
| doTypeNameC (p, type) |
| END ; |
| noSpace (p) ; |
| outText (p, '> (') ; |
| doExprC (p, e) ; |
| outText (p, ')') ; |
| RETURN |
| END |
| END |
| END ; |
| doExprC (p, e) |
| END doExprCastC ; |
| |
| |
| (* |
| requiresUnpackProc - returns TRUE if either the expr is a procedure or the proctypes differ. |
| *) |
| |
| PROCEDURE requiresUnpackProc (s: node) : BOOLEAN ; |
| BEGIN |
| assert (isAssignment (s)) ; |
| RETURN isProcedure (s^.assignmentF.expr) OR |
| (skipType (getType (s^.assignmentF.des)) # skipType (getType (s^.assignmentF.expr))) |
| END requiresUnpackProc ; |
| |
| |
| (* |
| doAssignmentC - |
| *) |
| |
| PROCEDURE doAssignmentC (p: pretty; s: node) ; |
| BEGIN |
| assert (isAssignment (s)) ; |
| doCommentC (p, s^.assignmentF.assignComment.body) ; |
| doExprCup (p, s^.assignmentF.des, requiresUnpackProc (s)) ; |
| setNeedSpace (p) ; |
| outText (p, "=") ; |
| setNeedSpace (p) ; |
| doExprCastC (p, s^.assignmentF.expr, getType (s^.assignmentF.des)) ; |
| outText (p, ";") ; |
| doAfterCommentC (p, s^.assignmentF.assignComment.after) |
| END doAssignmentC ; |
| |
| |
| (* |
| containsStatement - |
| *) |
| |
| PROCEDURE containsStatement (s: node) : BOOLEAN ; |
| BEGIN |
| RETURN (s # NIL) AND isStatementSequence (s) AND (NOT isStatementSequenceEmpty (s)) |
| END containsStatement ; |
| |
| |
| (* |
| doCompoundStmt - |
| *) |
| |
| PROCEDURE doCompoundStmt (p: pretty; s: node) ; |
| BEGIN |
| IF (s = NIL) OR (isStatementSequence (s) AND isStatementSequenceEmpty (s)) |
| THEN |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "{} /* empty. */\n") ; |
| p := popPretty (p) |
| ELSIF isStatementSequence (s) AND isSingleStatement (s) AND (NOT forceCompoundStatement) |
| THEN |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doStatementSequenceC (p, s) ; |
| p := popPretty (p) |
| ELSE |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "{\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doStatementSequenceC (p, s) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") ; |
| p := popPretty (p) |
| END |
| END doCompoundStmt ; |
| |
| |
| (* |
| doElsifC - |
| *) |
| |
| PROCEDURE doElsifC (p: pretty; s: node) ; |
| BEGIN |
| assert (isElsif (s)) ; |
| outText (p, "else if") ; |
| setNeedSpace (p) ; |
| outText (p, "(") ; |
| doExprC (p, s^.elsifF.expr) ; |
| outText (p, ")\n") ; |
| assert ((s^.elsifF.else = NIL) OR (s^.elsifF.elsif = NIL)) ; |
| IF forceCompoundStatement OR |
| (hasIfAndNoElse (s^.elsifF.then) AND |
| ((s^.elsifF.else # NIL) OR (s^.elsifF.elsif # NIL))) |
| THEN |
| (* avoid dangling else. *) |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "{\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "/* avoid dangling else. */\n") ; |
| doStatementSequenceC (p, s^.elsifF.then) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") ; |
| p := popPretty (p) |
| ELSE |
| doCompoundStmt (p, s^.elsifF.then) |
| END ; |
| IF containsStatement (s^.elsifF.else) |
| THEN |
| outText (p, "else\n") ; |
| IF forceCompoundStatement |
| THEN |
| (* avoid dangling else. *) |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "{\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "/* avoid dangling else. */\n") ; |
| doStatementSequenceC (p, s^.elsifF.else) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") ; |
| p := popPretty (p) |
| ELSE |
| doCompoundStmt (p, s^.elsifF.else) |
| END |
| ELSIF (s^.elsifF.elsif#NIL) AND isElsif (s^.elsifF.elsif) |
| THEN |
| doElsifC (p, s^.elsifF.elsif) |
| END |
| END doElsifC ; |
| |
| |
| (* |
| noIfElse - |
| *) |
| |
| PROCEDURE noIfElse (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN (n # NIL) AND isIf (n) AND (n^.ifF.else = NIL) AND (n^.ifF.elsif = NIL) |
| END noIfElse ; |
| |
| |
| (* |
| noIfElseChained - returns TRUE if, n, is an IF statement which |
| has no associated ELSE statement. An IF with an |
| ELSIF is also checked for no ELSE and will result |
| in a return value of TRUE. |
| *) |
| |
| PROCEDURE noIfElseChained (n: node) : BOOLEAN ; |
| VAR |
| e: node ; |
| BEGIN |
| IF n # NIL |
| THEN |
| IF isIf (n) |
| THEN |
| IF n^.ifF.else # NIL |
| THEN |
| (* we do have an else, continue to check this statement. *) |
| RETURN hasIfAndNoElse (n^.ifF.else) |
| ELSIF n^.ifF.elsif = NIL |
| THEN |
| (* neither else or elsif. *) |
| RETURN TRUE |
| ELSE |
| (* test elsif for lack of else. *) |
| e := n^.ifF.elsif ; |
| assert (isElsif (e)) ; |
| RETURN noIfElseChained (e) |
| END |
| ELSIF isElsif (n) |
| THEN |
| IF n^.elsifF.else # NIL |
| THEN |
| (* we do have an else, continue to check this statement. *) |
| RETURN hasIfAndNoElse (n^.elsifF.else) |
| ELSIF n^.elsifF.elsif = NIL |
| THEN |
| (* neither else or elsif. *) |
| RETURN TRUE |
| ELSE |
| (* test elsif for lack of else. *) |
| e := n^.elsifF.elsif ; |
| assert (isElsif (e)) ; |
| RETURN noIfElseChained (e) |
| END |
| END |
| END ; |
| RETURN FALSE |
| END noIfElseChained ; |
| |
| |
| (* |
| hasIfElse - |
| *) |
| |
| PROCEDURE hasIfElse (n: node) : BOOLEAN ; |
| BEGIN |
| IF n # NIL |
| THEN |
| IF isStatementSequence (n) |
| THEN |
| IF isStatementSequenceEmpty (n) |
| THEN |
| RETURN FALSE |
| ELSIF isSingleStatement (n) |
| THEN |
| n := GetIndice (n^.stmtF.statements, 1) ; |
| RETURN isIfElse (n) |
| END |
| END |
| END ; |
| RETURN FALSE |
| END hasIfElse ; |
| |
| |
| (* |
| isIfElse - |
| *) |
| |
| PROCEDURE isIfElse (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN (n # NIL) AND isIf (n) AND ((n^.ifF.else # NIL) OR (n^.ifF.elsif # NIL)) |
| END isIfElse ; |
| |
| |
| (* |
| hasIfAndNoElse - returns TRUE if statement, n, is a single statement |
| which is an IF and it has no else statement. |
| *) |
| |
| PROCEDURE hasIfAndNoElse (n: node) : BOOLEAN ; |
| BEGIN |
| IF n # NIL |
| THEN |
| IF isStatementSequence (n) |
| THEN |
| IF isStatementSequenceEmpty (n) |
| THEN |
| RETURN FALSE |
| ELSIF isSingleStatement (n) |
| THEN |
| n := GetIndice (n^.stmtF.statements, 1) ; |
| RETURN hasIfAndNoElse (n) |
| ELSE |
| n := GetIndice (n^.stmtF.statements, HighIndice (n^.stmtF.statements)) ; |
| RETURN hasIfAndNoElse (n) |
| END |
| ELSIF isElsif (n) OR isIf (n) |
| THEN |
| RETURN noIfElseChained (n) |
| END |
| END ; |
| RETURN FALSE |
| END hasIfAndNoElse ; |
| |
| |
| (* |
| doIfC - issue an if statement and also place in an after comment if one exists. |
| The if statement might contain an else or elsif which are also handled. |
| *) |
| |
| PROCEDURE doIfC (p: pretty; s: node) ; |
| BEGIN |
| assert (isIf (s)) ; |
| doCommentC (p, s^.ifF.ifComment.body) ; |
| outText (p, "if") ; |
| setNeedSpace (p) ; |
| outText (p, "(") ; |
| doExprC (p, s^.ifF.expr) ; |
| outText (p, ")") ; |
| doAfterCommentC (p, s^.ifF.ifComment.after) ; |
| IF hasIfAndNoElse (s^.ifF.then) AND |
| ((s^.ifF.else # NIL) OR (s^.ifF.elsif # NIL)) |
| THEN |
| (* avoid dangling else. *) |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "{\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "/* avoid dangling else. */\n") ; |
| doStatementSequenceC (p, s^.ifF.then) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") ; |
| p := popPretty (p) |
| ELSIF noIfElse (s) AND hasIfElse (s^.ifF.then) |
| THEN |
| (* gcc does not like legal non dangling else, as it is poor style. |
| So we will avoid getting a warning. *) |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "{\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| outText (p, "/* avoid gcc warning by using compound statement even if not strictly necessary. */\n") ; |
| doStatementSequenceC (p, s^.ifF.then) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") ; |
| p := popPretty (p) |
| ELSE |
| doCompoundStmt (p, s^.ifF.then) |
| END ; |
| assert ((s^.ifF.else = NIL) OR (s^.ifF.elsif = NIL)) ; |
| IF containsStatement (s^.ifF.else) |
| THEN |
| doCommentC (p, s^.ifF.elseComment.body) ; |
| outText (p, "else") ; |
| doAfterCommentC (p, s^.ifF.elseComment.after) ; |
| doCompoundStmt (p, s^.ifF.else) |
| ELSIF (s^.ifF.elsif#NIL) AND isElsif (s^.ifF.elsif) |
| THEN |
| doCommentC (p, s^.ifF.elseComment.body) ; |
| doCommentC (p, s^.ifF.elseComment.after) ; |
| doElsifC (p, s^.ifF.elsif) |
| END ; |
| doCommentC (p, s^.ifF.endComment.after) ; |
| doCommentC (p, s^.ifF.endComment.body) |
| END doIfC ; |
| |
| |
| (* |
| doForIncCP - |
| *) |
| |
| PROCEDURE doForIncCP (p: pretty; s: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isFor (s)) ; |
| t := skipType (getType (s^.forF.des)) ; |
| IF isEnumeration (t) |
| THEN |
| IF s^.forF.increment = NIL |
| THEN |
| doExprC (p, s^.forF.des) ; |
| outText (p, "= static_cast<") ; |
| doTypeNameC (p, getType (s^.forF.des)) ; |
| noSpace (p) ; |
| outText (p, ">(static_cast<int>(") ; |
| doExprC (p, s^.forF.des) ; |
| outText (p, "+1))") |
| ELSE |
| doExprC (p, s^.forF.des) ; |
| outText (p, "= static_cast<") ; |
| doTypeNameC (p, getType (s^.forF.des)) ; |
| noSpace (p) ; |
| outText (p, ">(static_cast<int>(") ; |
| doExprC (p, s^.forF.des) ; |
| outText (p, "+") ; |
| doExprC (p, s^.forF.increment) ; |
| outText (p, "))") |
| END |
| ELSE |
| doForIncC (p, s) |
| END |
| END doForIncCP ; |
| |
| |
| (* |
| doForIncC - |
| *) |
| |
| PROCEDURE doForIncC (p: pretty; s: node) ; |
| BEGIN |
| IF s^.forF.increment = NIL |
| THEN |
| doExprC (p, s^.forF.des) ; |
| outText (p, "++") |
| ELSE |
| doExprC (p, s^.forF.des) ; |
| outText (p, "=") ; |
| doExprC (p, s^.forF.des) ; |
| outText (p, "+") ; |
| doExprC (p, s^.forF.increment) |
| END |
| END doForIncC ; |
| |
| |
| (* |
| doForInc - |
| *) |
| |
| PROCEDURE doForInc (p: pretty; s: node) ; |
| BEGIN |
| IF lang = ansiCP |
| THEN |
| doForIncCP (p, s) |
| ELSE |
| doForIncC (p, s) |
| END |
| END doForInc ; |
| |
| |
| (* |
| doForC - |
| *) |
| |
| PROCEDURE doForC (p: pretty; s: node) ; |
| BEGIN |
| assert (isFor (s)) ; |
| outText (p, "for (") ; |
| doExprC (p, s^.forF.des) ; |
| outText (p, "=") ; |
| doExprC (p, s^.forF.start) ; |
| outText (p, ";") ; |
| setNeedSpace (p) ; |
| doExprC (p, s^.forF.des) ; |
| outText (p, "<=") ; |
| doExprC (p, s^.forF.end) ; |
| outText (p, ";") ; |
| setNeedSpace (p) ; |
| doForInc (p, s) ; |
| outText (p, ")\n") ; |
| doCompoundStmt (p, s^.forF.statements) |
| END doForC ; |
| |
| |
| (* |
| doRepeatC - |
| *) |
| |
| PROCEDURE doRepeatC (p: pretty; s: node) ; |
| BEGIN |
| assert (isRepeat (s)) ; |
| doCommentC (p, s^.repeatF.repeatComment.body) ; |
| outText (p, "do {") ; |
| doAfterCommentC (p, s^.repeatF.repeatComment.after) ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doStatementSequenceC (p, s^.repeatF.statements) ; |
| doCommentC (p, s^.repeatF.untilComment.body) ; |
| p := popPretty (p) ; |
| outText (p, "} while (! (") ; |
| doExprC (p, s^.repeatF.expr) ; |
| outText (p, "));") ; |
| doAfterCommentC (p, s^.repeatF.untilComment.after) |
| END doRepeatC ; |
| |
| |
| (* |
| doWhileC - |
| *) |
| |
| PROCEDURE doWhileC (p: pretty; s: node) ; |
| BEGIN |
| assert (isWhile (s)) ; |
| doCommentC (p, s^.whileF.doComment.body) ; |
| outText (p, "while (") ; |
| doExprC (p, s^.whileF.expr) ; |
| outText (p, ")") ; |
| doAfterCommentC (p, s^.whileF.doComment.after) ; |
| doCompoundStmt (p, s^.whileF.statements) ; |
| doCommentC (p, s^.whileF.endComment.body) ; |
| doCommentC (p, s^.whileF.endComment.after) |
| END doWhileC ; |
| |
| |
| (* |
| doFuncHighC - |
| *) |
| |
| PROCEDURE doFuncHighC (p: pretty; a: node) ; |
| VAR |
| s, n: node ; |
| BEGIN |
| IF isLiteral (a) AND (getType (a) = charN) |
| THEN |
| outCard (p, 0) |
| ELSIF isString (a) |
| THEN |
| outCard (p, a^.stringF.length-2) |
| ELSIF isConst (a) AND isString (a^.constF.value) |
| THEN |
| doFuncHighC (p, a^.constF.value) |
| ELSIF isUnbounded (getType (a)) |
| THEN |
| outText (p, '_') ; |
| outTextN (p, getSymName (a)) ; |
| outText (p, '_high') |
| ELSIF isArray (skipType (getType (a))) |
| THEN |
| n := skipType (getType (a)) ; |
| s := n^.arrayF.subr ; |
| IF isZero (getMin (s)) |
| THEN |
| doExprC (p, getMax (s)) |
| ELSE |
| outText (p, '(') ; |
| doExprC (p, getMax (s)) ; |
| doSubtractC (p, getMin (s)) ; |
| outText (p, ')') |
| END |
| ELSE |
| (* output sizeof (a) in bytes for the high. *) |
| outText (p, '(sizeof') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, a) ; |
| outText (p, ')-1)') |
| END |
| END doFuncHighC ; |
| |
| |
| (* |
| doMultiplyBySize - |
| *) |
| |
| PROCEDURE doMultiplyBySize (p: pretty; a: node) ; |
| BEGIN |
| IF (a # charN) AND (a # byteN) AND (a # locN) |
| THEN |
| setNeedSpace (p) ; |
| outText (p, '* sizeof (') ; |
| doTypeNameC (p, a) ; |
| noSpace (p) ; |
| outText (p, ')') |
| END |
| END doMultiplyBySize ; |
| |
| |
| (* |
| doTotype - |
| *) |
| |
| PROCEDURE doTotype (p: pretty; a, t: node) ; |
| BEGIN |
| IF (NOT isString (a)) AND (NOT isLiteral (a)) |
| THEN |
| IF isVar (a) |
| THEN |
| IF (a^.varF.isParameter OR a^.varF.isVarParameter) AND |
| isUnbounded (getType (a)) AND (skipType (getType (getType (a))) = skipType (getType (t))) |
| THEN |
| (* do not multiply by size as the existing high value is correct. *) |
| RETURN |
| END ; |
| a := getType (a) ; |
| IF isArray (a) |
| THEN |
| doMultiplyBySize (p, skipType (getType (a))) |
| END |
| END |
| END ; |
| IF t = wordN |
| THEN |
| setNeedSpace (p) ; |
| outText (p, '/ sizeof (') ; |
| doTypeNameC (p, wordN) ; |
| noSpace (p) ; |
| outText (p, ')') |
| END |
| END doTotype ; |
| |
| |
| (* |
| doFuncUnbounded - |
| *) |
| |
| PROCEDURE doFuncUnbounded (p: pretty; actual, formalParam, formal, func: node) ; |
| VAR |
| h: node ; |
| s: String ; |
| BEGIN |
| assert (isUnbounded (formal)) ; |
| outText (p, '(') ; |
| IF (lang = ansiCP) AND isParam (formalParam) |
| THEN |
| outText (p, "const") ; |
| setNeedSpace (p) |
| END ; |
| doTypeC (p, getType (formal), formal) ; |
| setNeedSpace (p) ; |
| outText (p, '*)') ; |
| setNeedSpace (p) ; |
| IF isLiteral (actual) AND (getType (actual) = charN) |
| THEN |
| outText (p, '"\0') ; |
| s := InitStringCharStar (keyToCharStar (actual^.literalF.name)) ; |
| s := DynamicStrings.Slice (DynamicStrings.Mark (s), 0, -1) ; |
| outTextS (p, s) ; |
| outText (p, '"') ; |
| s := KillString (s) |
| ELSIF isString (actual) |
| THEN |
| outCstring (p, actual, TRUE) |
| ELSIF isConst (actual) |
| THEN |
| actual := resolveString (actual) ; |
| assert (isString (actual)) ; |
| outCstring (p, actual, TRUE) |
| ELSIF isFuncCall (actual) |
| THEN |
| IF getExprType (actual) = NIL |
| THEN |
| metaError3 ('there is no return type to the procedure function {%3ad} which is being passed as the parameter {%1ad} to {%2ad}', formal, func, actual) |
| ELSE |
| outText (p, '&') ; |
| doExprC (p, actual) |
| END |
| ELSIF isUnbounded (getType (actual)) |
| THEN |
| doFQNameC (p, actual) |
| (* doExprC (p, actual). *) |
| ELSE |
| outText (p, '&') ; |
| doExprC (p, actual) ; |
| IF isArray (skipType (getType (actual))) |
| THEN |
| outText (p, '.array[0]') |
| END |
| END ; |
| IF NOT (enableDefForCStrings AND isDefForC (getScope (func))) |
| THEN |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| doFuncHighC (p, actual) ; |
| doTotype (p, actual, formal) |
| END |
| END doFuncUnbounded ; |
| |
| |
| (* |
| doProcedureParamC - |
| *) |
| |
| PROCEDURE doProcedureParamC (p: pretty; actual, formal: node) ; |
| BEGIN |
| IF isForC (formal) |
| THEN |
| outText (p, '(') ; |
| doFQNameC (p, getType (formal)) ; |
| outText (p, "_C") ; |
| outText (p, ')') ; |
| setNeedSpace (p) ; |
| doExprC (p, actual) |
| ELSE |
| outText (p, '(') ; |
| doTypeNameC (p, getType (formal)) ; |
| outText (p, ')') ; |
| setNeedSpace (p) ; |
| outText (p, '{') ; |
| outText (p, '(') ; |
| doFQNameC (p, getType (formal)) ; |
| outText (p, '_t)') ; |
| setNeedSpace (p) ; |
| doExprC (p, actual) ; |
| outText (p, '}') |
| END |
| END doProcedureParamC ; |
| |
| |
| (* |
| doAdrExprC - |
| *) |
| |
| PROCEDURE doAdrExprC (p: pretty; n: node) ; |
| BEGIN |
| IF isDeref (n) |
| THEN |
| (* (* no point in issuing & ( * n ) *) *) |
| doExprC (p, n^.unaryF.arg) |
| ELSIF isVar (n) AND n^.varF.isVarParameter |
| THEN |
| (* (* no point in issuing & ( * n ) *) *) |
| doFQNameC (p, n) |
| ELSE |
| outText (p, '&') ; |
| doExprC (p, n) |
| END |
| END doAdrExprC ; |
| |
| |
| (* |
| typePair - |
| *) |
| |
| PROCEDURE typePair (a, b, x, y: node) : BOOLEAN ; |
| BEGIN |
| RETURN ((a = x) AND (b = y)) OR ((a = y) AND (b = x)) |
| END typePair ; |
| |
| |
| (* |
| needsCast - return TRUE if the actual type parameter needs to be cast to |
| the formal type. |
| *) |
| |
| PROCEDURE needsCast (at, ft: node) : BOOLEAN ; |
| BEGIN |
| at := skipType (at) ; |
| ft := skipType (ft) ; |
| IF (at = nilN) OR (at^.kind = nil) OR |
| (at = ft) OR |
| typePair (at, ft, cardinalN, wordN) OR |
| typePair (at, ft, cardinalN, ztypeN) OR |
| typePair (at, ft, integerN, ztypeN) OR |
| typePair (at, ft, longcardN, ztypeN) OR |
| typePair (at, ft, shortcardN, ztypeN) OR |
| typePair (at, ft, longintN, ztypeN) OR |
| typePair (at, ft, shortintN, ztypeN) OR |
| typePair (at, ft, realN, rtypeN) OR |
| typePair (at, ft, longrealN, rtypeN) OR |
| typePair (at, ft, shortrealN, rtypeN) |
| THEN |
| RETURN FALSE |
| ELSE |
| RETURN TRUE |
| END |
| END needsCast ; |
| |
| |
| (* |
| checkSystemCast - checks to see if we are passing to/from |
| a system generic type (WORD, BYTE, ADDRESS) |
| and if so emit a cast. It returns the number of |
| open parenthesis. |
| *) |
| |
| PROCEDURE checkSystemCast (p: pretty; actual, formal: node) : CARDINAL ; |
| VAR |
| at, ft: node ; |
| BEGIN |
| at := getExprType (actual) ; |
| ft := getType (formal) ; |
| IF needsCast (at, ft) |
| THEN |
| IF lang = ansiCP |
| THEN |
| IF isString (actual) AND (skipType (ft) = addressN) |
| THEN |
| outText (p, "const_cast<void*> (reinterpret_cast<const void*> (") ; |
| RETURN 2 |
| ELSIF isPointer (skipType (ft)) OR (skipType (ft) = addressN) |
| THEN |
| IF actual = nilN |
| THEN |
| IF isVarParam (formal) |
| THEN |
| metaError1 ('NIL is being passed to a VAR parameter {%1DMad}', formal) |
| END ; |
| (* NULL is compatible with pointers/address. *) |
| RETURN 0 |
| ELSE |
| outText (p, 'reinterpret_cast<') ; |
| doTypeNameC (p, ft) ; |
| IF isVarParam (formal) |
| THEN |
| outText (p, '*') |
| END ; |
| noSpace (p) ; |
| outText (p, '> (') |
| END |
| ELSE |
| outText (p, 'static_cast<') ; |
| doTypeNameC (p, ft) ; |
| IF isVarParam (formal) |
| THEN |
| outText (p, '*') |
| END ; |
| noSpace (p) ; |
| outText (p, '> (') |
| END ; |
| RETURN 1 |
| ELSE |
| outText (p, '(') ; |
| doTypeNameC (p, ft) ; |
| IF isVarParam (formal) |
| THEN |
| outText (p, '*') |
| END ; |
| noSpace (p) ; |
| outText (p, ')') ; |
| setNeedSpace (p) |
| END |
| END ; |
| RETURN 0 |
| END checkSystemCast ; |
| |
| |
| (* |
| emitN - |
| *) |
| |
| PROCEDURE emitN (p: pretty; a: ARRAY OF CHAR; n: CARDINAL) ; |
| BEGIN |
| WHILE n>0 DO |
| outText (p, a) ; |
| DEC (n) |
| END |
| END emitN ; |
| |
| |
| (* |
| isForC - return true if node n is a varparam, param or procedure |
| which was declared inside a definition module for "C". |
| *) |
| |
| PROCEDURE isForC (n: node) : BOOLEAN ; |
| BEGIN |
| IF isVarParam (n) |
| THEN |
| RETURN n^.varparamF.isForC |
| ELSIF isParam (n) |
| THEN |
| RETURN n^.paramF.isForC |
| ELSIF isProcedure (n) |
| THEN |
| RETURN n^.procedureF.isForC |
| END ; |
| RETURN FALSE |
| END isForC ; |
| |
| |
| (* |
| isDefForCNode - return TRUE if node n was declared inside a definition module for "C". |
| *) |
| |
| PROCEDURE isDefForCNode (n: node) : BOOLEAN ; |
| VAR |
| name: Name ; |
| BEGIN |
| WHILE (n # NIL) AND (NOT (isImp (n) OR isDef (n) OR isModule (n))) DO |
| n := getScope (n) |
| END ; |
| IF (n # NIL) AND isImp (n) |
| THEN |
| name := getSymName (n) ; |
| n := lookupDef (name) ; |
| END ; |
| RETURN (n # NIL) AND isDef (n) AND isDefForC (n) |
| END isDefForCNode ; |
| |
| |
| (* |
| doFuncParamC - |
| *) |
| |
| PROCEDURE doFuncParamC (p: pretty; actual, formal, func: node) ; |
| VAR |
| ft, at: node ; |
| lbr : CARDINAL ; |
| BEGIN |
| IF formal = NIL |
| THEN |
| doExprC (p, actual) |
| ELSE |
| ft := skipType (getType (formal)) ; |
| IF isUnbounded (ft) |
| THEN |
| doFuncUnbounded (p, actual, formal, ft, func) |
| ELSE |
| IF isAProcType (ft) AND isProcedure (actual) |
| THEN |
| IF isVarParam (formal) |
| THEN |
| metaError1 ('{%1MDad} cannot be passed as a VAR parameter', actual) |
| ELSE |
| doProcedureParamC (p, actual, formal) |
| END |
| ELSIF (getType (actual) # NIL) AND isProcType (skipType (getType (actual))) AND isAProcType (ft) AND isForC (formal) |
| THEN |
| IF isVarParam (formal) |
| THEN |
| metaError2 ('{%1MDad} cannot be passed as a VAR parameter to the definition for C module as the parameter requires a cast to the formal type {%2MDtad}', |
| actual, formal) |
| ELSE |
| outText (p, '(') ; |
| doFQNameC (p, getType (formal)) ; |
| outText (p, "_C") ; |
| outText (p, ')') ; |
| setNeedSpace (p) ; |
| doExprC (p, actual) ; |
| outText (p, ".proc") |
| END |
| ELSIF (getType (actual) # NIL) AND isProcType (skipType (getType (actual))) AND (getType (actual) # getType (formal)) |
| THEN |
| IF isVarParam (formal) |
| THEN |
| metaError2 ('{%1MDad} cannot be passed as a VAR parameter as the parameter requires a cast to the formal type {%2MDtad}', |
| actual, formal) |
| ELSE |
| doCastC (p, getType (formal), actual) |
| END |
| ELSE |
| lbr := checkSystemCast (p, actual, formal) ; |
| IF isVarParam (formal) |
| THEN |
| doAdrExprC (p, actual) |
| ELSE |
| doExprC (p, actual) |
| END ; |
| emitN (p, ")", lbr) |
| END |
| END |
| END |
| END doFuncParamC ; |
| |
| |
| (* |
| getNthParamType - return the type of parameter, i, in list, l. |
| If the parameter is a vararg NIL is returned. |
| *) |
| |
| PROCEDURE getNthParamType (l: Index; i: CARDINAL) : node ; |
| VAR |
| p: node ; |
| BEGIN |
| p := getNthParam (l, i) ; |
| IF p # NIL |
| THEN |
| RETURN getType (p) |
| END ; |
| RETURN NIL |
| END getNthParamType ; |
| |
| |
| (* |
| getNthParam - return the parameter, i, in list, l. |
| If the parameter is a vararg NIL is returned. |
| *) |
| |
| PROCEDURE getNthParam (l: Index; i: CARDINAL) : node ; |
| VAR |
| p : node ; |
| j, k, h: CARDINAL ; |
| BEGIN |
| IF l # NIL |
| THEN |
| j := LowIndice (l) ; |
| h := HighIndice (l) ; |
| WHILE j <= h DO |
| p := GetIndice (l, j) ; |
| IF isParam (p) |
| THEN |
| k := identListLen (p^.paramF.namelist) |
| ELSIF isVarParam (p) |
| THEN |
| k := identListLen (p^.varparamF.namelist) |
| ELSE |
| assert (isVarargs (p)) ; |
| RETURN NIL |
| END ; |
| IF i <= k |
| THEN |
| RETURN p |
| ELSE |
| DEC (i, k) ; |
| INC (j) |
| END |
| END |
| END ; |
| RETURN NIL |
| END getNthParam ; |
| |
| |
| (* |
| doFuncArgsC - |
| *) |
| |
| PROCEDURE doFuncArgsC (p: pretty; s: node; l: Index; needParen: BOOLEAN) ; |
| VAR |
| actual, formal: node ; |
| i, n : CARDINAL ; |
| BEGIN |
| IF needParen |
| THEN |
| outText (p, "(") |
| END ; |
| IF s^.funccallF.args # NIL |
| THEN |
| i := 1 ; |
| n := expListLen (s^.funccallF.args) ; |
| WHILE i<=n DO |
| actual := getExpList (s^.funccallF.args, i) ; |
| formal := getNthParam (l, i) ; |
| doFuncParamC (p, actual, formal, s^.funccallF.function) ; |
| IF i<n |
| THEN |
| outText (p, ",") ; |
| setNeedSpace (p) |
| END ; |
| INC (i) |
| END |
| END ; |
| IF needParen |
| THEN |
| noSpace (p) ; |
| outText (p, ")") |
| END |
| END doFuncArgsC ; |
| |
| |
| (* |
| doProcTypeArgsC - |
| *) |
| |
| PROCEDURE doProcTypeArgsC (p: pretty; s: node; args: Index; needParen: BOOLEAN) ; |
| VAR |
| a, b: node ; |
| i, n: CARDINAL ; |
| BEGIN |
| IF needParen |
| THEN |
| outText (p, "(") |
| END ; |
| IF s^.funccallF.args # NIL |
| THEN |
| i := 1 ; |
| n := expListLen (s^.funccallF.args) ; |
| WHILE i<=n DO |
| a := getExpList (s^.funccallF.args, i) ; |
| b := GetIndice (args, i) ; |
| doFuncParamC (p, a, b, s^.funccallF.function) ; |
| IF i<n |
| THEN |
| outText (p, ",") ; |
| setNeedSpace (p) |
| END ; |
| INC (i) |
| END |
| END ; |
| IF needParen |
| THEN |
| noSpace (p) ; |
| outText (p, ")") |
| END |
| END doProcTypeArgsC ; |
| |
| |
| (* |
| doAdrArgC - |
| *) |
| |
| PROCEDURE doAdrArgC (p: pretty; n: node) ; |
| BEGIN |
| IF isDeref (n) |
| THEN |
| (* & and * cancel each other out. *) |
| doExprC (p, n^.unaryF.arg) |
| ELSIF isVar (n) AND (n^.varF.isVarParameter) |
| THEN |
| (* & and * cancel each other out. *) |
| outTextN (p, getSymName (n)) (* --fixme-- does the caller need to cast it? *) |
| ELSE |
| IF isString (n) |
| THEN |
| IF lang = ansiCP |
| THEN |
| outText (p, "const_cast<void*> (reinterpret_cast<const void*>") ; |
| outText (p, "(") ; |
| doExprC (p, n) ; |
| outText (p, "))") |
| ELSE |
| doExprC (p, n) |
| END |
| ELSE |
| outText (p, "&") ; |
| doExprC (p, n) |
| END |
| END |
| END doAdrArgC ; |
| |
| |
| (* |
| doAdrC - |
| *) |
| |
| PROCEDURE doAdrC (p: pretty; n: node) ; |
| BEGIN |
| assert (isUnary (n)) ; |
| doAdrArgC (p, n^.unaryF.arg) |
| END doAdrC ; |
| |
| |
| (* |
| doInc - |
| *) |
| |
| PROCEDURE doInc (p: pretty; n: node) ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF lang = ansiCP |
| THEN |
| doIncDecCP (p, n, "+") |
| ELSE |
| doIncDecC (p, n, "+=") |
| END |
| END doInc ; |
| |
| |
| (* |
| doDec - |
| *) |
| |
| PROCEDURE doDec (p: pretty; n: node) ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF lang = ansiCP |
| THEN |
| doIncDecCP (p, n, "-") |
| ELSE |
| doIncDecC (p, n, "-=") |
| END |
| END doDec ; |
| |
| |
| (* |
| doIncDecC - |
| *) |
| |
| PROCEDURE doIncDecC (p: pretty; n: node; op: ARRAY OF CHAR) ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF n^.intrinsicF.args # NIL |
| THEN |
| doExprC (p, getExpList (n^.intrinsicF.args, 1)) ; |
| setNeedSpace (p) ; |
| outText (p, op) ; |
| setNeedSpace (p) ; |
| IF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| outText (p, '1') |
| ELSE |
| doExprC (p, getExpList (n^.intrinsicF.args, 2)) |
| END |
| END |
| END doIncDecC ; |
| |
| |
| (* |
| doIncDecCP - |
| *) |
| |
| PROCEDURE doIncDecCP (p: pretty; n: node; op: ARRAY OF CHAR) ; |
| VAR |
| lhs, |
| type: node ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF n^.intrinsicF.args # NIL |
| THEN |
| lhs := getExpList (n^.intrinsicF.args, 1) ; |
| doExprC (p, lhs) ; |
| setNeedSpace (p) ; |
| type := getType (lhs) ; |
| IF isPointer (type) OR (type = addressN) |
| THEN |
| (* cast to (char * ) and then back again after the arithmetic is complete. *) |
| outText (p, "=") ; |
| setNeedSpace (p) ; |
| outText (p, 'reinterpret_cast<') ; |
| doTypeNameC (p, type) ; |
| noSpace (p) ; |
| outText (p, '> (reinterpret_cast<char *> (') ; |
| doExprC (p, lhs) ; |
| noSpace (p) ; |
| outText (p, ')') ; |
| outText (p, op) ; |
| IF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| outText (p, '1') |
| ELSE |
| doExprC (p, getExpList (n^.intrinsicF.args, 2)) |
| END ; |
| outText (p, ')') |
| ELSIF isEnumeration (skipType (type)) |
| THEN |
| outText (p, "= static_cast<") ; |
| doTypeNameC (p, type) ; |
| noSpace (p) ; |
| outText (p, ">(static_cast<int>(") ; |
| doExprC (p, lhs) ; |
| outText (p, ")") ; |
| outText (p, op) ; |
| IF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| outText (p, '1') |
| ELSE |
| doExprC (p, getExpList (n^.intrinsicF.args, 2)) |
| END ; |
| outText (p, ")") |
| ELSE |
| outText (p, op) ; |
| outText (p, "=") ; |
| setNeedSpace (p) ; |
| IF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| outText (p, '1') |
| ELSE |
| doExprC (p, getExpList (n^.intrinsicF.args, 2)) |
| END |
| END |
| END |
| END doIncDecCP ; |
| |
| |
| (* |
| doInclC - |
| *) |
| |
| PROCEDURE doInclC (p: pretty; n: node) ; |
| VAR |
| lo: node ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF n^.intrinsicF.args # NIL |
| THEN |
| IF expListLen (n^.intrinsicF.args) = 2 |
| THEN |
| doExprC (p, getExpList (n^.intrinsicF.args, 1)) ; |
| lo := getSetLow (getExpList (n^.intrinsicF.args, 1)) ; |
| setNeedSpace (p) ; |
| outText (p, '|=') ; |
| setNeedSpace (p) ; |
| outText (p, '(1') ; |
| setNeedSpace (p) ; |
| outText (p, '<<') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, getExpList (n^.intrinsicF.args, 2)) ; |
| doSubtractC (p, lo) ; |
| setNeedSpace (p) ; |
| outText (p, '))') |
| ELSE |
| HALT (* metaError0 ('expecting two parameters to INCL') *) |
| END |
| END |
| END doInclC ; |
| |
| |
| (* |
| doExclC - |
| *) |
| |
| PROCEDURE doExclC (p: pretty; n: node) ; |
| VAR |
| lo: node ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF n^.intrinsicF.args # NIL |
| THEN |
| IF expListLen (n^.intrinsicF.args) = 2 |
| THEN |
| doExprC (p, getExpList (n^.intrinsicF.args, 1)) ; |
| lo := getSetLow (getExpList (n^.intrinsicF.args, 1)) ; |
| setNeedSpace (p) ; |
| outText (p, '&=') ; |
| setNeedSpace (p) ; |
| outText (p, '(~(1') ; |
| setNeedSpace (p) ; |
| outText (p, '<<') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, getExpList (n^.intrinsicF.args, 2)) ; |
| doSubtractC (p, lo) ; |
| setNeedSpace (p) ; |
| outText (p, ')))') |
| ELSE |
| HALT (* metaError0 ('expecting two parameters to EXCL') *) |
| END |
| END |
| END doExclC ; |
| |
| |
| (* |
| doNewC - |
| *) |
| |
| PROCEDURE doNewC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF n^.intrinsicF.args = NIL |
| THEN |
| HALT |
| ELSE |
| IF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| keyc.useStorage ; |
| outText (p, 'Storage_ALLOCATE') ; |
| setNeedSpace (p) ; |
| outText (p, '((void **)') ; |
| setNeedSpace (p) ; |
| outText (p, '&') ; |
| doExprC (p, getExpList (n^.intrinsicF.args, 1)) ; |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| t := skipType (getType (getExpList (n^.intrinsicF.args, 1))) ; |
| IF isPointer (t) |
| THEN |
| t := getType (t) ; |
| outText (p, 'sizeof') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doTypeNameC (p, t) ; |
| noSpace (p) ; |
| outText (p, '))') |
| ELSE |
| metaError1 ('expecting a pointer type variable as the argument to NEW, rather than {%1ad}', t) |
| END |
| END |
| END |
| END doNewC ; |
| |
| |
| (* |
| doDisposeC - |
| *) |
| |
| PROCEDURE doDisposeC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| IF n^.intrinsicF.args = NIL |
| THEN |
| HALT |
| ELSE |
| IF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| keyc.useStorage ; |
| outText (p, 'Storage_DEALLOCATE') ; |
| setNeedSpace (p) ; |
| outText (p, '((void **)') ; |
| setNeedSpace (p) ; |
| outText (p, '&') ; |
| doExprC (p, getExpList (n^.intrinsicF.args, 1)) ; |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| t := skipType (getType (getExpList (n^.intrinsicF.args, 1))) ; |
| IF isPointer (t) |
| THEN |
| t := getType (t) ; |
| outText (p, 'sizeof') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doTypeNameC (p, t) ; |
| noSpace (p) ; |
| outText (p, '))') |
| ELSE |
| metaError1 ('expecting a pointer type variable as the argument to DISPOSE, rather than {%1ad}', t) |
| END |
| ELSE |
| HALT (* metaError0 ('expecting a single parameter to DISPOSE') *) |
| END |
| END |
| END doDisposeC ; |
| |
| |
| (* |
| doCapC - |
| *) |
| |
| PROCEDURE doCapC (p: pretty; n: node) ; |
| BEGIN |
| assert (isUnary (n)) ; |
| IF n^.unaryF.arg = NIL |
| THEN |
| HALT (* metaError0 ('expecting a single parameter to CAP') *) |
| ELSE |
| keyc.useCtype ; |
| IF getGccConfigSystem () |
| THEN |
| outText (p, 'TOUPPER') |
| ELSE |
| outText (p, 'toupper') |
| END ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, n^.unaryF.arg) ; |
| outText (p, ')') |
| END |
| END doCapC ; |
| |
| |
| (* |
| doLengthC - |
| *) |
| |
| PROCEDURE doLengthC (p: pretty; n: node) ; |
| BEGIN |
| assert (isUnary (n)) ; |
| IF n^.unaryF.arg = NIL |
| THEN |
| HALT (* metaError0 ('expecting a single parameter to LENGTH') *) |
| ELSE |
| keyc.useM2RTS ; |
| outText (p, 'M2RTS_Length') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, n^.unaryF.arg) ; |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| doFuncHighC (p, n^.unaryF.arg) ; |
| outText (p, ')') |
| END |
| END doLengthC ; |
| |
| |
| (* |
| doAbsC - |
| *) |
| |
| PROCEDURE doAbsC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isUnary (n)) ; |
| IF n^.unaryF.arg = NIL |
| THEN |
| HALT |
| ELSE |
| t := getExprType (n) |
| END ; |
| IF t = longintN |
| THEN |
| keyc.useLabs ; |
| outText (p, "labs") |
| ELSIF t = integerN |
| THEN |
| keyc.useAbs ; |
| outText (p, "abs") |
| ELSIF t = realN |
| THEN |
| keyc.useFabs ; |
| outText (p, "fabs") |
| ELSIF t = longrealN |
| THEN |
| keyc.useFabsl ; |
| outText (p, "fabsl") |
| ELSIF t = cardinalN |
| THEN |
| (* do nothing. *) |
| ELSE |
| HALT |
| END ; |
| setNeedSpace (p) ; |
| outText (p, "(") ; |
| doExprC (p, n^.unaryF.arg) ; |
| outText (p, ")") |
| END doAbsC ; |
| |
| |
| (* |
| doValC - |
| *) |
| |
| PROCEDURE doValC (p: pretty; n: node) ; |
| BEGIN |
| assert (isBinary (n)) ; |
| outText (p, '(') ; |
| doTypeNameC (p, n^.binaryF.left) ; |
| outText (p, ')') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, n^.binaryF.right) ; |
| outText (p, ')') |
| END doValC ; |
| |
| |
| (* |
| doMinC - |
| *) |
| |
| PROCEDURE doMinC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isUnary (n)) ; |
| t := getExprType (n^.unaryF.arg) ; |
| doExprC (p, getMin (t)) ; |
| END doMinC ; |
| |
| |
| (* |
| doMaxC - |
| *) |
| |
| PROCEDURE doMaxC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isUnary (n)) ; |
| t := getExprType (n^.unaryF.arg) ; |
| doExprC (p, getMax (t)) ; |
| END doMaxC ; |
| |
| |
| (* |
| isIntrinsic - returns if, n, is an intrinsic procedure. |
| The intrinsic functions are represented as unary and binary nodes. |
| *) |
| |
| PROCEDURE isIntrinsic (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| unreachable, |
| throw, |
| inc, |
| dec, |
| incl, |
| excl, |
| new, |
| dispose, |
| halt : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isIntrinsic ; |
| |
| |
| (* |
| doHalt - |
| *) |
| |
| PROCEDURE doHalt (p: pretty; n: node) ; |
| BEGIN |
| assert (n^.kind = halt) ; |
| IF (n^.intrinsicF.args = NIL) OR (expListLen (n^.intrinsicF.args) = 0) |
| THEN |
| outText (p, 'M2RTS_HALT') ; |
| setNeedSpace (p) ; |
| outText (p, '(-1)') |
| ELSIF expListLen (n^.intrinsicF.args) = 1 |
| THEN |
| outText (p, 'M2RTS_HALT') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, getExpList (n^.intrinsicF.args, 1)) ; |
| outText (p, ')') |
| END |
| END doHalt ; |
| |
| |
| (* |
| doCreal - emit the appropriate creal function. |
| *) |
| |
| PROCEDURE doCreal (p: pretty; t: node) ; |
| BEGIN |
| CASE t^.kind OF |
| |
| complex : keyc.useComplex ; |
| outText (p, "creal") | |
| longcomplex : keyc.useComplex ; |
| outText (p, "creall") | |
| shortcomplex: keyc.useComplex ; |
| outText (p, "crealf") |
| |
| END |
| END doCreal ; |
| |
| |
| (* |
| doCimag - emit the appropriate cimag function. |
| *) |
| |
| PROCEDURE doCimag (p: pretty; t: node) ; |
| BEGIN |
| CASE t^.kind OF |
| |
| complex : keyc.useComplex ; |
| outText (p, "cimag") | |
| longcomplex : keyc.useComplex ; |
| outText (p, "cimagl") | |
| shortcomplex: keyc.useComplex ; |
| outText (p, "cimagf") |
| |
| END |
| END doCimag ; |
| |
| |
| (* |
| doReC - |
| *) |
| |
| PROCEDURE doReC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (n^.kind = re) ; |
| IF n^.unaryF.arg # NIL |
| THEN |
| t := getExprType (n^.unaryF.arg) |
| ELSE |
| HALT |
| END ; |
| doCreal (p, t) ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, n^.unaryF.arg) ; |
| outText (p, ')') |
| END doReC ; |
| |
| |
| (* |
| doImC - |
| *) |
| |
| PROCEDURE doImC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (n^.kind = im) ; |
| IF n^.unaryF.arg # NIL |
| THEN |
| t := getExprType (n^.unaryF.arg) |
| ELSE |
| HALT |
| END ; |
| doCimag (p, t) ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, n^.unaryF.arg) ; |
| outText (p, ')') |
| END doImC ; |
| |
| |
| (* |
| doCmplx - |
| *) |
| |
| PROCEDURE doCmplx (p: pretty; n: node) ; |
| BEGIN |
| assert (isBinary (n)) ; |
| keyc.useComplex ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, n^.binaryF.left) ; |
| outText (p, ')') ; |
| setNeedSpace (p) ; |
| outText (p, '+') ; |
| setNeedSpace (p) ; |
| outText (p, '(') ; |
| doExprC (p, n^.binaryF.right) ; |
| setNeedSpace (p) ; |
| outText (p, '*') ; |
| setNeedSpace (p) ; |
| outText (p, 'I') ; |
| outText (p, ')') |
| END doCmplx ; |
| |
| |
| (* |
| doIntrinsicC - |
| *) |
| |
| PROCEDURE doIntrinsicC (p: pretty; n: node) ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| doCommentC (p, n^.intrinsicF.intrinsicComment.body) ; |
| CASE n^.kind OF |
| |
| unreachable: doUnreachableC (p, n) | |
| throw : doThrowC (p, n) | |
| halt : doHalt (p, n) | |
| inc : doInc (p, n) | |
| dec : doDec (p, n) | |
| incl : doInclC (p, n) | |
| excl : doExclC (p, n) | |
| new : doNewC (p, n) | |
| dispose : doDisposeC (p, n) |
| |
| END ; |
| outText (p, ";") ; |
| doAfterCommentC (p, n^.intrinsicF.intrinsicComment.after) |
| END doIntrinsicC ; |
| |
| |
| (* |
| isIntrinsicFunction - returns true if, n, is an instrinsic function. |
| *) |
| |
| PROCEDURE isIntrinsicFunction (n: node) : BOOLEAN ; |
| BEGIN |
| CASE n^.kind OF |
| |
| val, |
| adr, |
| size, |
| tsize, |
| float, |
| trunc, |
| ord, |
| chr, |
| cap, |
| abs, |
| high, |
| length, |
| min, |
| max, |
| re, |
| im, |
| cmplx: RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isIntrinsicFunction ; |
| |
| |
| (* |
| doSizeC - |
| *) |
| |
| PROCEDURE doSizeC (p: pretty; n: node) ; |
| BEGIN |
| assert (isUnary (n)) ; |
| outText (p, "sizeof (") ; |
| doExprC (p, n^.unaryF.arg) ; |
| outText (p, ")") |
| END doSizeC ; |
| |
| |
| (* |
| doConvertC - |
| *) |
| |
| PROCEDURE doConvertC (p: pretty; n: node; conversion: ARRAY OF CHAR) ; |
| BEGIN |
| assert (isUnary (n)) ; |
| setNeedSpace (p) ; |
| outText (p, "(") ; |
| outText (p, conversion) ; |
| setNeedSpace (p) ; |
| outText (p, "(") ; |
| doExprC (p, n^.unaryF.arg) ; |
| outText (p, "))") |
| END doConvertC ; |
| |
| |
| (* not needed? |
| val: doValC (p, n) | |
| adr: doAdrC (p, n) | |
| size, |
| tsize: doSizeC (p, n) | |
| float: doConvertC (p, n, "(double)") | |
| trunc: doConvertC (p, n, "(int)") | |
| ord: doConvertC (p, n, "(unsigned int)") | |
| chr: doConvertC (p, n, "(char)") | |
| cap: doCapC (p, n) | |
| abs: doAbsC (p, n) | |
| high: doFuncHighC (p, n^.unaryF.arg, 1)) | |
| length: doLengthC (p, n) | |
| min: doMinC (p, n) | |
| max: doMaxC (p, n) | |
| throw: doThrowC (p, n) | |
| re: doReC (p, n) | |
| im: doImC (p, n) | |
| cmplx: doCmplx (p, n) |
| *) |
| |
| |
| (* |
| getFuncFromExpr - |
| *) |
| |
| PROCEDURE getFuncFromExpr (n: node) : node ; |
| BEGIN |
| n := skipType (getType (n)) ; |
| WHILE (n # procN) AND (NOT isProcType (n)) DO |
| n := skipType (getType (n)) |
| END ; |
| RETURN n |
| END getFuncFromExpr ; |
| |
| |
| (* |
| doFuncExprC - |
| *) |
| |
| PROCEDURE doFuncExprC (p: pretty; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isFuncCall (n)) ; |
| IF isProcedure (n^.funccallF.function) |
| THEN |
| doFQDNameC (p, n^.funccallF.function, TRUE) ; |
| setNeedSpace (p) ; |
| doFuncArgsC (p, n, n^.funccallF.function^.procedureF.parameters, TRUE) |
| ELSE |
| outText (p, "(*") ; |
| doExprC (p, n^.funccallF.function) ; |
| outText (p, ".proc") ; |
| outText (p, ")") ; |
| t := getFuncFromExpr (n^.funccallF.function) ; |
| setNeedSpace (p) ; |
| IF t = procN |
| THEN |
| doProcTypeArgsC (p, n, NIL, TRUE) |
| ELSE |
| assert (isProcType (t)) ; |
| doProcTypeArgsC (p, n, t^.proctypeF.parameters, TRUE) |
| END |
| END |
| END doFuncExprC ; |
| |
| |
| (* |
| doFuncCallC - |
| *) |
| |
| PROCEDURE doFuncCallC (p: pretty; n: node) ; |
| BEGIN |
| doCommentC (p, n^.funccallF.funccallComment.body) ; |
| doFuncExprC (p, n) ; |
| outText (p, ";") ; |
| doAfterCommentC (p, n^.funccallF.funccallComment.after) |
| END doFuncCallC ; |
| |
| |
| (* |
| doCaseStatementC - |
| *) |
| |
| PROCEDURE doCaseStatementC (p: pretty; n: node; needBreak: BOOLEAN) ; |
| BEGIN |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doStatementSequenceC (p, n) ; |
| IF needBreak |
| THEN |
| outText (p, "break;\n") |
| END ; |
| p := popPretty (p) |
| END doCaseStatementC ; |
| |
| |
| (* |
| doExceptionC - |
| *) |
| |
| PROCEDURE doExceptionC (p: pretty; a: ARRAY OF CHAR; n: node) ; |
| VAR |
| w: CARDINAL ; |
| BEGIN |
| w := getDeclaredMod (n) ; |
| outText (p, a) ; |
| setNeedSpace (p) ; |
| outText (p, '("') ; |
| outTextS (p, findFileNameFromToken (w, 0)) ; |
| outText (p, '",') ; |
| setNeedSpace (p) ; |
| outCard (p, tokenToLineNo (w, 0)) ; |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| outCard (p, tokenToColumnNo (w, 0)) ; |
| outText (p, ');\n') ; |
| outText (p, '__builtin_unreachable ();\n') |
| END doExceptionC ; |
| |
| |
| (* |
| doExceptionCP - |
| *) |
| |
| PROCEDURE doExceptionCP (p: pretty; a: ARRAY OF CHAR; n: node) ; |
| VAR |
| w: CARDINAL ; |
| BEGIN |
| w := getDeclaredMod (n) ; |
| outText (p, a) ; |
| setNeedSpace (p) ; |
| outText (p, '("') ; |
| outTextS (p, findFileNameFromToken (w, 0)) ; |
| outText (p, '",') ; |
| setNeedSpace (p) ; |
| outCard (p, tokenToLineNo (w, 0)) ; |
| outText (p, ',') ; |
| setNeedSpace (p) ; |
| outCard (p, tokenToColumnNo (w, 0)) ; |
| outText (p, ');\n') ; |
| outText (p, '__builtin_unreachable ();\n') |
| END doExceptionCP ; |
| |
| |
| (* |
| doException - |
| *) |
| |
| PROCEDURE doException (p: pretty; a: ARRAY OF CHAR; n: node) ; |
| BEGIN |
| keyc.useException ; |
| IF lang = ansiCP |
| THEN |
| doExceptionCP (p, a, n) |
| ELSE |
| doExceptionC (p, a, n) |
| END |
| END doException ; |
| |
| |
| (* |
| doRangeListC - |
| *) |
| |
| PROCEDURE doRangeListC (p: pretty; c: node) ; |
| VAR |
| r : node ; |
| i, h: CARDINAL ; |
| BEGIN |
| assert (isCaseList (c)) ; |
| i := 1 ; |
| h := HighIndice (c^.caselistF.rangePairs) ; |
| WHILE i<=h DO |
| r := GetIndice (c^.caselistF.rangePairs, i) ; |
| assert ((r^.rangeF.hi = NIL) OR (r^.rangeF.lo = r^.rangeF.hi)) ; |
| outText (p, "case") ; |
| setNeedSpace (p) ; |
| doExprC (p, r^.rangeF.lo) ; |
| outText (p, ":\n") ; |
| INC (i) |
| END |
| END doRangeListC ; |
| |
| |
| (* |
| doRangeIfListC - |
| *) |
| |
| PROCEDURE doRangeIfListC (p: pretty; e, c: node) ; |
| VAR |
| r : node ; |
| i, h: CARDINAL ; |
| BEGIN |
| assert (isCaseList (c)) ; |
| i := 1 ; |
| h := HighIndice (c^.caselistF.rangePairs) ; |
| WHILE i<=h DO |
| r := GetIndice (c^.caselistF.rangePairs, i) ; |
| IF (r^.rangeF.lo # r^.rangeF.hi) AND (r^.rangeF.hi # NIL) |
| THEN |
| outText (p, "((") ; |
| doExprC (p, e) ; |
| outText (p, ")") ; |
| setNeedSpace (p) ; |
| outText (p, ">=") ; |
| setNeedSpace (p) ; |
| doExprC (p, r^.rangeF.lo) ; |
| outText (p, ")") ; |
| setNeedSpace (p) ; |
| outText (p, "&&") ; |
| setNeedSpace (p) ; |
| outText (p, "((") ; |
| doExprC (p, e) ; |
| outText (p, ")") ; |
| setNeedSpace (p) ; |
| outText (p, "<=") ; |
| setNeedSpace (p) ; |
| doExprC (p, r^.rangeF.hi) ; |
| outText (p, ")") |
| ELSE |
| outText (p, "((") ; |
| doExprC (p, e) ; |
| outText (p, ")") ; |
| setNeedSpace (p) ; |
| outText (p, "==") ; |
| setNeedSpace (p) ; |
| doExprC (p, r^.rangeF.lo) ; |
| outText (p, ")") |
| END ; |
| IF i<h |
| THEN |
| setNeedSpace (p) ; |
| outText (p, "||") ; |
| setNeedSpace (p) |
| END ; |
| INC (i) |
| END |
| END doRangeIfListC ; |
| |
| |
| (* |
| doCaseLabels - |
| *) |
| |
| PROCEDURE doCaseLabels (p: pretty; n: node; needBreak: BOOLEAN) ; |
| BEGIN |
| assert (isCaseLabelList (n)) ; |
| doRangeListC (p, n^.caselabellistF.caseList) ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doStatementSequenceC (p, n^.caselabellistF.statements) ; |
| IF needBreak |
| THEN |
| outText (p, "break;\n\n") |
| END ; |
| p := popPretty (p) |
| END doCaseLabels ; |
| |
| |
| (* |
| doCaseLabelListC - |
| *) |
| |
| PROCEDURE doCaseLabelListC (p: pretty; n: node; haveElse: BOOLEAN) ; |
| VAR |
| i, h: CARDINAL ; |
| c : node ; |
| BEGIN |
| assert (isCase (n)) ; |
| i := 1 ; |
| h := HighIndice (n^.caseF.caseLabelList) ; |
| WHILE i<=h DO |
| c := GetIndice (n^.caseF.caseLabelList, i) ; |
| doCaseLabels (p, c, (i<h) OR haveElse OR caseException) ; |
| INC (i) |
| END |
| END doCaseLabelListC ; |
| |
| |
| (* |
| doCaseIfLabels - |
| *) |
| |
| PROCEDURE doCaseIfLabels (p: pretty; e, n: node; |
| i, h: CARDINAL) ; |
| BEGIN |
| assert (isCaseLabelList (n)) ; |
| IF i > 1 |
| THEN |
| outText (p, "else") ; |
| setNeedSpace (p) ; |
| END ; |
| outText (p, "if") ; |
| setNeedSpace (p) ; |
| outText (p, "(") ; |
| doRangeIfListC (p, e, n^.caselabellistF.caseList) ; |
| outText (p, ")\n") ; |
| IF h = 1 |
| THEN |
| doCompoundStmt (p, n^.caselabellistF.statements) |
| ELSE |
| outText (p, "{\n") ; |
| doStatementSequenceC (p, n^.caselabellistF.statements) ; |
| outText (p, "}\n") |
| END |
| END doCaseIfLabels ; |
| |
| |
| (* |
| doCaseIfLabelListC - |
| *) |
| |
| PROCEDURE doCaseIfLabelListC (p: pretty; n: node) ; |
| VAR |
| i, h: CARDINAL ; |
| c : node ; |
| BEGIN |
| assert (isCase (n)) ; |
| i := 1 ; |
| h := HighIndice (n^.caseF.caseLabelList) ; |
| WHILE i<=h DO |
| c := GetIndice (n^.caseF.caseLabelList, i) ; |
| doCaseIfLabels (p, n^.caseF.expression, c, i, h) ; |
| INC (i) |
| END |
| END doCaseIfLabelListC ; |
| |
| |
| (* |
| doCaseElseC - |
| *) |
| |
| PROCEDURE doCaseElseC (p: pretty; n: node) ; |
| BEGIN |
| assert (isCase (n)) ; |
| IF n^.caseF.else = NIL |
| THEN |
| IF caseException |
| THEN |
| outText (p, "\ndefault:\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doException (p, 'CaseException', n) ; |
| p := popPretty (p) |
| END |
| ELSE |
| outText (p, "\ndefault:\n") ; |
| doCaseStatementC (p, n^.caseF.else, TRUE) |
| END |
| END doCaseElseC ; |
| |
| |
| (* |
| doCaseIfElseC - |
| *) |
| |
| PROCEDURE doCaseIfElseC (p: pretty; n: node) ; |
| BEGIN |
| assert (isCase (n)) ; |
| IF n^.caseF.else = NIL |
| THEN |
| IF TRUE |
| THEN |
| outText (p, "\n") ; |
| outText (p, "else {\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doException (p, 'CaseException', n) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") |
| END |
| ELSE |
| outText (p, "\n") ; |
| outText (p, "else {\n") ; |
| doCaseStatementC (p, n^.caseF.else, FALSE) ; |
| outText (p, "}\n") |
| END |
| END doCaseIfElseC ; |
| |
| |
| (* |
| canUseSwitchCaseLabels - returns TRUE if all the case labels are |
| single values and not ranges. |
| *) |
| |
| PROCEDURE canUseSwitchCaseLabels (n: node) : BOOLEAN ; |
| VAR |
| i, h: CARDINAL ; |
| r, l: node ; |
| BEGIN |
| assert (isCaseLabelList (n)) ; |
| l := n^.caselabellistF.caseList ; |
| i := 1 ; |
| h := HighIndice (l^.caselistF.rangePairs) ; |
| WHILE i<=h DO |
| r := GetIndice (l^.caselistF.rangePairs, i) ; |
| IF (r^.rangeF.hi # NIL) AND (r^.rangeF.lo # r^.rangeF.hi) |
| THEN |
| RETURN FALSE |
| END ; |
| INC (i) |
| END ; |
| RETURN TRUE |
| END canUseSwitchCaseLabels ; |
| |
| |
| (* |
| canUseSwitch - returns TRUE if the case statement can be implement |
| by a switch statement. This will be TRUE if all case |
| selectors are single values rather than ranges. |
| *) |
| |
| PROCEDURE canUseSwitch (n: node) : BOOLEAN ; |
| VAR |
| i, h: CARDINAL ; |
| c : node ; |
| BEGIN |
| assert (isCase (n)) ; |
| i := 1 ; |
| h := HighIndice (n^.caseF.caseLabelList) ; |
| WHILE i<=h DO |
| c := GetIndice (n^.caseF.caseLabelList, i) ; |
| IF NOT canUseSwitchCaseLabels (c) |
| THEN |
| RETURN FALSE |
| END ; |
| INC (i) |
| END ; |
| RETURN TRUE |
| END canUseSwitch ; |
| |
| |
| (* |
| doCaseC - |
| *) |
| |
| PROCEDURE doCaseC (p: pretty; n: node) ; |
| VAR |
| i: CARDINAL ; |
| BEGIN |
| assert (isCase (n)) ; |
| IF canUseSwitch (n) |
| THEN |
| i := getindent (p) ; |
| outText (p, "switch") ; |
| setNeedSpace (p) ; |
| outText (p, "(") ; |
| doExprC (p, n^.caseF.expression) ; |
| p := pushPretty (p) ; |
| outText (p, ")") ; |
| setindent (p, i + indentationC) ; |
| outText (p, "\n{\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doCaseLabelListC (p, n, n^.caseF.else # NIL) ; |
| doCaseElseC (p, n) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") ; |
| p := popPretty (p) |
| ELSE |
| doCaseIfLabelListC (p, n) ; |
| doCaseIfElseC (p, n) |
| END |
| END doCaseC ; |
| |
| |
| (* |
| doLoopC - |
| *) |
| |
| PROCEDURE doLoopC (p: pretty; s: node) ; |
| BEGIN |
| assert (isLoop (s)) ; |
| outText (p, 'for (;;)\n') ; |
| outText (p, "{\n") ; |
| p := pushPretty (p) ; |
| setindent (p, getindent (p) + indentationC) ; |
| doStatementSequenceC (p, s^.loopF.statements) ; |
| p := popPretty (p) ; |
| outText (p, "}\n") |
| END doLoopC ; |
| |
| |
| (* |
| doExitC - |
| *) |
| |
| PROCEDURE doExitC (p: pretty; s: node) ; |
| BEGIN |
| assert (isExit (s)) ; |
| outText (p, "/* exit. */\n") |
| END doExitC ; |
| |
| |
| (* |
| doStatementsC - |
| *) |
| |
| PROCEDURE doStatementsC (p: pretty; s: node) ; |
| BEGIN |
| IF s = NIL |
| THEN |
| (* do nothing. *) |
| ELSIF isStatementSequence (s) |
| THEN |
| doStatementSequenceC (p, s) |
| ELSIF isComment (s) |
| THEN |
| doCommentC (p, s) |
| ELSIF isExit (s) |
| THEN |
| doExitC (p, s) |
| ELSIF isReturn (s) |
| THEN |
| doReturnC (p, s) |
| ELSIF isAssignment (s) |
| THEN |
| doAssignmentC (p, s) |
| ELSIF isIf (s) |
| THEN |
| doIfC (p, s) |
| ELSIF isFor (s) |
| THEN |
| doForC (p, s) |
| ELSIF isRepeat (s) |
| THEN |
| doRepeatC (p, s) |
| ELSIF isWhile (s) |
| THEN |
| doWhileC (p, s) |
| ELSIF isIntrinsic (s) |
| THEN |
| doIntrinsicC (p, s) |
| ELSIF isFuncCall (s) |
| THEN |
| doFuncCallC (p, s) |
| ELSIF isCase (s) |
| THEN |
| doCaseC (p, s) |
| ELSIF isLoop (s) |
| THEN |
| doLoopC (p, s) |
| ELSIF isExit (s) |
| THEN |
| doExitC (p, s) |
| ELSE |
| HALT (* need to handle another s^.kind. *) |
| END |
| END doStatementsC ; |
| |
| |
| PROCEDURE stop ; END stop ; |
| |
| (* |
| doLocalVarC - |
| *) |
| |
| PROCEDURE doLocalVarC (p: pretty; s: scopeT) ; |
| BEGIN |
| includeVarProcedure (s) ; |
| debugLists ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) |
| END doLocalVarC ; |
| |
| |
| (* |
| doLocalConstTypesC - |
| *) |
| |
| PROCEDURE doLocalConstTypesC (p: pretty; s: scopeT) ; |
| BEGIN |
| simplifyTypes (s) ; |
| includeConstType (s) ; |
| |
| doP := p ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) ; |
| |
| END doLocalConstTypesC ; |
| |
| |
| (* |
| addParamDone - |
| *) |
| |
| PROCEDURE addParamDone (n: node) ; |
| BEGIN |
| IF isVar (n) AND n^.varF.isParameter |
| THEN |
| addDone (n) ; |
| addDone (getType (n)) |
| END |
| END addParamDone ; |
| |
| |
| (* |
| includeParameters - |
| *) |
| |
| PROCEDURE includeParameters (n: node) ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| ForeachIndiceInIndexDo (n^.procedureF.decls.variables, addParamDone) |
| END includeParameters ; |
| |
| |
| (* |
| isHalt - |
| *) |
| |
| PROCEDURE isHalt (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = halt |
| END isHalt ; |
| |
| |
| (* |
| isReturnOrHalt - |
| *) |
| |
| PROCEDURE isReturnOrHalt (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN isHalt (n) OR isReturn (n) |
| END isReturnOrHalt ; |
| |
| |
| (* |
| isLastStatementReturn - |
| *) |
| |
| PROCEDURE isLastStatementReturn (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN isLastStatement (n, isReturnOrHalt) |
| END isLastStatementReturn ; |
| |
| |
| (* |
| isLastStatementSequence - |
| *) |
| |
| PROCEDURE isLastStatementSequence (n: node; q: isNodeF) : BOOLEAN ; |
| VAR |
| h : CARDINAL ; |
| BEGIN |
| assert (isStatementSequence (n)) ; |
| h := HighIndice (n^.stmtF.statements) ; |
| IF h > 0 |
| THEN |
| RETURN isLastStatement (GetIndice (n^.stmtF.statements, h), q) |
| END ; |
| RETURN FALSE |
| END isLastStatementSequence ; |
| |
| |
| (* |
| isLastStatementIf - |
| *) |
| |
| PROCEDURE isLastStatementIf (n: node; q: isNodeF) : BOOLEAN ; |
| VAR |
| ret: BOOLEAN ; |
| BEGIN |
| assert (isIf (n)) ; |
| ret := TRUE ; |
| IF (n^.ifF.elsif # NIL) AND ret |
| THEN |
| ret := isLastStatement (n^.ifF.elsif, q) |
| END ; |
| IF (n^.ifF.then # NIL) AND ret |
| THEN |
| ret := isLastStatement (n^.ifF.then, q) |
| END ; |
| IF (n^.ifF.else # NIL) AND ret |
| THEN |
| ret := isLastStatement (n^.ifF.else, q) |
| END ; |
| RETURN ret |
| END isLastStatementIf ; |
| |
| |
| (* |
| isLastStatementElsif - |
| *) |
| |
| PROCEDURE isLastStatementElsif (n: node; q: isNodeF) : BOOLEAN ; |
| VAR |
| ret: BOOLEAN ; |
| BEGIN |
| assert (isElsif (n)) ; |
| ret := TRUE ; |
| IF (n^.elsifF.elsif # NIL) AND ret |
| THEN |
| ret := isLastStatement (n^.elsifF.elsif, q) |
| END ; |
| IF (n^.elsifF.then # NIL) AND ret |
| THEN |
| ret := isLastStatement (n^.elsifF.then, q) |
| END ; |
| IF (n^.elsifF.else # NIL) AND ret |
| THEN |
| ret := isLastStatement (n^.elsifF.else, q) |
| END ; |
| RETURN ret |
| END isLastStatementElsif ; |
| |
| |
| (* |
| isLastStatementCase - |
| *) |
| |
| PROCEDURE isLastStatementCase (n: node; q: isNodeF) : BOOLEAN ; |
| VAR |
| ret : BOOLEAN ; |
| i, h: CARDINAL ; |
| c : node ; |
| BEGIN |
| ret := TRUE ; |
| assert (isCase (n)) ; |
| i := 1 ; |
| h := HighIndice (n^.caseF.caseLabelList) ; |
| WHILE i<=h DO |
| c := GetIndice (n^.caseF.caseLabelList, i) ; |
| assert (isCaseLabelList (c)) ; |
| ret := ret AND isLastStatement (c^.caselabellistF.statements, q) ; |
| INC (i) |
| END ; |
| IF n^.caseF.else # NIL |
| THEN |
| ret := ret AND isLastStatement (n^.caseF.else, q) |
| END ; |
| RETURN ret |
| END isLastStatementCase ; |
| |
| |
| (* |
| isLastStatement - returns TRUE if the last statement in, n, is, q. |
| *) |
| |
| PROCEDURE isLastStatement (n: node; q: isNodeF) : BOOLEAN ; |
| VAR |
| ret: BOOLEAN ; |
| BEGIN |
| IF n = NIL |
| THEN |
| RETURN FALSE |
| ELSIF isStatementSequence (n) |
| THEN |
| RETURN isLastStatementSequence (n, q) |
| ELSIF isProcedure (n) |
| THEN |
| assert (isProcedure (n)) ; |
| RETURN isLastStatement (n^.procedureF.beginStatements, q) |
| ELSIF isIf (n) |
| THEN |
| RETURN isLastStatementIf (n, q) |
| ELSIF isElsif (n) |
| THEN |
| RETURN isLastStatementElsif (n, q) |
| ELSIF isCase (n) |
| THEN |
| RETURN isLastStatementCase (n, q) |
| ELSIF q (n) |
| THEN |
| RETURN TRUE |
| END ; |
| RETURN FALSE |
| END isLastStatement ; |
| |
| |
| (* |
| doProcedureC - |
| *) |
| |
| PROCEDURE doProcedureC (n: node) ; |
| VAR |
| s: CARDINAL ; |
| BEGIN |
| outText (doP, "\n") ; |
| includeParameters (n) ; |
| |
| keyc.enterScope (n) ; |
| |
| doProcedureHeadingC (n, FALSE) ; |
| outText (doP, "\n") ; |
| doP := outKc (doP, "{\n") ; |
| s := getcurline (doP) ; |
| doLocalConstTypesC (doP, n^.procedureF.decls) ; |
| doLocalVarC (doP, n^.procedureF.decls) ; |
| doUnboundedParamCopyC (doP, n) ; |
| |
| IF s # getcurline (doP) |
| THEN |
| outText (doP, "\n") |
| END ; |
| |
| doStatementsC (doP, n^.procedureF.beginStatements) ; |
| IF n^.procedureF.returnType # NIL |
| THEN |
| IF returnException |
| THEN |
| IF isLastStatementReturn (n) |
| THEN |
| outText (doP, "/* static analysis guarentees a RETURN statement will be used before here. */\n") ; |
| outText (doP, "__builtin_unreachable ();\n") ; |
| ELSE |
| doException (doP, 'ReturnException', n) |
| END |
| END |
| END ; |
| doP := outKc (doP, "}\n") ; |
| keyc.leaveScope (n) |
| END doProcedureC ; |
| |
| |
| (* |
| outProceduresC - |
| *) |
| |
| PROCEDURE outProceduresC (p: pretty; s: scopeT) ; |
| BEGIN |
| doP := p ; |
| IF debugDecl |
| THEN |
| printf ("seen %d procedures\n", HighIndice (s.procedures)) |
| END ; |
| |
| ForeachIndiceInIndexDo (s.procedures, doProcedureC) |
| END outProceduresC ; |
| |
| |
| (* |
| output - |
| *) |
| |
| PROCEDURE output (n: node; c, t, v: nodeProcedure) ; |
| BEGIN |
| IF isConst (n) |
| THEN |
| c (n) |
| ELSIF isVar (n) |
| THEN |
| v (n) |
| ELSE |
| t (n) |
| END |
| END output ; |
| |
| |
| (* |
| allDependants - |
| *) |
| |
| PROCEDURE allDependants (n: node) : dependentState ; |
| VAR |
| l: alist ; |
| s: dependentState ; |
| BEGIN |
| l := alists.initList () ; |
| s := walkDependants (l, n) ; |
| alists.killList (l) ; |
| RETURN s |
| END allDependants ; |
| |
| |
| (* |
| walkDependants - |
| *) |
| |
| PROCEDURE walkDependants (l: alist; n: node) : dependentState ; |
| BEGIN |
| IF (n=NIL) OR alists.isItemInList (doneQ, n) |
| THEN |
| RETURN completed |
| ELSIF alists.isItemInList (l, n) |
| THEN |
| RETURN recursive |
| ELSE |
| alists.includeItemIntoList (l, n) ; |
| RETURN doDependants (l, n) |
| END |
| END walkDependants ; |
| |
| |
| (* |
| walkType - |
| *) |
| |
| PROCEDURE walkType (l: alist; n: node) : dependentState ; |
| VAR |
| t: node ; |
| BEGIN |
| t := getType (n) ; |
| IF alists.isItemInList (doneQ, t) |
| THEN |
| RETURN completed |
| ELSIF alists.isItemInList (partialQ, t) |
| THEN |
| RETURN blocked |
| ELSE |
| queueBlocked (t) ; |
| RETURN blocked |
| END |
| END walkType ; |
| |
| |
| (* |
| db - |
| *) |
| |
| PROCEDURE db (a: ARRAY OF CHAR; n: node) ; |
| BEGIN |
| IF getDebugTopological () |
| THEN |
| outText (doP, a) ; |
| IF n#NIL |
| THEN |
| outTextS (doP, gen (n)) |
| END |
| END |
| END db ; |
| |
| |
| (* |
| dbt - |
| *) |
| |
| PROCEDURE dbt (a: ARRAY OF CHAR) ; |
| BEGIN |
| IF getDebugTopological () |
| THEN |
| outText (doP, a) |
| END |
| END dbt ; |
| |
| |
| (* |
| dbs - |
| *) |
| |
| PROCEDURE dbs (s: dependentState; n: node) ; |
| BEGIN |
| IF getDebugTopological () |
| THEN |
| CASE s OF |
| |
| completed: outText (doP, '{completed ') | |
| blocked : outText (doP, '{blocked ') | |
| partial : outText (doP, '{partial ') | |
| recursive: outText (doP, '{recursive ') |
| |
| END ; |
| IF n#NIL |
| THEN |
| outTextS (doP, gen (n)) |
| END ; |
| outText (doP, '}\n') |
| END |
| END dbs ; |
| |
| |
| (* |
| dbq - |
| *) |
| |
| PROCEDURE dbq (n: node) ; |
| BEGIN |
| IF getDebugTopological () |
| THEN |
| IF alists.isItemInList (todoQ, n) |
| THEN |
| db ('{T', n) ; outText (doP, '}') |
| ELSIF alists.isItemInList (partialQ, n) |
| THEN |
| db ('{P', n) ; outText (doP, '}') |
| ELSIF alists.isItemInList (doneQ, n) |
| THEN |
| db ('{D', n) ; outText (doP, '}') |
| END |
| END |
| END dbq ; |
| |
| |
| (* |
| walkRecord - |
| *) |
| |
| PROCEDURE walkRecord (l: alist; n: node) : dependentState ; |
| VAR |
| s : dependentState ; |
| o, |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| i := LowIndice (n^.recordF.listOfSons) ; |
| t := HighIndice (n^.recordF.listOfSons) ; |
| db ('\nwalking ', n) ; o := getindent (doP) ; setindent (doP, getcurpos (doP)+3) ; |
| dbq (n) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.recordF.listOfSons, i) ; |
| db ('', q) ; |
| IF isRecordField (q) AND q^.recordfieldF.tag |
| THEN |
| (* do nothing as it is a tag selector processed in the varient. *) |
| ELSE |
| s := walkDependants (l, q) ; |
| IF s#completed |
| THEN |
| dbs (s, q) ; |
| addTodo (n) ; |
| dbq (n) ; |
| db ('\n', NIL) ; |
| setindent (doP, o) ; |
| RETURN s |
| END |
| END ; |
| INC (i) |
| END ; |
| db ('{completed', n) ; dbt ('}\n') ; |
| setindent (doP, o) ; |
| RETURN completed |
| END walkRecord ; |
| |
| |
| (* |
| walkVarient - |
| *) |
| |
| PROCEDURE walkVarient (l: alist; n: node) : dependentState ; |
| VAR |
| s : dependentState ; |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| db ('\nwalking', n) ; |
| s := walkDependants (l, n^.varientF.tag) ; |
| IF s#completed |
| THEN |
| dbs (s, n^.varientF.tag) ; |
| dbq (n^.varientF.tag) ; |
| db ('\n', NIL) ; |
| RETURN s |
| END ; |
| i := LowIndice (n^.varientF.listOfSons) ; |
| t := HighIndice (n^.varientF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientF.listOfSons, i) ; |
| db ('', q) ; |
| s := walkDependants (l, q) ; |
| IF s#completed |
| THEN |
| dbs (s, q) ; |
| db ('\n', NIL) ; |
| RETURN s |
| END ; |
| INC (i) |
| END ; |
| db ('{completed', n) ; dbt ('}\n') ; |
| RETURN completed |
| END walkVarient ; |
| |
| |
| (* |
| queueBlocked - |
| *) |
| |
| PROCEDURE queueBlocked (n: node) ; |
| BEGIN |
| IF NOT (alists.isItemInList (doneQ, n) OR alists.isItemInList (partialQ, n)) |
| THEN |
| addTodo (n) |
| END |
| END queueBlocked ; |
| |
| |
| (* |
| walkVar - |
| *) |
| |
| PROCEDURE walkVar (l: alist; n: node) : dependentState ; |
| VAR |
| t: node ; |
| BEGIN |
| t := getType (n) ; |
| IF alists.isItemInList (doneQ, t) |
| THEN |
| RETURN completed |
| ELSE |
| queueBlocked (t) ; |
| RETURN blocked |
| END |
| END walkVar ; |
| |
| |
| (* |
| walkEnumeration - |
| *) |
| |
| PROCEDURE walkEnumeration (l: alist; n: node) : dependentState ; |
| VAR |
| s : dependentState ; |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| i := LowIndice (n^.enumerationF.listOfSons) ; |
| t := HighIndice (n^.enumerationF.listOfSons) ; |
| s := completed ; |
| WHILE i<=t DO |
| q := GetIndice (n^.enumerationF.listOfSons, i) ; |
| s := walkDependants (l, q) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| INC (i) |
| END ; |
| RETURN s |
| END walkEnumeration ; |
| |
| |
| (* |
| walkSubrange - |
| *) |
| |
| PROCEDURE walkSubrange (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.subrangeF DO |
| s := walkDependants (l, low) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| s := walkDependants (l, high) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| s := walkDependants (l, type) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END |
| END ; |
| RETURN completed |
| END walkSubrange ; |
| |
| |
| (* |
| walkSubscript - |
| *) |
| |
| PROCEDURE walkSubscript (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.subscriptF DO |
| s := walkDependants (l, expr) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| s := walkDependants (l, type) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END |
| END ; |
| RETURN completed |
| END walkSubscript ; |
| |
| |
| (* |
| walkPointer - |
| *) |
| |
| PROCEDURE walkPointer (l: alist; n: node) : dependentState ; |
| VAR |
| t: node ; |
| BEGIN |
| (* if the type of, n, is done or partial then we can output pointer. *) |
| t := getType (n) ; |
| IF alists.isItemInList (partialQ, t) OR alists.isItemInList (doneQ, t) |
| THEN |
| (* pointer to partial can always generate a complete type. *) |
| RETURN completed |
| END ; |
| RETURN walkType (l, n) |
| END walkPointer ; |
| |
| |
| (* |
| walkArray - |
| *) |
| |
| PROCEDURE walkArray (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.arrayF DO |
| (* |
| s := walkDependants (l, type) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| *) |
| (* an array can only be declared if its data type has already been emitted. *) |
| IF NOT alists.isItemInList (doneQ, type) |
| THEN |
| s := walkDependants (l, type) ; |
| queueBlocked (type) ; |
| IF s=completed |
| THEN |
| (* downgrade the completed to partial as it has not yet been written. *) |
| RETURN partial |
| ELSE |
| RETURN s |
| END |
| END ; |
| RETURN walkDependants (l, subr) |
| END |
| END walkArray ; |
| |
| |
| (* |
| walkConst - |
| *) |
| |
| PROCEDURE walkConst (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.constF DO |
| s := walkDependants (l, type) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| s := walkDependants (l, value) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END |
| END ; |
| RETURN completed |
| END walkConst ; |
| |
| |
| (* |
| walkVarParam - |
| *) |
| |
| PROCEDURE walkVarParam (l: alist; n: node) : dependentState ; |
| VAR |
| t: node ; |
| BEGIN |
| t := getType (n) ; |
| IF alists.isItemInList (partialQ, t) |
| THEN |
| (* parameter can be issued from a partial. *) |
| RETURN completed |
| END ; |
| RETURN walkDependants (l, t) |
| END walkVarParam ; |
| |
| |
| (* |
| walkParam - |
| *) |
| |
| PROCEDURE walkParam (l: alist; n: node) : dependentState ; |
| VAR |
| t: node ; |
| BEGIN |
| t := getType (n) ; |
| IF alists.isItemInList (partialQ, t) |
| THEN |
| (* parameter can be issued from a partial. *) |
| RETURN completed |
| END ; |
| RETURN walkDependants (l, t) |
| END walkParam ; |
| |
| |
| (* |
| walkOptarg - |
| *) |
| |
| PROCEDURE walkOptarg (l: alist; n: node) : dependentState ; |
| VAR |
| t: node ; |
| BEGIN |
| t := getType (n) ; |
| IF alists.isItemInList (partialQ, t) |
| THEN |
| (* parameter can be issued from a partial. *) |
| RETURN completed |
| END ; |
| RETURN walkDependants (l, t) |
| END walkOptarg ; |
| |
| |
| (* |
| walkRecordField - |
| *) |
| |
| PROCEDURE walkRecordField (l: alist; n: node) : dependentState ; |
| VAR |
| t: node ; |
| s: dependentState ; |
| BEGIN |
| assert (isRecordField (n)) ; |
| t := getType (n) ; |
| IF alists.isItemInList (partialQ, t) |
| THEN |
| dbs (partial, n) ; |
| RETURN partial |
| ELSIF alists.isItemInList (doneQ, t) |
| THEN |
| dbs (completed, n) ; |
| RETURN completed |
| ELSE |
| addTodo (t) ; |
| dbs (blocked, n) ; |
| dbq (n) ; |
| dbq (t) ; |
| (* s := walkDependants (l, t) *) |
| RETURN blocked |
| END |
| END walkRecordField ; |
| |
| |
| (* |
| walkVarientField - |
| *) |
| |
| PROCEDURE walkVarientField (l: alist; n: node) : dependentState ; |
| VAR |
| s : dependentState ; |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| i := LowIndice (n^.varientfieldF.listOfSons) ; |
| t := HighIndice (n^.varientfieldF.listOfSons) ; |
| s := completed ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientfieldF.listOfSons, i) ; |
| s := walkDependants (l, q) ; |
| IF s#completed |
| THEN |
| dbs (s, n) ; |
| RETURN s |
| END ; |
| INC (i) |
| END ; |
| n^.varientfieldF.simple := (t <= 1) ; |
| dbs (s, n) ; |
| RETURN s |
| END walkVarientField ; |
| |
| |
| (* |
| walkEnumerationField - |
| *) |
| |
| PROCEDURE walkEnumerationField (l: alist; n: node) : dependentState ; |
| BEGIN |
| RETURN completed |
| END walkEnumerationField ; |
| |
| |
| (* |
| walkSet - |
| *) |
| |
| PROCEDURE walkSet (l: alist; n: node) : dependentState ; |
| BEGIN |
| RETURN walkDependants (l, getType (n)) |
| END walkSet ; |
| |
| |
| (* |
| walkProcType - |
| *) |
| |
| PROCEDURE walkProcType (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| t: node ; |
| BEGIN |
| t := getType (n) ; |
| IF alists.isItemInList (partialQ, t) |
| THEN |
| (* proctype can be generated from partial types. *) |
| ELSE |
| s := walkDependants (l, t) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END |
| END ; |
| RETURN walkParameters (l, n^.proctypeF.parameters) |
| END walkProcType ; |
| |
| |
| (* |
| walkProcedure - |
| *) |
| |
| PROCEDURE walkProcedure (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| s := walkDependants (l, getType (n)) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| RETURN walkParameters (l, n^.procedureF.parameters) |
| END walkProcedure ; |
| |
| |
| (* |
| walkParameters - |
| *) |
| |
| PROCEDURE walkParameters (l: alist; p: Index) : dependentState ; |
| VAR |
| s : dependentState ; |
| i, h: CARDINAL ; |
| q : node ; |
| BEGIN |
| i := LowIndice (p) ; |
| h := HighIndice (p) ; |
| WHILE i<=h DO |
| q := GetIndice (p, i) ; |
| s := walkDependants (l, q) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| INC (i) |
| END ; |
| RETURN completed |
| END walkParameters ; |
| |
| |
| (* |
| walkFuncCall - |
| *) |
| |
| PROCEDURE walkFuncCall (l: alist; n: node) : dependentState ; |
| BEGIN |
| RETURN completed |
| END walkFuncCall ; |
| |
| |
| (* |
| walkUnary - |
| *) |
| |
| PROCEDURE walkUnary (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.unaryF DO |
| s := walkDependants (l, arg) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| RETURN walkDependants (l, resultType) |
| END |
| END walkUnary ; |
| |
| |
| (* |
| walkBinary - |
| *) |
| |
| PROCEDURE walkBinary (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.binaryF DO |
| s := walkDependants (l, left) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| s := walkDependants (l, right) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| RETURN walkDependants (l, resultType) |
| END |
| END walkBinary ; |
| |
| |
| (* |
| walkComponentRef - |
| *) |
| |
| PROCEDURE walkComponentRef (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.componentrefF DO |
| s := walkDependants (l, rec) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| s := walkDependants (l, field) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| RETURN walkDependants (l, resultType) |
| END |
| END walkComponentRef ; |
| |
| |
| (* |
| walkPointerRef - |
| *) |
| |
| PROCEDURE walkPointerRef (l: alist; n: node) : dependentState ; |
| VAR |
| s: dependentState ; |
| BEGIN |
| WITH n^.pointerrefF DO |
| s := walkDependants (l, ptr) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| s := walkDependants (l, field) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| RETURN walkDependants (l, resultType) |
| END |
| END walkPointerRef ; |
| |
| |
| (* |
| walkSetValue - |
| *) |
| |
| PROCEDURE walkSetValue (l: alist; n: node) : dependentState ; |
| VAR |
| s : dependentState ; |
| i, j: CARDINAL ; |
| BEGIN |
| assert (isSetValue (n)) ; |
| WITH n^.setvalueF DO |
| s := walkDependants (l, type) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| i := LowIndice (values) ; |
| j := HighIndice (values) ; |
| WHILE i <= j DO |
| s := walkDependants (l, GetIndice (values, i)) ; |
| IF s#completed |
| THEN |
| RETURN s |
| END ; |
| INC (i) |
| END |
| END ; |
| RETURN completed |
| END walkSetValue ; |
| |
| |
| (* |
| doDependants - return the dependentState depending upon whether |
| all dependants have been declared. |
| *) |
| |
| PROCEDURE doDependants (l: alist; n: node) : dependentState ; |
| BEGIN |
| WITH n^ DO |
| CASE kind OF |
| |
| throw, (* --fixme-- *) |
| varargs, |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet, |
| (* base types. *) |
| boolean, |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| ztype, |
| rtype, |
| complex, |
| longcomplex, |
| shortcomplex, |
| proc : RETURN completed | |
| (* language features and compound type attributes. *) |
| type : RETURN walkType (l, n) | |
| record : RETURN walkRecord (l, n) | |
| varient : RETURN walkVarient (l, n) | |
| var : RETURN walkVar (l, n) | |
| enumeration : RETURN walkEnumeration (l, n) | |
| subrange : RETURN walkSubrange (l, n) | |
| pointer : RETURN walkPointer (l, n) | |
| array : RETURN walkArray (l, n) | |
| string : RETURN completed | |
| const : RETURN walkConst (l, n) | |
| literal : RETURN completed | |
| varparam : RETURN walkVarParam (l, n) | |
| param : RETURN walkParam (l, n) | |
| optarg : RETURN walkOptarg (l, n) | |
| recordfield : RETURN walkRecordField (l, n) | |
| varientfield : RETURN walkVarientField (l, n) | |
| enumerationfield: RETURN walkEnumerationField (l, n) | |
| set : RETURN walkSet (l, n) | |
| proctype : RETURN walkProcType (l, n) | |
| subscript : RETURN walkSubscript (l, n) | |
| (* blocks. *) |
| procedure : RETURN walkProcedure (l, n) | |
| def, |
| imp, |
| module, |
| (* statements. *) |
| loop, |
| while, |
| for, |
| repeat, |
| if, |
| elsif, |
| assignment : HALT | |
| (* expressions. *) |
| componentref : RETURN walkComponentRef (l, n) | |
| pointerref : RETURN walkPointerRef (l, n) | |
| not, |
| abs, |
| min, |
| max, |
| chr, |
| cap, |
| ord, |
| float, |
| trunc, |
| high : RETURN walkUnary (l, n) | |
| cast, |
| val, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide : RETURN walkBinary (l, n) | |
| constexp, |
| neg, |
| adr, |
| size, |
| tsize, |
| deref : RETURN walkUnary (l, n) | |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal : RETURN walkBinary (l, n) | |
| funccall : RETURN walkFuncCall (l, n) | |
| setvalue : RETURN walkSetValue (l, n) |
| |
| END |
| END |
| END doDependants ; |
| |
| |
| (* |
| tryComplete - returns TRUE if node, n, can be and was completed. |
| *) |
| |
| PROCEDURE tryComplete (n: node; c, t, v: nodeProcedure) : BOOLEAN ; |
| BEGIN |
| IF isEnumeration (n) |
| THEN |
| (* can always emit enumerated types. *) |
| output (n, c, t, v) ; |
| RETURN TRUE |
| ELSIF isType (n) AND isTypeHidden (n) AND (getType (n)=NIL) |
| THEN |
| (* can always emit hidden types. *) |
| outputHidden (n) ; |
| RETURN TRUE |
| ELSIF allDependants (n) = completed |
| THEN |
| output (n, c, t, v) ; |
| RETURN TRUE |
| END ; |
| RETURN FALSE |
| END tryComplete ; |
| |
| |
| (* |
| tryCompleteFromPartial - |
| *) |
| |
| PROCEDURE tryCompleteFromPartial (n: node; t: nodeProcedure) : BOOLEAN ; |
| BEGIN |
| IF isType (n) AND (getType (n)#NIL) AND isPointer (getType (n)) AND (allDependants (getType (n)) = completed) |
| THEN |
| (* alists.includeItemIntoList (partialQ, getType (n)) ; *) |
| outputHiddenComplete (n) ; |
| RETURN TRUE |
| ELSIF allDependants (n) = completed |
| THEN |
| t (n) ; |
| RETURN TRUE |
| END ; |
| RETURN FALSE |
| END tryCompleteFromPartial ; |
| |
| |
| (* |
| visitIntrinsicFunction - |
| *) |
| |
| PROCEDURE visitIntrinsicFunction (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isIntrinsicFunction (n)) ; |
| CASE n^.kind OF |
| |
| val, |
| cmplx: WITH n^.binaryF DO |
| visitNode (v, left, p) ; |
| visitNode (v, right, p) ; |
| visitNode (v, resultType, p) |
| END | |
| length, |
| adr, |
| size, |
| tsize, |
| float, |
| trunc, |
| ord, |
| chr, |
| cap, |
| abs, |
| high, |
| min, |
| max, |
| re, |
| im : WITH n^.unaryF DO |
| visitNode (v, arg, p) ; |
| visitNode (v, resultType, p) |
| END |
| |
| END |
| END visitIntrinsicFunction ; |
| |
| |
| (* |
| visitUnary - |
| *) |
| |
| PROCEDURE visitUnary (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isUnary (n)) ; |
| WITH n^.unaryF DO |
| visitNode (v, arg, p) ; |
| visitNode (v, resultType, p) |
| END |
| END visitUnary ; |
| |
| |
| (* |
| visitBinary - |
| *) |
| |
| PROCEDURE visitBinary (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| WITH n^.binaryF DO |
| visitNode (v, left, p) ; |
| visitNode (v, right, p) ; |
| visitNode (v, resultType, p) |
| END |
| END visitBinary ; |
| |
| |
| (* |
| visitBoolean - |
| *) |
| |
| PROCEDURE visitBoolean (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| visitNode (v, falseN, p) ; |
| visitNode (v, trueN, p) |
| END visitBoolean ; |
| |
| |
| (* |
| visitScope - |
| *) |
| |
| PROCEDURE visitScope (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| IF mustVisitScope |
| THEN |
| visitNode (v, n, p) |
| END |
| END visitScope ; |
| |
| |
| (* |
| visitType - |
| *) |
| |
| PROCEDURE visitType (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isType (n)) ; |
| visitNode (v, n^.typeF.type, p) ; |
| visitScope (v, n^.typeF.scope, p) |
| END visitType ; |
| |
| |
| (* |
| visitIndex - |
| *) |
| |
| PROCEDURE visitIndex (v: alist; i: Index; p: nodeProcedure) ; |
| VAR |
| j, h: CARDINAL ; |
| BEGIN |
| j := 1 ; |
| h := HighIndice (i) ; |
| WHILE j <= h DO |
| visitNode (v, GetIndice (i, j), p) ; |
| INC (j) |
| END |
| END visitIndex ; |
| |
| |
| (* |
| visitRecord - |
| *) |
| |
| PROCEDURE visitRecord (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isRecord (n)) ; |
| visitScope (v, n^.recordF.scope, p) ; |
| visitIndex (v, n^.recordF.listOfSons, p) |
| END visitRecord ; |
| |
| |
| (* |
| visitVarient - |
| *) |
| |
| PROCEDURE visitVarient (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isVarient (n)) ; |
| visitIndex (v, n^.varientF.listOfSons, p) ; |
| visitNode (v, n^.varientF.varient, p) ; |
| visitNode (v, n^.varientF.tag, p) ; |
| visitScope (v, n^.varientF.scope, p) |
| END visitVarient ; |
| |
| |
| (* |
| visitVar - |
| *) |
| |
| PROCEDURE visitVar (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isVar (n)) ; |
| visitNode (v, n^.varF.type, p) ; |
| visitNode (v, n^.varF.decl, p) ; |
| visitScope (v, n^.varF.scope, p) |
| END visitVar ; |
| |
| |
| (* |
| visitEnumeration - |
| *) |
| |
| PROCEDURE visitEnumeration (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isEnumeration (n)) ; |
| visitIndex (v, n^.enumerationF.listOfSons, p) ; |
| visitScope (v, n^.enumerationF.scope, p) |
| END visitEnumeration ; |
| |
| |
| (* |
| visitSubrange - |
| *) |
| |
| PROCEDURE visitSubrange (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isSubrange (n)) ; |
| visitNode (v, n^.subrangeF.low, p) ; |
| visitNode (v, n^.subrangeF.high, p) ; |
| visitNode (v, n^.subrangeF.type, p) ; |
| visitScope (v, n^.subrangeF.scope, p) |
| END visitSubrange ; |
| |
| |
| (* |
| visitPointer - |
| *) |
| |
| PROCEDURE visitPointer (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isPointer (n)) ; |
| visitNode (v, n^.pointerF.type, p) ; |
| visitScope (v, n^.pointerF.scope, p) |
| END visitPointer ; |
| |
| |
| (* |
| visitArray - |
| *) |
| |
| PROCEDURE visitArray (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isArray (n)) ; |
| visitNode (v, n^.arrayF.subr, p) ; |
| visitNode (v, n^.arrayF.type, p) ; |
| visitScope (v, n^.arrayF.scope, p) |
| END visitArray ; |
| |
| |
| (* |
| visitConst - |
| *) |
| |
| PROCEDURE visitConst (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isConst (n)) ; |
| visitNode (v, n^.constF.type, p) ; |
| visitNode (v, n^.constF.value, p) ; |
| visitScope (v, n^.constF.scope, p) |
| END visitConst ; |
| |
| |
| (* |
| visitVarParam - |
| *) |
| |
| PROCEDURE visitVarParam (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isVarParam (n)) ; |
| visitNode (v, n^.varparamF.namelist, p) ; |
| visitNode (v, n^.varparamF.type, p) ; |
| visitScope (v, n^.varparamF.scope, p) |
| END visitVarParam ; |
| |
| |
| (* |
| visitParam - |
| *) |
| |
| PROCEDURE visitParam (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isParam (n)) ; |
| visitNode (v, n^.paramF.namelist, p) ; |
| visitNode (v, n^.paramF.type, p) ; |
| visitScope (v, n^.paramF.scope, p) |
| END visitParam ; |
| |
| |
| (* |
| visitOptarg - |
| *) |
| |
| PROCEDURE visitOptarg (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isOptarg (n)) ; |
| visitNode (v, n^.optargF.namelist, p) ; |
| visitNode (v, n^.optargF.type, p) ; |
| visitNode (v, n^.optargF.init, p) ; |
| visitScope (v, n^.optargF.scope, p) |
| END visitOptarg ; |
| |
| |
| (* |
| visitRecordField - |
| *) |
| |
| PROCEDURE visitRecordField (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isRecordField (n)) ; |
| visitNode (v, n^.recordfieldF.type, p) ; |
| visitNode (v, n^.recordfieldF.parent, p) ; |
| visitNode (v, n^.recordfieldF.varient, p) ; |
| visitScope (v, n^.recordfieldF.scope, p) |
| END visitRecordField ; |
| |
| |
| (* |
| visitVarientField - |
| *) |
| |
| PROCEDURE visitVarientField (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isVarientField (n)) ; |
| visitNode (v, n^.varientfieldF.parent, p) ; |
| visitNode (v, n^.varientfieldF.varient, p) ; |
| visitIndex (v, n^.varientfieldF.listOfSons, p) ; |
| visitScope (v, n^.varientfieldF.scope, p) |
| END visitVarientField ; |
| |
| |
| (* |
| visitEnumerationField - |
| *) |
| |
| PROCEDURE visitEnumerationField (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isEnumerationField (n)) ; |
| visitNode (v, n^.enumerationfieldF.type, p) ; |
| visitScope (v, n^.enumerationfieldF.scope, p) |
| END visitEnumerationField ; |
| |
| |
| (* |
| visitSet - |
| *) |
| |
| PROCEDURE visitSet (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isSet (n)) ; |
| visitNode (v, n^.setF.type, p) ; |
| visitScope (v, n^.setF.scope, p) |
| END visitSet ; |
| |
| |
| (* |
| visitProcType - |
| *) |
| |
| PROCEDURE visitProcType (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isProcType (n)) ; |
| visitIndex (v, n^.proctypeF.parameters, p) ; |
| visitNode (v, n^.proctypeF.optarg, p) ; |
| visitNode (v, n^.proctypeF.returnType, p) ; |
| visitScope (v, n^.proctypeF.scope, p) |
| END visitProcType ; |
| |
| |
| (* |
| visitSubscript - |
| *) |
| |
| PROCEDURE visitSubscript (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| (* |
| assert (isSubscript (n)) ; |
| visitNode (v, n^.subscriptF.type, p) ; |
| visitNode (v, n^.subscriptF.expr, p) |
| *) |
| END visitSubscript ; |
| |
| |
| (* |
| visitDecls - |
| *) |
| |
| PROCEDURE visitDecls (v: alist; s: scopeT; p: nodeProcedure) ; |
| BEGIN |
| visitIndex (v, s.constants, p) ; |
| visitIndex (v, s.types, p) ; |
| visitIndex (v, s.procedures, p) ; |
| visitIndex (v, s.variables, p) |
| END visitDecls ; |
| |
| |
| (* |
| visitProcedure - |
| *) |
| |
| PROCEDURE visitProcedure (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| visitDecls (v, n^.procedureF.decls, p) ; |
| visitScope (v, n^.procedureF.scope, p) ; |
| visitIndex (v, n^.procedureF.parameters, p) ; |
| visitNode (v, n^.procedureF.optarg, p) ; |
| visitNode (v, n^.procedureF.returnType, p) ; |
| visitNode (v, n^.procedureF.beginStatements, p) |
| END visitProcedure ; |
| |
| |
| (* |
| visitDef - |
| *) |
| |
| PROCEDURE visitDef (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isDef (n)) ; |
| visitDecls (v, n^.defF.decls, p) |
| END visitDef ; |
| |
| |
| (* |
| visitImp - |
| *) |
| |
| PROCEDURE visitImp (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isImp (n)) ; |
| visitDecls (v, n^.impF.decls, p) ; |
| visitNode (v, n^.impF.beginStatements, p) ; |
| visitNode (v, n^.impF.finallyStatements, p) |
| (* --fixme-- do we need to visit definitionModule? *) |
| END visitImp ; |
| |
| |
| (* |
| visitModule - |
| *) |
| |
| PROCEDURE visitModule (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isModule (n)) ; |
| visitDecls (v, n^.moduleF.decls, p) ; |
| visitNode (v, n^.moduleF.beginStatements, p) ; |
| visitNode (v, n^.moduleF.finallyStatements, p) |
| END visitModule ; |
| |
| |
| (* |
| visitLoop - |
| *) |
| |
| PROCEDURE visitLoop (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isLoop (n)) ; |
| visitNode (v, n^.loopF.statements, p) |
| END visitLoop ; |
| |
| |
| (* |
| visitWhile - |
| *) |
| |
| PROCEDURE visitWhile (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isWhile (n)) ; |
| visitNode (v, n^.whileF.expr, p) ; |
| visitNode (v, n^.whileF.statements, p) |
| END visitWhile ; |
| |
| |
| (* |
| visitRepeat - |
| *) |
| |
| PROCEDURE visitRepeat (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isRepeat (n)) ; |
| visitNode (v, n^.repeatF.expr, p) ; |
| visitNode (v, n^.repeatF.statements, p) |
| END visitRepeat ; |
| |
| |
| (* |
| visitCase - |
| *) |
| |
| PROCEDURE visitCase (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isCase (n)) ; |
| visitNode (v, n^.caseF.expression, p) ; |
| visitIndex (v, n^.caseF.caseLabelList, p) ; |
| visitNode (v, n^.caseF.else, p) |
| END visitCase ; |
| |
| |
| (* |
| visitCaseLabelList - |
| *) |
| |
| PROCEDURE visitCaseLabelList (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isCaseLabelList (n)) ; |
| visitNode (v, n^.caselabellistF.caseList, p) ; |
| visitNode (v, n^.caselabellistF.statements, p) |
| END visitCaseLabelList ; |
| |
| |
| (* |
| visitCaseList - |
| *) |
| |
| PROCEDURE visitCaseList (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isCaseList (n)) ; |
| visitIndex (v, n^.caselistF.rangePairs, p) |
| END visitCaseList ; |
| |
| |
| (* |
| visitRange - |
| *) |
| |
| PROCEDURE visitRange (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isRange (n)) ; |
| visitNode (v, n^.rangeF.lo, p) ; |
| visitNode (v, n^.rangeF.hi, p) |
| END visitRange ; |
| |
| |
| (* |
| visitIf - |
| *) |
| |
| PROCEDURE visitIf (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isIf (n)) ; |
| visitNode (v, n^.ifF.expr, p) ; |
| visitNode (v, n^.ifF.elsif, p) ; |
| visitNode (v, n^.ifF.then, p) ; |
| visitNode (v, n^.ifF.else, p) |
| END visitIf ; |
| |
| |
| (* |
| visitElsif - |
| *) |
| |
| PROCEDURE visitElsif (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isElsif (n)) ; |
| visitNode (v, n^.elsifF.expr, p) ; |
| visitNode (v, n^.elsifF.elsif, p) ; |
| visitNode (v, n^.elsifF.then, p) ; |
| visitNode (v, n^.elsifF.else, p) |
| END visitElsif ; |
| |
| |
| (* |
| visitFor - |
| *) |
| |
| PROCEDURE visitFor (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isFor (n)) ; |
| visitNode (v, n^.forF.des, p) ; |
| visitNode (v, n^.forF.start, p) ; |
| visitNode (v, n^.forF.end, p) ; |
| visitNode (v, n^.forF.increment, p) ; |
| visitNode (v, n^.forF.statements, p) |
| END visitFor ; |
| |
| |
| (* |
| visitAssignment - |
| *) |
| |
| PROCEDURE visitAssignment (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isAssignment (n)) ; |
| visitNode (v, n^.assignmentF.des, p) ; |
| visitNode (v, n^.assignmentF.expr, p) |
| END visitAssignment ; |
| |
| |
| (* |
| visitComponentRef - |
| *) |
| |
| PROCEDURE visitComponentRef (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isComponentRef (n)) ; |
| visitNode (v, n^.componentrefF.rec, p) ; |
| visitNode (v, n^.componentrefF.field, p) ; |
| visitNode (v, n^.componentrefF.resultType, p) |
| END visitComponentRef ; |
| |
| |
| (* |
| visitPointerRef - |
| *) |
| |
| PROCEDURE visitPointerRef (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isPointerRef (n)) ; |
| visitNode (v, n^.pointerrefF.ptr, p) ; |
| visitNode (v, n^.pointerrefF.field, p) ; |
| visitNode (v, n^.pointerrefF.resultType, p) |
| END visitPointerRef ; |
| |
| |
| (* |
| visitArrayRef - |
| *) |
| |
| PROCEDURE visitArrayRef (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isArrayRef (n)) ; |
| visitNode (v, n^.arrayrefF.array, p) ; |
| visitNode (v, n^.arrayrefF.index, p) ; |
| visitNode (v, n^.arrayrefF.resultType, p) |
| END visitArrayRef ; |
| |
| |
| (* |
| visitFunccall - |
| *) |
| |
| PROCEDURE visitFunccall (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isFuncCall (n)) ; |
| visitNode (v, n^.funccallF.function, p) ; |
| visitNode (v, n^.funccallF.args, p) ; |
| visitNode (v, n^.funccallF.type, p) |
| END visitFunccall ; |
| |
| |
| (* |
| visitVarDecl - |
| *) |
| |
| PROCEDURE visitVarDecl (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isVarDecl (n)) ; |
| visitNode (v, n^.vardeclF.type, p) ; |
| visitScope (v, n^.vardeclF.scope, p) |
| END visitVarDecl ; |
| |
| |
| (* |
| visitExplist - |
| *) |
| |
| PROCEDURE visitExplist (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isExpList (n)) ; |
| visitIndex (v, n^.explistF.exp, p) |
| END visitExplist ; |
| |
| |
| (* |
| visitExit - |
| *) |
| |
| PROCEDURE visitExit (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isExit (n)) ; |
| visitNode (v, n^.exitF.loop, p) |
| END visitExit ; |
| |
| |
| (* |
| visitReturn - |
| *) |
| |
| PROCEDURE visitReturn (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isReturn (n)) ; |
| visitNode (v, n^.returnF.exp, p) |
| END visitReturn ; |
| |
| |
| (* |
| visitStmtSeq - |
| *) |
| |
| PROCEDURE visitStmtSeq (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isStatementSequence (n)) ; |
| visitIndex (v, n^.stmtF.statements, p) |
| END visitStmtSeq ; |
| |
| |
| (* |
| visitVarargs - |
| *) |
| |
| PROCEDURE visitVarargs (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isVarargs (n)) ; |
| visitScope (v, n^.varargsF.scope, p) |
| END visitVarargs ; |
| |
| |
| (* |
| visitSetValue - |
| *) |
| |
| PROCEDURE visitSetValue (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isSetValue (n)) ; |
| visitNode (v, n^.setvalueF.type, p) ; |
| visitIndex (v, n^.setvalueF.values, p) |
| END visitSetValue ; |
| |
| |
| (* |
| visitIntrinsic - |
| *) |
| |
| PROCEDURE visitIntrinsic (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (isIntrinsic (n)) ; |
| visitNode (v, n^.intrinsicF.args, p) |
| END visitIntrinsic ; |
| |
| |
| (* |
| visitDependants - helper procedure function called from visitNode. |
| node n has just been visited, this procedure will |
| visit node, n, dependants. |
| *) |
| |
| PROCEDURE visitDependants (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| assert (n # NIL) ; |
| assert (alists.isItemInList (v, n)) ; |
| CASE n^.kind OF |
| |
| explist : visitExplist (v, n, p) | |
| funccall : visitFunccall (v, n, p) | |
| exit : visitExit (v, n, p) | |
| return : visitReturn (v, n, p) | |
| stmtseq : visitStmtSeq (v, n, p) | |
| comment : | |
| length : visitIntrinsicFunction (v, n, p) | |
| unreachable, |
| throw, |
| halt, |
| new, |
| dispose, |
| inc, |
| dec, |
| incl, |
| excl : visitIntrinsic (v, n, p) | |
| boolean : visitBoolean (v, n, p) | |
| nil, |
| false, |
| true : | |
| varargs : visitVarargs (v, n, p) | |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet, |
| (* base types. *) |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| ztype, |
| rtype, |
| complex, |
| longcomplex, |
| shortcomplex, |
| proc : | |
| (* language features and compound type attributes. *) |
| type : visitType (v, n, p) | |
| record : visitRecord (v, n, p) | |
| varient : visitVarient (v, n, p) | |
| var : visitVar (v, n, p) | |
| enumeration : visitEnumeration (v, n, p) | |
| subrange : visitSubrange (v, n, p) | |
| pointer : visitPointer (v, n, p) | |
| array : visitArray (v, n, p) | |
| string : | |
| const : visitConst (v, n, p) | |
| literal : | |
| varparam : visitVarParam (v, n, p) | |
| param : visitParam (v, n, p) | |
| optarg : visitOptarg (v, n, p) | |
| recordfield : visitRecordField (v, n, p) | |
| varientfield : visitVarientField (v, n, p) | |
| enumerationfield: visitEnumerationField (v, n, p) | |
| set : visitSet (v, n, p) | |
| proctype : visitProcType (v, n, p) | |
| subscript : visitSubscript (v, n, p) | |
| (* blocks. *) |
| procedure : visitProcedure (v, n, p) | |
| def : visitDef (v, n, p) | |
| imp : visitImp (v, n, p) | |
| module : visitModule (v, n, p) | |
| (* statements. *) |
| loop : visitLoop (v, n, p) | |
| while : visitWhile (v, n, p) | |
| for : visitFor (v, n, p) | |
| repeat : visitRepeat (v, n, p) | |
| case : visitCase (v, n, p) | |
| caselabellist : visitCaseLabelList (v, n, p) | |
| caselist : visitCaseList (v, n, p) | |
| range : visitRange (v, n, p) | |
| if : visitIf (v, n, p) | |
| elsif : visitElsif (v, n, p) | |
| assignment : visitAssignment (v, n, p) | |
| (* expressions. *) |
| componentref : visitComponentRef (v, n, p) | |
| pointerref : visitPointerRef (v, n, p) | |
| arrayref : visitArrayRef (v, n, p) | |
| cmplx, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal, |
| and, |
| or, |
| in, |
| cast, |
| val, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide : visitBinary (v, n, p) | |
| re : visitUnary (v, n, p) | |
| im : visitUnary (v, n, p) | |
| abs : visitUnary (v, n, p) | |
| chr : visitUnary (v, n, p) | |
| cap : visitUnary (v, n, p) | |
| high : visitUnary (v, n, p) | |
| ord : visitUnary (v, n, p) | |
| float : visitUnary (v, n, p) | |
| trunc : visitUnary (v, n, p) | |
| not : visitUnary (v, n, p) | |
| neg : visitUnary (v, n, p) | |
| adr : visitUnary (v, n, p) | |
| size : visitUnary (v, n, p) | |
| tsize : visitUnary (v, n, p) | |
| min : visitUnary (v, n, p) | |
| max : visitUnary (v, n, p) | |
| constexp : visitUnary (v, n, p) | |
| deref : visitUnary (v, n, p) | |
| identlist : | |
| vardecl : visitVarDecl (v, n, p) | |
| setvalue : visitSetValue (v, n, p) |
| |
| END |
| END visitDependants ; |
| |
| |
| (* |
| visitNode - visits node, n, if it is not already in the alist, v. |
| It calls p(n) if the node is unvisited. |
| *) |
| |
| PROCEDURE visitNode (v: alist; n: node; p: nodeProcedure) ; |
| BEGIN |
| IF (n#NIL) AND (NOT alists.isItemInList (v, n)) |
| THEN |
| alists.includeItemIntoList (v, n) ; |
| p (n) ; |
| visitDependants (v, n, p) |
| END |
| END visitNode ; |
| |
| |
| (* |
| genKind - returns a string depending upon the kind of node, n. |
| *) |
| |
| PROCEDURE genKind (n: node) : String ; |
| BEGIN |
| CASE n^.kind OF |
| |
| (* types, no need to generate a kind string as it it contained in the name. *) |
| nil, |
| true, |
| false, |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet, |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| boolean, |
| proc, |
| ztype, |
| rtype, |
| complex, |
| longcomplex, |
| shortcomplex : RETURN NIL | |
| |
| (* language features and compound type attributes. *) |
| type : RETURN InitString ('type') | |
| record : RETURN InitString ('record') | |
| varient : RETURN InitString ('varient') | |
| var : RETURN InitString ('var') | |
| enumeration : RETURN InitString ('enumeration') | |
| subrange : RETURN InitString ('subrange') | |
| array : RETURN InitString ('array') | |
| subscript : RETURN InitString ('subscript') | |
| string : RETURN InitString ('string') | |
| const : RETURN InitString ('const') | |
| literal : RETURN InitString ('literal') | |
| varparam : RETURN InitString ('varparam') | |
| param : RETURN InitString ('param') | |
| varargs : RETURN InitString ('varargs') | |
| pointer : RETURN InitString ('pointer') | |
| recordfield : RETURN InitString ('recordfield') | |
| varientfield : RETURN InitString ('varientfield') | |
| enumerationfield: RETURN InitString ('enumerationfield') | |
| set : RETURN InitString ('set') | |
| proctype : RETURN InitString ('proctype') | |
| (* blocks. *) |
| procedure : RETURN InitString ('procedure') | |
| def : RETURN InitString ('def') | |
| imp : RETURN InitString ('imp') | |
| module : RETURN InitString ('module') | |
| (* statements. *) |
| loop : RETURN InitString ('loop') | |
| while : RETURN InitString ('while') | |
| for : RETURN InitString ('for') | |
| repeat : RETURN InitString ('repeat') | |
| assignment : RETURN InitString ('assignment') | |
| if : RETURN InitString ('if') | |
| elsif : RETURN InitString ('elsif') | |
| (* expressions. *) |
| constexp : RETURN InitString ('constexp') | |
| neg : RETURN InitString ('neg') | |
| cast : RETURN InitString ('cast') | |
| val : RETURN InitString ('val') | |
| plus : RETURN InitString ('plus') | |
| sub : RETURN InitString ('sub') | |
| div : RETURN InitString ('div') | |
| mod : RETURN InitString ('mod') | |
| mult : RETURN InitString ('mult') | |
| divide : RETURN InitString ('divide') | |
| adr : RETURN InitString ('adr') | |
| size : RETURN InitString ('size') | |
| tsize : RETURN InitString ('tsize') | |
| chr : RETURN InitString ('chr') | |
| ord : RETURN InitString ('ord') | |
| float : RETURN InitString ('float') | |
| trunc : RETURN InitString ('trunc') | |
| high : RETURN InitString ('high') | |
| componentref : RETURN InitString ('componentref') | |
| pointerref : RETURN InitString ('pointerref') | |
| arrayref : RETURN InitString ('arrayref') | |
| deref : RETURN InitString ('deref') | |
| equal : RETURN InitString ('equal') | |
| notequal : RETURN InitString ('notequal') | |
| less : RETURN InitString ('less') | |
| greater : RETURN InitString ('greater') | |
| greequal : RETURN InitString ('greequal') | |
| lessequal : RETURN InitString ('lessequal') | |
| lsl : RETURN InitString ('lsl') | |
| lsr : RETURN InitString ('lsr') | |
| lor : RETURN InitString ('lor') | |
| land : RETURN InitString ('land') | |
| lnot : RETURN InitString ('lnot') | |
| lxor : RETURN InitString ('lxor') | |
| and : RETURN InitString ('and') | |
| or : RETURN InitString ('or') | |
| not : RETURN InitString ('not') | |
| identlist : RETURN InitString ('identlist') | |
| vardecl : RETURN InitString ('vardecl') |
| |
| END ; |
| HALT |
| END genKind ; |
| |
| |
| (* |
| gen - generate a small string describing node, n. |
| *) |
| |
| PROCEDURE gen (n: node) : String ; |
| VAR |
| s: String ; |
| d: CARDINAL ; |
| BEGIN |
| d := VAL (CARDINAL, VAL (LONGCARD, n)) ; |
| s := Sprintf1 (InitString ('< %d '), d) ; (* use 0x%x once FormatStrings has been released. *) |
| s := ConCat (s, genKind (n)) ; |
| s := ConCat (s, InitString (' ')) ; |
| s := ConCat (s, getFQstring (n)) ; |
| s := ConCat (s, InitString (' >')) ; |
| RETURN s |
| END gen ; |
| |
| |
| (* |
| dumpQ - |
| *) |
| |
| PROCEDURE dumpQ (q: ARRAY OF CHAR; l: alist) ; |
| VAR |
| m : String ; |
| n : node ; |
| d, |
| h, i: CARDINAL ; |
| BEGIN |
| m := Sprintf0 (InitString ('Queue ')) ; |
| m := KillString (WriteS (StdOut, m)) ; |
| m := Sprintf0 (InitString (q)) ; |
| m := KillString (WriteS (StdOut, m)) ; |
| m := Sprintf0 (InitString ('\n')) ; |
| m := KillString (WriteS (StdOut, m)) ; |
| i := 1 ; |
| h := alists.noOfItemsInList (l) ; |
| WHILE i<=h DO |
| n := alists.getItemFromList (l, i) ; |
| m := KillString (WriteS (StdOut, gen (n))) ; |
| INC (i) |
| END ; |
| m := Sprintf0 (InitString ('\n')) ; |
| m := KillString (WriteS (StdOut, m)) |
| END dumpQ ; |
| |
| |
| (* |
| dumpLists - |
| *) |
| |
| PROCEDURE dumpLists ; |
| VAR |
| m: String ; |
| BEGIN |
| IF getDebugTopological () |
| THEN |
| m := Sprintf0 (InitString ('\n')) ; |
| m := KillString (WriteS (StdOut, m)) ; |
| dumpQ ('todo', todoQ) ; |
| dumpQ ('partial', partialQ) ; |
| dumpQ ('done', doneQ) |
| END |
| END dumpLists ; |
| |
| |
| (* |
| outputHidden - |
| *) |
| |
| PROCEDURE outputHidden (n: node) ; |
| BEGIN |
| outText (doP, "#if !defined (") ; doFQNameC (doP, n) ; outText (doP, "_D)\n") ; |
| outText (doP, "# define ") ; doFQNameC (doP, n) ; outText (doP, "_D\n") ; |
| outText (doP, " typedef void *") ; doFQNameC (doP, n) ; outText (doP, ";\n") ; |
| outText (doP, "#endif\n\n") |
| END outputHidden ; |
| |
| |
| (* |
| outputHiddenComplete - |
| *) |
| |
| PROCEDURE outputHiddenComplete (n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| assert (isType (n)) ; |
| t := getType (n) ; |
| assert (isPointer (t)) ; |
| outText (doP, "#define ") ; doFQNameC (doP, n) ; outText (doP, "_D\n") ; |
| outText (doP, "typedef ") ; doTypeNameC (doP, getType (t)) ; |
| setNeedSpace (doP) ; outText (doP, "*") ; doFQNameC (doP, n) ; outText (doP, ";\n") |
| END outputHiddenComplete ; |
| |
| |
| (* |
| tryPartial - |
| *) |
| (* |
| PROCEDURE tryPartial (n: node; pt: nodeProcedure) : BOOLEAN ; |
| VAR |
| q : node ; |
| seenPointer: BOOLEAN ; |
| BEGIN |
| IF (n#NIL) AND isType (n) |
| THEN |
| seenPointer := FALSE ; |
| q := getType (n) ; |
| WHILE isPointer (q) DO |
| seenPointer := TRUE ; |
| q := getType (q) |
| END ; |
| IF q # NIL |
| THEN |
| IF isRecord (q) OR isProcType (q) |
| THEN |
| pt (n) ; |
| addTodo (q) ; |
| RETURN TRUE |
| ELSIF isArray (q) AND (seenPointer OR alists.isItemInList (doneQ, getType (q))) |
| THEN |
| pt (n) ; |
| addTodo (q) ; |
| RETURN TRUE |
| ELSIF isType (q) AND seenPointer |
| THEN |
| pt (n) ; |
| addTodo (q) ; |
| RETURN TRUE |
| END |
| END |
| END ; |
| RETURN FALSE |
| END tryPartial ; |
| *) |
| |
| |
| (* |
| tryPartial - |
| *) |
| |
| PROCEDURE tryPartial (n: node; pt: nodeProcedure) : BOOLEAN ; |
| VAR |
| q: node ; |
| BEGIN |
| IF (n#NIL) AND isType (n) |
| THEN |
| q := getType (n) ; |
| WHILE isPointer (q) DO |
| q := getType (q) |
| END ; |
| IF q # NIL |
| THEN |
| IF isRecord (q) OR isProcType (q) |
| THEN |
| pt (n) ; |
| addTodo (q) ; |
| RETURN TRUE |
| ELSIF isArray (q) |
| THEN |
| pt (n) ; |
| addTodo (q) ; |
| RETURN TRUE |
| END |
| END |
| END ; |
| RETURN FALSE |
| END tryPartial ; |
| |
| |
| (* |
| outputPartialRecordArrayProcType - |
| *) |
| |
| PROCEDURE outputPartialRecordArrayProcType (n, q: node; indirection: CARDINAL) ; |
| VAR |
| s: String ; |
| BEGIN |
| outText (doP, "typedef struct") ; setNeedSpace (doP) ; |
| s := getFQstring (n) ; |
| IF isRecord (q) |
| THEN |
| s := ConCat (s, Mark (InitString ("_r"))) |
| ELSIF isArray (q) |
| THEN |
| s := ConCat (s, Mark (InitString ("_a"))) |
| ELSIF isProcType (q) |
| THEN |
| s := ConCat (s, Mark (InitString ("_p"))) |
| END ; |
| outTextS (doP, s) ; |
| setNeedSpace (doP) ; |
| s := KillString (s) ; |
| WHILE indirection>0 DO |
| outText (doP, "*") ; |
| DEC (indirection) |
| END ; |
| doFQNameC (doP, n) ; |
| outText (doP, ";\n\n") |
| END outputPartialRecordArrayProcType ; |
| |
| |
| (* |
| outputPartial - |
| *) |
| |
| PROCEDURE outputPartial (n: node) ; |
| VAR |
| q : node ; |
| indirection: CARDINAL ; |
| BEGIN |
| q := getType (n) ; |
| indirection := 0 ; |
| WHILE isPointer (q) DO |
| q := getType (q) ; |
| INC (indirection) |
| END ; |
| outputPartialRecordArrayProcType (n, q, indirection) |
| END outputPartial ; |
| |
| |
| (* |
| tryOutputTodo - |
| *) |
| |
| PROCEDURE tryOutputTodo (c, t, v, pt: nodeProcedure) ; |
| VAR |
| i, n: CARDINAL ; |
| d : node ; |
| BEGIN |
| i := 1 ; |
| n := alists.noOfItemsInList (todoQ) ; |
| WHILE i<=n DO |
| d := alists.getItemFromList (todoQ, i) ; |
| IF tryComplete (d, c, t, v) |
| THEN |
| alists.removeItemFromList (todoQ, d) ; |
| alists.includeItemIntoList (doneQ, d) ; |
| i := 1 |
| ELSIF tryPartial (d, pt) |
| THEN |
| alists.removeItemFromList (todoQ, d) ; |
| alists.includeItemIntoList (partialQ, d) ; |
| i := 1 |
| ELSE |
| INC (i) |
| END ; |
| n := alists.noOfItemsInList (todoQ) |
| END |
| END tryOutputTodo ; |
| |
| |
| (* |
| tryOutputPartial - |
| *) |
| |
| PROCEDURE tryOutputPartial (t: nodeProcedure) ; |
| VAR |
| i, n: CARDINAL ; |
| d : node ; |
| BEGIN |
| i := 1 ; |
| n := alists.noOfItemsInList (partialQ) ; |
| WHILE i<=n DO |
| d := alists.getItemFromList (partialQ, i) ; |
| IF tryCompleteFromPartial (d, t) |
| THEN |
| alists.removeItemFromList (partialQ, d) ; |
| alists.includeItemIntoList (doneQ, d) ; |
| i := 1 ; |
| DEC (n) |
| ELSE |
| INC (i) |
| END |
| END |
| END tryOutputPartial ; |
| |
| |
| (* |
| debugList - |
| *) |
| |
| PROCEDURE debugList (a: ARRAY OF CHAR; l: alist) ; |
| VAR |
| i, h: CARDINAL ; |
| n : node ; |
| BEGIN |
| h := alists.noOfItemsInList (l) ; |
| IF h>0 |
| THEN |
| outText (doP, a) ; |
| outText (doP, ' still contains node(s)\n') ; |
| i := 1 ; |
| REPEAT |
| n := alists.getItemFromList (l, i) ; |
| dbg (n) ; |
| INC (i) |
| UNTIL i > h |
| END |
| END debugList ; |
| |
| |
| (* |
| debugLists - |
| *) |
| |
| PROCEDURE debugLists ; |
| BEGIN |
| IF getDebugTopological () |
| THEN |
| debugList ('todo', todoQ) ; |
| debugList ('partial', partialQ) |
| END |
| END debugLists ; |
| |
| |
| (* |
| addEnumConst - |
| *) |
| |
| PROCEDURE addEnumConst (n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| IF isConst (n) OR isEnumeration (n) |
| THEN |
| addTodo (n) |
| END |
| END addEnumConst ; |
| |
| |
| (* |
| populateTodo - |
| *) |
| |
| PROCEDURE populateTodo (p: nodeProcedure) ; |
| VAR |
| n : node ; |
| i, h: CARDINAL ; |
| l : alist ; |
| BEGIN |
| h := alists.noOfItemsInList (todoQ) ; |
| i := 1 ; |
| WHILE i <= h DO |
| n := alists.getItemFromList (todoQ, i) ; |
| l := alists.initList () ; |
| visitNode (l, n, p) ; |
| alists.killList (l) ; |
| h := alists.noOfItemsInList (todoQ) ; |
| INC (i) |
| END |
| END populateTodo ; |
| |
| |
| (* |
| topologicallyOut - |
| *) |
| |
| PROCEDURE topologicallyOut (c, t, v, tp, |
| pc, pt, pv: nodeProcedure) ; |
| VAR |
| tol, pal, |
| to, pa : CARDINAL ; |
| BEGIN |
| populateTodo (addEnumConst) ; |
| tol := 0 ; |
| pal := 0 ; |
| to := alists.noOfItemsInList (todoQ) ; |
| pa := alists.noOfItemsInList (partialQ) ; |
| WHILE (tol#to) OR (pal#pa) DO |
| dumpLists ; |
| tryOutputTodo (c, t, v, tp) ; |
| dumpLists ; |
| tryOutputPartial (pt) ; |
| tol := to ; |
| pal := pa ; |
| to := alists.noOfItemsInList (todoQ) ; |
| pa := alists.noOfItemsInList (partialQ) |
| END ; |
| dumpLists ; |
| debugLists |
| END topologicallyOut ; |
| |
| |
| (* |
| scaffoldStatic - |
| *) |
| |
| PROCEDURE scaffoldStatic (p: pretty; n: node) ; |
| BEGIN |
| outText (p, "\n") ; |
| doExternCP (p) ; |
| outText (p, "void") ; |
| setNeedSpace (p) ; |
| outText (p, "_M2_") ; |
| doFQNameC (p, n) ; |
| outText (p, "_init") ; |
| setNeedSpace (p) ; |
| outText (p, "(__attribute__((unused)) int argc") ; |
| outText (p, ",__attribute__((unused)) char *argv[]") ; |
| outText (p, ",__attribute__((unused)) char *envp[])\n"); |
| p := outKc (p, "{\n") ; |
| doStatementsC (p, n^.impF.beginStatements) ; |
| p := outKc (p, "}\n") ; |
| outText (p, "\n") ; |
| doExternCP (p) ; |
| outText (p, "void") ; |
| setNeedSpace (p) ; |
| outText (p, "_M2_") ; |
| doFQNameC (p, n) ; |
| outText (p, "_fini") ; |
| setNeedSpace (p) ; |
| outText (p, "(__attribute__((unused)) int argc") ; |
| outText (p, ",__attribute__((unused)) char *argv[]") ; |
| outText (p, ",__attribute__((unused)) char *envp[])\n"); |
| p := outKc (p, "{\n") ; |
| doStatementsC (p, n^.impF.finallyStatements) ; |
| p := outKc (p, "}\n") |
| END scaffoldStatic ; |
| |
| |
| (* |
| emitCtor - |
| *) |
| |
| PROCEDURE emitCtor (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| outText (p, "\n") ; |
| outText (p, "static void") ; |
| setNeedSpace (p) ; |
| outText (p, "ctorFunction ()\n") ; |
| doFQNameC (p, n) ; |
| p := outKc (p, "{\n") ; |
| outText (p, 'M2RTS_RegisterModule ("') ; |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| prints (p, s) ; |
| outText (p, '",\n') ; |
| outText (p, 'init, fini, dependencies);\n') ; |
| p := outKc (p, "}\n\n") ; |
| p := outKc (p, "struct ") ; |
| prints (p, s) ; |
| p := outKc (p, "_module_m2 { ") ; |
| prints (p, s) ; |
| p := outKc (p, "_module_m2 (); ~") ; |
| prints (p, s) ; |
| p := outKc (p, "_module_m2 (); } global_module_") ; |
| prints (p, s) ; |
| outText (p, ';\n\n') ; |
| prints (p, s) ; |
| p := outKc (p, "_module_m2::") ; |
| prints (p, s) ; |
| p := outKc (p, "_module_m2 ()\n") ; |
| p := outKc (p, "{\n") ; |
| outText (p, 'M2RTS_RegisterModule ("') ; |
| prints (p, s) ; |
| outText (p, '", init, fini, dependencies);') ; |
| p := outKc (p, "}\n") ; |
| prints (p, s) ; |
| p := outKc (p, "_module_m2::~") ; |
| prints (p, s) ; |
| p := outKc (p, "_module_m2 ()\n") ; |
| p := outKc (p, "{\n") ; |
| p := outKc (p, "}\n") ; |
| s := KillString (s) |
| END emitCtor ; |
| |
| |
| (* |
| scaffoldDynamic - |
| *) |
| |
| PROCEDURE scaffoldDynamic (p: pretty; n: node) ; |
| BEGIN |
| outText (p, "\n") ; |
| doExternCP (p) ; |
| outText (p, "void") ; |
| setNeedSpace (p) ; |
| outText (p, "_M2_") ; |
| doFQNameC (p, n) ; |
| outText (p, "_init") ; |
| setNeedSpace (p) ; |
| outText (p, "(__attribute__((unused)) int argc,") ; |
| outText (p, " __attribute__((unused)) char *argv[]") ; |
| outText (p, " __attribute__((unused)) char *envp[])\n") ; |
| p := outKc (p, "{\n") ; |
| doStatementsC (p, n^.impF.beginStatements) ; |
| p := outKc (p, "}\n") ; |
| outText (p, "\n") ; |
| doExternCP (p) ; |
| outText (p, "void") ; |
| setNeedSpace (p) ; |
| outText (p, "_M2_") ; |
| doFQNameC (p, n) ; |
| outText (p, "_fini") ; |
| setNeedSpace (p) ; |
| outText (p, "(__attribute__((unused)) int argc,") ; |
| outText (p, " __attribute__((unused)) char *argv[]") ; |
| outText (p, " __attribute__((unused)) char *envp[])\n") ; |
| p := outKc (p, "{\n") ; |
| doStatementsC (p, n^.impF.finallyStatements) ; |
| p := outKc (p, "}\n") ; |
| emitCtor (p, n) |
| END scaffoldDynamic ; |
| |
| |
| (* |
| scaffoldMain - |
| *) |
| |
| PROCEDURE scaffoldMain (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| outText (p, "int\n") ; |
| outText (p, "main") ; |
| setNeedSpace (p) ; |
| outText (p, "(int argc, char *argv[], char *envp[])\n") ; |
| p := outKc (p, "{\n") ; |
| outText (p, "M2RTS_ConstructModules (") ; |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| prints (p, s) ; |
| outText (p, ", argc, argv, envp);\n"); |
| outText (p, "M2RTS_DeconstructModules (") ; |
| prints (p, s) ; |
| outText (p, ", argc, argv, envp);\n"); |
| outText (p, "return 0;") ; |
| p := outKc (p, "}\n") ; |
| s := KillString (s) |
| END scaffoldMain ; |
| |
| |
| (* |
| outImpInitC - emit the init/fini functions and main function if required. |
| *) |
| |
| PROCEDURE outImpInitC (p: pretty; n: node) ; |
| BEGIN |
| IF getScaffoldDynamic () |
| THEN |
| scaffoldDynamic (p, n) |
| ELSE |
| scaffoldStatic (p, n) |
| END ; |
| IF getScaffoldMain () |
| THEN |
| scaffoldMain (p, n) |
| END |
| END outImpInitC ; |
| |
| |
| (* |
| runSimplifyTypes - |
| *) |
| |
| PROCEDURE runSimplifyTypes (n: node) ; |
| BEGIN |
| IF isImp (n) |
| THEN |
| simplifyTypes (n^.impF.decls) |
| ELSIF isModule (n) |
| THEN |
| simplifyTypes (n^.moduleF.decls) |
| ELSIF isDef (n) |
| THEN |
| simplifyTypes (n^.defF.decls) |
| END |
| END runSimplifyTypes ; |
| |
| |
| (* |
| outDefC - |
| *) |
| |
| PROCEDURE outDefC (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| assert (isDef (n)) ; |
| outputFile := mcStream.openFrag (1) ; (* first fragment. *) |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| print (p, "/* do not edit automatically generated by mc from ") ; |
| prints (p, s) ; print (p, ". */\n") ; |
| writeGPLheader (outputFile) ; |
| doCommentC (p, n^.defF.com.body) ; |
| print (p, "\n\n#if !defined (_") ; prints (p, s) ; print (p, "_H)\n") ; |
| print (p, "# define _") ; prints (p, s) ; print (p, "_H\n\n") ; |
| |
| keyc.genConfigSystem (p) ; |
| |
| print (p, "# ifdef __cplusplus\n") ; |
| print (p, 'extern "C" {\n') ; |
| print (p, "# endif\n") ; |
| |
| outputFile := mcStream.openFrag (3) ; (* third fragment. *) |
| |
| doP := p ; |
| ForeachIndiceInIndexDo (n^.defF.importedModules, doIncludeC) ; |
| |
| print (p, "\n") ; |
| print (p, "# if defined (_") ; prints (p, s) ; print (p, "_C)\n") ; |
| print (p, "# define EXTERN\n") ; |
| print (p, "# else\n") ; |
| print (p, '# define EXTERN extern\n') ; |
| print (p, "# endif\n\n") ; |
| |
| outDeclsDefC (p, n) ; |
| runPrototypeDefC (n) ; |
| |
| print (p, "# ifdef __cplusplus\n") ; |
| print (p, "}\n") ; |
| print (p, "# endif\n") ; |
| |
| print (p, "\n") ; |
| print (p, "# undef EXTERN\n") ; |
| print (p, "#endif\n") ; |
| |
| outputFile := mcStream.openFrag (2) ; (* second fragment. *) |
| keyc.genDefs (p) ; |
| |
| s := KillString (s) |
| END outDefC ; |
| |
| |
| (* |
| runPrototypeExported - |
| *) |
| |
| PROCEDURE runPrototypeExported (n: node) ; |
| BEGIN |
| IF isExported (n) |
| THEN |
| keyc.enterScope (n) ; |
| doProcedureHeadingC (n, TRUE) ; |
| print (doP, ";\n") ; |
| keyc.leaveScope (n) |
| END |
| END runPrototypeExported ; |
| |
| |
| (* |
| runPrototypeDefC - |
| *) |
| |
| PROCEDURE runPrototypeDefC (n: node) ; |
| BEGIN |
| IF isDef (n) |
| THEN |
| ForeachIndiceInIndexDo (n^.defF.decls.procedures, runPrototypeExported) |
| END |
| END runPrototypeDefC ; |
| |
| |
| (* |
| outImpC - |
| *) |
| |
| PROCEDURE outImpC (p: pretty; n: node) ; |
| VAR |
| s : String ; |
| defModule: node ; |
| BEGIN |
| assert (isImp (n)) ; |
| outputFile := mcStream.openFrag (1) ; (* first fragment. *) |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| print (p, "/* do not edit automatically generated by mc from ") ; |
| prints (p, s) ; print (p, ". */\n") ; |
| writeGPLheader (outputFile) ; |
| doCommentC (p, n^.impF.com.body) ; |
| outText (p, "\n") ; |
| outputFile := mcStream.openFrag (3) ; (* third fragment. *) |
| IF getExtendedOpaque () |
| THEN |
| doP := p ; |
| (* ForeachIndiceInIndexDo (n^.impF.importedModules, doIncludeC) ; *) |
| |
| includeExternals (n) ; |
| foreachModuleDo (n, runSimplifyTypes) ; |
| printf ("/* --extended-opaque seen therefore no #include will be used and everything will be declared in full. */\n") ; |
| foreachDefModuleDo (runIncludeDefConstType) ; |
| includeDefVarProcedure (n) ; |
| outDeclsImpC (p, n^.impF.decls) ; |
| foreachDefModuleDo (runPrototypeDefC) |
| ELSE |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| (* we don't want to include the .h file for this implementation module. *) |
| print (p, "#define _") ; prints (p, s) ; print (p, "_H\n") ; |
| print (p, "#define _") ; prints (p, s) ; print (p, "_C\n\n") ; |
| s := KillString (s) ; |
| |
| doP := p ; |
| ForeachIndiceInIndexDo (n^.impF.importedModules, doIncludeC) ; |
| print (p, "\n") ; |
| includeDefConstType (n) ; |
| includeDefVarProcedure (n) ; |
| outDeclsImpC (p, n^.impF.decls) ; |
| |
| defModule := lookupDef (getSymName (n)) ; |
| IF defModule # NIL |
| THEN |
| runPrototypeDefC (defModule) |
| END |
| END ; |
| |
| ForeachIndiceInIndexDo (n^.impF.decls.procedures, doPrototypeC) ; |
| |
| outProceduresC (p, n^.impF.decls) ; |
| outImpInitC (p, n) ; |
| |
| outputFile := mcStream.openFrag (2) ; (* second fragment. *) |
| keyc.genConfigSystem (p) ; |
| keyc.genDefs (p) |
| END outImpC ; |
| |
| |
| (* |
| outDeclsModuleC - |
| *) |
| |
| PROCEDURE outDeclsModuleC (p: pretty; s: scopeT) ; |
| BEGIN |
| simplifyTypes (s) ; |
| includeConstType (s) ; |
| |
| doP := p ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) ; |
| |
| (* try and output types, constants before variables and procedures. *) |
| includeVarProcedure (s) ; |
| |
| topologicallyOut (doConstC, doTypesC, doVarC, |
| outputPartial, |
| doNone, doCompletePartialC, doNone) ; |
| |
| ForeachIndiceInIndexDo (s.procedures, doPrototypeC) |
| END outDeclsModuleC ; |
| |
| |
| (* |
| outModuleInitC - |
| *) |
| |
| PROCEDURE outModuleInitC (p: pretty; n: node) ; |
| BEGIN |
| outText (p, "\n") ; |
| doExternCP (p) ; |
| outText (p, "void") ; |
| setNeedSpace (p) ; |
| outText (p, "_M2_") ; |
| doFQNameC (p, n) ; |
| outText (p, "_init") ; |
| setNeedSpace (p) ; |
| outText (p, "(__attribute__((unused)) int argc") ; |
| outText (p, ",__attribute__((unused)) char *argv[]") ; |
| outText (p, ",__attribute__((unused)) char *envp[])\n"); |
| p := outKc (p, "{\n") ; |
| doStatementsC (p, n^.moduleF.beginStatements) ; |
| p := outKc (p, "}\n") ; |
| outText (p, "\n") ; |
| doExternCP (p) ; |
| outText (p, "void") ; |
| setNeedSpace (p) ; |
| outText (p, "_M2_") ; |
| doFQNameC (p, n) ; |
| outText (p, "_fini") ; |
| setNeedSpace (p) ; |
| outText (p, "(__attribute__((unused)) int argc") ; |
| outText (p, ",__attribute__((unused)) char *argv[]") ; |
| outText (p, ",__attribute__((unused)) char *envp[])\n"); |
| p := outKc (p, "{\n") ; |
| doStatementsC (p, n^.moduleF.finallyStatements) ; |
| p := outKc (p, "}\n") |
| END outModuleInitC ; |
| |
| |
| (* |
| outModuleC - |
| *) |
| |
| PROCEDURE outModuleC (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| assert (isModule (n)) ; |
| outputFile := mcStream.openFrag (1) ; (* first fragment. *) |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| print (p, "/* do not edit automatically generated by mc from ") ; |
| prints (p, s) ; print (p, ". */\n") ; |
| writeGPLheader (outputFile) ; |
| doCommentC (p, n^.moduleF.com.body) ; |
| outText (p, "\n") ; |
| outputFile := mcStream.openFrag (3) ; (* third fragment. *) |
| IF getExtendedOpaque () |
| THEN |
| doP := p ; |
| includeExternals (n) ; |
| foreachModuleDo (n, runSimplifyTypes) ; |
| printf ("/* --extended-opaque seen therefore no #include will be used and everything will be declared in full. */\n") ; |
| foreachDefModuleDo (runIncludeDefConstType) ; |
| outDeclsModuleC (p, n^.moduleF.decls) ; |
| foreachDefModuleDo (runPrototypeDefC) |
| ELSE |
| doP := p ; |
| ForeachIndiceInIndexDo (n^.moduleF.importedModules, doIncludeC) ; |
| print (p, "\n") ; |
| outDeclsModuleC (p, n^.moduleF.decls) |
| END ; |
| |
| ForeachIndiceInIndexDo (n^.moduleF.decls.procedures, doPrototypeC) ; |
| |
| outProceduresC (p, n^.moduleF.decls) ; |
| outModuleInitC (p, n) ; |
| |
| outputFile := mcStream.openFrag (2) ; (* second fragment. *) |
| keyc.genConfigSystem (p) ; |
| keyc.genDefs (p) |
| END outModuleC ; |
| |
| |
| (* |
| outC - |
| *) |
| |
| PROCEDURE outC (p: pretty; n: node) ; |
| BEGIN |
| keyc.enterScope (n) ; |
| IF isDef (n) |
| THEN |
| outDefC (p, n) |
| ELSIF isImp (n) |
| THEN |
| outImpC (p, n) |
| ELSIF isModule (n) |
| THEN |
| outModuleC (p, n) |
| ELSE |
| HALT |
| END ; |
| keyc.leaveScope (n) |
| END outC ; |
| |
| |
| (* |
| doIncludeM2 - include modules in module, n. |
| *) |
| |
| PROCEDURE doIncludeM2 (n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| print (doP, 'IMPORT ') ; |
| prints (doP, s) ; |
| print (doP, ' ;\n') ; |
| s := KillString (s) ; |
| |
| IF isDef (n) |
| THEN |
| foreachNodeDo (n^.defF.decls.symbols, addDone) |
| ELSIF isImp (n) |
| THEN |
| foreachNodeDo (n^.impF.decls.symbols, addDone) |
| ELSIF isModule (n) |
| THEN |
| foreachNodeDo (n^.moduleF.decls.symbols, addDone) |
| END |
| END doIncludeM2 ; |
| |
| |
| (* |
| doConstM2 - |
| *) |
| |
| PROCEDURE doConstM2 (n: node) ; |
| BEGIN |
| print (doP, "CONST\n") ; |
| doFQNameC (doP, n) ; |
| setNeedSpace (doP) ; |
| doExprC (doP, n^.constF.value) ; |
| print (doP, '\n') |
| END doConstM2 ; |
| |
| |
| (* |
| doProcTypeM2 - |
| *) |
| |
| PROCEDURE doProcTypeM2 (p: pretty; n: node) ; |
| BEGIN |
| outText (p, "proc type to do..") |
| END doProcTypeM2 ; |
| |
| |
| (* |
| doRecordFieldM2 - |
| *) |
| |
| PROCEDURE doRecordFieldM2 (p: pretty; f: node) ; |
| BEGIN |
| doNameM2 (p, f) ; |
| outText (p, ":") ; |
| setNeedSpace (p) ; |
| doTypeM2 (p, getType (f)) ; |
| setNeedSpace (p) |
| END doRecordFieldM2 ; |
| |
| |
| (* |
| doVarientFieldM2 - |
| *) |
| |
| PROCEDURE doVarientFieldM2 (p: pretty; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| assert (isVarientField (n)) ; |
| doNameM2 (p, n) ; |
| outText (p, ":") ; |
| setNeedSpace (p) ; |
| i := LowIndice (n^.varientfieldF.listOfSons) ; |
| t := HighIndice (n^.varientfieldF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientfieldF.listOfSons, i) ; |
| IF isRecordField (q) |
| THEN |
| doRecordFieldM2 (p, q) ; |
| outText (p, ";\n") |
| ELSIF isVarient (q) |
| THEN |
| doVarientM2 (p, q) ; |
| outText (p, ";\n") |
| ELSE |
| HALT |
| END ; |
| INC (i) |
| END |
| END doVarientFieldM2 ; |
| |
| |
| (* |
| doVarientM2 - |
| *) |
| |
| PROCEDURE doVarientM2 (p: pretty; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| assert (isVarient (n)) ; |
| outText (p, "CASE") ; setNeedSpace (p) ; |
| IF n^.varientF.tag # NIL |
| THEN |
| IF isRecordField (n^.varientF.tag) |
| THEN |
| doRecordFieldM2 (p, n^.varientF.tag) |
| ELSIF isVarientField (n^.varientF.tag) |
| THEN |
| doVarientFieldM2 (p, n^.varientF.tag) |
| ELSE |
| HALT |
| END |
| END ; |
| setNeedSpace (p) ; |
| outText (p, "OF\n") ; |
| i := LowIndice (n^.varientF.listOfSons) ; |
| t := HighIndice (n^.varientF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientF.listOfSons, i) ; |
| IF isRecordField (q) |
| THEN |
| IF NOT q^.recordfieldF.tag |
| THEN |
| doRecordFieldM2 (p, q) ; |
| outText (p, ";\n") |
| END |
| ELSIF isVarientField (q) |
| THEN |
| doVarientFieldM2 (p, q) |
| ELSE |
| HALT |
| END ; |
| INC (i) |
| END ; |
| outText (p, "END") ; setNeedSpace (p) |
| END doVarientM2 ; |
| |
| |
| (* |
| doRecordM2 - |
| *) |
| |
| PROCEDURE doRecordM2 (p: pretty; n: node) ; |
| VAR |
| i, h: CARDINAL ; |
| f : node ; |
| BEGIN |
| assert (isRecord (n)) ; |
| p := outKm2 (p, "RECORD") ; |
| i := LowIndice (n^.recordF.listOfSons) ; |
| h := HighIndice (n^.recordF.listOfSons) ; |
| outText (p, "\n") ; |
| WHILE i<=h DO |
| f := GetIndice (n^.recordF.listOfSons, i) ; |
| IF isRecordField (f) |
| THEN |
| IF NOT f^.recordfieldF.tag |
| THEN |
| doRecordFieldM2 (p, f) ; |
| outText (p, ";\n") |
| END |
| ELSIF isVarient (f) |
| THEN |
| doVarientM2 (p, f) ; |
| outText (p, ";\n") |
| ELSIF isVarientField (f) |
| THEN |
| doVarientFieldM2 (p, f) |
| END ; |
| INC (i) |
| END ; |
| p := outKm2 (p, "END") ; setNeedSpace (p) |
| END doRecordM2 ; |
| |
| |
| (* |
| doPointerM2 - |
| *) |
| |
| PROCEDURE doPointerM2 (p: pretty; n: node) ; |
| BEGIN |
| outText (p, "POINTER TO") ; |
| setNeedSpace (doP) ; |
| doTypeM2 (p, getType (n)) ; |
| setNeedSpace (p) ; |
| outText (p, ";\n") |
| END doPointerM2 ; |
| |
| |
| (* |
| doTypeAliasM2 - |
| *) |
| |
| PROCEDURE doTypeAliasM2 (p: pretty; n: node) ; |
| BEGIN |
| doTypeNameC (p, n) ; |
| setNeedSpace (p) ; |
| outText (doP, "=") ; |
| setNeedSpace (p) ; |
| doTypeM2 (p, getType (n)) ; |
| setNeedSpace (p) ; |
| outText (p, "\n") |
| END doTypeAliasM2 ; |
| |
| |
| (* |
| doEnumerationM2 - |
| *) |
| |
| PROCEDURE doEnumerationM2 (p: pretty; n: node) ; |
| VAR |
| i, h: CARDINAL ; |
| s : node ; |
| t : String ; |
| BEGIN |
| outText (p, "(") ; |
| i := LowIndice (n^.enumerationF.listOfSons) ; |
| h := HighIndice (n^.enumerationF.listOfSons) ; |
| WHILE i <= h DO |
| s := GetIndice (n^.enumerationF.listOfSons, i) ; |
| doFQNameC (p, s) ; |
| IF i < h |
| THEN |
| outText (p, ",") ; setNeedSpace (p) |
| END ; |
| INC (i) |
| END ; |
| outText (p, ")") |
| END doEnumerationM2 ; |
| |
| |
| (* |
| doBaseM2 - |
| *) |
| |
| PROCEDURE doBaseM2 (p: pretty; n: node) ; |
| BEGIN |
| CASE n^.kind OF |
| |
| char, |
| cardinal, |
| longcard, |
| shortcard, |
| integer, |
| longint, |
| shortint, |
| complex, |
| longcomplex, |
| shortcomplex, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| boolean, |
| proc : doNameM2 (p, n) |
| |
| END ; |
| setNeedSpace (p) |
| END doBaseM2 ; |
| |
| |
| (* |
| doSystemM2 - |
| *) |
| |
| PROCEDURE doSystemM2 (p: pretty; n: node) ; |
| BEGIN |
| CASE n^.kind OF |
| |
| address, |
| loc, |
| byte , |
| word , |
| csizet , |
| cssizet: doNameM2 (p, n) |
| |
| END |
| END doSystemM2 ; |
| |
| |
| (* |
| doTypeM2 - |
| *) |
| |
| PROCEDURE doTypeM2 (p: pretty; n: node) ; |
| BEGIN |
| IF isBase (n) |
| THEN |
| doBaseM2 (p, n) |
| ELSIF isSystem (n) |
| THEN |
| doSystemM2 (p, n) |
| ELSIF isType (n) |
| THEN |
| doTypeAliasM2 (p, n) |
| ELSIF isProcType (n) |
| THEN |
| doProcTypeM2 (p, n) |
| ELSIF isPointer (n) |
| THEN |
| doPointerM2 (p, n) |
| ELSIF isEnumeration (n) |
| THEN |
| doEnumerationM2 (p, n) |
| ELSIF isRecord (n) |
| THEN |
| doRecordM2 (p, n) |
| END |
| END doTypeM2 ; |
| |
| |
| (* |
| doTypesM2 - |
| *) |
| |
| PROCEDURE doTypesM2 (n: node) ; |
| VAR |
| m: node ; |
| BEGIN |
| outText (doP, "TYPE\n") ; |
| doTypeM2 (doP, n) |
| END doTypesM2 ; |
| |
| |
| (* |
| doVarM2 - |
| *) |
| |
| PROCEDURE doVarM2 (n: node) ; |
| BEGIN |
| assert (isVar (n)) ; |
| doNameC (doP, n) ; |
| outText (doP, ":") ; |
| setNeedSpace (doP) ; |
| doTypeM2 (doP, getType (n)) ; |
| setNeedSpace (doP) ; |
| outText (doP, ";\n") |
| END doVarM2 ; |
| |
| |
| (* |
| doVarsM2 - |
| *) |
| |
| PROCEDURE doVarsM2 (n: node) ; |
| VAR |
| m: node ; |
| BEGIN |
| outText (doP, "VAR\n") ; |
| doVarM2 (n) |
| END doVarsM2 ; |
| |
| |
| (* |
| doTypeNameM2 - |
| *) |
| |
| PROCEDURE doTypeNameM2 (p: pretty; n: node) ; |
| BEGIN |
| doNameM2 (p, n) |
| END doTypeNameM2 ; |
| |
| |
| (* |
| doParamM2 - |
| *) |
| |
| PROCEDURE doParamM2 (p: pretty; n: node) ; |
| VAR |
| ptype: node ; |
| i : Name ; |
| c, t : CARDINAL ; |
| l : wlist ; |
| BEGIN |
| assert (isParam (n)) ; |
| ptype := getType (n) ; |
| IF n^.paramF.namelist = NIL |
| THEN |
| doTypeNameM2 (p, ptype) |
| ELSE |
| assert (isIdentList (n^.paramF.namelist)) ; |
| l := n^.paramF.namelist^.identlistF.names ; |
| IF l=NIL |
| THEN |
| doTypeNameM2 (p, ptype) |
| ELSE |
| t := wlists.noOfItemsInList (l) ; |
| c := 1 ; |
| WHILE c <= t DO |
| i := wlists.getItemFromList (l, c) ; |
| setNeedSpace (p) ; |
| doNamesC (p, i) ; |
| IF c<t |
| THEN |
| outText (p, ',') ; setNeedSpace (p) |
| END ; |
| INC (c) |
| END ; |
| outText (p, ':') ; setNeedSpace (p) ; |
| doTypeNameM2 (p, ptype) |
| END |
| END |
| END doParamM2 ; |
| |
| |
| (* |
| doVarParamM2 - |
| *) |
| |
| PROCEDURE doVarParamM2 (p: pretty; n: node) ; |
| VAR |
| ptype: node ; |
| i : Name ; |
| c, t : CARDINAL ; |
| l : wlist ; |
| BEGIN |
| assert (isVarParam (n)) ; |
| outText (p, 'VAR') ; setNeedSpace (p) ; |
| ptype := getType (n) ; |
| IF n^.varparamF.namelist = NIL |
| THEN |
| doTypeNameM2 (p, ptype) |
| ELSE |
| assert (isIdentList (n^.varparamF.namelist)) ; |
| l := n^.varparamF.namelist^.identlistF.names ; |
| IF l=NIL |
| THEN |
| doTypeNameM2 (p, ptype) |
| ELSE |
| t := wlists.noOfItemsInList (l) ; |
| c := 1 ; |
| WHILE c <= t DO |
| i := wlists.getItemFromList (l, c) ; |
| setNeedSpace (p) ; |
| doNamesC (p, i) ; |
| IF c<t |
| THEN |
| outText (p, ',') ; setNeedSpace (p) |
| END ; |
| INC (c) |
| END ; |
| outText (p, ':') ; setNeedSpace (p) ; |
| doTypeNameM2 (p, ptype) |
| END |
| END |
| END doVarParamM2 ; |
| |
| |
| (* |
| doParameterM2 - |
| *) |
| |
| PROCEDURE doParameterM2 (p: pretty; n: node) ; |
| BEGIN |
| IF isParam (n) |
| THEN |
| doParamM2 (p, n) |
| ELSIF isVarParam (n) |
| THEN |
| doVarParamM2 (p, n) |
| ELSIF isVarargs (n) |
| THEN |
| print (p, "...") |
| END |
| END doParameterM2 ; |
| |
| |
| (* |
| doPrototypeM2 - |
| *) |
| |
| PROCEDURE doPrototypeM2 (n: node) ; |
| VAR |
| i, h: CARDINAL ; |
| p : node ; |
| BEGIN |
| assert (isProcedure (n)) ; |
| noSpace (doP) ; |
| |
| doNameM2 (doP, n) ; |
| setNeedSpace (doP) ; |
| outText (doP, "(") ; |
| i := LowIndice (n^.procedureF.parameters) ; |
| h := HighIndice (n^.procedureF.parameters) ; |
| WHILE i <= h DO |
| p := GetIndice (n^.procedureF.parameters, i) ; |
| doParameterM2 (doP, p) ; |
| noSpace (doP) ; |
| IF i < h |
| THEN |
| print (doP, ";") ; setNeedSpace (doP) |
| END ; |
| INC (i) |
| END ; |
| outText (doP, ")") ; |
| IF n^.procedureF.returnType#NIL |
| THEN |
| setNeedSpace (doP) ; |
| outText (doP, ":") ; |
| doTypeM2 (doP, n^.procedureF.returnType) ; setNeedSpace (doP) |
| END ; |
| outText (doP, ";\n") |
| END doPrototypeM2 ; |
| |
| |
| (* |
| outputPartialM2 - just writes out record, array, and proctypes. |
| No need for forward declarations in Modula-2 |
| but we need to keep topological sort happy. |
| So when asked to output partial we emit the |
| full type for these types and then do nothing |
| when trying to complete partial to full. |
| *) |
| |
| PROCEDURE outputPartialM2 (n: node) ; |
| VAR |
| q: node ; |
| BEGIN |
| q := getType (n) ; |
| IF isRecord (q) |
| THEN |
| doTypeM2 (doP, n) |
| ELSIF isArray (q) |
| THEN |
| doTypeM2 (doP, n) |
| ELSIF isProcType (q) |
| THEN |
| doTypeM2 (doP, n) |
| END |
| END outputPartialM2 ; |
| |
| |
| (* |
| outDeclsDefM2 - |
| *) |
| |
| PROCEDURE outDeclsDefM2 (p: pretty; s: scopeT) ; |
| BEGIN |
| simplifyTypes (s) ; |
| includeConstType (s) ; |
| |
| doP := p ; |
| |
| topologicallyOut (doConstM2, doTypesM2, doVarsM2, |
| outputPartialM2, |
| doNothing, doNothing, doNothing) ; |
| |
| includeVarProcedure (s) ; |
| |
| topologicallyOut (doConstM2, doTypesM2, doVarsM2, |
| outputPartialM2, |
| doNothing, doNothing, doNothing) ; |
| |
| ForeachIndiceInIndexDo (s.procedures, doPrototypeM2) |
| END outDeclsDefM2 ; |
| |
| |
| (* |
| outDefM2 - |
| *) |
| |
| PROCEDURE outDefM2 (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := InitStringCharStar (keyToCharStar (getSource (n))) ; |
| print (p, "(* automatically created by mc from ") ; prints (p, s) ; print (p, ". *)\n\n") ; |
| s := KillString (s) ; |
| s := InitStringCharStar (keyToCharStar (getSymName (n))) ; |
| print (p, "DEFINITION MODULE ") ; prints (p, s) ; print (p, " ;\n\n") ; |
| |
| doP := p ; |
| ForeachIndiceInIndexDo (n^.defF.importedModules, doIncludeM2) ; |
| |
| print (p, "\n") ; |
| |
| outDeclsDefM2 (p, n^.defF.decls) ; |
| |
| print (p, "\n") ; |
| print (p, "END ") ; |
| prints (p, s) ; |
| print (p, ".\n") ; |
| s := KillString (s) |
| END outDefM2 ; |
| |
| |
| (* |
| outDeclsImpM2 - |
| *) |
| |
| PROCEDURE outDeclsImpM2 (p: pretty; s: scopeT) ; |
| BEGIN |
| simplifyTypes (s) ; |
| includeConstType (s) ; |
| |
| doP := p ; |
| |
| topologicallyOut (doConstM2, doTypesM2, doVarM2, |
| outputPartialM2, |
| doNothing, doNothing, doNothing) ; |
| |
| includeVarProcedure (s) ; |
| |
| topologicallyOut (doConstM2, doTypesM2, doVarsM2, |
| outputPartialM2, |
| doNothing, doNothing, doNothing) ; |
| |
| outText (p, "\n") ; |
| ForeachIndiceInIndexDo (s.procedures, doPrototypeC) |
| END outDeclsImpM2 ; |
| |
| |
| (* |
| outImpM2 - |
| *) |
| |
| PROCEDURE outImpM2 (p: pretty; n: node) ; |
| VAR |
| s: String ; |
| BEGIN |
| s := InitStringCharStar (keyToCharStar (getSource (n))) ; |
| print (p, "(* automatically created by mc from ") ; prints (p, s) ; print (p, ". *)\n\n") ; |
| print (p, "IMPLEMENTATION MODULE ") ; prints (p, s) ; print (p, " ;\n\n") ; |
| |
| doP := p ; |
| ForeachIndiceInIndexDo (n^.impF.importedModules, doIncludeM2) ; |
| print (p, "\n") ; |
| |
| includeDefConstType (n) ; |
| outDeclsImpM2 (p, n^.impF.decls) ; |
| |
| print (p, "\n") ; |
| print (p, "END ") ; |
| prints (p, s) ; |
| print (p, ".\n") ; |
| |
| s := KillString (s) |
| END outImpM2 ; |
| |
| |
| (* |
| outModuleM2 - |
| *) |
| |
| PROCEDURE outModuleM2 (p: pretty; n: node) ; |
| BEGIN |
| |
| END outModuleM2 ; |
| |
| |
| (* |
| outM2 - |
| *) |
| |
| PROCEDURE outM2 (p: pretty; n: node) ; |
| BEGIN |
| IF isDef (n) |
| THEN |
| outDefM2 (p, n) |
| ELSIF isImp (n) |
| THEN |
| outImpM2 (p, n) |
| ELSIF isModule (n) |
| THEN |
| outModuleM2 (p, n) |
| ELSE |
| HALT |
| END |
| END outM2 ; |
| |
| |
| (* |
| out - walks the tree of node declarations for the main module |
| and writes the output to the outputFile specified in |
| mcOptions. It outputs the declarations in the language |
| specified above. |
| *) |
| |
| PROCEDURE out ; |
| VAR |
| p: pretty ; |
| BEGIN |
| openOutput ; |
| p := initPretty (write, writeln) ; |
| CASE lang OF |
| |
| ansiC : outC (p, getMainModule ()) | |
| ansiCP: outC (p, getMainModule ()) | |
| pim4 : outM2 (p, getMainModule ()) |
| |
| END ; |
| closeOutput |
| END out ; |
| |
| |
| (* |
| setLangC - |
| *) |
| |
| PROCEDURE setLangC ; |
| BEGIN |
| lang := ansiC |
| END setLangC ; |
| |
| |
| (* |
| setLangCP - |
| *) |
| |
| PROCEDURE setLangCP ; |
| BEGIN |
| lang := ansiCP ; |
| keyc.cp |
| END setLangCP ; |
| |
| |
| (* |
| setLangM2 - |
| *) |
| |
| PROCEDURE setLangM2 ; |
| BEGIN |
| lang := pim4 |
| END setLangM2 ; |
| |
| |
| (* |
| addDone - adds node, n, to the doneQ. |
| *) |
| |
| PROCEDURE addDone (n: node) ; |
| BEGIN |
| alists.includeItemIntoList (doneQ, n) |
| END addDone ; |
| |
| |
| (* |
| addDoneDef - adds node, n, to the doneQ providing |
| it is not an opaque of the main module we are compiling. |
| *) |
| |
| PROCEDURE addDoneDef (n: node) ; |
| BEGIN |
| IF isDef (n) |
| THEN |
| addDone (n) ; |
| RETURN |
| END ; |
| IF (NOT isDef (n)) AND (lookupImp (getSymName (getScope (n))) = getMainModule ()) |
| THEN |
| metaError1 ('cyclic dependancy found between another module using {%1ad} from the definition module of the implementation main being compiled, use the --extended-opaque option to compile', n) ; |
| flushErrors ; |
| errorAbort0 ('terminating compilation') |
| ELSE |
| addDone (n) |
| END |
| END addDoneDef ; |
| |
| |
| (* |
| dbgAdd - |
| *) |
| |
| PROCEDURE dbgAdd (l: alist; n: node) : node ; |
| BEGIN |
| IF n#NIL |
| THEN |
| alists.includeItemIntoList (l, n) |
| END ; |
| RETURN n |
| END dbgAdd ; |
| |
| |
| (* |
| dbgType - |
| *) |
| |
| PROCEDURE dbgType (l: alist; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| t := dbgAdd (l, getType (n)) ; |
| out1 ("<%s type", n) ; |
| IF t = NIL |
| THEN |
| out0 (", type = NIL\n") |
| ELSE |
| out1 (", type = %s>\n", t) |
| END |
| END dbgType ; |
| |
| |
| (* |
| dbgPointer - |
| *) |
| |
| PROCEDURE dbgPointer (l: alist; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| t := dbgAdd (l, getType (n)) ; |
| out1 ("<%s pointer", n) ; |
| out1 (" to %s>\n", t) |
| END dbgPointer ; |
| |
| |
| (* |
| dbgRecord - |
| *) |
| |
| PROCEDURE dbgRecord (l: alist; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| out1 ("<%s record:\n", n) ; |
| i := LowIndice (n^.recordF.listOfSons) ; |
| t := HighIndice (n^.recordF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.recordF.listOfSons, i) ; |
| IF isRecordField (q) |
| THEN |
| out1 (" <recordfield %s", q) |
| ELSIF isVarientField (q) |
| THEN |
| out1 (" <varientfield %s", q) |
| ELSIF isVarient (q) |
| THEN |
| out1 (" <varient %s", q) |
| ELSE |
| HALT |
| END ; |
| q := dbgAdd (l, getType (q)) ; |
| out1 (": %s>\n", q) ; |
| INC (i) |
| END ; |
| outText (doP, ">\n") |
| END dbgRecord ; |
| |
| |
| (* |
| dbgVarient - |
| *) |
| |
| PROCEDURE dbgVarient (l: alist; n: node) ; |
| VAR |
| i, t: CARDINAL ; |
| q : node ; |
| BEGIN |
| out1 ("<%s varient: ", n) ; |
| out1 ("tag %s", n^.varientF.tag) ; |
| q := getType (n^.varientF.tag) ; |
| IF q=NIL |
| THEN |
| outText (doP, "\n") |
| ELSE |
| out1 (": %s\n", q) ; |
| q := dbgAdd (l, q) |
| END ; |
| i := LowIndice (n^.varientF.listOfSons) ; |
| t := HighIndice (n^.varientF.listOfSons) ; |
| WHILE i<=t DO |
| q := GetIndice (n^.varientF.listOfSons, i) ; |
| IF isRecordField (q) |
| THEN |
| out1 (" <recordfield %s", q) |
| ELSIF isVarientField (q) |
| THEN |
| out1 (" <varientfield %s", q) |
| ELSIF isVarient (q) |
| THEN |
| out1 (" <varient %s", q) |
| ELSE |
| HALT |
| END ; |
| q := dbgAdd (l, getType (q)) ; |
| out1 (": %s>\n", q) ; |
| INC (i) |
| END ; |
| outText (doP, ">\n") |
| END dbgVarient ; |
| |
| |
| (* |
| dbgEnumeration - |
| *) |
| |
| PROCEDURE dbgEnumeration (l: alist; n: node) ; |
| VAR |
| e : node ; |
| i, h: CARDINAL ; |
| BEGIN |
| outText (doP, "< enumeration ") ; |
| i := LowIndice (n^.enumerationF.listOfSons) ; |
| h := HighIndice (n^.enumerationF.listOfSons) ; |
| WHILE i<=h DO |
| e := GetIndice (n^.enumerationF.listOfSons, i) ; |
| out1 ("%s, ", e) ; |
| INC (i) |
| END ; |
| outText (doP, ">\n") |
| END dbgEnumeration ; |
| |
| |
| (* |
| dbgVar - |
| *) |
| |
| PROCEDURE dbgVar (l: alist; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| t := dbgAdd (l, getType (n)) ; |
| out1 ("<%s var", n) ; |
| out1 (", type = %s>\n", t) |
| END dbgVar ; |
| |
| |
| (* |
| dbgSubrange - |
| *) |
| |
| PROCEDURE dbgSubrange (l: alist; n: node) ; |
| BEGIN |
| IF n^.subrangeF.low = NIL |
| THEN |
| out1 ('%s', n^.subrangeF.type) |
| ELSE |
| out1 ('[%s', n^.subrangeF.low) ; |
| out1 ('..%s]', n^.subrangeF.high) |
| END |
| END dbgSubrange ; |
| |
| |
| (* |
| dbgArray - |
| *) |
| |
| PROCEDURE dbgArray (l: alist; n: node) ; |
| VAR |
| t: node ; |
| BEGIN |
| t := dbgAdd (l, getType (n)) ; |
| out1 ("<%s array ", n) ; |
| IF n^.arrayF.subr # NIL |
| THEN |
| dbgSubrange (l, n^.arrayF.subr) |
| END ; |
| out1 (" of %s>\n", t) |
| END dbgArray ; |
| |
| |
| (* |
| doDbg - |
| *) |
| |
| PROCEDURE doDbg (l: alist; n: node) ; |
| BEGIN |
| IF n=NIL |
| THEN |
| (* do nothing. *) |
| ELSIF isSubrange (n) |
| THEN |
| dbgSubrange (l, n) |
| ELSIF isType (n) |
| THEN |
| dbgType (l, n) |
| ELSIF isRecord (n) |
| THEN |
| dbgRecord (l, n) |
| ELSIF isVarient (n) |
| THEN |
| dbgVarient (l, n) |
| ELSIF isEnumeration (n) |
| THEN |
| dbgEnumeration (l, n) |
| ELSIF isPointer (n) |
| THEN |
| dbgPointer (l, n) |
| ELSIF isArray (n) |
| THEN |
| dbgArray (l, n) |
| ELSIF isVar (n) |
| THEN |
| dbgVar (l, n) |
| END |
| END doDbg ; |
| |
| |
| (* |
| dbg - |
| *) |
| |
| PROCEDURE dbg (n: node) ; |
| VAR |
| l: alist ; |
| o: pretty ; |
| f: File ; |
| s: String ; |
| i: CARDINAL ; |
| BEGIN |
| o := doP ; |
| f := outputFile ; |
| outputFile := StdOut ; |
| doP := initPretty (write, writeln) ; |
| |
| l := alists.initList () ; |
| alists.includeItemIntoList (l, n) ; |
| i := 1 ; |
| out1 ("dbg (%s)\n", n) ; |
| REPEAT |
| n := alists.getItemFromList (l, i) ; |
| doDbg (l, n) ; |
| INC (i) |
| UNTIL i>alists.noOfItemsInList (l) ; |
| doP := o ; |
| outputFile := f |
| END dbg ; |
| |
| |
| (* |
| makeStatementSequence - create and return a statement sequence node. |
| *) |
| |
| PROCEDURE makeStatementSequence () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (stmtseq) ; |
| n^.stmtF.statements := InitIndex (1) ; |
| RETURN n |
| END makeStatementSequence ; |
| |
| |
| (* |
| addStatement - adds node, n, as a statement to statememt sequence, s. |
| *) |
| |
| PROCEDURE addStatement (s: node; n: node) ; |
| BEGIN |
| IF n#NIL |
| THEN |
| assert (isStatementSequence (s)) ; |
| PutIndice (s^.stmtF.statements, HighIndice (s^.stmtF.statements) + 1, n) ; |
| IF isIntrinsic (n) AND (n^.intrinsicF.postUnreachable) |
| THEN |
| n^.intrinsicF.postUnreachable := FALSE ; |
| addStatement (s, makeIntrinsicProc (unreachable, 0, NIL)) |
| END |
| END |
| END addStatement ; |
| |
| |
| (* |
| isStatementSequence - returns TRUE if node, n, is a statement sequence. |
| *) |
| |
| PROCEDURE isStatementSequence (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = stmtseq |
| END isStatementSequence ; |
| |
| |
| (* |
| addGenericBody - adds comment node to funccall, return, assignment |
| nodes. |
| *) |
| |
| PROCEDURE addGenericBody (n, c: node); |
| BEGIN |
| CASE n^.kind OF |
| |
| unreachable, |
| throw, |
| halt, |
| new, |
| dispose, |
| inc, |
| dec, |
| incl, |
| excl : n^.intrinsicF.intrinsicComment.body := c | |
| funccall : n^.funccallF.funccallComment.body := c | |
| return : n^.returnF.returnComment.body := c | |
| assignment: n^.assignmentF.assignComment.body := c | |
| module : n^.moduleF.com.body := c | |
| def : n^.defF.com.body := c | |
| imp : n^.impF.com.body := c |
| |
| ELSE |
| END |
| END addGenericBody; |
| |
| |
| (* |
| addGenericAfter - adds comment node to funccall, return, assignment |
| nodes. |
| *) |
| |
| PROCEDURE addGenericAfter (n, c: node); |
| BEGIN |
| CASE n^.kind OF |
| |
| unreachable, |
| throw, |
| halt, |
| new, |
| dispose, |
| inc, |
| dec, |
| incl, |
| excl : n^.intrinsicF.intrinsicComment.after := c | |
| funccall : n^.funccallF.funccallComment.after := c | |
| return : n^.returnF.returnComment.after := c | |
| assignment: n^.assignmentF.assignComment.after := c | |
| module : n^.moduleF.com.after := c | |
| def : n^.defF.com.after := c | |
| imp : n^.impF.com.after := c |
| |
| ELSE |
| END |
| END addGenericAfter ; |
| |
| |
| (* |
| addCommentBody - adds a body comment to a statement sequence node. |
| *) |
| |
| PROCEDURE addCommentBody (n: node) ; |
| VAR |
| b: commentDesc ; |
| BEGIN |
| IF n # NIL |
| THEN |
| b := getBodyComment () ; |
| IF b # NIL |
| THEN |
| addGenericBody (n, makeCommentS (b)) |
| END |
| END |
| END addCommentBody ; |
| |
| |
| (* |
| addCommentAfter - adds an after comment to a statement sequence node. |
| *) |
| |
| PROCEDURE addCommentAfter (n: node) ; |
| VAR |
| a: commentDesc ; |
| BEGIN |
| IF n # NIL |
| THEN |
| a := getAfterComment () ; |
| IF a # NIL |
| THEN |
| addGenericAfter (n, makeCommentS (a)) |
| END |
| END |
| END addCommentAfter ; |
| |
| |
| (* |
| addIfComments - adds the, body, and, after, comments to if node, n. |
| *) |
| |
| PROCEDURE addIfComments (n: node; body, after: node) ; |
| BEGIN |
| assert (isIf (n)) ; |
| n^.ifF.ifComment.after := after ; |
| n^.ifF.ifComment.body := body |
| END addIfComments ; |
| |
| |
| (* |
| addElseComments - adds the, body, and, after, comments to an, if, or an elsif, node, n. |
| *) |
| |
| PROCEDURE addElseComments (n: node; body, after: node) ; |
| BEGIN |
| assert (isIf (n) OR isElsif (n)) ; |
| IF isIf (n) |
| THEN |
| n^.ifF.elseComment.after := after ; |
| n^.ifF.elseComment.body := body |
| ELSE |
| n^.elsifF.elseComment.after := after ; |
| n^.elsifF.elseComment.body := body |
| END |
| END addElseComments ; |
| |
| |
| (* |
| addIfEndComments - adds the, body, and, after, comments to an, if, node, n. |
| *) |
| |
| PROCEDURE addIfEndComments (n: node; body, after: node) ; |
| BEGIN |
| assert (isIf (n)) ; |
| n^.ifF.endComment.after := after ; |
| n^.ifF.endComment.body := body |
| END addIfEndComments ; |
| |
| |
| (* |
| makeReturn - creates and returns a return node. |
| *) |
| |
| PROCEDURE makeReturn () : node ; |
| VAR |
| type, |
| n : node ; |
| BEGIN |
| n := newNode (return) ; |
| n^.returnF.exp := NIL ; |
| IF isProcedure (getDeclScope ()) |
| THEN |
| n^.returnF.scope := getDeclScope () |
| ELSE |
| n^.returnF.scope := NIL |
| END ; |
| initPair (n^.returnF.returnComment) ; |
| RETURN n |
| END makeReturn ; |
| |
| |
| (* |
| isReturn - returns TRUE if node, n, is a return. |
| *) |
| |
| PROCEDURE isReturn (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = return |
| END isReturn ; |
| |
| |
| (* |
| putReturn - assigns node, e, as the expression on the return node. |
| *) |
| |
| PROCEDURE putReturn (n: node; e: node) ; |
| BEGIN |
| assert (isReturn (n)) ; |
| n^.returnF.exp := e |
| END putReturn ; |
| |
| |
| (* |
| makeWhile - creates and returns a while node. |
| *) |
| |
| PROCEDURE makeWhile () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (while) ; |
| n^.whileF.expr := NIL ; |
| n^.whileF.statements := NIL ; |
| initPair (n^.whileF.doComment) ; |
| initPair (n^.whileF.endComment) ; |
| RETURN n |
| END makeWhile ; |
| |
| |
| (* |
| putWhile - places an expression, e, and statement sequence, s, into the while |
| node, n. |
| *) |
| |
| PROCEDURE putWhile (n: node; e, s: node) ; |
| BEGIN |
| assert (isWhile (n)) ; |
| n^.whileF.expr := e ; |
| n^.whileF.statements := s |
| END putWhile ; |
| |
| |
| (* |
| isWhile - returns TRUE if node, n, is a while. |
| *) |
| |
| PROCEDURE isWhile (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = while |
| END isWhile ; |
| |
| |
| (* |
| addWhileDoComment - adds body and after comments to while node, w. |
| *) |
| |
| PROCEDURE addWhileDoComment (w: node; body, after: node) ; |
| BEGIN |
| assert (isWhile (w)) ; |
| w^.whileF.doComment.after := after ; |
| w^.whileF.doComment.body := body |
| END addWhileDoComment ; |
| |
| |
| (* |
| addWhileEndComment - adds body and after comments to the end of a while node, w. |
| *) |
| |
| PROCEDURE addWhileEndComment (w: node; body, after: node) ; |
| BEGIN |
| assert (isWhile (w)) ; |
| w^.whileF.endComment.after := after ; |
| w^.whileF.endComment.body := body |
| END addWhileEndComment ; |
| |
| |
| (* |
| makeAssignment - creates and returns an assignment node. |
| The designator is, d, and expression, e. |
| *) |
| |
| PROCEDURE makeAssignment (d, e: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (assignment) ; |
| n^.assignmentF.des := d ; |
| n^.assignmentF.expr := e ; |
| initPair (n^.assignmentF.assignComment) ; |
| RETURN n |
| END makeAssignment ; |
| |
| |
| (* |
| isAssignment - |
| *) |
| |
| PROCEDURE isAssignment (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = assignment |
| END isAssignment ; |
| |
| |
| (* |
| putBegin - assigns statements, s, to be the normal part in |
| block, b. The block may be a procedure or module, |
| or implementation node. |
| *) |
| |
| PROCEDURE putBegin (b: node; s: node) ; |
| BEGIN |
| assert (isImp (b) OR isProcedure (b) OR isModule (b)) ; |
| CASE b^.kind OF |
| |
| imp : b^.impF.beginStatements := s | |
| module : b^.moduleF.beginStatements := s | |
| procedure: b^.procedureF.beginStatements := s |
| |
| END |
| END putBegin ; |
| |
| |
| (* |
| putFinally - assigns statements, s, to be the final part in |
| block, b. The block may be a module |
| or implementation node. |
| *) |
| |
| PROCEDURE putFinally (b: node; s: node) ; |
| BEGIN |
| assert (isImp (b) OR isProcedure (b) OR isModule (b)) ; |
| CASE b^.kind OF |
| |
| imp : b^.impF.finallyStatements := s | |
| module : b^.moduleF.finallyStatements := s |
| |
| END |
| END putFinally ; |
| |
| |
| (* |
| makeExit - creates and returns an exit node. |
| *) |
| |
| PROCEDURE makeExit (l: node; n: CARDINAL) : node ; |
| VAR |
| e: node ; |
| BEGIN |
| assert (isLoop (l)) ; |
| e := newNode (exit) ; |
| e^.exitF.loop := l ; |
| l^.loopF.labelno := n ; |
| RETURN e |
| END makeExit ; |
| |
| |
| (* |
| isExit - returns TRUE if node, n, is an exit. |
| *) |
| |
| PROCEDURE isExit (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = exit |
| END isExit ; |
| |
| |
| (* |
| makeLoop - creates and returns a loop node. |
| *) |
| |
| PROCEDURE makeLoop () : node ; |
| VAR |
| l: node ; |
| BEGIN |
| l := newNode (loop) ; |
| l^.loopF.statements := NIL ; |
| l^.loopF.labelno := 0 ; |
| RETURN l |
| END makeLoop ; |
| |
| |
| (* |
| putLoop - places statement sequence, s, into loop, l. |
| *) |
| |
| PROCEDURE putLoop (l, s: node) ; |
| BEGIN |
| assert (isLoop (l)) ; |
| l^.loopF.statements := s |
| END putLoop ; |
| |
| |
| (* |
| isLoop - returns TRUE if, n, is a loop node. |
| *) |
| |
| PROCEDURE isLoop (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = loop |
| END isLoop ; |
| |
| |
| (* |
| makeComment - creates and returns a comment node. |
| *) |
| |
| PROCEDURE makeComment (a: ARRAY OF CHAR) : node ; |
| VAR |
| c: commentDesc ; |
| s: String ; |
| BEGIN |
| c := initComment (TRUE) ; |
| s := InitString (a) ; |
| addText (c, DynamicStrings.string (s)) ; |
| s := KillString (s) ; |
| RETURN makeCommentS (c) |
| END makeComment ; |
| |
| |
| (* |
| makeCommentS - creates and returns a comment node. |
| *) |
| |
| PROCEDURE makeCommentS (c: commentDesc) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| IF c = NIL |
| THEN |
| RETURN NIL |
| ELSE |
| n := newNode (comment) ; |
| n^.commentF.content := c ; |
| RETURN n |
| END |
| END makeCommentS ; |
| |
| |
| (* |
| isComment - returns TRUE if node, n, is a comment. |
| *) |
| |
| PROCEDURE isComment (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = comment |
| END isComment ; |
| |
| |
| (* |
| initPair - initialise the commentPair, c. |
| *) |
| |
| PROCEDURE initPair (VAR c: commentPair) ; |
| BEGIN |
| c.after := NIL ; |
| c.body := NIL |
| END initPair ; |
| |
| |
| (* |
| makeIf - creates and returns an if node. The if node |
| will have expression, e, and statement sequence, s, |
| as the then component. |
| *) |
| |
| PROCEDURE makeIf (e, s: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (if) ; |
| n^.ifF.expr := e ; |
| n^.ifF.then := s ; |
| n^.ifF.else := NIL ; |
| n^.ifF.elsif := NIL ; |
| initPair (n^.ifF.ifComment) ; |
| initPair (n^.ifF.elseComment) ; |
| initPair (n^.ifF.endComment) ; |
| RETURN n |
| END makeIf ; |
| |
| |
| (* |
| isIf - returns TRUE if, n, is an if node. |
| *) |
| |
| PROCEDURE isIf (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = if |
| END isIf ; |
| |
| |
| (* |
| makeElsif - creates and returns an elsif node. |
| This node has an expression, e, and statement |
| sequence, s. |
| *) |
| |
| PROCEDURE makeElsif (i, e, s: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (elsif) ; |
| n^.elsifF.expr := e ; |
| n^.elsifF.then := s ; |
| n^.elsifF.elsif := NIL ; |
| n^.elsifF.else := NIL ; |
| initPair (n^.elsifF.elseComment) ; |
| assert (isIf (i) OR isElsif (i)) ; |
| IF isIf (i) |
| THEN |
| i^.ifF.elsif := n ; |
| assert (i^.ifF.else = NIL) |
| ELSE |
| i^.elsifF.elsif := n ; |
| assert (i^.elsifF.else = NIL) |
| END ; |
| RETURN n |
| END makeElsif ; |
| |
| |
| (* |
| isElsif - returns TRUE if node, n, is an elsif node. |
| *) |
| |
| PROCEDURE isElsif (n: node) : BOOLEAN ; |
| BEGIN |
| RETURN n^.kind = elsif |
| END isElsif ; |
| |
| |
| (* |
| putElse - the else is grafted onto the if/elsif node, i, |
| and the statement sequence will be, s. |
| *) |
| |
| PROCEDURE putElse (i, s: node) ; |
| BEGIN |
| assert (isIf (i) OR isElsif (i)) ; |
| IF isIf (i) |
| THEN |
| assert (i^.ifF.elsif = NIL) ; |
| assert (i^.ifF.else = NIL) ; |
| i^.ifF.else := s |
| ELSE |
| assert (i^.elsifF.elsif = NIL) ; |
| assert (i^.elsifF.else = NIL) ; |
| i^.elsifF.else := s |
| END |
| END putElse ; |
| |
| |
| (* |
| makeFor - creates and returns a for node. |
| *) |
| |
| PROCEDURE makeFor () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (for) ; |
| n^.forF.des := NIL ; |
| n^.forF.start := NIL ; |
| n^.forF.end := NIL ; |
| n^.forF.increment := NIL ; |
| n^.forF.statements := NIL ; |
| RETURN n |
| END makeFor ; |
| |
| |
| (* |
| isFor - returns TRUE if node, n, is a for node. |
| *) |
| |
| PROCEDURE isFor (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = for |
| END isFor ; |
| |
| |
| (* |
| putFor - assigns the fields of the for node with |
| ident, i, |
| start, s, |
| end, e, |
| increment, i, |
| statements, sq. |
| *) |
| |
| PROCEDURE putFor (f, i, s, e, b, sq: node) ; |
| BEGIN |
| assert (isFor (f)) ; |
| f^.forF.des := i ; |
| f^.forF.start := s ; |
| f^.forF.end := e ; |
| f^.forF.increment := b ; |
| f^.forF.statements := sq |
| END putFor ; |
| |
| |
| (* |
| makeRepeat - creates and returns a repeat node. |
| *) |
| |
| PROCEDURE makeRepeat () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (repeat) ; |
| n^.repeatF.expr := NIL ; |
| n^.repeatF.statements := NIL ; |
| initPair (n^.repeatF.repeatComment) ; |
| initPair (n^.repeatF.untilComment) ; |
| RETURN n |
| END makeRepeat ; |
| |
| |
| (* |
| isRepeat - returns TRUE if node, n, is a repeat node. |
| *) |
| |
| PROCEDURE isRepeat (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = repeat |
| END isRepeat ; |
| |
| |
| (* |
| putRepeat - places statements, s, and expression, e, into |
| repeat statement, n. |
| *) |
| |
| PROCEDURE putRepeat (n, s, e: node) ; |
| BEGIN |
| n^.repeatF.expr := e ; |
| n^.repeatF.statements := s |
| END putRepeat ; |
| |
| |
| (* |
| addRepeatComment - adds body and after comments to repeat node, r. |
| *) |
| |
| PROCEDURE addRepeatComment (r: node; body, after: node) ; |
| BEGIN |
| assert (isRepeat (r)) ; |
| r^.repeatF.repeatComment.after := after ; |
| r^.repeatF.repeatComment.body := body |
| END addRepeatComment ; |
| |
| |
| (* |
| addUntilComment - adds body and after comments to the until section of a repeat node, r. |
| *) |
| |
| PROCEDURE addUntilComment (r: node; body, after: node) ; |
| BEGIN |
| assert (isRepeat (r)) ; |
| r^.repeatF.untilComment.after := after ; |
| r^.repeatF.untilComment.body := body |
| END addUntilComment ; |
| |
| |
| (* |
| makeCase - builds and returns a case statement node. |
| *) |
| |
| PROCEDURE makeCase () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (case) ; |
| n^.caseF.expression := NIL ; |
| n^.caseF.caseLabelList := InitIndex (1) ; |
| n^.caseF.else := NIL ; |
| RETURN n |
| END makeCase ; |
| |
| |
| (* |
| isCase - returns TRUE if node, n, is a case statement. |
| *) |
| |
| PROCEDURE isCase (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = case |
| END isCase ; |
| |
| |
| (* |
| putCaseExpression - places expression, e, into case statement, n. |
| n is returned. |
| *) |
| |
| PROCEDURE putCaseExpression (n: node; e: node) : node ; |
| BEGIN |
| assert (isCase (n)) ; |
| n^.caseF.expression := e ; |
| RETURN n |
| END putCaseExpression ; |
| |
| |
| (* |
| putCaseElse - places else statement, e, into case statement, n. |
| n is returned. |
| *) |
| |
| PROCEDURE putCaseElse (n: node; e: node) : node ; |
| BEGIN |
| assert (isCase (n)) ; |
| n^.caseF.else := e ; |
| RETURN n |
| END putCaseElse ; |
| |
| |
| (* |
| putCaseStatement - places a caselist, l, and associated |
| statement sequence, s, into case statement, n. |
| n is returned. |
| *) |
| |
| PROCEDURE putCaseStatement (n: node; l: node; s: node) : node ; |
| BEGIN |
| assert (isCase (n)) ; |
| assert (isCaseList (l)) ; |
| IncludeIndiceIntoIndex (n^.caseF.caseLabelList, makeCaseLabelList (l, s)) ; |
| RETURN n |
| END putCaseStatement ; |
| |
| |
| (* |
| makeCaseLabelList - creates and returns a caselabellist node. |
| *) |
| |
| PROCEDURE makeCaseLabelList (l, s: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (caselabellist) ; |
| n^.caselabellistF.caseList := l ; |
| n^.caselabellistF.statements := s ; |
| RETURN n |
| END makeCaseLabelList ; |
| |
| |
| (* |
| isCaseLabelList - returns TRUE if, n, is a caselabellist. |
| *) |
| |
| PROCEDURE isCaseLabelList (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = caselabellist |
| END isCaseLabelList ; |
| |
| |
| (* |
| makeCaseList - creates and returns a case statement node. |
| *) |
| |
| PROCEDURE makeCaseList () : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (caselist) ; |
| n^.caselistF.rangePairs := InitIndex (1) ; |
| RETURN n |
| END makeCaseList ; |
| |
| |
| (* |
| isCaseList - returns TRUE if, n, is a case list. |
| *) |
| |
| PROCEDURE isCaseList (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = caselist |
| END isCaseList ; |
| |
| |
| (* |
| putCaseRange - places the case range lo..hi into caselist, n. |
| *) |
| |
| PROCEDURE putCaseRange (n: node; lo, hi: node) : node ; |
| BEGIN |
| assert (isCaseList (n)) ; |
| IncludeIndiceIntoIndex (n^.caselistF.rangePairs, makeRange (lo, hi)) ; |
| RETURN n |
| END putCaseRange ; |
| |
| |
| (* |
| makeRange - creates and returns a case range. |
| *) |
| |
| PROCEDURE makeRange (lo, hi: node) : node ; |
| VAR |
| n: node ; |
| BEGIN |
| n := newNode (range) ; |
| n^.rangeF.lo := lo ; |
| n^.rangeF.hi := hi ; |
| RETURN n |
| END makeRange ; |
| |
| |
| (* |
| isRange - returns TRUE if node, n, is a range. |
| *) |
| |
| PROCEDURE isRange (n: node) : BOOLEAN ; |
| BEGIN |
| assert (n # NIL) ; |
| RETURN n^.kind = range |
| END isRange ; |
| |
| |
| (* |
| dupExplist - |
| *) |
| |
| PROCEDURE dupExplist (n: node) : node ; |
| VAR |
| m: node ; |
| i: CARDINAL ; |
| BEGIN |
| assert (isExpList (n)) ; |
| m := makeExpList () ; |
| i := LowIndice (n^.explistF.exp) ; |
| WHILE i <= HighIndice (n^.explistF.exp) DO |
| putExpList (m, dupExpr (GetIndice (n^.explistF.exp, i))) ; |
| INC (i) |
| END ; |
| RETURN m |
| END dupExplist ; |
| |
| |
| (* |
| dupArrayref - |
| *) |
| |
| PROCEDURE dupArrayref (n: node) : node ; |
| BEGIN |
| assert (isArrayRef (n)) ; |
| RETURN makeArrayRef (dupExpr (n^.arrayrefF.array), dupExpr (n^.arrayrefF.index)) |
| END dupArrayref ; |
| |
| |
| (* |
| dupPointerref - |
| *) |
| |
| PROCEDURE dupPointerref (n: node) : node ; |
| BEGIN |
| assert (isPointerRef (n)) ; |
| RETURN makePointerRef (dupExpr (n^.pointerrefF.ptr), dupExpr (n^.pointerrefF.field)) |
| END dupPointerref ; |
| |
| |
| (* |
| dupComponentref - |
| *) |
| |
| PROCEDURE dupComponentref (n: node) : node ; |
| BEGIN |
| assert (isComponentRef (n)) ; |
| RETURN doMakeComponentRef (dupExpr (n^.componentrefF.rec), dupExpr (n^.componentrefF.field)) |
| END dupComponentref ; |
| |
| |
| (* |
| dupBinary - |
| *) |
| |
| PROCEDURE dupBinary (n: node) : node ; |
| BEGIN |
| (* assert (isBinary (n)) ; *) |
| RETURN makeBinary (n^.kind, |
| dupExpr (n^.binaryF.left), dupExpr (n^.binaryF.right), |
| n^.binaryF.resultType) |
| END dupBinary ; |
| |
| |
| (* |
| dupUnary - |
| *) |
| |
| PROCEDURE dupUnary (n: node) : node ; |
| BEGIN |
| (* assert (isUnary (n)) ; *) |
| RETURN makeUnary (n^.kind, dupExpr (n^.unaryF.arg), n^.unaryF.resultType) |
| END dupUnary ; |
| |
| |
| (* |
| dupFunccall - |
| *) |
| |
| PROCEDURE dupFunccall (n: node) : node ; |
| VAR |
| m: node ; |
| BEGIN |
| assert (isFuncCall (n)) ; |
| m := makeFuncCall (dupExpr (n^.funccallF.function), dupExpr (n^.funccallF.args)) ; |
| m^.funccallF.type := n^.funccallF.type ; |
| RETURN m |
| END dupFunccall ; |
| |
| |
| (* |
| dupSetValue - |
| *) |
| |
| PROCEDURE dupSetValue (n: node) : node ; |
| VAR |
| m: node ; |
| i: CARDINAL ; |
| BEGIN |
| m := newNode (setvalue) ; |
| m^.setvalueF.type := n^.setvalueF.type ; |
| i := LowIndice (n^.setvalueF.values) ; |
| WHILE i <= HighIndice (n^.setvalueF.values) DO |
| m := putSetValue (m, dupExpr (GetIndice (n^.setvalueF.values, i))) ; |
| INC (i) |
| END ; |
| RETURN m |
| END dupSetValue ; |
| |
| |
| (* |
| dupExpr - duplicate the expression nodes, it does not duplicate |
| variables, literals, constants but only the expression |
| operators (including function calls and parameter lists). |
| *) |
| |
| PROCEDURE dupExpr (n: node) : node ; |
| BEGIN |
| IF n = NIL |
| THEN |
| RETURN NIL |
| ELSE |
| RETURN doDupExpr (n) |
| END |
| END dupExpr ; |
| |
| |
| (* |
| doDupExpr - |
| *) |
| |
| PROCEDURE doDupExpr (n: node) : node ; |
| BEGIN |
| assert (n # NIL) ; |
| CASE n^.kind OF |
| |
| explist : RETURN dupExplist (n) | |
| exit, |
| return, |
| stmtseq, |
| comment : HALT | (* should not be duplicating code. *) |
| length : HALT | (* length should have been converted into unary. *) |
| (* base constants. *) |
| nil, |
| true, |
| false, |
| (* system types. *) |
| address, |
| loc, |
| byte, |
| word, |
| csizet, |
| cssizet, |
| (* base types. *) |
| boolean, |
| proc, |
| char, |
| integer, |
| cardinal, |
| longcard, |
| shortcard, |
| longint, |
| shortint, |
| real, |
| longreal, |
| shortreal, |
| bitset, |
| ztype, |
| rtype, |
| complex, |
| longcomplex, |
| shortcomplex : RETURN n | |
| (* language features and compound type attributes. *) |
| type, |
| record, |
| varient, |
| var, |
| enumeration, |
| subrange, |
| subscript, |
| array, |
| string, |
| const, |
| literal, |
| varparam, |
| param, |
| varargs, |
| optarg, |
| pointer, |
| recordfield, |
| varientfield, |
| enumerationfield, |
| set, |
| proctype : RETURN n | |
| (* blocks. *) |
| procedure, |
| def, |
| imp, |
| module : RETURN n | |
| (* statements. *) |
| loop, |
| while, |
| for, |
| repeat, |
| case, |
| caselabellist, |
| caselist, |
| range, |
| if, |
| elsif, |
| assignment : RETURN n | |
| (* expressions. *) |
| arrayref : RETURN dupArrayref (n) | |
| pointerref : RETURN dupPointerref (n) | |
| componentref : RETURN dupComponentref (n) | |
| cmplx, |
| and, |
| or, |
| equal, |
| notequal, |
| less, |
| greater, |
| greequal, |
| lessequal, |
| cast, |
| val, |
| plus, |
| sub, |
| div, |
| mod, |
| mult, |
| divide, |
| in : RETURN dupBinary (n) | |
| re, |
| im, |
| constexp, |
| deref, |
| abs, |
| chr, |
| cap, |
| high, |
| float, |
| trunc, |
| ord, |
| not, |
| neg, |
| adr, |
| size, |
| tsize, |
| min, |
| max : RETURN dupUnary (n) | |
| identlist : RETURN n | |
| vardecl : RETURN n | |
| funccall : RETURN dupFunccall (n) | |
| setvalue : RETURN dupSetValue (n) |
| |
| END |
| END doDupExpr ; |
| |
| |
| (* |
| setNoReturn - sets noreturn field inside procedure. |
| *) |
| |
| PROCEDURE setNoReturn (n: node; value: BOOLEAN) ; |
| BEGIN |
| assert (n#NIL) ; |
| assert (isProcedure (n)) ; |
| IF n^.procedureF.noreturnused AND (n^.procedureF.noreturn # value) |
| THEN |
| metaError1 ('{%1DMad} definition module and implementation module have different <* noreturn *> attributes', n) ; |
| END ; |
| n^.procedureF.noreturn := value ; |
| n^.procedureF.noreturnused := TRUE |
| END setNoReturn ; |
| |
| |
| (* |
| makeSystem - |
| *) |
| |
| PROCEDURE makeSystem ; |
| BEGIN |
| systemN := lookupDef (makeKey ('SYSTEM')) ; |
| |
| addressN := makeBase (address) ; |
| locN := makeBase (loc) ; |
| byteN := makeBase (byte) ; |
| wordN := makeBase (word) ; |
| csizetN := makeBase (csizet) ; |
| cssizetN := makeBase (cssizet) ; |
| |
| adrN := makeBase (adr) ; |
| tsizeN := makeBase (tsize) ; |
| throwN := makeBase (throw) ; |
| |
| enterScope (systemN) ; |
| addressN := addToScope (addressN) ; |
| locN := addToScope (locN) ; |
| byteN := addToScope (byteN) ; |
| wordN := addToScope (wordN) ; |
| csizetN := addToScope (csizetN) ; |
| cssizetN := addToScope (cssizetN) ; |
| adrN := addToScope (adrN) ; |
| tsizeN := addToScope (tsizeN) ; |
| throwN := addToScope (throwN) ; |
| |
| assert (sizeN#NIL) ; (* assumed to be built already. *) |
| sizeN := addToScope (sizeN) ; (* also export size from system. *) |
| leaveScope ; |
| |
| addDone (addressN) ; |
| addDone (locN) ; |
| addDone (byteN) ; |
| addDone (wordN) ; |
| addDone (csizetN) ; |
| addDone (cssizetN) |
| END makeSystem ; |
| |
| |
| (* |
| makeM2rts - |
| *) |
| |
| PROCEDURE makeM2rts ; |
| BEGIN |
| m2rtsN := lookupDef (makeKey ('M2RTS')) |
| END makeM2rts ; |
| |
| |
| (* |
| makeBitnum - |
| *) |
| |
| PROCEDURE makeBitnum () : node ; |
| VAR |
| b: node ; |
| BEGIN |
| b := newNode (subrange) ; |
| b^.subrangeF.type := NIL ; |
| b^.subrangeF.scope := NIL ; |
| b^.subrangeF.low := lookupConst (b, makeKey ('0')) ; |
| b^.subrangeF.high := lookupConst (b, makeKey ('31')) ; |
| RETURN b |
| END makeBitnum ; |
| |
| |
| (* |
| makeBaseSymbols - |
| *) |
| |
| PROCEDURE makeBaseSymbols ; |
| BEGIN |
| baseSymbols := initTree () ; |
| |
| booleanN := makeBase (boolean) ; |
| charN := makeBase (char) ; |
| procN := makeBase (proc) ; |
| cardinalN := makeBase (cardinal) ; |
| longcardN := makeBase (longcard) ; |
| shortcardN := makeBase (shortcard) ; |
| integerN := makeBase (integer) ; |
| longintN := makeBase (longint) ; |
| shortintN := makeBase (shortint) ; |
| bitsetN := makeBase (bitset) ; |
| bitnumN := makeBitnum () ; |
| ztypeN := makeBase (ztype) ; |
| rtypeN := makeBase (rtype) ; |
| complexN := makeBase (complex) ; |
| longcomplexN := makeBase (longcomplex) ; |
| shortcomplexN := makeBase (shortcomplex) ; |
| realN := makeBase (real) ; |
| longrealN := makeBase (longreal) ; |
| shortrealN := makeBase (shortreal) ; |
| |
| nilN := makeBase (nil) ; |
| trueN := makeBase (true) ; |
| falseN := makeBase (false) ; |
| |
| sizeN := makeBase (size) ; |
| minN := makeBase (min) ; |
| maxN := makeBase (max) ; |
| floatN := makeBase (float) ; |
| truncN := makeBase (trunc) ; |
| ordN := makeBase (ord) ; |
| valN := makeBase (val) ; |
| chrN := makeBase (chr) ; |
| capN := makeBase (cap) ; |
| absN := makeBase (abs) ; |
| newN := makeBase (new) ; |
| disposeN := makeBase (dispose) ; |
| lengthN := makeBase (length) ; |
| incN := makeBase (inc) ; |
| decN := makeBase (dec) ; |
| inclN := makeBase (incl) ; |
| exclN := makeBase (excl) ; |
| highN := makeBase (high) ; |
| imN := makeBase (im) ; |
| reN := makeBase (re) ; |
| cmplxN := makeBase (cmplx) ; |
| |
| putSymKey (baseSymbols, makeKey ('BOOLEAN'), booleanN) ; |
| putSymKey (baseSymbols, makeKey ('PROC'), procN) ; |
| putSymKey (baseSymbols, makeKey ('CHAR'), charN) ; |
| putSymKey (baseSymbols, makeKey ('CARDINAL'), cardinalN) ; |
| putSymKey (baseSymbols, makeKey ('SHORTCARD'), shortcardN) ; |
| putSymKey (baseSymbols, makeKey ('LONGCARD'), longcardN) ; |
| putSymKey (baseSymbols, makeKey ('INTEGER'), integerN) ; |
| putSymKey (baseSymbols, makeKey ('LONGINT'), longintN) ; |
| putSymKey (baseSymbols, makeKey ('SHORTINT'), shortintN) ; |
| putSymKey (baseSymbols, makeKey ('BITSET'), bitsetN) ; |
| putSymKey (baseSymbols, makeKey ('REAL'), realN) ; |
| putSymKey (baseSymbols, makeKey ('SHORTREAL'), shortrealN) ; |
| putSymKey (baseSymbols, makeKey ('LONGREAL'), longrealN) ; |
| putSymKey (baseSymbols, makeKey ('COMPLEX'), complexN) ; |
| putSymKey (baseSymbols, makeKey ('LONGCOMPLEX'), longcomplexN) ; |
| putSymKey (baseSymbols, makeKey ('SHORTCOMPLEX'), shortcomplexN) ; |
| |
| putSymKey (baseSymbols, makeKey ('NIL'), nilN) ; |
| putSymKey (baseSymbols, makeKey ('TRUE'), trueN) ; |
| putSymKey (baseSymbols, makeKey ('FALSE'), falseN) ; |
| putSymKey (baseSymbols, makeKey ('SIZE'), sizeN) ; |
| putSymKey (baseSymbols, makeKey ('MIN'), minN) ; |
| putSymKey (baseSymbols, makeKey ('MAX'), maxN) ; |
| putSymKey (baseSymbols, makeKey ('FLOAT'), floatN) ; |
| putSymKey (baseSymbols, makeKey ('TRUNC'), truncN) ; |
| putSymKey (baseSymbols, makeKey ('ORD'), ordN) ; |
| putSymKey (baseSymbols, makeKey ('VAL'), valN) ; |
| putSymKey (baseSymbols, makeKey ('CHR'), chrN) ; |
| putSymKey (baseSymbols, makeKey ('CAP'), capN) ; |
| putSymKey (baseSymbols, makeKey ('ABS'), absN) ; |
| putSymKey (baseSymbols, makeKey ('NEW'), newN) ; |
| putSymKey (baseSymbols, makeKey ('DISPOSE'), disposeN) ; |
| putSymKey (baseSymbols, makeKey ('LENGTH'), lengthN) ; |
| putSymKey (baseSymbols, makeKey ('INC'), incN) ; |
| putSymKey (baseSymbols, makeKey ('DEC'), decN) ; |
| putSymKey (baseSymbols, makeKey ('INCL'), inclN) ; |
| putSymKey (baseSymbols, makeKey ('EXCL'), exclN) ; |
| putSymKey (baseSymbols, makeKey ('HIGH'), highN) ; |
| putSymKey (baseSymbols, makeKey ('CMPLX'), cmplxN) ; |
| putSymKey (baseSymbols, makeKey ('RE'), reN) ; |
| putSymKey (baseSymbols, makeKey ('IM'), imN) ; |
| |
| addDone (booleanN) ; |
| addDone (charN) ; |
| addDone (cardinalN) ; |
| addDone (longcardN) ; |
| addDone (shortcardN) ; |
| addDone (integerN) ; |
| addDone (longintN) ; |
| addDone (shortintN) ; |
| addDone (bitsetN) ; |
| addDone (bitnumN) ; |
| addDone (ztypeN) ; |
| addDone (rtypeN) ; |
| addDone (realN) ; |
| addDone (longrealN) ; |
| addDone (shortrealN) ; |
| addDone (complexN) ; |
| addDone (longcomplexN) ; |
| addDone (shortcomplexN) ; |
| addDone (procN) ; |
| addDone (nilN) ; |
| addDone (trueN) ; |
| addDone (falseN) |
| |
| END makeBaseSymbols ; |
| |
| |
| (* |
| makeBuiltins - |
| *) |
| |
| PROCEDURE makeBuiltins ; |
| BEGIN |
| bitsperunitN := makeLiteralInt (makeKey ('8')) ; |
| bitsperwordN := makeLiteralInt (makeKey ('32')) ; |
| bitspercharN := makeLiteralInt (makeKey ('8')) ; |
| unitsperwordN := makeLiteralInt (makeKey ('4')) ; |
| |
| addDone (bitsperunitN) ; |
| addDone (bitsperwordN) ; |
| addDone (bitspercharN) ; |
| addDone (unitsperwordN) |
| END makeBuiltins ; |
| |
| |
| (* |
| init - |
| *) |
| |
| PROCEDURE init ; |
| BEGIN |
| lang := ansiC ; |
| outputFile := StdOut ; |
| doP := initPretty (write, writeln) ; |
| todoQ := alists.initList () ; |
| partialQ := alists.initList () ; |
| doneQ := alists.initList () ; |
| modUniverse := initTree () ; |
| defUniverse := initTree () ; |
| modUniverseI := InitIndex (1) ; |
| defUniverseI := InitIndex (1) ; |
| scopeStack := InitIndex (1) ; |
| makeBaseSymbols ; |
| makeSystem ; |
| makeBuiltins ; |
| makeM2rts ; |
| outputState := punct ; |
| tempCount := 0 ; |
| mustVisitScope := FALSE |
| END init ; |
| |
| |
| BEGIN |
| init |
| END decl. |