%ebm=true %dump=false %profile=false program pasq ( input, output, codefile, objectfile, tokenfile ) ; (**************************************************** * * * 1900 pascal compiler mk 2 * * ----------------------------- * * * * authors : j welsh * * c quinn * * k mcshane * * * * department of computer science * * queen's university * * belfast * * * * from the eth zurich compiler * * for cdc 6000 by u ammann * * * ****************************************************) (* the compiler was developed in 5 stages by "stepwise enrichment" as follows stage 1 source listing generation and lexical analysis stage 2 syntax analysis and syntactic error recovery stage 3 semantic analysis and semantic error recovery stage 4 object program generation stage 5 postmortem diagnostics and user option handling . * * * * * * * * *) (* this listing embodies stages 1 - 5 *) (* stage 1 : source listing generation and lexical analysis (a) source listing generation source listing generation is implemented by the following procedures : nextch this procedure reads the next source character from the input stream, copies it to the output stream, and leaves its value in the global variable ch . ends of line are transmitted as blank characters. error this procedure enables the analysis processes to record error codes for incorporation in the output listing. each error is assumed to be assoc. iated with the current position in the input source . on the assumption that one-pass generation of an absolute object program may take place, the listing generator provides for the printing of an associated object address with each source line listed. the object address is taken from the global variable currentaddress, whose initialisation and incrementing is assumed to be carried out elsewhere. address printing can be turned on and off by the procedures listaddresses and listnoaddresses. initialisation of the listing generation variables is carried out by the procedure initlisting, which should be called before the first call to nextch. finalisation is carried out by the procedure endlisting which should be called after compilation is complete. the complete interface between the source-handler and the rest of the compiler thus comprises the following globals : var ch : char ; procedure nextch ; procedure error(code : integer) ; var currentaddress : addrrange ; procedure listaddresses ; procedure listnoaddresses ; procedure initlisting ; procedure endlisting ; (b) lexical analysis lexical analysis is carried out by the procedure insymbol. when called, insymbol scans the next language symbol in the input stream and returns a representation of it in the following global variables : symbol in all cases symbol represents the symbol scanned, as defined by the type symboltype operator when symbol = addop,mulop or relop, operator represents the particular operator scanned, as defined by the type optype spelling when symbol = ident , spelling holds the (significant) characters of the identifier scanned constant when symbol = intconst, realconst, charconst or stringconst, constant holds a representation of the constant scanned *) (* stage 2 : syntax analysis and syntactic error recovery (a) syntax analysis syntax analysis is top-down without back-up, implemented as a set of recursive descent procedures. these procedures are based on the syntax diagrams given in the revised report and are nested as tightly as the mutual interaction permits. the order, names, and nesting of the procedures is as follows programme block inconstant typ simpletype fieldlist labeldeclaration ** typedeclaration ** vardeclaration ** procdeclaration ** parameterlist body ** statement selector call expression simpleexpression term factor assignment ** compoundstatement ** ifstatement ** casestatement ** whilestatement ** repeatstatement ** forstatement ** withstatement ** gotostatement ** the procedures marked ** do not correspond to syntax diagrams in the revised report, but to particular limbs of the diagram for the procedure enclosing them. they are introduced only to break down these procedures into manageable proportions . the procedure 'call' is introduced to implement the analysis of actual parameter lists in procedure and function calls, which in the revised report is shown as duplicate sub-diagrams within those for 'statement' and 'factor'. the syntax analysers are written on the assumption that the next syntactic goal can always be selected by inspection of (at most) the next incoming symbol ( i.e. that the underlying grammar is ll(1) ). this is not so at the following points in the diagrams actually used 1. a statement beginning with an identifier may be either an assignment or a procedure call 2. a factor beginning with an identifier may be either a variable or a function call 3. a simple type beginning with an identifier may be either a named type already declared or a subrange whose lower bound is a constant identifier in all cases to resolve the choice on a purely syntactic basis would require a look ahead of a further symbol. however if parallel semantic analysis is assumed (as in stage 3 of this compiler) these choices can be resolved without further lookahead, by inspection of the current semantic attributes of the identifier involved. for this reason syntactic resolution of these choices is not used. a similar problem arises with the actual parameter lists of the built-in procedures and functions of pascal which are best analysed by special purpose syntax routines. these are again selected by a semantic rather than syntactic test. (b) syntactic error recovery recovery in the syntax analysis process following the discovery of a syntax error is incorporated into the syntax procedures on the following basis 1. each procedure when called is passed an actual parameter which is a set of symbols forming the (right) context of the string which it should scan. this context normally includes (a) all symbols which may legitimately follow the string to be scanned (b) such additional symbols as a superior (calling) procedure may wish to handle in the event of error recovery 2. when entered the procedure may ensure that the current symbol is an acceptable starter for the string to be scanned, and if not scan forward until such a symbol is found (subject to 4. below) 3. when calling a subsidiary syntax procedure the procedure passes on as context its own context plus those symbols if any which it may determine as right context for the substring to be scanned 4. to recover from a syntax error the procedure may scan over (skip) any symbol provided it is not contained in the context passed to it 5. on exit the syntax procedure ensures that the current symbol is contained in the context passed to it, flagging a terminal error and skipping if this is not initially the case. *) (* stage 3 : semantic analysis and semantic error recovery semantic analysis and semantic error recovery is implemented by "enrichment" of the syntax analyser constructed in stage 2 with semantic interludes. the semantic analysis depends on the following globally-defined data structures and manipulative procedures (a) the identifier table this holds an entry for each identifier,either standard or program defined, which may appear in the program being compiled. the form of entry used depends on the "class" of usage of the identifier and is represented by the variant record type "idrec" the table is organised as a set of binary trees, one for each identifier scope currently open, the nesting of these scopes being represented by the array "display" as follows (1) each display entry points to the root of the corresponding identifier tree , and indicates whether the scope is one delimited by a program block, or by a with statement (2) the global variables "top" and "level" index the topmost scope and topmost block scope respectively within the display insertion and lookup of identifiers within the table is provided by the two procedures "entered" and "searchid". standard identifiers supported by the language are held within the table as a scope corresponding to a pseudo-block enclosing the main program (at display level 0). these entries are created by the procedure "stdidentries" within the procedure "initsemantictables" (b) the type table all types underlying the data defined by the program being compiled are represented by type entries whose form is determined by the "form" of the type so represented (i.e. scalars,arrays,etc.). entries are constructed using a corresponding variant record type "typerec" these type entries are accessed only via the identifier table entries for type identifiers, or via the representation of the data objects (variables,constants,functions,expressions) whose type they describe. thus for example all identifier table entries have a common field "idtype" which points to an underlying type entry (with an obvious interpretation for all classes of identifier other than "proc") where types in turn depend on identifiers for their definition (e.o. an enumerated sclar type such as (false,true)) the type entries point back to the relevant identifier entries in the identifier table (i.e. to those for 'flase' and 'true') the type entries representing the standard types supported by the language (integer,real,etc.) are created by the procedure "stdtypentries" within the procedure "initsemantictables". these entries are directly accessible via global pointer variables "intype","realtype",etc., as well as via the identifier entries for "integer","real",etc. to facilitate type analysis within the semantic analyser a general-purpose boolean function "comptypes" is provided to test the compatibility of two types as represented by pointers to the corresponding type entries. a result true is returned if the types are identical (i.e. the pointers point to the same type entry), strictly equivalent (i.e. two distinct type entries of identical form and content), or compatible by subrange-to-range transfer (c) the label table this holds an entry for each label appearing in the program being compiled, each entry being of the record type "labelrec" the table is held as a set of linear lists, one for each block currently open. the block entries within the display serve to locate these lists, as well as the identifier table trees. insertion and lookup of labels within the table is provided by two procedures "enterlabel" and "searchlabel" recovery from semantic errors is accomodated within these data structures and procedures as follows (a) duplicate, mis-used and undeclared identifiers (1) if enterid finds an entry for the identifier already in the current scope, an error is flagged but a second entry is still made(for possible selection by searchid as below) (2) searchid when called is passed a parameter specifying the acceptable classes of entry to be found . if the first entry encountered for the identifier is not of an acceptable class searching continues within the current scope for a possible duplicate entry. if no acceptable duplicate is found in the scope a misuse error is reported and an anonymous default entry of acceptable class is returned. (3) if searchid fails to find an entry in any scope for the identifier sought,an undeclared error is reported and an entry of acceptable class is created for the ident- ifier, with otherwise default attributes. (underclared labels are similarly handled by the procedure "searchlabel") (b) type ambiguities in all situations where the type of a data object is not determined it is represented by a pointer value 'nil'. the type-checking function "comptypes" is defined to return 'true' if either of its parameters has this value. in this way normal type analysis can proceed without a preliminary screening for indeterminate types at every point at which they might arise. *) (* stage 4 : object program generation (a) the generation interface object program generation is imbedded within the syntactic/semantic analyser as a set of procedure calls. these calls, and the types underlying their parameter lists, provide a generation interface which is independent of the precise object code to be generated. between calls the analyser stores and transmits data of these types but without any necessary knowledge of their internal nature. likewise the generative procedures called should operate without any knowledge of the analyser's functioning or of the structures within which it stores the common data. in practice however it is unnecessarily cumbersome in a one pass system to segregate e.g. the analyser's data on types from that which determines and describes their representation in the object program. in these situations the interface allows access of the analyser-built data-structures by the generator procedures. each case where this is so is noted in the following summary of the interface procedures. (1) sequential code generation the code generated, whatever its form, is assumed to be for sequential execution. each code sequence which can be entered other than sequentially is represented at compile time by a record of type 'codesequence'. these records are bound to points in the code by the procedures startcodesequence - for a previously unreference sequence expectcodesequence - for a sequence which may be referenced before it is generated nextiscodesequence - for a sequence previously 'expected' all references(jumps etc.) are generated by the control generating procedures manipulating these codesequence records. (2) representation and storage of data the representation and storage of data within the object program is described by the compiler as follows 1. each typentry carries a field 'representation' of type 'typerepresentation' which describes how such data is to be represented in the object program. 2. each identry for a directly referenceable stored data item (variable, formal parameter or function result) carries a corresponding field of type 'runtimeaddress' which holds the necessary address co-ordinates for the run-time access of that data. 3. each identry for a record field name carries a field 'offset' of type 'fieldoffset' which specifies the field's run-time co-ordinates relative to those of the record as a whole. these compile-time descriptions are generated by two major procedures 4. setrepresentationfor which determines the representation for a given type. for record types it also determines the field offset for each field identifier 5. setaddressfor which determines the run-time address co-ordinates for a variable, formal parameter or function result. since these run-time addresses are assumed to lie within a conventional run-time storage stack, procedure calls 'openstackframe' and 'closestackframe' are used to delimit the static nesting of stack frames for the address allocator. the operations setrepresentationfor and setaddressfor are allowed to operate directly on the analyser.built type and identifier entries. (3) block and program housekeeping the necessary compile- and runtime housekeeping operations associated with the object program are realised as follows 1. the complete generator is initialised by an operation initcodegeneration before any other storage allocation or code generative action takes place 2. the necessary prelude and postlude code for each procedure or program block is realised by the operations enterbody leavebody enterprogram leaveprogram because of the unpredictable nature of the prelude code optimisations possible for procedures and functions the operation enterbody is given access to the analyser's identry for the procedure/function name 3. to enable additional housekeeping, and possible diagnostic actions, appropriate to statement level the operations openstatement closstatement are invoked as the initial and final action for each statement compiled. (4) variables, expressions and assignment the code generation interface for variable access, expression evaluation and assignment assumes a postfix code form (though the generating procedures called may transform this code thereafter). the generating calls represent operations on a hypothetical run-time stack of operand references and values, as follows 1. variable access is realised by the following hypothetical operations stackreference indexedreference fieldreference pnterreference withreference filereference openwith closewith the parameter lists for these reference creating operations enable the complete representation characteristics of the data items referenced to be included in the stack entry. this is true for all stacked operands. 2. expression evaluation (other than program defined function calls) is realised by the following additional stack operations integerfunction negateinteger binaryintegeroperation integercomparison floatinteger realfunction negatereal binaryrealoperation realcomparison negateboolean binarybooleanoperation singletonset rangeset binarysetoperation setcomparison strngcomparison stackconstant the operation integercomparison is assumed to be applicable to all scalar and pointer types other than real. the operation binarybooleanoperation is defined and used in a way which permits either 3. finally assignment is realised by the single hypothetical stack operation - assign. (5) special operations the special operations, provided in the source language as built-in procedures, are realised by the following generative operations fileoperation readoperation writescalars writestring packoperation heapoperation (6) control statements control statement code is realised by the following hypothetical operations jumponfalse labeljump jump opencase closecase openfor closefor to avoid duplication of data structures by the analyser and generator the operation closecase is given access to the case list built by the analyser for each case statement. (7) procedure and function calls calls to program defined procedures and functions are realised by the following operations openparameterlist passactual passformal passreference passvalue closeparameterlist callactual callformal takeresult leaveresult the operations open- and closeparameterlist are invoked even for parameterless calls. *) (* stage 5 : postmortem diagnostics and option handling (a) postmortem diagnostics the compiler is capable of modifying the object program in order to collect data required for postmortem diagnostic output. the diagnostic facilities available are: a dump, a profile, a retrospective trace, and a forward trace. these are actually produced, in source-language form, by a "postmortem program", which runs after execution of the object program. (1) preparation for a dump if a dump is required, the compiler is made to write, to the file 'objectfile', descriptions of all objects relevant to the formatting of the dump, namely: types, enumeration constants, variables (including parameters), fields, and blocks. this is achieved by invoking the following procedures:- filescope - files all locally-defined objects filestdtypes - files those standard types which are not entered in the type table each object is described by a record of type 'objectdescr'. (2) preparation for a profile and/or a trace the compiler inserts a "flow-point" immediately before each source-program statement (whether simple or structured), and also before each while-expression and until-clause. these flow-points divide (the executable parts of) the source program, and the corresponding object program, into sections called "flow-units", in such a way that each object-program flow-unit is a straight-line code sequence. each flow-unit is associated with the flow-point immediately preceeding it. if any form of profile or trace is required, the compiler is, in general, made to generate code at each flow-point to count how often control passes through that flow-point, and to record the address of the flow-point for tracing purposes if required. if only profiling is required (i.e. no tracing), however, the compiler is at liberty to suppress generation of code at any flow-point whose count is guaranteed to be the same as some other flow-point. (e.g. flow-points preceding component statements of a compound statement will always have the same count, provided each statement has a single entry and a single exit.) at each flow-point the syntax analyser invokes the procedure 'flowpoint', which, by invoking a special code-generation procedure 'enterflowunit', generates a call on a suitable monitor routine and plants an in-line counter (in this version.) if any form of profile or trace is required, the compiler is made to write, to the file 'tokenfile', a lexically-analysed representation of the source program, stripped of certain parts, namely label-, constant-, type-, variable-, and formal-parameter-parts, which are irrelevant to flow analysis. here is the syntax of what remains:- -> -> ( )* -> program / -> procedure / function the file will contain three kinds of tokens: (1) "symbol- tokens", corresponding to symbols in the source program; (2) "flow-tokens", corresponding to flow-points; and (3) "break-tokens", which immediately precede procedure-or- function-headings, block-begins, statement-labels, and case- label-lists, and which are used only to facilitate the formatting of the profile and traces. each flow-token contains the object-program address of the corresponding flow-point, plus an indication of whether code was actually generated at that flow-point or not. if so, the flow-token also contains the address of the counter corresponding to the flow-point. tokens are written to the file by the procedures 'preservetoken', 'markflowpoint', and 'markbreak'. each token is described by a record of type 'tokenrec'. (3) initialisation and termination initialisation and termination of the diagnostics handler are performed by the procedures 'initdiagnostics' and 'enddiagnostics' respectively. (b) option handling the compiler is controlled by a set of user options, which is described by the type 'optiontype'. the integer-valued options are stored in the array 'parmvalue'. the boolean-valued options are stored in the arrays 'reqd' and 'locallyreqd', of which the former represents global option values, and the latter represents, where appropriate, option values which may vary from one part of the program to another. default option values are set by the procedure 'initoptions', which takes the default boolean option values from the switch word. this procedure must be called before any other module. *) const globallevel = 1 ; displimit = 20 ; nilvalue = 0 ; (* constants used by the source listing generator *) linemax = 101 ; errmax = 6 ; (* constants used by the lexical analyser *) space = ' ' ; nowordsymbols = 36 ; alfalength = 8 ; charsinword = 4 ; octaldigitmax = 8 ; intsigmax = 7 ; sigmax = 12 ; lastdigmax = 7 ; max10 = 838860 ; (* constant used by the diagnostics handler *) nilserial = 0; (* constants used by the code generator *) (* *** loader interface addresses *** *) (* run-time constants *) rtsignbit = 149 ; floatzero = 150 ; pointfive = 152 ; smone = 154 ; charbitsbase = 155 ; rt4ktable = 159 ; masktable = 168 ; singlelengthmasks = 168 ; doublelengthmasks = 192 ; singlewordbitmasks = 288 ; doublewordbitmasks = 312 ; rtmasktable = 408 ; e2 = 433 ; e3 = 436 ; e4 = 440 ; e6 = 445 ; e8 = 452 ; e12 = 461 ; e24 = 474 ; rtstringmasks = 499 ; tentopower3 = 503 ; okword = 504 ; (* run-time variables *) message = 505 ; square = 507 ; rti = 509 ; rto = 510 ; currframe = 695 ; wordlength = 24; xlocal = 1 ; xmod = 2 ; xref = 3 ; fpa = 8 ; workmax = 39 ; static = 1; nextbase = 3 ; ldx = 000b; adx = 001b; ngx = 002b; sbx = 003b; sto = 010b; ads = 011b; ngs = 012b; sbs = 013b; andx = 020b; orx = 021b; erx = 022b; obey = 023b; ldch = 024b; txu = 026b; txl = 027b; stoz = 033b; dch = 034b; dla = 037b; ands = 030b; ors = 031b; mpy = 040b; mpa = 042b; dvd = 044b; dvs = 046b; bze = 050b; bnz = 052b; bpz = 054b; bng = 56b; call = 070b; exit = 072b; brn = 074b; bfp = 076b; ldn = 100b; adn = 101b; ngn = 102b; sbn = 103b; slc = 110b; src = 112b; smo = 117b; andn = 120b; orn = 121b; ern = 122b; ldct = 124b; move = 126b; float = 130b; fix = 131b; fad = 132b; fsb = 133b; fmpy = 134b; fdvd = 135b; lfp = 136b; lfpz = 136b; sfp = 137b; susty = 160b ; give = 165b ; srl = 112b ; sll = 110b ; slcs = 2200b; slls = 2201b; slas = 2202b; slcd = 2220b; slld = 2221b; slad = 2222b; srcs = 2240b; srls = 2241b; sras = 2242b; srcd = 2260b; srld = 2261b; srad = 2262b; onvclear = 4 ; oncset = 5; oncclear = 6; stackmax = 40 ; idmax = 300 ; codemax = 1000 ; linkbase = 3200 ; dbmlinkmax = 99 ; ebmlinkmax = 199 ; dbmcodebase = 3000 ; ebmcodebase = 3100 ; codelimit32k = 100000b ; type (* types used by the source listing generator *) lineposition = 1..linemax ; sourceline = record linenumber : integer ; line : array [lineposition] of char ; firstline,blankline : boolean ; firstread,firstnonblank,lastnonblank, lastsignificant,charnumber : lineposition ; listinginprogress : boolean ; errinx : 0..errmax ; erroroverflow : boolean ; errlist : array [1..errmax] of record errorposition : lineposition ; errorcode : integer end end ; addrrange = 0..777777b ; (* types used by the lexical analyser *) symboltype = (ident,intconst,realconst,charconst,stringconst,notsy, mulop,addop,relop,leftparent,rightparent, leftbracket,rightbracket, comma,semicolon,period,arrow,colon,becomes, labelsy,constsy,typesy,varsy,funcsy,procsy,setsy, packedsy,arraysy,recordsy,filesy, beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy, gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy, thensy,programsy,valuesy,othersy) ; optype = (mul,rdiv,andop,idiv,imod,plus,minus,orop, ltop,leop,geop,gtop,neop,eqop,inop,notop) ; valuekind = (intvalue,boolvalue,charvalue, realvalue,setvalue,stringvalue ) ; stringp = ^strings ; strings = record word : integer ; nextword : stringp end ; valu = record size : integer ; case kind : valuekind of intvalue : ( ival1,ival2 : integer ) ; boolvalue : ( bval : boolean ) ; charvalue : ( cval : char ) ; realvalue : ( rval : real ) ; setvalue : ( setval : set of 0..47 ) ; stringvalue: ( length : integer ; string : stringp) end ; (* type used both in the analyser and by the diagnostics handler *) serialrange = integer; (* types used by the syntax analyser *) setofsymbols = set of symboltype ; stdprocfuncs = (getp,putp,resetp,rewritep, readp,writep,readlnp,writelnp,pagep, datep,timep,millp,haltp, iclp,newp,disposep,packp,unpackp, absf,sqrf,oddf,succf,predf,ordf,chrf,truncf,roundf, sinf,cosf,expf,lnf,sqrtf,arctanf, addressf,cardf, eoff,eolnf) ; typentry = ^ typerec ; identry = ^ idrec ; formalentry = ^ formrec ; labelentry = ^ labelrec ; scopecopy = ^ scoperec ; idlist = record firstentry,lastentry : identry end ; typeform = (scalars,subranges,pointers,sets,arrays,records, files,variantpart,variant) ; declkind = (standard,declared) ; disprange = 0..displimit ; (* types used in the analyser/generator interface *) interface = (programname,optionsused,startprogram,finishprogram, constbase,stackbase,firstuserlink) ; coderange = 0..codemax ; linkrange = 0..ebmlinkmax ; monitorroutines = (progprelude,progpostlude,prelude2, (* block control *) prelude1,prelude4,prelude3,postlude, dmpprld2,dmpprld1,dmpprld4,dmpprld3,dmppstld, countflow,retroflow,traceflow, packcharacters,unpackcharacters, (* packing *) packnbits,unpacknbits, newop,disposeop, (* heap control *) mathfuncs, (* math functions *) opensnt,openst,openpnt,openpt,putt, (* file control *) putnt,putmark,gett,getnt,getmark, resett,resetnt,rewritet,rewritent, closet,closent, readinteger,readreal, (* input control *) writeinteger,writefloatingpoint, (* output control *) writefixedpoint,writeformattedcharacter, writesequence,writeboolean, cvn1,cn1,cvn3,cn3,ce2,cn2,cvn5,cn5, (* check control *) cn4,cvn7,cn7,cn6,cvp1,cp1,cvp3,cp3, cp2,cvp5,cp5,ce4,cp4,cvp7,cp7,cp6, cve3,ce3,cve5,ce5,cve7,ce7,cve2, cvn2,cvp2,cve4,cvn4,cvp4,cvn6,cvp6, cfpv,cv0,ofer, checkcase,nocheck,caserror ) ; (* case control *) typerepresentation = packed record case size : addrrange of 1 : ( bitsize : 1..24 ; min,max : integer ) ; 2 : ( floatingpoint : boolean ) end ; runtimeaddress = packed record blocklevel : disprange ; relativeaddress : addrrange end ; fieldoffset = packed record wordoffset : addrrange ; case partword : boolean of false : ( wordsize : addrrange ) ; true : ( bitsize : 1..23 ; bitoffset : 0..23 ) end ; codesequence = packed record linked : boolean ; linkindex : linkrange ; case expected : boolean of false : (startaddress : addrrange) ; true : (lastcodereference : coderange) end ; jumps = (alwayslinked,linkedifnecessary,notlinked) ; stackentry = ^stackrec ; stacktop = (topofstack,nexttotop) ; (* --- types used in files implementation --- *) readorwritefile = (readfile,writefile) ; outputkind = (intkind,realkind,charkind,boolkind, stringkind,defaultkind ) ; inputkind = intkind..charkind ; formatkind = (default,floating,fixed) ; (* ------------------------------------------- *) typerec = packed record serial : serialrange ; next : typentry ; representation : typerepresentation ; case form : typeform of scalars : (case scalarkind : declkind of declared : (firstconst : identry)) ; subranges : (rangetype : typentry ; min,max : integer) ; pointers : (domaintype : typentry) ; sets : (packedset : boolean ; basetype : typentry ) ; arrays : (aeltype,inxtype : typentry ; packedarray : boolean) ; records : (packedrecord : boolean ; fieldscope : identry ; nonvarpart : identry ; varpart : typentry) ; files : (packedfile,textfile : boolean ; feltype : typentry) ; variantpart : (tagfield : identry ; firstvariant : typentry) ; variant : (fstvarfield : identry ; nextvariant,subvarpart : typentry ; variantvalue : valu) end ; idclass = (types,consts,vars,field,proc,func,prog) ; setofidclass = set of idclass ; idkind = (actual,formal) ; idrec = record serial : serialrange ; name : alfa ; leftlink,rightlink : identry ; idtype : typentry ; next : identry ; case klass : idclass of consts: ( values : valu ) ; vars: ( varparam : boolean ; varaddress : runtimeaddress ) ; field: ( offset : fieldoffset ) ; proc, func: ( case pfdeckind : declkind of standard: ( pfindex : stdprocfuncs ) ; declared: ( case pfkind : idkind of actual: ( formals : formalentry ; codebody : codesequence ; assignable : boolean ; forward : boolean ; result : runtimeaddress ; formalscope : scopecopy) ; formal: ( faddress : runtimeaddress))) end ; formrec = packed record next : formalentry ; formaltype : typentry ; case klass : idclass of vars : ( formalisvar : boolean ) end ; labelrec = record labelvalue : integer ; nextlabel : labelentry ; defined : boolean ; labelledcode : codesequence end ; casentry = ^ caserec ; caserec = record casevalue : integer ; caselimb : codesequence ; nextcase : casentry end ; scopekind = ( bloc,withst ) ; scoperec = record idscope : identry ; case scope : scopekind of bloc : ( typechain : typentry ; firstlabel : labelentry ; localaddress : addrrange ) ; withst : ( fieldspacked : boolean ; withbase : stackentry ) end ; (* types used by the code generator *) shortaddress = 0..4095 ; bitrange = 0..24 ; stackkind = (reference,formalreference,konstant,result, condition,statementbase) ; condkind = (xcondition,ccondition,multijumpcondition) ; accesskind = (direct,indirect,evaluated) ; register = 0..fpa ; stackrec = record factor : integer ; nextentry : stackentry ; rep : typerepresentation ; mayhaveoverflowed : boolean ; case kind : stackkind of reference : ( wordaddress : record adjustment : integer ; case access : accesskind of direct , indirect : ( offset : addrrange ; staticlevel : disprange ) ; evaluated : ( case inxref : boolean of false : ( disposable : boolean ; tempref : addrrange)) end ; case partwordreference : boolean of false : ( case indexed : boolean of true : ( indices : stackentry )) ; true : ( bitsize : 1..23 ; bitoffset : 0..23 ; case indexedpartword : boolean of false : ( charposition : boolean ) ; true : ( case indexevaluated : boolean of true : ( storedshift : addrrange ) ; false : ( index : stackentry ; lowerbound : integer )))) ; formalreference : ( baseoffset,formaloffset : addrrange ; callisfunction : boolean ; baseinxref : boolean ) ; konstant : ( konstvalue : valu ) ; result : ( case inregister : boolean of false : ( tempresult : addrrange ) ; true : ( reg : register )) ; condition : ( case kindofcondition : condkind of xcondition : ( falsejumpins : bze..bng ; case inconditionregister: boolean of false : ( tempcondition : addrrange ) ; true : ( condregister : register )) ; ccondition : ( falseifset : boolean ) ; multijumpcondition : ( jumpcondition : boolean ; jumpdestination : codesequence )) ; statementbase : ( codewasbeinggenerated : boolean ) end ; modifier = 0..3 ; workrange = 0..workmax ; setofregisters = set of register ; workset = set of workrange ; brins = bze..bng ; shiftcode = 0..3777b ; shiftrange = 0..47 ; ordercode = 0..177b ; directoperand = 0..4095 ; operanddescription = record entry : stackentry ; ispartword, isconstant, iszero, ispowerof2, isinregister : boolean ; cvalue : integer ; log2 : integer end ; checkrange = (positive,negative,posorneg) ; (* types used by the diagnostics handler *) objectdescr = packed record objserial: serialrange; case objclass: idclass of types: (objrepresentation: typerepresentation; case objform: typeform of scalars: (case objscalarkind: declkind of declared: (objfirstconst: serialrange); standard: (stdtype: (intstd,realstd,charstd))); subranges: (objrangetype: serialrange; objmin, objmax: integer); sets: (setispacked: boolean; objbasetype: serialrange); arrays: (arrayispacked: boolean; objaeltype, objinxtype: serialrange); records: (recordispacked: boolean; objnonvarpart, objvarpart: serialrange); files: (fileispacked, fileistext: boolean; objfeltype: serialrange); variantpart: (objtagfield, objfstvariant: serialrange); variant: (objsubnonvarpart, objsubvarpart, objnextvariant: serialrange; objvariantvalue: integer)); consts: (constname: alfa; constvalue: integer; nextconst: serialrange); vars: (varname: alfa; vartype: serialrange; isvarparam: boolean; localaddress: addrrange; nextlocalvar: serialrange); field: (fieldtype: serialrange; objoffset: fieldoffset; nextfield: serialrange); prog,proc,func: (* the serial no. of this object-table entry serves to identify the corresponding block in the object program. *) (blockname: alfa; firstlocalvar: serialrange) end; kindoftoken = (symboltoken,flowtoken,breaktoken) ; kindofbreak = (blockhead,blockbody,statlabel,caselabellist) ; counteraddrrange = addrrange; tokenrec = packed record case tokenkind: kindoftoken of symboltoken: (case tokensymbol: symboltype of ident: (tokenspelling: alfa); intconst: (tokenintval: integer); realconst: (tokenrealval: real); charconst: (tokencharval: char); tosy, mulop, addop, relop: (tokenop: optype) ); flowtoken: (flowaddress: addrrange; case counted: boolean of true: (countaddress: counteraddrrange) ); breaktoken: (breakaddress: addrrange; breakkind: kindofbreak) end; (* type corresponding to programmer options *) optiontype = (checks,cdm,ebm, dump,profile,retro,trace,listing, margin,retromax,tracemin,tracemax, newpage,title,other); booloptiontype = checks..listing ; intoptiontype = margin..tracemax ; setofoptions = set of booloptiontype ; var (* global variables used by the source listing generator *) ch: char ; currentaddress,lineaddress : addrrange ; addresstobeprinted,stilltobeprinted: boolean ; source : sourceline ; errorcount : integer ; startmill,endmill : integer ; datestring, timestring : alfa ; atheadofsource : boolean ; (* global variables used by the lexical analyser *) symbol : symboltype ; operator : optype ; constant : valu ; spelling : alfa ; (* tables used by the lexical analyser *) onecharsymbols : array[char] of record symbolvalue : symboltype ; opvalue : optype end ; wordsymbols : array[ 1..nowordsymbols] of record spelling : alfa ; symbolvalue : symboltype ; opvalue : optype end ; lastoflength : array[0..alfalength] of 0..nowordsymbols ; (* global variables used by the syntax analyser *) blankline : boolean ; blockbegsys,typebegsys,constbegsys,simptypebegsys,typedels, statbegsys,facbegsys,selectsymbols,parambegsy : setofsymbols ; (* table used by syntax analyser *) missingcodefor : array[symboltype] of integer ; stdpfnames : array[stdprocfuncs] of alfa ; inttype,realtype,booltype,chartype,codeftype, alfatype,texttype,niltype,unisettype,layouttype : typentry ; exptype,vartype : typentry ; inputfile,outputfile : identry ; emptyset : valu ; defaultentry : array[idclass] of identry ; top,level,levelfound : disprange ; display : array [disprange] of scoperec ; spaces : alfa ; firstconstant : stringp ; progname : integer ; unitno : 0..23 ; checksrequested,edmrequested,ebmrequested : boolean ; libcodesequences : array[monitorroutines] of codesequence ; libaddresses : array[monitorroutines] of addrrange ; messagerepresentation, realrepresentation,booleanrepresentation, charrepresentation,integerrepresentation, pointerrepresentation,defaultrepresentation, layoutrepresentation : typerepresentation ; defaultaddress : runtimeaddress ; (* variables & tables used by the code generator *) proglinks : array[startprogram..finishprogram] of codesequence ; thoselocked : setofregisters ; topstackentry : stackentry ; thosefree : setofregisters ; entryusing : array[register] of stackentry ; workspace : workset ; codefile :file of integer ; firstworkaddress, lastlocaladdress : addrrange ; nextfilelocation : addrrange ; charaddressingacceptable : boolean ; addressed : record n : shortaddress ; m : modifier ; size : addrrange ; case ispartword : boolean of true : ( bitsize : bitrange ; case ischarposition : boolean of false : ( shiftn : bitrange ; shiftm : modifier ) ) end ; loaded : record reg : register ; size : 1..2 end ; overflowoccurred,posoverflow : boolean ; protectedformals : addrrange ; nextins : coderange ; nomodeoverflow : boolean ; nocodeoverflow : boolean ; linktable : array[linkrange] of integer ; nextlink : linkrange ; nolinkoverflow : boolean ; linklimit : linkrange ; firstobjectlocation : addrrange ; bitmax : 1..24 ; addressmax : integer ; prelude : array[boolean,boolean,boolean] of monitorroutines ; codeistobegenerated : boolean ; powerof2 : boolean ; logbase2 : 0..24 ; codebase : addrrange ; forframesize : addrrange ; firstformaloffset : addrrange ; initaddress : addrrange ; xchoice : array[1..4] of register ; xxchoice: array[1..3] of register ; reverseof : array[brins] of brins ; brncode : integer ; rtshifts : array[shiftrange] of bitrange ; fjumpfor : array[ltop..eqop] of bze..bng ; fpinsfor : array[mul..minus] of float..fdvd ; (* --- variables used in code generation for files --- *) openroutine : array [boolean,boolean] of monitorroutines ; closeroutine : array [boolean] of monitorroutines ; fileops : array [getp..rewritep,boolean] of monitorroutines ; readroutine : array [intkind..realkind] of monitorroutines ; readreg : array [inputkind] of register ; readrep : array [inputkind] of typerepresentation ; rtaddressfor : array [readorwritefile] of addrrange ; offsetfor : array [eoff..eolnf] of addrrange ; writeroutine : array [intkind..boolkind] of monitorroutines ; defaultwidth : array [intkind..boolkind] of 1..120 ; linefeed, pagethrow : valu ; (* ----------------------------------------------------*) checkroutine : array[checkrange, (* +ve,-ve,or either *) boolean, (* overflow test necessary *) boolean, (* max test necessary *) boolean, (* min test necessary *) boolean (* sign test necessary *) ] of monitorroutines ; givecode : array [ datep..millp ] of 0..12 ; code : array[coderange] of integer ; (* global variables used by the diagnostics handler *) nextserial : serialrange; objectfile : file of objectdescr; tokenfile : file of tokenrec; tokenstobesaved : boolean; mustcountnextflowunit : boolean; gotospossible : boolean; (* global variables corresponding to programmer options *) optionschosen : setofoptions ; reqd, locallyreqd : array [booloptiontype] of boolean; parmvalue : array [intoptiontype] of integer; countreqd : boolean; optionname : array [optiontype] of alfa; value (* initialisation of tables used by the lexical analyser *) onecharsymbols = ( othersy,notop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, colon,notop, semicolon,notop, relop,ltop, relop,eqop, relop,gtop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, relop,neop, othersy,notop, othersy,notop, othersy,notop, othersy,notop, leftparent,notop, rightparent,notop, mulop,mul, addop,plus, comma,notop, addop,minus, period,notop, mulop,rdiv, arrow,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, ident,notop, leftbracket,notop, othersy,notop, rightbracket,notop, arrow,notop, othersy,notop ) ; wordsymbols = ('if ',ifsy,notop, 'do ',dosy,notop, 'of ',ofsy,notop, 'to ',tosy,plus, 'in ',relop,inop, 'or ',addop,orop, 'end ',endsy,notop, 'for ',forsy,notop, 'var ',varsy,notop, 'div ',mulop,idiv, 'mod ',mulop,imod, 'set ',setsy,notop, 'and ',mulop,andop, 'not ',notsy,neop, 'then ',thensy,notop, 'else ',elsesy,notop, 'with ',withsy,notop, 'goto ',gotosy,notop, 'case ',casesy,notop, 'type ',typesy,notop, 'file ',filesy,notop, 'begin ',beginsy,notop, 'until ',untilsy,notop, 'value ',valuesy,notop, 'while ',whilesy,notop, 'array ',arraysy,notop, 'const ',constsy,notop, 'label ',labelsy,notop, 'repeat ',repeatsy,notop, 'record ',recordsy,notop, 'downto ',tosy,minus, 'packed ',packedsy,notop, 'program ',programsy,notop, 'function',funcsy,notop, 'procedur',procsy,notop ) ; lastoflength = (0,0,6,14,21,28,32,33,35) ; (* initialisation of tables used by the syntax analyser *) missingcodefor = (2,0,0,0,0,0, 0,0,0,9,4, 11,12, 20,14,0,0,5,0, 0,0,0,0,0,0,0, 0,0,0,0, 0,0,0,0,0,0,0, 0,13,0,0,8,54,0,0, 52,0,0) ; stdpfnames = ('get ','put ','reset ','rewrite ', 'read ','write ','readln ','writeln ', 'page ', 'date ','time ','mill ','halt ', 'icl ', 'new ','dispose ','pack ','unpack ', 'abs ','sqr ','odd ','succ ', 'pred ','ord ','chr ','trunc ', 'round ', 'sin ','cos ','exp ','ln ', 'sqrt ','arctan ', 'addresso','card ', 'eof ','eoln ' ) ; emptyset = (2,setvalue,0,0,0,0) ; unitno = 0 ; libaddresses = ( 933,1006,1103,1104,1113,1114,1122,1125,1126, 1141,1142,1156,1160,1164,1176,1203,1211,1219, 1235,1252,1294,1346,1361,1364,1370,1373,1566, 1580,1595,1772,1789,1963,1993,1995,2123,2125, 2177,2191,2290,2305,2414,2425,2615,2679,2684, 2732,2794,2795,2797,2798,2799,2799,2802,2803, 2804,2807,2808,2809,2814,2815,2817,2818,2819, 2822,2823,2824,2824,2827,2828,2829,2834,2835, 2837,2838,2840,2841,2845,2845,2845,2849,2849, 2849,2853,2853,2859,2862,2864,2868,2875,2879 ); (* initialisation of tables used by the code generator *) prelude = ( prelude1, (* prelude of non-global proc/func *) prelude2, (* prelude of parameterless non-global proc*) prelude3, (* prelude of global proc/func *) prelude4, (* prelude of parameterless global proc *) dmpprld1, (* as above, *) dmpprld2, (* but interfacing to *) dmpprld3, (* postmortem dump *) dmpprld4) ; (* *) xchoice = (6,4,5,7) ; xxchoice = (6,4,5) ; reverseof = (bnz,0,bze,0,bng,0,bpz) ; brncode = 03600000b ; rtshifts = ( 0 , 0 , e2 , e3 , e4 , 0 , e6 , 0 , e8 , 0 , 0 , 0 , e12 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , e24 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ; fjumpfor = (bpz,bng,bng,bpz,bze,bnz) ; fpinsfor = (fmpy,fdvd,0,0,0,fad,fsb) ; openroutine = ( opensnt,openpnt,openst,openpt) ; closeroutine = ( closent,closet) ; fileops = ( getnt,gett,putnt,putt, resetnt,resett,rewritent,rewritet) ; readroutine = ( readinteger,readreal ) ; readreg = ( 6,fpa,6 ) ; rtaddressfor = ( rti,rto) ; offsetfor = (1,2) ; writeroutine = ( writeinteger,writefloatingpoint, writeformattedchar,writeboolean) ; defaultwidth = ( 8,16,1,5) ; linefeed = (1,charvalue,' ') ; pagethrow= (1,charvalue,'!') ; checkroutine = (nocheck,cp1,cp2,cp3,cp4,cp5,cp6,cp7, cv0,cvp1,cvp2,cvp3,cvp4,cvp5,cvp6,cvp7, nocheck,cn1,cn2,cn3,cn4,cn5,cn6,cn7, cv0,cvn1,cvn2,cvn3,cvn4,cvn5,cvn6,cvn7, nocheck,nocheck,ce2,ce3,ce4,ce5,nocheck,ce7, cv0,nocheck,cve2,cve3,cve4,cve5,nocheck,cve7) ; givecode = ( 1,2,10) ; (* initialisation of programmer option names *) optionname = ('checks ', 'cdm ', 'ebm ', 'dump ', 'profile ', 'retro ', 'trace ', 'listing ', 'margin ', 'retromax', 'tracemin', 'tracemax', 'newpage ', 'title ', ' '); (* ---------------- the diagnostics handler ----------------------- *) (* ---- token file handling ---- *) procedure inittokenfile; begin rewrite(tokenfile); tokenstobesaved := false end (* inittokenfile *) ; procedure endtokenfile; begin if countreqd and tokenstobesaved then put(tokenfile) (* the last token *) end (* endtokenfile *) ; procedure markflowpoint (flowloc: addrrange; willbecounted: boolean; countloc: counteraddrrange) ; var token: tokenrec; begin if countreqd then begin token := tokenfile^; with tokenfile^ do begin tokenkind := flowtoken; flowaddress := flowloc; counted := willbecounted; if willbecounted then countaddress := countloc; end; put(tokenfile); tokenfile^ := token end end (* markflowpoint *) ; procedure markbreak (kind: kindofbreak) ; var token: tokenrec; begin if countreqd then begin token := tokenfile^; with tokenfile^ do begin tokenkind := breaktoken; breakaddress := currentaddress; breakkind := kind; end; put(tokenfile); tokenfile^ := token end end (* marklabel *) ; procedure preservetoken; begin if countreqd then begin if tokenstobesaved then put(tokenfile); (* the previous token, if any *) with tokenfile^ do begin tokenkind := symboltoken; tokensymbol := symbol; case symbol of ident: tokenspelling := spelling; intconst: tokenintval := constant.ival1; realconst: tokenrealval := constant.rval; charconst: tokencharval := constant.cval; tosy, mulop, addop, relop: tokenop := operator; stringconst, notsy,leftparent,rightparent,leftbracket,rightbracket, comma,semicolon,period,arrow,colon,becomes, labelsy,constsy,typesy,varsy,funcsy,procsy,setsy, packedsy,arraysy,recordsy,filesy, beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy, gotosy,endsy,elsesy,untilsy,ofsy,dosy, thensy,programsy,valuesy,othersy: end (* case *) end (* with *) end end (* preservetoken *) ; procedure startsavingtokens ; begin tokenstobesaved := true end (* startsavingtokens *) ; procedure stopsavingtokens ; begin tokenstobesaved := false end (* stopsavingtokens *) ; (* ---- object file handling ---- *) procedure initobjectfile; begin rewrite(objectfile); nextserial := nilserial+1; end (* initobjectfile *) ; procedure putobject (var object: objectdescr); begin objectfile^ := object; put(objectfile) end (* putobject *) ; procedure iserialise (id: identry); begin if id<>nil then begin id^.serial := nextserial; nextserial := nextserial+1 end end (* iserialise *) ; procedure tserialise (typ: typentry); begin if typ<>nil then begin typ^.serial := nextserial; nextserial := nextserial+1 end end (* tserialise *) ; function idserialof (id: identry): serialrange; begin if id=nil then idserialof := nilserial else idserialof := id^.serial end (* idserialof *) ; function typeserialof (typ: typentry): serialrange; begin if typ=nil then typeserialof := nilserial else typeserialof := typ^.serial end (* typeserialof *) ; function internalvalue (generalisedvalue : valu) : integer; begin with generalisedvalue do case kind of intvalue: internalvalue := ival1; boolvalue: internalvalue := ord(bval); charvalue: internalvalue := ord(cval) end end (* internalvalue *) ; procedure fileid (id, nextid: identry); var object: objectdescr; serialofnextid: serialrange; begin if id<>nil then begin serialofnextid := idserialof(nextid); with id^, object do begin objserial := serial; objclass := klass; case klass of consts: begin constname := name; constvalue := internalvalue(values); nextconst := serialofnextid end; vars: begin varname := name; vartype := typeserialof(idtype); isvarparam := varparam; localaddress := varaddress.relativeaddress; nextlocalvar := serialofnextid end; field: begin fieldtype := typeserialof(idtype); objoffset := offset; nextfield := serialofnextid end; prog,proc,func: begin blockname := name; firstlocalvar := serialofnextid end end (* case *) end (* with *) ; putobject(object) end end (* fileid *) ; procedure filetype (typ: typentry); var object: objectdescr; procedure fileidlist (firstid: identry); var thisid, nextid: identry; begin thisid := firstid; while thisid<>nil do begin nextid := thisid^.next; fileid(thisid,nextid); thisid := nextid end end (* fileidlist *) ; begin (* filetype *) if typ<>nil then begin with typ^, object do begin objserial := serial; objclass := types; objrepresentation := representation; objform := form; case form of scalars: begin objscalarkind := scalarkind; case scalarkind of standard: if typ=inttype then stdtype := intstd else if typ=realtype then stdtype := realstd else if typ=chartype then stdtype := charstd; declared: begin fileidlist(firstconst); objfirstconst := idserialof(firstconst) end end (* case scalarkind *) ; end; subranges: begin objrangetype := typeserialof(rangetype); objmin := min; objmax := max end; pointers: ; sets: begin setispacked := packedset; objbasetype := typeserialof(basetype) end; arrays: begin arrayispacked := packedarray; objaeltype := typeserialof(aeltype); objinxtype := typeserialof(inxtype) end; records: begin fileidlist(nonvarpart); recordispacked := packedrecord; objnonvarpart := idserialof(nonvarpart); objvarpart := typeserialof(varpart) end; files: begin fileispacked := packedfile; fileistext := textfile; objfeltype := typeserialof(feltype) end; variantpart: begin fileid(tagfield,nil); objtagfield := idserialof(tagfield); objfstvariant := typeserialof(firstvariant) end; variant: begin fileidlist(fstvarfield); objsubnonvarpart := idserialof(fstvarfield); objsubvarpart := typeserialof(subvarpart); objnextvariant := typeserialof(nextvariant); objvariantvalue := internalvalue(variantvalue) end end (* case form *) end (* with *) ; putobject(object) end end (* filetype *) ; procedure filescope (blockid: identry) ; var previousvar: identry; thistype: typentry; procedure filelocalvars (entry: identry) ; begin if entry<>nil then with entry^ do begin filelocalvars(rightlink); if klass=vars then begin fileid(entry,previousvar); previousvar := entry end; filelocalvars(leftlink); end end (* filelocalvars *) ; begin (* filescope *) if reqd[dump] then with display[level] do begin (* file local variables, including formal parameters *) previousvar := nil; filelocalvars(idscope); (* file block *) fileid(blockid,previousvar); (* file types *) thistype := typechain; while thistype<>nil do begin filetype(thistype); thistype := thistype^.next end; end end (* filescope *) ; procedure filestdtypes ; (* ... which have not yet been serialised *) begin if reqd[dump] then begin tserialise(inttype); filetype(inttype); tserialise(realtype); filetype(realtype); tserialise(chartype); filetype(chartype); (* serialise boolean constants *) with booltype^ do begin iserialise(firstconst); iserialise(firstconst^.next) end; tserialise(booltype); filetype(booltype); tserialise(texttype); filetype(texttype); tserialise(alfatype^.inxtype); filetype(alfatype^.inxtype); tserialise(alfatype); filetype(alfatype); end end (* filestdtypes *) ; (* ---- flow analysis ---- *) procedure initflowanalysisofbody ; var d : disprange; begin if countreqd then begin gotospossible := false; for d := globallevel to level do gotospossible := gotospossible or (display[d].firstlabel<>nil); mustcountnextflowunit := true end end (* initflowanalysisofbody *) ; procedure enterflowunit (flowroutine : monitorroutines; var flowloc : addrrange; var countloc : counteraddrrange) ; forward ; (* in the code generator *) procedure flowpoint ; var flowroutine : monitorroutines; willbecounted : boolean; flowloc : addrrange; countloc : counteraddrrange; begin if countreqd then begin willbecounted := true; if locallyreqd[trace] then flowroutine := traceflow else if reqd[retro] then flowroutine := retroflow else if reqd[profile] and mustcountnextflowunit then flowroutine := countflow else willbecounted := false; if willbecounted then begin enterflowunit(flowroutine,flowloc,countloc); markflowpoint(flowloc,true,countloc) end else markflowpoint(currentaddress,false,0); mustcountnextflowunit := gotospossible end end (* flowpoint *) ; procedure countnextflowunit ; begin mustcountnextflowunit := true end (* countnextflowunit *) ; (* ------------------------------ *) procedure initdiagnostics ; begin inittokenfile; initobjectfile; end (* initdiagnostics *) ; procedure enddiagnostics ; begin endtokenfile; end (* enddiagnostics *) ; (* ---------------- programmer options ---------------- *) procedure initoptions ; var optionstobechanged : set of booloptiontype ; option : booloptiontype ; begin (* fetch the switch word *) icl(ldx,5,30) ; icl(sto,5,optionstobechanged); optionschosen := ([checks,dump,profile,listing]-optionstobechanged) +(optionstobechanged-[checks,dump,profile,listing]) ; for option := checks to listing do reqd[option] := (option in [checks,dump,profile,listing]) <> (option in optionstobechanged); locallyreqd[checks] := reqd[checks]; locallyreqd[trace] := reqd[trace]; locallyreqd[listing] := reqd[listing]; countreqd := reqd[profile] or reqd[retro] or reqd[trace]; (*memo*) parmvalue[margin] := 80; parmvalue[retromax] := 50; parmvalue[tracemin] := 1; parmvalue[tracemax] := 2; end (* initoptions *) ; procedure setbooleanoption (option : booloptiontype; optionvalue, locally : boolean) ; begin if locally then locallyreqd[option] := optionvalue and reqd[option] else begin if optionvalue then optionschosen := optionschosen+ [option] else optionschosen := optionschosen - [option] ; reqd[option] := optionvalue; if option in [profile,retro,trace] then countreqd := reqd[profile] or reqd[retro] or reqd[trace]; if option in [checks,trace,listing] then locallyreqd[option] := reqd[option] end end (* setbooleanoption *) ; procedure setintegeroption (option : intoptiontype; optionvalue : integer) ; begin parmvalue[option] := optionvalue end (* setintegeroption *) ; procedure printoptions ; var option : booloptiontype; begin write('object code options = '); if reqd[cdm] then write('compact') else write('extended'); write(' data mode, '); if reqd[ebm] then write('extended') else write('direct'); write(' branch mode, with'); if not reqd[checks] then write('out'); writeln(' checks.'); writeln; write('postmortem options = '); if reqd[dump] then write(' dump ') ; if reqd[profile] then write(' profile ') ; if reqd[retro] then write(' retro ( ',parmvalue[retromax]:2,' ) ') ; if reqd[trace] then write(' trace ( ',parmvalue[tracemin]:2, ' , ',parmvalue[tracemax]:2,' ) ') ; writeln end (* printoptions *) ; (* ---------------- the source listing generator ------------------ *) procedure analysedirective ; forward ; procedure readnextline ; var i : lineposition ; begin with source do begin i := 1 ; firstread := i ; blankline := true ; if not firstline then get(input) ; repeat line[i] := input^ ; if line[i] <> ' ' then begin if blankline then begin firstnonblank := i ; blankline := false end ; lastnonblank := i end ; get(input) ; i := i+1 until eoln(input) ; firstline := false end end (* readnextline *) ; procedure listthisline ; var i : lineposition; procedure listerrors ; var k : 1..errmax ; nextprintposition,lastarrowposition : lineposition ; procedure starterrorline ; begin writeln ; write('***** ***** ') ; nextprintposition := source.firstread end (* starterrorline *) ; procedure printarrowat ( position : lineposition ) ; begin if position < nextprintposition then starterrorline ; write('^':position-nextprintposition+1) ; lastarrowposition := position ; nextprintposition := position+1 end (* printarrowat *) ; procedure printcode ( code : integer ) ; var width : 1..3 ; begin if code < 10 then width := 1 else if code < 100 then width := 2 else width := 3 ; write(code:width) ; nextprintposition := nextprintposition+width end (* printcode *) ; procedure printcomma ; begin write(',') ; nextprintposition := nextprintposition+1 end (* printcomma *) ; begin with source do begin errorcount := errorcount + errinx; writeln ; starterrorline ; with errlist[1] do begin printarrowat(errorposition) ; printcode(errorcode) end ; for k := 2 to errinx do with errlist[k] do begin if errorposition = lastarrowposition then printcomma else printarrowat(errorposition) ; printcode(errorcode) end ; if erroroverflow then begin starterrorline ; write('further errors suppressed') end ; writeln ; errinx := 0 ; erroroverflow := false end end (* listerrors *) ; begin with source do if locallyreqd[listing] or not blankline and (errinx > 0) then begin write(linenumber:5,' ') ; if not blankline then begin if addresstobeprinted then begin write(lineaddress:5) ; lineaddress := currentaddress ; addresstobeprinted := stilltobeprinted end else write(' ') ; write(' ':2+firstnonblank-firstread) ; for i := firstnonblank to lastnonblank do write(line[i]) ; if errinx > 0 then listerrors end ; writeln end ; end (* listthisline *) ; procedure firstchofnextline ; begin with source do begin readnextline ; while blankline or (firstnonblank>=firstread+parmvalue[margin]) or (line[firstread] = '%') do begin if not blankline and (line[firstread]='%') then begin lastsignificant := lastnonblank ; charnumber := firstread+1 ; ch := line[charnumber] ; analysedirective end ; listthisline ; linenumber := linenumber+1 ; readnextline end ; if lastnonblank >= firstread+parmvalue[margin] then lastsignificant := firstread+parmvalue[margin]-1 else lastsignificant := lastnonblank ; charnumber := firstnonblank ; ch := line[charnumber] end end (* firstchofnextline *) ; procedure nextch ; begin with source do if charnumber >= lastsignificant then if charnumber = lastsignificant then begin charnumber := charnumber+1 ; ch := ' ' ; end else begin listthisline ; linenumber := linenumber+1 ; firstchofnextline end else begin charnumber := charnumber+1 ; ch := line[charnumber] end end (* nextch *) ; procedure error ( code : integer); begin codeistobegenerated := false; with source do if errinx = errmax then erroroverflow := true else begin errinx := errinx+1 ; with errlist[errinx] do begin errorcode := code ; errorposition := charnumber; end ; end end (* error *) ; procedure listaddresses ; begin lineaddress := currentaddress ; addresstobeprinted := true ; stilltobeprinted := true end (* listaddresses *) ; procedure listnoaddresses ; begin stilltobeprinted := false end (* listnoaddresses *) ; procedure initlisting ; var datestring,timestring : alfa ; begin (* initlisting *) date(datestring) ; time(timestring) ; writeln ; mill(startmill) ; writeln( 'pascal compiler mk2-issue 3 on ',datestring, ' at ',timestring ) ; writeln ; writeln ; addresstobeprinted := false; stilltobeprinted := false; errorcount := 0 ; with source do begin listinginprogress := true ; linenumber := 0 ; errinx := 0 ; erroroverflow := false ; firstline := true ; atheadofsource := true ; firstchofnextline ; atheadofsource := false end end (* initlisting *) ; procedure endlisting ; begin listthisline ; writeln ; writeln ; write('compilation complete : ') ; if errorcount = 0 then write(' no') else write(errorcount:7) ; writeln(' errors reported') ; writeln ; mill(endmill) ; write('compilation time = ',endmill-startmill,' milliseconds') ; writeln ; writeln ; write('source program = ',source.linenumber+1,' lines') ; writeln ; writeln ; writeln ; if errorcount = 0 then begin write('object program = ',currentaddress-1,' words') ; writeln ; writeln ; printoptions end ; end (* endlisting *) ; (* ------------------- the lexical analyser ----------------------- *) procedure readsymbol ; (* this procedure reads the next basic symbol of the source program and returns its description in the global variables symbol, operator, spelling and constant *) label 1, 2, 3, 4 ; var k : 0..alfalength ; packediden : alfa ; lastwasq,stringend : boolean ; i,n : 0..charsinword ; lgth : integer ; lastp,tailp,headp : stringp ; lich : packed array [1..charsinword] of char ; l : 1..nowordsymbols ; stillinteger,negative : boolean ; digit : array [1..sigmax] of 0..9 ; significant,scale,exponent,lival : integer ; factor,scalefactor,lrval : real ; siglimit : 0..sigmax ; j : 1..sigmax ; octalmap : record case octal : boolean of true : (octalword : packed array[1..8] of 0..7) ; false : (integerword : integer) end ; begin (* readsymbol *) (* read character by character until next significant character *) 1: while ch = ' ' do nextch ; blankline := false ; case ch of 'a','b','c','d','e','f','g','h','i', 'j','k','l','m','n','o','p','q','r', 's','t','u','v','w','x','y','z' : (* analysis of an identifier *) begin k := 0 ; packediden := ' ' ; repeat if k < alfalength then begin k := k+1 ; packediden[k] := ch end ; nextch until (ch > '9') and ((ch < 'a') or (ch > 'z')) ; for l := lastoflength[k-1]+1 to lastoflength[k] do with wordsymbols[l] do if spelling=packediden then begin symbol := symbolvalue ; operator := opvalue ; goto 2 end ; symbol := ident ; operator := notop ; spelling := packediden ; 2: end ; '0','1','2','3','4', '5','6','7','8','9': (* analysis of a constant *) begin stillinteger := true ; significant := 0 ; scale := 0 ; (* ignore leading zeroes *) while ch='0' do nextch ; while ch<='9' do begin significant:=significant+1 ; if significant <= sigmax then digit[significant] := ord(ch) ; nextch end ; if ch='b' then (* octal constant *) begin nextch ; if significant > octaldigitmax then error(203) else with octalmap do begin integerword := 0 ; for j := 1 to significant do if digit[j] > 7 then begin error(204) ; goto 3 end else octalword[8-significant+j] := digit[j] ; lival := integerword ; 3: end end else (* decimal constant *) begin if ch='.' then begin nextch ; if ch='.' (* if '.' is followed by a second '.' then reset ch to ':' and leave for next call of insymbol *) then ch := ':' else begin stillinteger := false ; if ch>'9' then error(201) else repeat if (ch#'0') or (significant#0) then begin significant := significant+1 ; if significant <= sigmax then digit[significant] := ord(ch) end ; scale := scale+1 ; nextch until ch>'9' end end ; if ch='e' then (* read exponent part *) begin stillinteger := false ; nextch ; negative := (ch='-') ; if negative or (ch='+') then nextch ; exponent := 0 ; if ch>'9' then error(201) else repeat exponent := 10*exponent+ord(ch) ; nextch until ch>'9' ; if negative then scale := scale+exponent else scale := scale-exponent end ; if stillinteger then (* integer constant *) if significant > intsigmax then stillinteger := false else begin lival := 0 ; for j := 1 to significant do if (lival>max10) or (lival=max10) and (digit[j]>lastdigmax) then begin stillinteger := false ; goto 4 end else lival := 10*lival+digit[j] ; 4: end end ; if stillinteger then (* set up description for integer or octal constant *) begin with constant do begin size := 1 ; kind := intvalue ; ival1 := lival end ; symbol := intconst end else (* set up description for decimal constant *) begin lrval := 0.0 ; if significant > sigmax then begin siglimit := sigmax ; scale := scale-(significant-sigmax) end else siglimit := significant ; for j := 1 to siglimit do lrval := 10.0*lrval+digit[j] ; if scale # 0 then begin negative := scale<0 ; factor := 10 ; scalefactor := 1 ; repeat if odd(scale) then scalefactor := scalefactor*factor ; factor := sqr(factor) ; scale := scale div 2 until scale=0 ; if negative then lrval := lrval*scalefactor else lrval := lrval/scalefactor end ; with constant do begin size := 2 ; kind := realvalue ; rval := lrval end ; symbol := realconst end ; operator := notop end ; '''' : (* analysis of a character string *) begin operator := notop ; lastwasq := false ; stringend := false ; lastp := nil ; lgth := 0 ; i := 0 ; nextch ; repeat if (ch # '''') or lastwasq then begin if i = charsinword then begin new(tailp) ; tailp^.word := ord(lich) ; if lastp = nil then headp := tailp else lastp^.nextword := tailp ; lastp := tailp ; i := 0 ; end ; i := i+1 ; lgth := lgth+1 ; lastwasq := false ; lich[i] := ch ; nextch end else begin lastwasq := true ; nextch ; stringend := ch # '''' end until stringend ; with constant do if lgth<=1 then begin if lgth = 0 then error(205) ; size := 1 ; kind := charvalue ; cval := lich[1] ; symbol := charconst end else begin for n := i+1 to charsinword do lich[n] := '0' ; new(tailp) ; with tailp^ do begin word := ord(lich) ; nextword := nil end ; if lastp = nil then headp := tailp else lastp^.nextword := tailp ; if(lgth mod charsinword)=0 then size := lgth div charsinword else size := lgth div charsinword + 1 ; kind := stringvalue ; length := lgth ; string := headp ; symbol := stringconst end end ; (* analysis of an operator/delimiter *) (* 2-character operator/delimiter *) ':' : begin operator := notop ; nextch ; if ch = '=' then begin symbol := becomes ; nextch end else symbol := colon end ; '.' : begin operator := notop ; nextch ; if ch = '.' then begin symbol := colon ; nextch end else symbol := period end ; '(' : begin nextch ; if ch # '*' then begin symbol := leftparent ; operator := notop end else begin nextch ; repeat while ch # '*' do nextch ; nextch until ch = ')' ; nextch ; goto 1 end end ; '<' : begin nextch ; symbol := relop ; if ch='=' then begin operator := leop ; nextch end else if ch='>' then begin operator := neop ; nextch end else operator := ltop end ; '>' : begin nextch ; symbol := relop ; if ch='=' then begin operator := geop ; nextch end else operator := gtop end ; '*','+','-','#','=','/', ')', '[',']',',',';','^','$','&','@', '$','_','%','?','"','!': (* 1-character operator/delimiter *) begin with onecharsymbols[ch] do begin symbol := symbolvalue ; operator := opvalue end ; nextch end ; end (* case *) end (* readsymbol *) ; (* --- the following procedure & function are placed in this position in the code as they are used by both the code generator and the analyser *) procedure getbounds ( boundtype : typentry ; var boundmin,boundmax : integer ) ; var nextconst : identry ; begin (* getbounds *) with boundtype^ do if form = subranges then begin boundmin := min ; boundmax := max end else begin boundmin := 0 ; if boundtype = chartype then boundmax := 63 else if boundtype^.firstconst # nil then begin nextconst := boundtype^.firstconst ; repeat boundmax := nextconst^.values.ival1 ; nextconst := nextconst^.next until nextconst = nil end else boundmax := 0 end end (* getbounds *) ; function cardinality ( thistype : typentry ) : integer ; var max,min : integer ; begin (* cardinality *) getbounds(thistype,min,max) ; cardinality := max - min + 1 end (* cardinality *) ; (*--------------------- the code generator ------------------ *) procedure expectlinksequence(entry : interface) ; begin with proglinks[entry] do begin expected := true ; lastcodereference := 0 ; linked := true ; linkindex := ord(entry) ; end end (* expect link sequence *) ; procedure filecode (location : addrrange ; contents : integer) ; procedure fileaway (contents : integer) ; begin codefile^ := contents ; put(codefile) ; nextfilelocation := nextfilelocation + 1 ; end (* file away *) ; begin if location < nextfilelocation then error(251) else begin while nextfilelocation < location do fileaway(0) ; fileaway(contents) ; end end (* file code *) ; procedure initcodegeneration ; var index,linksize : 0..ebmlinkmax ; libroutine : monitorroutines ; begin if reqd[ebm] then begin ebmrequested := true ; edmrequested := true ; linklimit := ebmlinkmax ; bitmax := 18 ; addressmax := 777777b ; end else begin ebmrequested := false ; linklimit := dbmlinkmax ; if reqd[cdm] then begin edmrequested := false ; bitmax := 15 ; addressmax := 77777b ; end else begin edmrequested := true ; bitmax := 18 ; addressmax := 777777b ; end ; end ; if reqd[dump] then firstformaloffset := 5 else firstformaloffset := 4; with defaultaddress do begin blocklevel := globallevel ; relativeaddress := 0 end ; with realrepresentation do begin size := 2 ; floatingpoint := true end ; with booleanrepresentation do begin size := 1 ; bitsize := 1 ; min := 0 ; max := 1 end ; with charrepresentation do begin size := 1 ; bitsize := 6 ; min := 0 ; max := 63 end ; with integerrepresentation do begin size := 1 ; bitsize :=24 ; min := -maxint ; max := maxint end ; with pointerrepresentation do begin size := 1 ; bitsize := bitmax ; min := 0 ; max := addressmax end ; with defaultrepresentation do begin size := 1 ; bitsize := 24 ; min := -maxint ; max := maxint end ; with layoutrepresentation do begin size := 1 ; bitsize := 1 ; min := 0 ; max := 1 end ; with messagerepresentation do begin size := 2 ; floatingpoint := false ; end ; for libroutine := progprelude to caserror do with libcodesequences[libroutine] do begin linked := false ; expected := false ; startaddress := libaddresses[libroutine] ; end ; readrep[intkind] := integerrepresentation ; readrep[realkind]:=realrepresentation ; readrep[charkind]:= charrepresentation ; firstconstant := nil ; codeistobegenerated := true ; charaddressingacceptable := true ; rewrite(codefile) ; nextfilelocation := linkbase ; filecode(nextfilelocation,ord(optionschosen)) ; if reqd[ebm] then linksize := ebmlinkmax else linksize := dbmlinkmax ; for index := 1 to linksize do filecode(nextfilelocation,0) ; firstobjectlocation := nextfilelocation ; currentaddress := nextfilelocation ; expectlinksequence(startprogram) ; expectlinksequence(finishprogram) ; nextlink := ord(firstuserlink) ; nolinkoverflow := true ; nomodeoverflow := true end (* initcodegeneration *) ; (* --- code generation and linkage ------------ *) procedure opencodespace ; begin nocodeoverflow := true ; nextins := 0 ; codebase := currentaddress end (* opencodespace *) ; procedure endcodegeneration ; var option : optiontype ; index : linkrange ; nextconstant : stringp ; begin linktable[ord(optionsused)] := ord(optionschosen) ; linktable[ord(constbase)] := currentaddress ; nextconstant := firstconstant ; while nextconstant # nil do begin filecode(currentaddress,nextconstant^.word) ; nextconstant := nextconstant^.nextword ; currentaddress := currentaddress + 1 end ; if not edmrequested and (currentaddress >= codelimit32k) and nomodeoverflow then begin error(270) ; nomodeoverflow := false end ; linktable[ord(stackbase)] := currentaddress ; for option := dump to trace do filecode(nextfilelocation,ord(reqd[option])) ; for option := retromax to tracemax do filecode(nextfilelocation,parmvalue[option]) ; for index := 0 to linklimit do filecode(nextfilelocation,linktable[index]) ; end (* end code generation *) ; procedure closecodespace ; var codeoffset : coderange ; begin for codeoffset := 0 to nextins-1 do filecode(codebase+codeoffset,code[codeoffset]) end (* writecode *) ; procedure copycode ( codevalue : integer ) ; begin if nextins = codemax then begin if nocodeoverflow then begin error(253) ; nocodeoverflow := false end ; nextins := 0 end ; code[nextins] := codevalue ; nextins := nextins + 1 ; if not ebmrequested and (currentaddress >= codelimit32k) and nomodeoverflow then begin error(270) ; nomodeoverflow := false end ; currentaddress := currentaddress + 1 end (* copycode *) ; procedure leavecodelocation ( var locationleft : coderange ) ; begin locationleft := nextins ; copycode(0) end (* leavecodelocation*) ; procedure insertatcodelocation ( location : coderange ; insertion : integer ) ; begin code[location] := insertion end (* insertatcodelocation *) ; procedure ins ( f : ordercode ; x : register ; n : directoperand ; m : modifier ) ; var instruction : integer ; begin icl(ldx,0,x) ; icl(slc,0,7) ; icl(orx,0,f) ; icl(slc,0,2) ; icl(orx,0,m) ; icl(slc,0,12) ; icl(orx,0,n) ; icl(sto,0,instruction) ; copycode(instruction) end (* ins *) ; function thenextlink : linkrange ; begin if nextlink >= linklimit then begin if nolinkoverflow then begin error(252) ; nolinkoverflow := false end ; nextlink := 0 ; end ; thenextlink := nextlink ; nextlink := nextlink + 1 ; end (* the next link *) ; procedure ajumpins(thisjump : jumps ; f : ordercode ; x : register ; var sequence : codesequence ) ; const relativeaddresslimit = 8192 ; var instruction, backstep : integer ; operand : addrrange ; b9 : 0..1 ; begin b9 := 0 ; with sequence do if expected then if thisjump = notlinked then begin operand := lastcodereference ; lastcodereference := nextins ; end else begin if ebmrequested then b9 := 1 ; if not linked then begin linked := true ; linkindex := thenextlink ; end ; operand := linkbase + linkindex ; end else (* code already found *) if ebmrequested then begin backstep := startaddress - currentaddress ; if (abs(backstep) >= relativeaddresslimit) or (thisjump = alwayslinked) then begin b9 := 1 ; if not linked then begin linked := true ; linkindex := thenextlink ; linktable[linkindex] := startaddress ; end ; operand := linkbase + linkindex ; end else begin (* reduce negative address to 14 bits *) icl(ldx,0,backstep) ; icl(sll,0,2012b) ; icl(srl,0,2012b) ; icl(sto,0,operand) ; end end else operand := startaddress ; icl(ldx,0,x) ; icl(slc,0,7) ; icl(orx,0,f) ; icl(orx,0,b9) ; icl(slc,0,14) ; icl(orx,0,operand) ; icl(sto,0,instruction) ; copycode(instruction) ; end (* a jump ins *) ; procedure jumpins(f : ordercode ; x : register ; var sequence : codesequence) ; begin ajumpins(notlinked,f,x,sequence) ; end (* jump ins *) ; procedure linkedjumpins(f : ordercode ; x : register ; var sequence : codesequence) ; begin ajumpins(linkedifnecessary,f,x,sequence) ; end (* linked jump ins *) ; procedure jumpindirectins(f : ordercode ; x : register ; var sequence : codesequence) ; begin ajumpins(alwayslinked,f,x,sequence) ; end (* jump indirect ins *) ; procedure shiftins ( f : shiftcode ; x: register ; n : shiftrange ; m : modifier ) ; var instruction : integer ; begin icl(ldx,0,x) ; icl(slc,0,11) ; icl(orx,0,f) ; icl(src,0,2) ; icl(orx,0,m) ; icl(slc,0,12) ; icl(orx,0,n) ; icl(sto,0,instruction) ; copycode(instruction) end (* shiftins *) ; (* --- sequential code generation --------------- *) procedure startcodesequence ( var sequence : codesequence ) ; begin with sequence do begin linked := false ; expected := false ; startaddress := currentaddress end end (* startcodesequence *) ; procedure expectcodesequence(var sequence : codesequence) ; begin with sequence do begin expected := true ; lastcodereference := 0 ; linked := false end end (* expectcodesequence *) ; procedure fixupaddresses(firstfixup : coderange ; addresstobeset : addrrange) ; var nextfixup : coderange ; codeaddress, jumpaddress : integer ; begin if nocodeoverflow then begin jumpaddress := addresstobeset ; nextfixup := firstfixup ; while nextfixup # 0 do begin codeaddress := addressof(code[nextfixup]) ; if ebmrequested then begin jumpaddress := addresstobeset - (currentaddress - (nextins - nextfixup)) ; if jumpaddress < 0 then begin (* reduce negative address to 14 bits *) icl(ldx,0,jumpaddress) ; icl(sll,0,2012b) ; icl(srl,0,2012b) ; icl(sto,0,jumpaddress) ; end ; end ; icl(ldx,2,codeaddress) ; icl(ldx,0,0,2) ; icl(dla,0,nextfixup) ; icl(ldx,0,jumpaddress) ; icl(dla,0,0,2) ; end ; end ; end (* fix up addresses *) ; procedure nextiscodesequence ( var sequence : codesequence ) ; var needingfixup : coderange ; codeaddress : integer ; begin with sequence do begin if linked then if ebmrequested then linktable[linkindex] := currentaddress else linktable[linkindex] := brncode + currentaddress ; fixupaddresses(lastcodereference,currentaddress) ; expected := false ; startaddress := currentaddress end end (* nextiscodesequence *) ; procedure linkcodesequence ( expectedsequence : codesequence ; var destination : codesequence ) ; var nextreference : coderange ; codeaddress : integer ; destaddress : addrrange ; begin if(expectedsequence.lastcodereference # 0) and nocodeoverflow then if destination.expected then begin nextreference := expectedsequence.lastcodereference ; repeat codeaddress := addressof(code[nextreference]) ; icl(ldx,2,codeaddress) ; icl(ldx,0,0,2) ; icl(dla,0,nextreference) until nextreference = 0 ; nextreference := destination.lastcodereference ; icl(ldx,0,nextreference) ; icl(ldx,2,codeaddress) ; icl(dla,0,0,2) ; destination.lastcodereference := expectedsequence.lastcodereference end else fixupaddresses(expectedsequence.lastcodereference, destination.startaddress) ; end (* linkcodesequence *) ; procedure addressconstant ( cvalue : valu ; var n : addrrange ; var m : modifier ) ; forward ; procedure constins ( f : ordercode ; x : register ; n : integer ) ; var cvalue : valu ; cn : shortaddress ; cm : modifier ; begin if (n>=0) and (n<=4095) then ins(f+100b,x,n,0) else if (n<0) and (n>=-4095) and (f<=003b) then if f in [000b,001b] then ins(f+102b,x,-n,0) else ins(f+076b,x,-n,0) else begin with cvalue do begin size := 1 ; kind := intvalue ; ival1 := n end ; addressconstant(cvalue,cn,cm) ; ins(f,x,cn,cm) end end (* constins *) ; procedure doubleins( f : ordercode ; x : register ; n : directoperand ; m : modifier ) ; begin ins(f,x,n,m) ; ins(f,x+1,n+1,m) end (* doubleins *) ; procedure normalise ( var n : integer ; var m : modifier ) ; var adjustins : ordercode ; ndiv4k : integer ; i : integer ; begin if (n < 0) or (n > 4094) then begin case m of 0 : begin m := xmod ; adjustins := ldx end ; xlocal : begin ins(ldx,xmod,xlocal,0) ; m := xmod ; adjustins := adx end ; xmod , xref : adjustins := adx end (* case *) ; if n < 0 then begin n := n-1 ; ndiv4k := (-n) div 4096 ; n := n + 4096 * (ndiv4k+1) ; adjustins := adjustins + 2 (* negative of adjustins *) end (* i.e. ngx or sbx *) else begin n := n+1 ; ndiv4k := n div 4096 - 1 ; n := n mod 4096 end ; ins(adjustins,m,rt4ktable+(ndiv4k mod 8),0) ; if ndiv4k div 8 > 0 then begin if adjustins in [ldx,ngx] then adjustins := adjustins+1 ; for i := 1 to ndiv4k div 8 do ins(adjustins,m,rt4ktable+8,0) end end end (* normalise *) ; (* --- work location housekeeping --------------- *) procedure openworkspaceat ( startaddress : addrrange ) ; begin firstworkaddress := startaddress ; lastlocaladdress := startaddress - 1 ; workspace := [0..39] end (* openworkspaceat *) ; procedure get1worklocation ( var workaddress : addrrange ) ; label 1 ; var workindex : workrange ; begin for workindex := 0 to workmax do if workindex in workspace then begin workspace := workspace - [workindex] ; workaddress := firstworkaddress + workindex ; goto 1 end ; error(260) ; workaddress := firstworkaddress ; 1: if workaddress > lastlocaladdress then lastlocaladdress := workaddress end ; procedure get2worklocations ( var workaddress : addrrange ) ; label 1 ; var workindex : workrange ; begin for workindex := 0 to workmax-1 do if (workindex in workspace) and (workindex+1 in workspace) then begin workspace := workspace - [workindex,workindex+1] ; workaddress := firstworkaddress+workindex ; goto 1 end ; error(260) ; workaddress := firstworkaddress ; 1: if workaddress >=lastlocaladdress then lastlocaladdress := workaddress+1 end (* get2worklocations *) ; procedure freeworklocation ( workaddress : addrrange ) ; begin workspace := workspace + [workaddress-firstworkaddress] end (* freeworklocation *) ; procedure freeanyworklocationsfrom ( entry : stackentry ) ; begin with entry^ do begin case kind of reference : with wordaddress do if (access = evaluated) and not inxref and disposable then freeworklocation(tempref) ; result : if not inregister then begin freeworklocation(tempresult) ; if rep.size = 2 then freeworklocation(tempresult+1) end ; condition : if (kindofcondition=xcondition) and not inconditionregister then freeworklocation(tempcondition) ; formalreference , konstant , statementbase : ; end end end (* freeanyworklocationsfrom *) ; (* --- stack housekeeping ----------------------- *) procedure initstack ; begin topstackentry := nil end (* initstack *) ; procedure stack ( entry : stackentry ) ; begin entry^.nextentry := topstackentry ; topstackentry := entry end (* stack *) ; procedure unstack ( var entry : stackentry ) ; begin entry := topstackentry ; topstackentry := topstackentry^.nextentry end ; procedure freestackentry ( entry : stackentry ) ; begin freeanyworklocationsfrom(entry) ; dispose(entry) end ; (* --- register housekeeping -------------------- *) procedure bindregistersto ( entry : stackentry ) ; begin with entry^ do case kind of reference : with wordaddress do if (access = evaluated) and inxref then begin thosefree := thosefree - [xref] ; entryusing[xref] := entry end ; formalreference : if baseinxref then begin thosefree := thosefree - [xref] ; entryusing[xref] := entry end ; konstant : ; result : if inregister then begin thosefree := thosefree - [reg] ; entryusing[reg] := entry ; if (rep.size = 2) and (reg # fpa) then begin thosefree := thosefree - [reg+1] ; entryusing[reg+1] := entry end end ; condition : if (kindofcondition = xcondition) and inconditionregister then begin thosefree := thosefree - [condregister] ; entryusing[condregister] := entry end end end (* bindregistersto *) ; procedure freeregistersfrom ( entry : stackentry ) ; var thoseused : setofregisters ; begin thoseused := [ ] ; with entry^ do case kind of reference : with wordaddress do if (access = evaluated) and inxref then thoseused := [xref] ; formalreference : if baseinxref then thoseused := [xref] ; konstant : ; result : if inregister then if (rep.size = 1) or (reg = fpa) then thoseused := [reg] else thoseused := [reg,reg+1] ; condition : if (kindofcondition = xcondition) and inconditionregister then thoseused := [condregister] end ; thosefree := thosefree + thoseused end (* freeregistersfrom *) ; procedure saveregister ( fx : register ) ; label 1 ; var size : 1..2 ; n : addrrange ; x,m : register ; begin x := fx ; if not (x in thosefree) then begin with entryusing[x]^ do case kind of reference : with wordaddress do begin get1worklocation(n) ; size := 1 ; inxref := false ; disposable := true ; tempref := n end ; formalreference : begin baseinxref := false ; goto 1 end ; result : begin size := rep.size ; x := reg ; if size = 1 then get1worklocation(n) else get2worklocations(n) ; inregister := false ; tempresult := n end ; condition : begin get1worklocation(n) ; size := 1 ; inconditionregister := false ; tempcondition := n end end ; m := xlocal ; normalise(n,m) ; if size = 1 then ins(sto,x,n,m) else if x = fpa then ins(sfp,0,n,m) else begin doubleins(sto,x,n,m) ; thosefree := thosefree + [x+1] end ; 1: thosefree := thosefree + [x] end end (* saveregister *) ; procedure lockregister ( x : register ) ; begin thoselocked := thoselocked + [x] end (* lockregister *) ; procedure unlockregister ( x : register ) ; begin thoselocked := thoselocked - [x] end (* unlockregister *) ; procedure listthoseusedby ( entry : stackentry ; var thoseused : setofregisters ) ; var thosesofar : setofregisters ; thisindex : stackentry ; begin with entry^ do case kind of reference : begin if (wordaddress.access=evaluated) and wordaddress.inxref then thosesofar := [xref] else thosesofar := [ ] ; if partwordreference then begin if indexedpartword and not indexevaluated then begin listthoseusedby(index,thoseusedby) ; thosesofar := thosesofar + thoseused end end else if indexed then begin thisindex := indices ; repeat listthoseusedby(thisindex,thoseused) ; thosesofar := thosesofar + thoseused ; thisindex := thisindex^.nextentry until thisindex = nil end ; thoseused := thosesofar end ; formalreference : if baseinxref then thoseused := [xref] else thoseused := [ ] ; konstant : thoseused := [ ] ; result : if inregister then if (rep.size = 2) and (reg # fpa) then thoseused := [reg,reg+1] else thoseused := [reg] else thoseused := [ ] ; condition : if (kindofcondition = xcondition) and inconditionregister then thoseused := [condregister] else thoseused := [ ] end end (* listthoseusedby *) ; procedure saveallregisters ; var x : register ; begin for x := xref to fpa do saveregister(x) end (* saveallregisters *) ; procedure freeallregisters ; var x : register ; begin thosefree := [0..fpa] end (* freeallregisters *) ; procedure moveregister ( xfrom,xto : register ) ; begin ins(ldx,xto,xfrom,0) end (* moveregister *) ; function xchosenfrom ( thoseavailable,thoseprohibited : setofregisters ) : register ; label 1 ; var thoseusable : setofregisters ; i : 1..4 ; begin thoseusable := thoseavailable * [4,5,6,7] - thoseprohibited ; if thoseusable # [ ] then begin for i := 1 to 4 do if xchoice[i] in thoseusable then goto 1 end else begin for i := 1 to 4 do if not(xchoice[i] in thoseprohibited) then goto 1 ; (* if this point reached - compiler error *) error(261) ; i := 1 end ; 1: xchosenfrom := xchoice[i] end (* xchosenfrom *) ; function xxchosenfrom(thoseavailable,thoseprohibited : setofregisters) : register ; label 1 ; var thoseusable : setofregisters ; i : 1..3 ; x : register ; begin thoseusable := thoseavailable * [4,5,6,7] - thoseprohibited ; if thoseusable # [ ] then begin for i := 1 to 3 do begin x := xxchoice[i] ; if [x,x+1] <= thoseusable then goto 1 end ; for i := 1 to 3 do begin x := xxchoice[i] ; if thoseusable * [x,x+1] # [ ] then goto 1 end end else begin for i := 1 to 3 do begin x := xxchoice[i] ; if thoseprohibited * [x,x+1] = [ ] then goto 1 end ; (* if this point reached - compiler error *) error(261) ; x := xxchoice[1] end ; 1: xxchosenfrom := x end (* xxchosenfrom *) ; function bestregisterfor ( entry : stackentry ) : register ; var thoseused : setofregisters ; begin listthoseusedby(entry,thoseused) ; with entry^.rep do if size = 1 then bestregisterfor := xchosenfrom(thoseused + thosefree , thoselocked ) else if floatingpoint then bestregisterfor := fpa else bestregisterfor := xxchosenfrom(thoseused + thosefree , thoselocked) end (* bestregisterfor *) ; procedure get1register ( var x : register ) ; begin x := xchosenfrom(thosefree,[ ]) ; saveregister(x) end (* get1register *) ; procedure get2registers ( var xx : register ) ; begin xx := xxchosenfrom(thosefree,[ ]) ; saveregister(xx) ; saveregister(xx+1) end (* get2registers *) ; (* --- addressing run-time values --------------- *) function xmodneededtosave ( x : register ) : boolean ; begin if not (x in thosefree) then with entryusing[x]^ do case kind of reference : xmodneededtosave := (wordaddress.tempref > 4095) ; formalreference : xmodneededtosave := false ; result : xmodneededtosave := (tempresult > 4096-rep.size) ; condition : xmodneededtosave := (tempcondition > 4095) end else xmodneededtosave := false end (* xmodneededtosave *) ; procedure testforpowerof2 ( n1: integer ) ; (* decides whether parameter is a power of 2 , setting the global boolean powerof2 accordingly . when true the global logbase2 holds the corresponding power *) var n : integer ; begin n := n1 ; logbase2 := 0 ; if n # 0 then while n mod 2 = 0 do begin logbase2 := logbase2 + 1 ; n := n div 2 end ; powerof2 := ( n = 1 ) end (* testforpowerof2 *) ; procedure setxtolevel ( x : register ; requiredlevel : disprange ) ; var nextlevel : disprange ; begin if requiredlevel = level then ins(ldx,x,xlocal,0) else if requiredlevel = level-1 then ins(ldx,x,static,xlocal) else begin ins(ldx,xmod,static,xlocal) ; nextlevel := level-2 ; while nextlevel # requiredlevel do begin ins(ldx,xmod,static,xmod) ; nextlevel := nextlevel-1 end ; ins(ldx,x,static,xmod) end end (* setxtolevel *) ; function eq(left,right : integer) : boolean ; forward ; procedure addressvalue ( entry : stackentry ) ; forward ; procedure loadx ( x : register ; entry : stackentry ) ; forward ; procedure address ( entry : stackentry ) ; (* generates code (if necessary) to enable the location described by entry to be addressed, and leaves addressing co-ordinates in the global record addressed. any registers bound to entry, or stack entries occupied by its indices are freed in the process *) var xrefset,xmodset,xmodsaved : boolean ; finaln,tempn : integer ; finalm,tempm : modifier ; thisindex,nextindex : stackentry ; indexadjustment : (none,shifting,multiplication) ; position : (notacharposition,fixedcharposition, indexedcharposition) ; charindex : 0..3 ; capossible : boolean ; procedure savexmodifnecessary ; begin if xmodset and not xmodsaved then begin ins(sto,xmod,0,0) ; xmodsaved := true end end (* savexmodifnecessary *) ; procedure addwordaddress ; label 1 ; var tempn : integer ; tempm : modifier ; procedure savexrefifnecessary ; begin if xmodset and not xrefset then saveregister(xref) end (* savexrefifnecessary *) ; begin xmodsaved := false ; with entry^.wordaddress do case access of direct : begin finaln := offset + adjustment ; if staticlevel = globallevel then begin if xrefset then finalm := xref else finalm := 0 ; goto 1 end else if staticlevel = level then if xrefset then begin tempn := xlocal ; tempm := 0 end else begin finalm := xlocal ; goto 1 end else if staticlevel = level-1 then begin tempn := static ; tempm := xlocal end else begin savexmodifnecessary ; savexrefifnecessary ; setxtolevel(xmod,staticlevel+1) ; tempn := static ; tempm := xmod end end ; indirect : begin finaln := adjustment ; tempn := offset ; if staticlevel = globallevel then tempm := 0 else if staticlevel = level then tempm := xlocal else begin savexmodifnecessary ; savexrefifnecessary ; setxtolevel(xmod,staticlevel) ; tempm := xmod end end ; evaluated : begin finaln := adjustment ; if inxref then begin finalm := xref ; goto 1 end else begin tempn := tempref ; tempm := xlocal end end end ; if tempn > 4095 then begin savexmodifnecessary ; savexrefifnecessary ; normalise(tempn,tempm) end ; if xrefset then begin ins(adx,xref,tempn,tempm) ; finalm := xref end else begin if xmodset then begin if xmodneededtosave(xref) then savexmodifnecessary ; saveregister(xref) ; finalm := xref end else finalm := xmod ; ins(ldx,finalm,tempn,tempm) end ; 1: end (* addwordaddress *) ; begin (* address *) with entry^ do case kind of reference : begin if partwordreference then begin capossible := charaddressingacceptable and (wordaddress.adjustment >= 0) and not(wordaddress.access = evaluated) ; if indexedpartword then if indexevaluated then begin tempn := storedshift ; tempm := xlocal ; normalise(tempn,tempm) ; ins(ldx,xmod,tempn,tempm) ; xmodset := true ; xrefset := false ; position := notacharposition end else begin loadx(xref,index) ; constins(sbx,xref,lowerbound) ; if capossible and (index^.factor = 4) and (bitoffset = 0) then begin position := indexedcharposition ; shiftins(srcs,xref,2,0) ; xmodset := false end else begin testforpowerof2(index^.factor) ; if powerof2 then begin ins(ldn,xmod,index^.factor-1,0) ; ins(andx,xmod,xref,0) ; shiftins(srls,xref,logbase2,0) end else ins(dvs,xmod,rtshifts[index^.factor],0); ins(ldx,xmod,rtshifts[index^.factor]+1,xmod); xmodset := true ; position := notacharposition end ; freestackentry(index) ; xrefset := true end else begin if charposition then if charaddressingacceptable then position := indexedcharposition else (* should not occur *) else if capossible and (bitsize = 6) and (bitoffset mod 6 = 0) then position := fixedcharposition else position := notacharposition ; xmodset := false ; xrefset := false end ; addwordaddress ; normalise(finaln,finalm) ; with addressed do begin ispartword := true ; case position of notacharposition : begin ischarposition := false ; shiftn := bitoffset ; if xmodset then shiftm := xmod else shiftm := 0 ; bitsize := entry^.bitsize end ; fixedcharposition : begin ischarposition := true ; charindex := 3 - bitoffset div 6 ; if finalm in [xmod,xref] then begin if charindex # 0 then ins(orx,finalm,charbitsbase+charindex,0) end else if not((finalm=xlocal) and (charindex=0) or (finalm=0) and (charindex=3)) then begin ins(ldct,xmod,128*charindex,0) ; if finalm=xlocal then ins(orx,xmod,xlocal,0) ; finalm := xmod end end ; indexedcharposition : ischarposition := true end ; if xmodset and xmodsaved then ins(ldx,xmod,0,0) end end else begin if indexed then with wordaddress do begin nextindex := indices ; repeat thisindex := nextindex ; addressvalue(thisindex) ; if (access # evaluated) or not inxref then saveregister(xref) ; testforpowerof2(thisindex^.factor) ; if powerof2 then if logbase2 =0 then indexadjustment := none else indexadjustment := shifting else begin with addressed do if m = xmod then begin ins(ldx,0,n,m) ; n := 0 ; m := 0 end ; constins(ldx,xmod,thisindex^.factor) ; indexadjustment := multiplication end ; if (access = evaluated) and inxref then with addressed do case indexadjustment of none : ins(adx,xref,n,m) ; shifting : begin ins(ldx,xmod,n,m) ; shiftins(slls,xmod,logbase2,0) ; ins(adx,xref,xmod,0) end ; multiplication : ins(mpa,xmod,n,m) end else begin with addressed do case indexadjustment of none : ins(ldx,xref,n,m) ; shifting : begin ins(ldx,xref,n,m) ; shiftins(slls,xref,logbase2,0) end ; multiplication : ins(mpy,xmod,n,m) end ; if access = evaluated then begin tempn := tempref ; tempm := xlocal ; normalise(tempn,tempm) ; ins(adx,xref,tempn,tempm) ; if disposable then freeworklocation(tempref) ; inxref := true end else begin xrefset := true ; xmodset := false ; addwordaddress ; adjustment := finaln ; access := evaluated ; inxref := true end ; bindregistersto(entry) end ; nextindex := thisindex^.nextentry ; freestackentry(thisindex) until nextindex = nil ; indexed := false ; finaln := adjustment ; finalm := xref end else begin xrefset := false ; xmodset := false ; addwordaddress end ; normalise(finaln,finalm) ; addressed.ispartword := false end ; end ; formalreference : begin if not baseinxref then begin saveregister(xref) ; ins(ldx,xref,nextbase,xlocal) end ; finaln := formaloffset ; finalm := xref ; normalise(finaln,finalm) ; addressed.ispartword := false end ; konstant , result , condition : end ; with addressed do begin n := finaln ; m := finalm ; size := entry^.rep.size end ; freeregistersfrom(entry) end (* address *) ; procedure addressconstant ; label 1 ; var wordsought : integer ; offset : addrrange ; thisword,lastword,nextintable,nextinstring : stringp ; procedure append ( newvalue : integer ) ; var newword : stringp ; begin new(newword) ; with newword^ do begin word := newvalue ; nextword := nil end ; if lastword = nil then firstconstant := newword else lastword^.nextword := newword ; lastword := newword end (* append *) ; begin (* addressconstant *) (* search for constant in existing table *) if cvalue.kind = stringvalue then wordsought := cvalue.string^.word else wordsought := cvalue.ival1 ; thisword := firstconstant ; lastword := nil ; offset := 0 ; while thisword # nil do begin if eq(thisword^.word,wordsought) then if cvalue.kind = stringvalue then begin nextintable := thisword^.nextword ; nextinstring := cvalue.string^.nextword ; while ( nextintable # nil ) and ( nextinstring # nil ) and eq(nextintable^.word,nextinstring^.word) do begin nextintable := nextintable^.nextword ; nextinstring := nextinstring^.nextword end ; if ( nextintable = nil ) and ( nextinstring = nil ) then goto 1 end else if ( cvalue.size = 1 ) or ( thisword^.nextword # nil ) and eq(thisword^.nextword^.word,cvalue.ival2) then goto 1 ; lastword := thisword ; thisword := thisword^.nextword ; offset := offset + 1 end ; (* append new constant to table *) if cvalue.kind = stringvalue then begin nextinstring := cvalue.string ; repeat append(nextinstring^.word) ; nextinstring := nextinstring^.nextword until nextinstring = nil end else begin append(cvalue.ival1) ; if cvalue.size = 2 then append(cvalue.ival2) end ; 1: (* generate address code and co-ordinates *) ins(ldx,xmod,linkbase+ord(constbase),0) ; n := offset ; m := xmod ; normalise(n,m) end (* addressconstant *) ; procedure loadaddress ( x : register ; entry : stackentry ) ; (* assumes entry does not describe a part word or the contents of a register *) label 1 ; var thoseused : setofregisters ; tempn : addrrange ; tempm : modifier ; begin listthoseusedby(entry,thoseused) ; if not (x in thoseused) then saveregister(x) ; with entry^ do case kind of reference : if not indexed and(wordaddress.adjustment = 0) and (wordaddress.access # direct) then begin with wordaddress do if access = indirect then begin tempn := offset ; if staticlevel = globallevel then tempm := 0 else if staticlevel = level then tempm := xlocal else begin setxtolevel(xmod,staticlevel) ; tempm := xmod end end else if inxref then begin freeregistersfrom(entry) ; if x = xref then goto 1 else begin tempn := xref ; tempm := 0 end end else begin tempn := tempref ; tempm := xlocal end ; normalise(tempn,tempm) ; ins(ldx,x,tempn,tempm) end else begin address(entry) ; with addressed do ins(ldn,x,n,m) end ; formalreference : begin address(entry) ; with addressed do ins(ldn,x,n,m) end ; konstant : begin addressconstant(konstvalue,tempn,tempm) ; ins(ldn,x,tempn,tempm) end end ; 1: end (* loadaddress *) ; procedure addressvalue ; (* generates code (if necessary) to enable the value described by entry to be addressed, and leaves addressing co-ordinates in the global record addressed . any registers bound to entry are freed in the process. *) var tempn : addrrange ; tempm : modifier ; begin with entry^ do begin case kind of reference : if partwordreference then begin loadx(0,entry) ; with addressed do begin n := 0 ; m := 0 end end else address(entry) ; konstant : with addressed do addressconstant(konstvalue,n,m) ; result : begin if inregister then begin freeregistersfrom(entry) ; with addressed do begin n := reg ; m := 0 end end else begin tempn := tempresult ; tempm := xlocal ; normalise(tempn,tempm) ; with addressed do begin n := tempn ; m := tempm end end end ; condition : begin loadx(0,entry) ; with addressed do begin n := 0 ; m := 0 end end end ; addressed.size := rep.size ; addressed.ispartword := false end end (* addressvalue *) ; procedure removeindicesfrom ( entry : stackentry ) ; (* assumes (entry^.kind = reference) and not entry^.partwordref. if entry is indexed code to carry out indexing is generated and entry reset to an equivalent reference with word.access = loaded and not indexed . *) begin with entry^ do if indexed then begin address(entry) ; wordaddress.adjustment := addressed.n ; bindregistersto(entry) end end (* removeindicesfrom *) ; (* --- loading run-time values ------------------ *) procedure load ( entry : stackentry ) ; forward ; procedure jumpif ( entry : stackentry ; jumpontrue : boolean ; var destination : codesequence ) ; var brins : bze .. bng ; n : addrrange ; m : modifier ; x : register ; begin with entry^ do case kind of reference , result : begin load(entry) ; if jumpontrue then brins := bnz else brins := bze ; jumpins(brins,loaded.reg,destination) end ; konstant : if konstvalue.bval = jumpontrue then jumpins(brn,0,destination) ; condition : case kindofcondition of xcondition : begin if inconditionregister then begin x := condregister ; freeregistersfrom(entry) end else begin n := tempcondition ; m := xlocal ; normalise(n,m) ; ins(ldx,0,n,m) ; x := 0 end ; if jumpontrue then brins := reverseof[falsejumpins] else brins := falsejumpins ; jumpins(brins,x,destination) end ; ccondition : if jumpontrue = falseifset then jumpins(brn,oncclear,destination) else jumpins(brn,oncset,destination) ; multijumpcondition : if jumpcondition = jumpontrue then linkcodesequence(jumpdestination,destination) else begin jumpins(brn,0,destination) ; nextiscodesequence(jumpdestination) end end (* case kindofcondition *) end end (* jumpif *) ; procedure loadx ; (* generates code to load value described by entry into register x ( if necessary ) . registers bound to entry are freed in the process *) var tobejumpedon : boolean ; toloadconditionjumpedon,afterconditionloaded : codesequence ; thoseused : setofregisters ; procedure loadbooleanvalue ( condition : boolean ) ; begin if condition then ins(ldn,x,1,0) else ins(ldn,x,0,0) end ; begin listthoseusedby(entry,thoseused) ; if not(x in thoseused) then saveregister(x) ; with entry^ do begin case kind of reference : begin address(entry) ; with addressed do if ispartword and ischarposition then ins(ldch,x,n,m) else begin ins(ldx,x,n,m) ; if ispartword then begin if (shiftn # 0) or (shiftm # 0) then shiftins(srls,x,shiftn,shiftm) ; if (shiftm # 0) or (bitsize reg then begin moveregister(reg+1,x+1) ; moveregister(reg,x) end end else begin addressvalue(entry) ; with addressed do doubleins(ldx,x,n,m) end end ; freeanyworklocationsfrom(entry) ; kind := result ; inregister := true ; reg := x end end (* loadxx *) ; procedure loadfpa ( entry : stackentry ) ; (* generates code to load value described by entry into fpa, freeing registers bound to entry in the process *) begin with entry^ do if (kind = result) and inregister and (reg = fpa) then freeregistersfrom(entry) else begin saveregister(fpa) ; if (kind = konstant) and (konstvalue.rval = 0.0) then ins(lfpz,1,0,0) else begin addressvalue(entry) ; with addressed do ins(lfp,0,n,m) end ; freeanyworklocationsfrom(entry) ; kind := result ; inregister := true ; reg := fpa end end (* loadfpa *) ; procedure load ; (* generates code to load value described by entry into an appropriate register (if not already loaded) and sets the global record loaded to describe the loaded value. any registers bound to the entry are freed in the process *) var chosenregister : register ; begin if (entry^.kind = result) and entry^.inregister and not( entry^.reg in thoselocked ) then begin chosenregister := entry^.reg ; freeregistersfrom(entry) end else begin chosenregister := bestregisterfor(entry) ; if chosenregister = fpa then loadfpa(entry) else if entry^.rep.size = 1 then loadx(chosenregister,entry) else loadxx(chosenregister,entry) end ; with loaded do begin reg := chosenregister ; size := entry^.rep.size end end (* load *) ; (* --- call to run-time routines ---------------- *) procedure systemcall ( libroutine : monitorroutines ) ; var xcall : register ; begin if ( libroutine < readinteger ) and (libroutine in [ packcharacters,unpackcharacters, packnbits ,unpacknbits, newop ,disposeop, getnt ,gett, putnt ,putt, resetnt ,resett, rewritent ,rewritet, getmark ,putmark ]) then xcall := 0 else xcall := xmod ; linkedjumpins(call,xcall,libcodesequences[libroutine]) ; end (* systemcall *) ; function lt ( left,right : integer ) : boolean ; begin if (left < 0) and (right >= 0) then lt := true else if (left >= 0) and (right < 0) then lt := false else lt := (left < right) end (* lt *) ; function eq ; begin if (left < 0) and (right >= 0) or (left >= 0) and (right < 0) then eq := false else eq := (left = right) end (* eq *) ; procedure checkoverflow ; var aftercheck : codesequence ; begin (* checkoverflow *) expectcodesequence(aftercheck) ; jumpins(brn,onvclear,aftercheck) ; systemcall(ofer) ; nextiscodesequence(aftercheck) end (* checkoverflow *) ; procedure rangecheck ( entry : stackentry ; minrequired,maxrequired : integer ) ; var actualmin,actualmax : integer ; rangerequired : checkrange ; oftestnecessary,signtestnecessary, maxtestnecessary,mintestnecessary : boolean ; begin if locallyreqd[checks] then begin with entry^ do begin actualmin := rep.min ; actualmax := rep.max ; oftestnecessary := mayhaveoverflowed end ; if lt(actualmin,minrequired) or lt(maxrequired,actualmax) then begin if lt(maxrequired,actualmin) or lt(actualmax,minrequired) then begin error(302) ; if entry^.kind = konstant then entry^.konstvalue.ival1 := minrequired end else begin if minrequired >= 0 then begin rangerequired := positive ; signtestnecessary := (actualmin < 0) ; mintestnecessary := (minrequired # 0) and lt(actualmin,minrequired) ; maxtestnecessary := lt(maxrequired,actualmax) end else if maxrequired < 0 then begin rangerequired := negative ; signtestnecessary := (actualmax >= 0) ; mintestnecessary := lt(actualmin,minrequired) ; maxtestnecessary := (maxrequired # -1) and lt(maxrequired,actualmax) end else begin rangerequired := posorneg ; mintestnecessary := lt(actualmin,minrequired) ; maxtestnecessary := lt(maxrequired,actualmax) ; signtestnecessary := (mintestnecessary and (actualmax>=0)) or (maxtestnecessary and (actualmin<0)) end ; if checkroutine[rangerequired,oftestnecessary, maxtestnecessary,mintestnecessary, signtestnecessary] # nocheck then begin loadx(6,entry) ; systemcall(checkroutine[rangerequired,oftestnecessary, maxtestnecessary,mintestnecessary, signtestnecessary]) ; if mintestnecessary then copycode(minrequired) ; if maxtestnecessary then copycode(maxrequired+1) ; bindregistersto(entry) end end end else if oftestnecessary then checkoverflow end end (* rangecheck *) ; (* --- representation and storage of data ------- *) function bitsneededfor ( decimalvalue : integer ) : bitrange ; var bits : bitrange ; quotient : integer ; begin bits := 0 ; quotient := decimalvalue ; repeat bits := bits + 1 ; quotient := quotient div 2 ; until quotient = 0 ; bitsneededfor := bits end (* bitsneededfor *) ; procedure setrepresentationfor ( entry : typentry ) ; var nextconst : identry ; nextvalue,basemax,basemin,indexmax,indexmin : integer ; wordsneeded : addrrange ; elsperword : 1..24 ; noelements : integer ; wordsused : addrrange ; bitsused : bitrange ; packing : boolean ; actualbasetype : typentry ; procedure alloclevel(nonvariantpart : identry ; variantpart : typentry ; startword : addrrange ; startbits : bitrange ; var maxwordsize : addrrange ; var maxbitsize : bitrange ) ; var wordfree,thisvarwordsize : addrrange ; bitsfree,thisvarbitsize : 0..24 ; lastfield,thisfield,firstactualfield : identry ; thisvariant : typentry ; tagshouldspread : boolean ; procedure spreadlastfield ; begin if lastfield # nil then begin with lastfield^.offset do if bitoffset = 0 then begin partword := false ; wordsize := 1 end else bitsize := wordlength - bitoffset ; wordfree := wordfree + 1 ; bitsfree := wordlength ; lastfield := nil end else if bitsfree # wordlength then begin wordfree := wordfree + 1 ; bitsfree := wordlength end end (* spreadlastfield *) ; procedure allocfield ( fieldentry : identry ) ; var wordsneeded : addrrange ; bitsneeded : 1..24 ; begin with fieldentry^ do if idtype # nil then begin wordsneeded := idtype^.representation.size ; if packing and(wordsneeded = 1) and (idtype^.representation.bitsize bitsfree then spreadlastfield ; with offset do begin wordoffset := wordfree ; partword := true ; bitsize := bitsneeded ; bitoffset := wordlength - bitsfree end ; bitsfree := bitsfree - bitsneeded ; if bitsfree = 0 then begin wordfree := wordfree + 1 ; bitsfree := wordlength ; lastfield := nil end else lastfield := fieldentry end else begin if packing then spreadlastfield ; with offset do begin wordoffset := wordfree ; partword := false ; wordsize := wordsneeded end ; wordfree := wordfree + wordsneeded ; lastfield := nil end end end (* allocfield *) ; begin (* alloclevel *) wordfree := startword ; bitsfree := startbits ; lastfield := nil ; thisfield := nonvariantpart ; while thisfield # nil do begin allocfield(thisfield) ; thisfield := thisfield^.next end ; if variantpart # nil then begin with variantpart^ do begin if tagfield # nil then allocfield(tagfield) ; (* decide whether tag field is to be spread by testing *) (* whether any of the immediately following fields fits *) (* in same word *) if packing then begin tagshouldspread := true ; thisvariant := firstvariant ; while thisvariant # nil do with thisvariant^ do begin if fstvarfield # nil then firstactualfield := fstvarfield else if subvarpart = nil then firstactualfield := nil else firstactualfield := subvarpart^.tagfield ; if firstactualfield # nil then if firstactualfield^.idtype # nil then with firstactualfield^.idtype^. representation do if size = 1 then if bitsize <= bitsfree then tagshouldspread := false ; thisvariant := nextvariant end (* with *) ; if tagshouldspread then spreadlastfield end ; if bitsfree = wordlength then begin maxwordsize := wordfree ; maxbitsize := wordlength end else begin maxwordsize := wordfree + 1 ; maxbitsize := wordlength - bitsfree end ; with representation do begin size := maxwordsize ; if maxwordsize = 1 then bitsize := maxbitsize else if maxwordsize = 2 then floatingpoint := false end ; end ; thisvariant := variantpart^.firstvariant ; while thisvariant # nil do with thisvariant^ do begin alloclevel(fstvarfield,subvarpart,wordfree,bitsfree, thisvarwordsize,thisvarbitsize ) ; with representation do begin size := thisvarwordsize ; if size = 1 then bitsize := thisvarbitsize else if size = 2 then floatingpoint := false end ; if thisvarwordsize > maxwordsize then begin maxwordsize := thisvarwordsize ; maxbitsize := thisvarbitsize end else if thisvarwordsize = maxwordsize then if thisvarbitsize > maxbitsize then maxbitsize := thisvarbitsize ; thisvariant := nextvariant end end else begin if packing and (wordfree > 0) then spreadlastfield ; if bitsfree = wordlength then begin maxwordsize := wordfree ; maxbitsize := wordlength end else begin maxwordsize := wordfree + 1 ; maxbitsize := wordlength - bitsfree end end end (* alloclevel *) ; begin if entry # nil then with entry^ do case form of scalars : if scalarkind = declared then begin representation.size := 1 ; nextconst := firstconst ; nextvalue := 0 ; while nextconst # nil do begin nextconst^.values.kind := intvalue ; nextconst^.values.ival1 := nextvalue ; nextvalue := nextvalue + 1 ; nextconst := nextconst^.next end ; representation.min := 0 ; representation.max := nextvalue - 1 ; representation.bitsize:=bitsneededfor(nextvalue-1) end ; subranges : if rangetype = realtype then representation := realtype^.representation else begin representation.size := 1 ; representation.min := min ; representation.max := max ; if min < 0 then representation.bitsize := wordlength else representation.bitsize := bitsneededfor(max) end ; pointers : representation := pointerrepresentation ; sets : begin if basetype = nil then basemax := 1 else begin if basetype^.form = subranges then actualbasetype := basetype^.rangetype else actualbasetype := basetype ; if actualbasetype = inttype then basemax := 2 * wordlength - 1 else getbounds(actualbasetype,basemin,basemax) end ; if basemax < wordlength then begin representation.size := 1 ; if basemax = wordlength - 1 then representation.min := -maxint + 1 else representation.min := 0 ; representation.max := maxint ; representation.bitsize := basemax + 1 end else begin representation.size := 2 ; representation.floatingpoint := false end end ; arrays : if (aeltype # nil) and (inxtype # nil) then begin getbounds(inxtype,indexmin,indexmax) ; noelements := indexmax - indexmin + 1 ; if packedarray and (aeltype^.representation.size=1) then begin elsperword := wordlength div aeltype^.representation.bitsize ; wordsneeded := noelements div elsperword ; if noelements mod elsperword # 0 then wordsneeded := wordsneeded+1 ; end else wordsneeded := noelements * aeltype^.representation.size ; representation.size := wordsneeded ; if wordsneeded = 1 then begin representation.min := -maxint ; representation.max := maxint ; representation.bitsize := wordlength end else if wordsneeded =2 then representation.floatingpoint := false end else representation := defaultrepresentation ; records : begin packing := packedrecord ; alloclevel(nonvarpart,varpart,0,wordlength, wordsused,bitsused) ; with representation do begin size := wordsused ; if wordsused = 1 then begin if bitsused = wordlength - 1 then min := -maxint + 1 else min := 0 ; max := maxint ; bitsize := bitsused end else if wordsused = 2 then floatingpoint := false end end ; files : representation.size := 19 end end (* setrepresentationfor *) ; procedure setaddressfor ( entry : identry ) ; begin with entry^,display[level] do case klass of vars : begin varaddress.blocklevel := level ; if level = globallevel then begin varaddress.relativeaddress := currentaddress ; if idtype # nil then currentaddress := currentaddress + idtype^.representation.size end else begin varaddress.relativeaddress := localaddress ; if varparam then localaddress := localaddress + 1 else if idtype # nil then localaddress := localaddress + idtype^.representation.size end end ; proc , func : if pfkind = formal then begin faddress.relativeaddress := localaddress ; faddress.blocklevel := level ; localaddress := localaddress + 2 end else begin result.relativeaddress := localaddress ; result.blocklevel := level ; if idtype # nil then localaddress := localaddress + idtype^.representation.size end end end (* setaddressfor *) ; procedure openstackframe ; begin display[level].localaddress := firstformaloffset end (*openstackframe *) ; procedure closestackframe ; begin end (* closestackframe *) ; (* --- block and program housekeeping ----------- *) procedure transfer ( name : alfa ; var first, second : integer ) ; (* transfer values of type alfa to two values of type integer *) var transrec : record case dummy : integer of 0 : (a : alfa) ; 1 : (i1, i2 : integer) end ; begin with transrec do begin dummy := 0 ; a := name ; dummy := 1 ; first := i1 ; second := i2 end end (* transfer *) ; procedure enterbody ( blockid : identry ) ; begin if codeistobegenerated then begin nextiscodesequence(blockid^.codebody) ; opencodespace ; with blockid^ do systemcall( prelude[ reqd[dump], (level = globallevel+1) , (klass = proc) and (formals = nil)]) ; leavecodelocation(forframesize) ; if reqd[dump] then copycode(blockid^.serial) ; end ; openworkspaceat(display[level].localaddress) ; freeallregisters ; initstack end (* enterbody *) ; procedure leavebody ; begin if codeistobegenerated then begin insertatcodelocation(forframesize,lastlocaladdress+1) ; if reqd[dump] then systemcall(dmppstld) else systemcall(postlude) ; closecodespace end end (* leavebody *) ; procedure nameprogram ( name : alfa ) ; var dummy : integer ; begin transfer(name,linktable[ord(programname)],dummy) end (* nameprogram *) ; procedure getdevicefor(filename : alfa ; var device : addrrange) ; const devicerecsize = 6 ; type devicetype = (lp,cr,mt,da) ; openingmode = (readonly,writeonly,readwrite) ; var val1, val2 : integer ; begin (* getdevicefor *) device := nextfilelocation ; if filename = 'input ' then begin filecode(nextfilelocation,ord(readonly)) ; filecode(nextfilelocation,0) ; filecode(nextfilelocation,ord(cr)) end else if filename = 'output ' then begin filecode(nextfilelocation,ord(writeonly)) ; filecode(nextfilelocation,0) ; filecode(nextfilelocation,ord(lp)) end else begin filecode(nextfilelocation,ord(readwrite)) ; filecode(nextfilelocation,unitno) ; unitno := unitno+1 ; filecode(nextfilelocation,ord(da)) ; transfer(filename,val1,val2) ; filecode(nextfilelocation,val1) ; filecode(nextfilelocation,val2) ; filecode(nextfilelocation,20202020b) end ; while nextfilelocation # device + devicerecsize do filecode(nextfilelocation,0) ; currentaddress := nextfilelocation end (* getdevicefor *) ; procedure enterprogram ( progid : identry ) ; begin if codeistobegenerated then begin nextiscodesequence(proglinks[startprogram]) ; opencodespace ; systemcall(progprelude) ; leavecodelocation(forframesize) ; if reqd[dump] then copycode(progid^.serial) ; end ; openworkspaceat(display[level].localaddress) ; freeallregisters ; initstack end (* enterprogram *) ; procedure leaveprogram ; var message : stackentry ; begin if codeistobegenerated then begin insertatcodelocation(forframesize,lastlocaladdress+1) ; systemcall(progpostlude) ; closecodespace ; end end (* leaveprogram *) ; procedure enterflowunit (* flowroutine : monitorroutines; var flowloc : addrrange; var countloc : counteraddrrange *) ; begin if codeistobegenerated then begin systemcall(flowroutine); flowloc := currentaddress; countloc := currentaddress; (* inline *) copycode(0); (* counter *) end end (* enterflowunit *) ; procedure openstatement ( linenumber : integer ; statkind : symboltype ) ; var statentry : stackentry ; begin new(statentry) ; with statentry^ do begin kind := statementbase ; codewasbeinggenerated := codeistobegenerated end ; stack(statentry) ; (* may be removed later codeistobegenerated := true ; - - - - - *) protectedformals := 0 ; freeallregisters end (* openstatement *) ; procedure closstatement ; var debris,statentry : stackentry ; begin while topstackentry^.kind # statementbase do begin unstack(debris) ; freestackentry(debris) end ; unstack(statentry) ; (* may be removed later codeistobegenerated := statentry^.codewasbeinggenerated ; - - - - - *) freeallregisters ; freestackentry(statentry) end (* clostatement *) ; (* --- variables , expressions and assignment --- *) (* --- global variable initialisation ----------- *) procedure startinitialisationof ( varaddress : runtimeaddress ) ; begin initaddress := varaddress.relativeaddress end ; procedure initialvalue ( initvalue : valu ) ; var next : stringp ; begin if codeistobegenerated then begin with initvalue do if kind = stringvalue then begin next := string ; repeat filecode(initaddress,next^.word) ; initaddress := initaddress + 1 ; next := next^.nextword until next = nil ; end else begin filecode(initaddress,ival1) ; initaddress := initaddress + 1 ; if size = 2 then begin filecode(initaddress,ival2) ; initaddress := initaddress + 1 end end end end (* initialvalue *) ; (* --- 1. variable access --------- *) procedure stackreference ( indirct : boolean ; location : runtimeaddress ; representation : typerepresentation ) ; var refentry : stackentry ; begin if codeistobegenerated then begin new(refentry) ; with refentry^ do begin rep := representation ; mayhaveoverflowed := false ; kind := reference ; with wordaddress do begin adjustment := 0 ; if indirct then access := indirect else access := direct ; offset := location.relativeaddress ; staticlevel := location.blocklevel end ; partwordreference := false ; indexed := false end ; stack(refentry) end end (* stackreference *) ; procedure stackresult(representation : typerepresentation) ; var resultentry : stackentry ; begin new(resultentry) ; with resultentry^ do begin rep := representation ; kind := result ; inregister := true ; end ; stack(resultentry) ; end (* stack result *) ; procedure indexedreference ( packedarray : boolean ; lowbound,highbound : integer ; elementrepresentation:typerepresentation) ; var indexentry : stackentry ; indexconstant : boolean ; normalisedindex : addrrange ; elementsperword : 2..wordlength ; begin if codeistobegenerated then begin unstack(indexentry) ; rangecheck(indexentry,lowbound,highbound) ; if indexentry^.kind = konstant then begin indexconstant := true ; normalisedindex := indexentry^.konstvalue.ival1 - lowbound ; freestackentry(indexentry) end else indexconstant := false ; with topstackentry^ do begin if packedarray and (elementrepresentation.size = 1) and (elementrepresentation.bitsize <= 12) then begin removeindicesfrom(topstackentry) ; partwordreference := true ; elementsperword := wordlength div elementrepresentation.bitsize ; bitsize := wordlength div elementsperword ; if indexconstant then begin wordaddress.adjustment := wordaddress.adjustment + normalisedindex div elementsperword ; bitoffset := wordlength - bitsize * (normalisedindex mod elementsperword +1); indexedpartword := false ; charposition := false end else begin bitoffset := 0 ; indexedpartword := true ; indexevaluated := false ; index := indexentry ; indexentry^.factor := elementsperword ; lowerbound := lowbound end end else begin if indexconstant then wordaddress.adjustment := wordaddress.adjustment + normalisedindex*elementrepresention.size else begin wordaddress.adjustment := wordaddress.adjustment - lowbound*elementrepresentation.size; indexentry^.factor := elementrepresentation.size ; if indexed then indexentry^.nextentry := indices else begin indexentry^.nextentry := nil ; indexed := true end ; indices := indexentry end end ; rep := elementrepresentation end end end (* indexedreference *) ; procedure fieldreference ( field : fieldoffset ; fieldrepresentation : typerepresentation ) ; begin if codeistobegenerated then begin with topstackentry^ do begin if field.partword then begin if not partwordreference then begin removeindicesfrom(topstackentry) ; partwordreference := true ; indexedpartword := false ; charposition := false ; bitoffset := 0 end ; bitsize := field.bitsize ; bitoffset := bitoffset + field.bitoffset end ; wordaddress.adjustment := wordaddress.adjustment + field.wordoffset ; rep := fieldrepresentation end end end (* fieldreference *) ; procedure pnterreference ( representation : typerepresentation ) ; begin if codeistobegenerated then begin with topstackentry^ do begin if (kind = reference) and (wordaddress.access = direct) and not partwordreference and not indexed then with wordaddress do begin offset := offset + adjustment ; adjustment := 0 ; access := indirect end else begin loadx(xref,topstackentry) ; kind := reference ; with wordaddress do begin adjustment := 0 ; access := evaluated ; inxref := true end ; partwordreference := false ; indexed := false end ; bindregistersto(topstackentry) ; rep := representation end end end (* pnterreference *) ; procedure withreference ( withbase : stackentry ; field : fieldoffset ; fieldrepresentation : typerepresentation ) ; var fieldrefentry : stackentry ; begin if codeistobegenerated then begin new(fieldrefentry) ; fieldrefentry^ := withbase^ ; with fieldrefentry^ do begin rep := fieldrepresentation ; wordaddress.adjustment := wordaddress.adjustment + field.wordoffset ; if field.partword then begin if not partwordreference then begin partwordreference := true ; bitoffset := field.bitoffset ; indexedpartword := false ; charposition := false end else bitoffset := bitoffset + field.bitoffset ; bitsize := field.bitsize end end ; stack(fieldrefentry) end end (* withreference *) ; procedure filereference ( packedfile, textfile : boolean ; elementrepresentation : typerepresentation ) ; begin if codeistobegenerated then with topstackentry^ do begin rep := elementrepresentation ; if (kind = reference) and (wordaddress.access = direct) (* adjustment := adjustment + elpoffset(=0) *) then wordaddress.access := indirect else begin loadx(xref,topstackentry) ; kind := reference ; with wordaddress do begin adjustment := 0 ; (* elpoffset = 0 *) access := evaluated ; inxref := true end end ; bindregistersto(topstackentry) ; if textfile then begin partwordreference := true ; indexedpartword := false ; charposition := true end end end ; procedure openwith ( var withbase : stackentry ) ; var xmodsaved : boolean ; tostoreaddress,tostoreshift : addrrange ; xadd : register ; xstore : modifier ; begin if codeistobegenerated then begin charaddressingacceptable := false ; address(topstackentry) ; xmodsaved := false ; with addressed do begin if m in [xmod,xref] then begin get1worklocation(tostoreaddress) ; with topstackentry^.wordaddress do begin adjustment := n ; access := evaluated ; inxref := false ; disposable := false ; tempref := tostoreaddress end ; if (tostoreaddress > 4095) and ((m=xmod) or ispartword and (shiftm=xmod)) then begin ins(ldx,0,xmod,0) ; xmodsaved := true end ; if (m = xmod) and xmodsaved then xadd := 0 else xadd := m ; xstore := xlocal ; normalise(tostoreaddress,xstore) ; ins(sto,xadd,tostoreaddress,xstore) end ; if ispartword then begin if (shiftm # 0) then begin get1worklocation(tostoreshift) ; with topstackentry^ do begin indexevaluated := true ; storedshift := tostoreshift end ; if (tostoreshift > 4095) and (shiftm = xmod) and not xmodsaved then begin ins(ldx,0,shiftm,0) ; xmodsaved := true end ; if (shiftm = xmod) and xmodsaved then shiftm := 0 ; xstore := xlocal ; normalise(tostoreshift,xstore) ; ins(sto,shiftm,tostoreshift,xstore) end end else topstackentry^.indexed := false end ; withbase := topstackentry ; charaddressingacceptable := true end end (* openwith *) ; procedure closewith ; var withbase : stackentry ; begin if codeistobegenerated then begin unstack(withbase) ; with withbase^ do begin if wordaddress.access = evaluated then freeworklocation(wordaddress.tempref) ; if partwordreference and indexedpartword and indexevaluated then freeworklocation(storedshift) end ; freestackentry(withbase) end end (* closewith *) ; (* --- 2. expression evaluation --- *) (* ------ integer arithmetic ------ *) function valueiszero ( entry : stackentry ) : boolean ; var next : stringp ; begin with entry^ do if kind = konstant then with konstvalue do case kind of intvalue : valueiszero := (ival1 = 0) ; charvalue: valueiszero := (cval = chr(0)) ; boolvalue: valueiszero := not bval ; realvalue: valueiszero := (rval = 0.0) ; setvalue : if setval = [ ] then valueiszero := true else valueiszero := false ; stringvalue : begin next := string ; while (next # nil) and(next^.word = 0) do next := next^.nextword ; valueiszero :=(next = nil) end end else valueiszero := false end (* valueiszero *) ; procedure ctarithmetic ( operator : optype ; left,right : integer ; var result : integer ) ; (* carries out operation result := left operator right where operator is one of plus,minus,mul,div,mod - avoiding machine overflow but setting the global overflowoccurred *) begin overflowoccurred := false ; case operator of plus, minus: begin if operator = minus then right := -right ; if (left>0) and (right>0) and (left>maxint-right) or (left<0) and (right<0) and (-left>maxint+right) then begin overflowoccurred := true ; posoverflow := (left > 0) end else result := left + right end ; mul : begin if (right # 0) and (abs(left) > maxint div abs(right)) then begin overflowoccurred := true ; posoverflow := (left > 0) and (right > 0) or (left < 0) and (right < 0) end else result := left * right end ; idiv : if right = 0 then overflowoccurred := true else result := left div right ; imod : if right = 0 then overflowoccurred := true else result := left mod right end end (* ctarithmetic *) ; procedure integerfunction ( whichfunc : stdprocfuncs ) ; var positivevalue : codesequence ; loadreg : register ; i,c : 0..47 ; procedure countbitsin ( x : register ) ; var nextelement,nullelement : codesequence ; begin startcodesequence(nextelement) ; expectcodesequence(nullelement) ; jumpins(bpz,x,nullelement) ; ins(adn,4,1,0) ; nextiscodesequence(nullelement) ; shiftins(slls,x,1,0) ; jumpins(bnz,x,nextelement) end (* countbitsin *) ; procedure setlimitsforresult ; var oldmin,oldmax,newmin,newmax : integer ; begin oldmin := topstackentry^.rep.min ; oldmax := topstackentry^.rep.max ; case whichfunc of absf, sqrf : begin if oldmin < 0 then if oldmax >= 0 then begin newmin := 0 ; if -oldmin > oldmax then newmax := -oldmin else newmax := oldmax end else begin newmin := -oldmax ; newmax := -oldmin end else begin newmin := oldmin ; newmax := oldmax end ; if whichfunc = sqrf then begin ctarithmetic(mul,newmin,newmin,newmin) ; if overflowoccurred then error(303) ; ctarithmetic(mul,newmax,newmax,newmax) ; topstackentry^.mayhaveoverflowed := overflowoccurred end end ; succf : begin ctarithmetic(plus,oldmin,1,newmin) ; ctarithmetic(plus,oldmax,1,newmax) ; topstackentry^.mayhaveoverflowed := overflowoccurred end ; predf : begin ctarithmetic(minus,oldmax,1,newmax) ; ctarithmetic(minus,oldmin,1,newmin) ; topstackentry^.mayhaveoverflowed := overflowoccurred end ; cardf : begin newmin := 0 ; if topstackentry^.rep.size = 1 then newmax := topstackentry^.rep.bitsize else newmax := 47 end end ; topstackentry^.rep.min := newmin ; topstackentry^.rep.max := newmax end (* setlimitsforresult *) ; begin if codeistobegenerated then begin if whichfunc = ordf then begin if topstackentry^.rep.size # 1 then error(125) end else if whichfunc = chrf then begin rangecheck(topstackentry,0,63) ; topstackentry^.rep := charrepresentation end else if whichfunc = addressf then begin get1register(loadreg) ; loadaddress(loadreg,topstackentry) ; freeanyworklocationsfrom(topstackentry) ; with topstackentry^ do begin rep := pointerrepresentation ; kind := result ; inregister := true ; reg := loadreg end end else begin if topstackentry^.kind = konstant then with topstackentry^.konstvalue do if whichfunc = oddf then begin kind := boolvalue ; bval := odd(ival1) ; topstackentry^.rep := booleanrepresentation end else begin case whichfunc of absf : if ival1 < 0 then ctarithmetic(minus,0,ival1,ival1) else overflowoccurred := false ; sqrf : ctarithmetic(mul,ival1,ival1,ival1) ; succf : ctarithmetic(plus,ival1,1,ival1) ; predf : ctarithmetic(minus,ival1,1,ival1) ; cardf : begin c := 0 ; for i := 0 to 47 do if i in setval then c := c + 1 ; kind := intvalue ; ival1 := c ; overflowoccurred := false end end ; if overflowoccurred then error(303) end else begin if whichfunc = sqrf then begin lockregister(7) ; load(topstackentry) ; unlockregister(7) end else if whichfunc = cardf then begin lockregister(4) ; load(topstackentry) ; unlockregister(4) end else load(topstackentry) ; case whichfunc of absf : begin expectcodesequence(positivevalue) ; jumpins(bpz,loaded.reg,positivevalue) ; ins(ngx,loaded.reg,loaded.reg,0) ; nextiscodesequence(positivevalue) end ; sqrf : begin saveregister(loaded.reg + 1) ; ins(mpy,loaded.reg,loaded.reg,0) ; if locallyreqd[checks] then shiftins(slad,loaded.reg,23,0) else topstackentry^.reg := loaded.reg + 1 end ; oddf : begin ins(andn,loaded.reg,1,0) ; topstackentry^.rep := booleanrepresentation end ; succf : ins(adn,loaded.reg,1,0) ; predf : ins(sbn,loaded.reg,1,0) ; cardf : begin saveregister(4) ; ins(ldn,4,0,0) ; countbitsin(loaded.reg) ; if loaded.size = 2 then countbitsin(loaded.reg + 1 ) ; with topstackentry^ do begin rep := integerrepresentation ; reg := 4 end end end (* case *) ; bindregistersto(topstackentry) end (* not a constant *) ; if whichfunc # oddf then setlimitsforresult end end end (* integerfunction *) ; procedure negateinteger ; var chosenreg : register ; thoseused : setofregisters ; newmax : integer ; begin if codeistobegenerated then begin with topstackentry^ do begin if kind = konstant then konstvalue.ival1 := -konstvalue.ival1 else begin chosenreg := bestregisterfor(topstackentry) ; listthoseusedby(topstackentry,thoseused) ; if not(chosenreg in thoseused) then saveregister(chosenreg) ; addressvalue(topstackentry) ; with addressed do ins(ngx,chosenreg,n,m) ; freeanyworklocationsfrom(topstackentry) ; kind := result ; inregister := true ; reg := chosenreg ; bindregistersto(topstackentry) end ; newmax := -rep.min ; rep.min := -rep.max ; rep.max := newmax end end end (* negateinteger *) ; procedure analyse ( var operand : operanddescription ) ; begin with operand,entry^ do if kind = konstant then begin ispartword := false ; isinregister := false ; isconstant := true ; cvalue := konstvalue.ival1 ; iszero := (cvalue = 0) ; testforpowerof2(cvalue) ; ispowerof2 := powerof2 ; log2 := logbase2 end else begin isconstant := false ; iszero := false ; ispowerof2 := false ; ispartword := (kind = reference) and partwordreference ; isinregister := (kind = result) and inregister end end (* analyse *) ; procedure binaryintegeroperation ( operator : optype ) ; var leftoperand,rightoperand, increment,multiplier : operanddescription ; reslt : integer ; resultreg,remainderreg,quotientreg : register ; thoseused : setofregisters ; resultentry : stackentry ; afteradjustment : codesequence ; procedure setlimitsforresult ; var leftmin,leftmax,rightmin,rightmax, resultmin,resultmax,savedmin : integer ; possibleoverflow : boolean ; ufcount,ofcount : integer ; procedure trymin ( possiblemin : integer ) ; begin if lt(possiblemin,resultmin) then resultmin := possiblemin end (* trymin *) ; procedure trymax ( possiblemax : integer ) ; begin if lt(resultmax,possiblemax) then resultmax := possiblemax end (* trymax *) ; procedure tryproduct ( bound1,bound2 : integer ) ; var product : integer ; begin ctarithmetic(mul,bound1,bound2,product) ; if overflowoccurred then if posoverflow then begin ofcount := ofcount+1 ; resultmax := maxint end else begin ufcount := ufcount+1 ; resultmin := -maxint end else begin trymin(product) ; trymax(product) end end (* tryproduct *) ; procedure tryquotient ( bound1,bound2 : integer ) ; var quotient : integer ; begin ctarithmetic(idiv,bound1,bound2,quotient) ; trymin(quotient) ; trymax(quotient) end (* tryquotient *) ; begin with leftoperand.entry^.rep do begin leftmin := min ; leftmax := max end ; with rightoperand.entry^.rep do begin rightmin := min ; rightmax := max end ; possibleoverflow := leftoperand.entry^.mayhaveoverflowed or rightoperand.entry^.mayhaveoverflowed ; case operator of plus, minus : begin if operator = minus then begin savedmin := rightmin ; rightmin := -rightmax ; rightmax := -savedmin end ; ctarithmetic(plus,leftmin,rightmin,resultmin) ; if overflowoccurred then if posoverflow then error(303) else begin possibleoverflow := true ; resultmin := -maxint end ; ctarithmetic(plus,leftmax,rightmax,resultmax) ; if overflowoccurred then if posoverflow then begin possibleoverflow := true ; resultmax := maxint end else error(303) end ; mul : begin resultmin := maxint ; resultmax := -maxint ; ofcount := 0 ; ufcount := 0 ; tryproduct(leftmin,rightmin) ; tryproduct(leftmin,rightmax) ; tryproduct(leftmax,rightmin) ; tryproduct(leftmax,rightmax) ; if (ofcount # 0) or (ufcount # 0) then begin possibleoverflow := true ; if (ofcount = 4) or (ufcount = 4) then error(303) end end ; idiv : begin resultmin := maxint ; resultmax := -maxint ; if rightmin # 0 then begin tryquotient(leftmin,rightmin) ; tryquotient(leftmax,rightmin) ; end ; if rightmax # 0 then begin tryquotient(leftmin,rightmax) ; tryquotient(leftmax,rightmax) end ; if (rightmin <= 0) and (rightmax >= 0) then begin possibleoverflow := true ; if rightmin < 0 then begin tryquotient(leftmin,-1) ; tryquotient(leftmax,-1) end ; if rightmax > 0 then begin tryquotient(leftmin,1) ; tryquotient(leftmax,1) end ; if (rightmin = 0) and (rightmax = 0) then error(303) end end ; imod : if (rightmin = 0) and (rightmax = 0) then error(303) else if eq(leftmin,leftmax) and eq(rightmin,rightmax) then begin resultmin := leftmin mod rightmin ; resultmax := resultmin end else begin resultmin := 0 ; resultmax := 0 ; if (rightmin <= 0) and (rightmax >= 0) then possibleoverflow := true ; if (leftmin < 0) and (rightmin < 0) then if leftmin < rightmin then trymin(rightmin+1) else trymin(leftmin) ; if (leftmin < 0) and (rightmax > 0) then if -leftmin > rightmax then trymin(-rightmax+1) else trymin(leftmin) ; if (leftmax > 0) and (rightmin < 0) then if leftmax >= -rightmin then trymax(-rightmin-1) else trymax(leftmax) ; if (leftmax > 0) and (rightmax > 0) then if leftmax >= rightmax then trymax(rightmax-1) else trymax(leftmax) end end ; with resultentry^ do begin rep.min := resultmin ; rep.max := resultmax ; mayhaveoverflowed := possibleoverflow end end (* setlimitsforresult *) ; begin if codeistobegenerated then begin unstack(rightoperand.entry) ; unstack(leftoperand.entry) ; new(resultentry) ; resultentry^.rep := integerrepresentation ; setlimitsforresult ; analyse(leftoperand) ; analyse(rightoperand); if leftoperand.isconstant and rightoperand.isconstant then begin ctarithmetic(operator,leftoperand.cvalue, rightoperand.cvalue,reslt) ; if overflowoccurred then error(303) ; with resultentry^ do begin kind := konstant ; with konstvalue do begin size := 1 ; kind := intvalue ; ival1:= reslt end end end else if leftoperand.iszero then case operator of plus : resultentry^ := rightoperand.entry^ ; minus : begin if rightoperand.isinregister then resultreg := rightoperand.entry^.reg else get1register(resultreg) ; addressvalue(rightoperand.entry) ; with addressed do ins(ngx,resultreg,n,m) ; with resultentry^ do begin kind := result ; inregister := true ; reg := resultreg end ; bindregistersto(resultentry) end ; mul , idiv , imod : resultentry^ := leftoperand.entry^ end (* case *) else if rightoperand.iszero then case operator of plus , minus : resultentry^ := leftoperand.entry^ ; mul : resultentry^ := rightoperand.entry^ ; idiv , imod : error(303) end (* case *) else begin case operator of plus : begin if rightoperand.isinregister or rightoperand.ispartword then begin load(rightoperand.entry) ; increment := leftoperand end else begin load(leftoperand.entry) ; increment := rightoperand end ; if increment.isconstant then constins(adx,loaded.reg,increment.cvalue) else begin addressvalue(increment.entry) ; with addressed do ins(adx,loaded.reg,n,m) end ; resultreg := loaded.reg end ; minus : begin load(leftoperand.entry) ; if rightoperand.isconstant then constins(sbx,loaded.reg,rightoperand.cvalue) else begin addressvalue(rightoperand.entry) ; with addressed do ins(sbx,loaded.reg,n,m) end ; resultreg := loaded.reg end ; mul : begin lockregister(7) ; if leftoperand.ispowerof2 or rightoperand.isinregister or (rightoperand.isconstant and not rightoperand.ispowerof2) or rightoperand.ispartword then begin load(rightoperand.entry) ; multiplier := leftoperand end else begin load(leftoperand.entry) ; multiplier := rightoperand end ; unlockregister(7) ; if multiplier.ispowerof2 then begin if multiplier.log2 # 0 then shiftins(slas,loaded.reg,multiplier.log2, 0) ; end else begin listthoseusedby(multiplier.entry,thoseused) ; if not( loaded.reg+1 in thoseused) then saveregister(loaded.reg+1) ; addressvalue(multiplier.entry) ; with addressed do ins(mpy,loaded.reg,n,m) ; shiftins(slad,loaded.reg,23,0) ; end; resultreg := loaded.reg end ; idiv , imod : begin lockregister(4) ; if (operator=imod) and rightoperand.isinregister then begin lockregister(rightoperand.entry^.reg + 1) ; load(leftoperand.entry) ; unlockregister(rightoperand.entry^.reg + 1) end else load(leftoperand.entry) ; unlockregister(4) ; remainderreg := loaded.reg - 1 ; quotientreg := loaded.reg ; listthoseusedby(rightoperand.entry,thoseused) ; if not( remainderreg in thoseused) then saveregister(remainderreg) ; addressvalue(rightoperand.entry) ; with addressed do ins(dvs,remainderreg,n,m) ; expectcodesequence(afteradjustment) ; jumpins(bpz,quotientreg,afteradjustment) ; jumpins(bze,remainderreg,afteradjustment) ; if operator = imod then with addressed do ins(sbx,remainderreg,n,m) else ins(adn,quotientreg,1,0) ; nextiscodesequence(afteradjustment) ; if operator = imod then resultreg := remainderreg else resultreg := quotientreg end end (* case *) ; with resultentry^ do begin kind := result ; inregister := true ; reg := resultreg end ; bindregistersto(resultentry) end ; stack(resultentry) ; freestackentry(leftoperand.entry) ; freestackentry(rightoperand.entry) end end (* binaryintegeroperation *) ; procedure integercomparison ( operator : optype ) ; var leftoperand,rightoperand : stackentry ; difference : integer ; resultvalue : boolean ; begin if codeistobegenerated then begin if operator in [leop,gtop] then begin unstack(rightoperand) ; unstack(leftoperand) ; stack(rightoperand) ; stack(leftoperand) end ; binaryintegeroperation(minus) ; rangecheck(topstackentry,-maxint,maxint) ; with topstackentry^ do begin if kind = konstant then begin difference := konstvalue.ival1 ; case operator of ltop , gtop : resultvalue := (difference < 0) ; leop , geop : resultvalue := (difference >=0) ; eqop : resultvalue := (difference = 0) ; neop : resultvalue := (difference # 0) end ; with konstvalue do begin kind := boolvalue ; bval := resultvalue end end else begin load(topstackentry) ; kind := condition ; kindofcondition := xcondition ; falsejumpins := fjumpfor[operator] ; inconditionregister := true ; condregister := loaded.reg ; bindregistersto(topstackentry) end ; rep := booleanrepresentation end end end (* integercomparison *) ; (* ------ real arithmetic ------ *) procedure floatinteger(stackposition : stacktop ) ; var floatentry : stackentry ; oldvalue : real ; begin if codeistobegenerated then begin if stackposition = topofstack then floatentry := topstackentry else floatentry := topstackentry^.nextentry ; with floatentry^ do begin if kind = konstant then with konstvalue do begin oldvalue := ival1 ; size := 2 ; kind := realvalue ; rval := oldvalue end else begin lockregister(7) ; load(floatentry) ; unlockregister(7) ; saveregister(loaded.reg + 1) ; ins(ldn,loaded.reg+1,0,0) ; saveregister(fpa) ; if locallyreqd[checks] then checkoverflow ; mayhaveoverflowed := false ; ins(float,0,loaded.reg,0) ; reg := fpa ; bindregistersto(floatentry) end ; rep.size := 2 ; rep.floatingpoint := true end end end (* floatinteger *) ; function valueinfpa ( entry : stackentry) : boolean ; begin valueinfpa := ((entry^.kind = result) and entry^.inregister and (entry^.reg = fpa)) end (* valueinfpa *) ; procedure realfunction ( whichfunc : stdprocfuncs ) ; var positivevalue,afteradjustment : codesequence ; chosenreg : register ; m : stdprocfuncs ; i : 0..9 ; begin if codeistobegenerated then begin case whichfunc of absf : begin loadfpa(topstackentry) ; expectcodesequence(positivevalue) ; get2registers(chosenreg) ; ins(sfp,0,chosenreg,0) ; jumpins(bpz,chosenreg,positivevalue) ; ins(fsb,4,floatzero,0) ; nextiscodesequence(positivevalue) end ; sqrf : if valueinfpa(topstackentry) then begin ins(sfp,0,square,0) ; (* --- *) ins(fmpy,0,square,0) ; (* --- *) end else begin loadfpa(topstackentry) ; with addressed do ins(fmpy,0,n,m) end ; truncf , roundf : begin loadfpa(topstackentry) ; get2registers(chosenreg) ; ins(fix,0,chosenreg,0) ; expectcodesequence(afteradjustment) ; if whichfunc = truncf then jumpins(bpz,chosenreg,afteradjustment) else begin ins(txl,chosenreg+1,pointfive,0) ; jumpins(brn,oncset,afteradjustment) end ; ins(adn,chosenreg,1,0) ; nextiscodesequence(afteradjustment) ; topstackentry^.reg := chosenreg ; topstackentry^.rep := integerrepresentation end ; sinf , cosf , expf , lnf , sqrtf , arctanf : begin loadfpa(topstackentry) ; saveallregisters ; ins(ldn,3,ord(whichfunc)-ord(sinf),0) ; systemcall(mathfuncs) end end (* case *) ; bindregistersto(topstackentry) ; topstackentry^.mayhaveoverflowed := true end end (* realfunction *) ; procedure negatereal ; begin if codeistobegenerated then begin with topstackentry^ do if kind = konstant then konstvalue.rval := -konstvalue.rval else begin loadfpa(topstackentry) ; ins(fsb,4,floatzero,0) ; bindregistersto(topstackentry) end end end (* negatereal *) ; procedure binaryrealoperation ( realoperator : optype ) ; label 1 ; var leftoperand,rightoperand,resultentry : stackentry ; xf : 0..4 ; resultvalue,rval1,rval2 : real ; begin if codeistobegenerated then begin unstack(rightoperand) ; unstack(leftoperand) ; new(resultentry) ; resultentry^.rep := realrepresentation ; if valueiszero(rightoperand) and (realoperator = rdiv) then error(303) else if (leftoperand^.kind = konstant) and (rightoperand^.kind = konstant) then begin with leftoperand^.konstvalue do begin rval1 := rval ; rval2 := rightoperand^.konstvalue.rval ; icl(lfp,0,rval1) ; case realoperator of plus : icl(fad,0,rval2) ; minus : icl(fsb,0,rval2) ; mul : icl(fmpy,0,rval2) ; rdiv : icl(fdvd,0,rval2) end ; icl(sfp,0,resultvalue) ; icl(brn,onvclear,1) ; error(303) ; 1: end ; with resultentry^ do begin kind := konstant ; with konstvalue do begin size := 2 ; kind := realvalue ; rval := resultvalue end end end else begin if valueinfpa(rightoperand) then begin xf := 4 ; addressvalue(leftoperand) end else begin xf := 0 ; loadfpa(leftoperand) ; addressvalue(rightoperand) end ; with addressed do ins(fpinsfor[realoperator],xf,n,m) ; with resultentry^ do begin kind := result ; inregister := true ; reg := fpa end ; bindregistersto(resultentry) end ; resultentry^.mayhaveoverflowed := true ; stack(resultentry) ; freestackentry(leftoperand) ; freestackentry(rightoperand) end end (* binaryrealoperation *) ; procedure realcomparison ( operator : optype ) ; var leftoperand,rightoperand,resultentry : stackentry ; newvalue : boolean ; rightminusleftneeded,ngxneeded,reversedfsbneeded : boolean ; chosenreg : register ; begin if codeistobegenerated then begin unstack(rightoperand) ; unstack(leftoperand) ; new(resultentry) ; resultentry^.rep := booleanrepresentation ; if (rightoperand^.kind = konstant) and (leftoperand^.kind = konstant) then begin with leftoperand^.konstvalue do case operator of ltop : newvalue := rval < rightoperand^.konstvalue.rval ; leop : newvalue := rval <= rightoperand^.konstvalue.rval ; geop : newvalue := rval >= rightoperand^.konstvalue.rval ; gtop : newvalue := rval > rightoperand^.konstvalue.rval ; neop : newvalue := rval # rightoperand^.konstvalue.rval ; eqop : newvalue := rval = rightoperand^.konstvalue.rval end ; with resultentry^ do begin kind := konstant ; with konstvalue do begin size := 1 ; kind := boolvalue ; bval := newvalue end end ; end else begin rightminusleftneeded := (operator in [leop,gtop]) ; if valueiszero(leftoperand) and not valueinfpa(rightoperand) and rightminusleftneeded or valueiszero(rightoperand) and not valueinfpa(leftoperand) and not rightminusleftneeded then begin get1register(chosenreg) ; if valueiszero(leftoperand) then addressvalue(rightoperand) else addressvalue(leftoperand) ; with addressed do ins(ldx,chosenreg,n,m) end else begin if valueinfpa(rightoperand) then begin freeregistersfrom(rightoperand) ; addressvalue(leftoperand) ; reversedfsbneeded := not rightminusleftneeded end else begin loadfpa(leftoperand) ; addressvalue(rightoperand) ; reversedfsbneeded := rightminusleftneeded end ; with addressed do if reversedfsbneeded then ins(fsb,4,n,m) else ins(fsb,0,n,m) ; get2registers(chosenreg) ; ins(sfp,0,chosenreg,0) end ; resultentry^.mayhaveoverflowed := true ; resultentry^.rep := integerrepresentation ; rangecheck(resultentry,-maxint,maxint) ; resultentry^.rep := booleanrepresentation ; with resultentry^ do begin kind := condition ; kindofcondition := xcondition ; falsejumpins := fjumpfor[operator] ; inconditionregister := true ; condregister := chosenreg end ; bindregistersto(resultentry) end ; stack(resultentry) ; freestackentry(leftoperand) ; freestackentry(rightoperand) end end (* realcomparison *) ; (* ------ boolean arithmetic ------ *) procedure negateboolean ; begin if codeistobegenerated then with topstackentry^ do case kind of konstant : konstvalue.bval := not konstvalue.bval ; condition : case kindofcondition of xcondition : falsejumpins := reverseof[falsejumpins] ; ccondition : falseifset := not falseifset ; multijumpcondition : jumpcondition := not jumpcondition end ; reference , result : begin load(topstackentry) ; ins(ern,loaded.reg,1,0) ; bindregistersto(topstackentry) end end (* case *) end (* negateboolean *) ; procedure binarybooleanoperator ( operator : optype ; firstsuchoperator : boolean ) ; var booleanoperand, condentry : stackentry ; begin if codeistobegenerated then begin unstack(booleanoperand) ; if firstsuchoperator then begin new(condentry) ; with condentry^ do begin rep := booleanrepresentation ; kind := condition ; kindofcondition := multijumpcondition ; jumpcondition := (operator = orop) ; expectcodesequence(jumpdestination) end ; stack(condentry) end ; with topstackentry^ do jumpif(booleanoperand,jumpcondition,jumpdestination) ; freestackentry(booleanoperand) end end (* binarybooleanoperator *) ; procedure excludeconditions ; begin if codeistobegenerated then with topstackentry^ do if kind = condition then begin load(topstackentry) ; bindregistersto(topstackentry) end end (* excludeconditions *) ; (* ------ set arithmetic ------ *) function bitrepfor ( val,setsize : integer ) : integer ; begin if setsize = 1 then bitrepfor := val + 24 else bitrepfor := val end ; (* bitrepfor *) procedure singletonset ( setrepresentation : typerepresentation ) ; var i : 0..47 ; begin if codeistobegenerated then begin if setrepresentation.size = 1 then rangecheck(topstackentry,0,23) else rangecheck(topstackentry,0,47) ; with topstackentry^ do begin if kind = konstant then with konstvalue do begin i := ival1 ; size := setrepresentation.size ; kind := setvalue ; setval := [ bitrepfor(i,size) ] end else begin (* generate a reference to a monitor table *) loadx(xref,topstackentry) ; if setrepresentation.size # 1 then ins(adx,xref,xref,0) ; factor := 0 ; kind := reference ; with wordaddress do begin if setrepresentation.size = 1 then adjustment := singlewordbitmasks else adjustment := doublewordbitmasks ; access := evaluated ; inxref := true end ; partwordreference := false ; indexed := false ; bindregistersto(topstackentry) end ; rep := setrepresentation end end end (* singletonset *) ; procedure rangeset ( setrepresentation : typerepresentation ) ; var upperbound,lowerbound,rangeentry : stackentry ; i,shiftn : integer ; loadreg,savereg : register ; shiftm : modifier ; konstrange : set of 0..47 ; function xrefneededtoaddress ( entry : stackentry ) : boolean ; begin with entry^ do case kind of reference : if partwordreference then if indexedpartword then if indexevaluated then xrefneededtoaddress := ((wordaddress.staticlevel # level) and (wordaddress.staticlevel # globallevel)) else xrefneededtoaddress := true else xrefneededtoaddress := false else xrefneededtoaddress := indexed ; formalreference : xrefneededtoaddress := true ; result , condition , statementbase : xrefneededtoaddress := false end (* case *) end (* xrefneededtoaddress *) ; begin if codeistobegenerated then begin unstack(upperbound) ; unstack(lowerbound) ; if setrepresentation.size = 1 then begin rangecheck(lowerbound,0,23) ; rangecheck(upperbound,0,23) end else begin rangecheck(lowerbound,0,47) ; rangecheck(upperbound,0,47) end ; new(rangeentry) ; if (upperbound^.kind = konstant) and (lowerbound^.kind = konstant) then begin konstrange :=[ ] ; for i := lowerbound^.konstvalue.ival1 to upperbound^.konstvalue.ival1 do konstrange := konstrange + [ bitrepfor(i,setrepresentation.size) ] ; with rangeentry^ do begin rep := setrepresentation ; kind := konstant ; with konstvalue do begin size := setrepresentation.size ; kind := setvalue ; setval := konstrange end end end else begin if setrepresentation.size = 1 then get1register(loadreg) else get2registers(loadreg) ; if lowerbound^.kind = konstant then begin shiftn := lowerbound^.konstvalue.ival1 ; shiftm := 0 ; loadx(xref,upperbound) ; constins(sbx,xref,shiftn) end else begin if xrefneededtoaddress(lowerbound) then begin load(upperbound) ; savereg := loaded.reg ; loadx(xmod,lowerbound) ; ins(ldx,xref,savereg,0) end else begin loadx(xref,upperbound) ; loadx(xmod,lowerbound) end ; ins(sbx,xref,xmod,0) ; shiftn := 0 ; shiftm := xmod end ; if setrepresentation.size = 1 then begin ins(ldx,loadreg,singlelengthmasks,xref) ; if (shiftn # 0) or (shiftm # 0) then shiftins(slls,loadreg,shiftn,shiftm) end else begin ins(adx,xref,xref,0) ; doubleins(ldx,loadreg,doublelengthmasks,xref) ; if (shiftn # 0) or (shiftm # 0) then shiftins(slld,loadreg,shiftn,shiftm) end ; with rangeentry^ do begin rep := setrepresentation ; kind := result ; inregister := true ; reg := loadreg end ; bindregistersto(rangeentry) end ; stack(rangeentry) ; freestackentry(lowerbound) ; freestackentry(upperbound) end end (* rangeset *) ; function empty ( entry : stackentry ) : boolean ; begin if entry^.kind = konstant then if entry^.konstvalue.setval = [ ] then empty := true else empty := false else empty := false end (* empty *) ; procedure binarysetoperation ( setoperator : optype ) ; var rightoperand,leftoperand,resultentry, firstoperand,secondoperand : stackentry ; loadreg,lr : register ; lm : integer ; thoseused : setofregisters ; logicalins : ordercode ; optimisable,firstwordzero : boolean ; newvalue : set of 0..47 ; procedure analyse ( entry : stackentry ) ; begin if entry^.kind = konstant then with entry^.konstvalue do if size = 1 then optimisable := false else begin firstwordzero := ival1=0 ; optimisable := firstwordzero or(ival2 = 0) end else optimisable := false end ; (* analyse *) begin (* binarysetoperation *) if codeistobegenerated then begin unstack(rightoperand) ; unstack(leftoperand) ; new(resultentry) ; if empty(leftoperand) then resultentry^.rep := rightoperand^.rep else resultentry^.rep := leftoperand^.rep ; if (rightoperand^.kind = konstant) and (leftoperand^.kind = konstant) then begin with leftoperand^.konstvalue do case setoperator of mul : newvalue:=setval * rightoperand^.konstvalue.setval ; plus : newvalue:=setval + rightoperand^.konstvalue.setval ; minus : newvalue:=setval - rightoperand^.konstvalue.setval end ; with resultentry^ do begin kind := konstant ; with konstvalue do begin size := rep.size ; kind := setvalue ; setval := newvalue end end end else begin if empty(leftoperand) or empty(rightoperand) then begin (* optimise if one of the operands is the empty set *) case setoperator of mul : if empty(leftoperand) then resultentry^ := leftoperand^ else resultentry^ := rightoperand^ ; plus : if empty(leftoperand) then resultentry^ := rightoperand^ else resultentry^ := leftoperand^ ; minus : resultentry^ := leftoperand^ end end else begin (* if appropriate,optimise by reversing operands *) case setoperator of mul , plus : if (rightoperand^.kind = result) and rightoperand^.inregister or (leftoperand^.kind = result) then begin firstoperand := rightoperand ; secondoperand := leftoperand end else begin firstoperand := leftoperand ; secondoperand := rightoperand end ; minus : begin firstoperand := rightoperand ; secondoperand := leftoperand end end (* case *) ; if setoperator = plus then logicalins := orx else logicalins := andx ; (* attempt further optimisation on second operand *) (* i.e. where one of the words of a multi-word *) (* constant set is zero *) analyse(secondoperand) ; if optimisable then begin if setoperator = plus then begin load(firstoperand) ; loadreg := loaded.reg end else begin loadreg := bestregisterfor(firstoperand) ; listthoseusedby(firstoperand,thoseused) ; if not(loadreg in thoseused) then saveregister(loadreg) ; if not(loadreg+1 in thoseused) then saveregister(loadreg+1) ; addressvalue(firstoperand) ; with addressed do if firstwordzero then begin ins(ldn,loadreg,0,0) ; ins(ldx,loadreg+1,n+1,m) end else begin ins(ldx,loadreg,n,m) ; ins(ldn,loadreg+1,0,0) end end ; if setoperator = minus then if firstwordzero then ins(erx,loadreg+1,smone,0) else ins(erx,loadreg,smone,0) ; if firstwordzero then begin lr := loadreg + 1 ; lm := secondoperand^.konstvalue.ival2 end else begin lr := loadreg ; lm := secondoperand^.konstvalue.ival1 end ; constins(logicalins,lr,lm) end else begin (* attempt optimisation on firstoperand *) (* this will only apply to set difference *) analyse(firstoperand) ; if (setoperator = minus) and optimisable then begin get2registers(loadreg) ; listthoseusedby(secondoperand,thoseused) ; if (loadreg in thoseused) then saveregister(loadreg) ; if (loadreg+1 in thoseused) then saveregister(loadreg+1) ; if firstwordzero then begin constins(ldx,loadreg+1,firstoperand^.konstvalue. ival2) ; ins(erx,loadreg+1,smone,0) end else begin constins(ldx,loadreg,firstoperand^.konstvalue. ival1) ; ins(erx,loadreg,smone,0) end ; addressvalue(secondoperand) ; with addressed do if firstwordzero then begin ins(ldx,loadreg,n,m) ; ins(andx,loadreg+1,n+1,m) end else begin ins(ldx,loadreg+1,n+1,m) ; ins(andx,loadreg,n,m) end end else begin (* usual case - neither operand optimisable *) load(firstoperand) ; loadreg := loaded.reg ; if setoperator = minus then begin ins(erx,loadreg,smone,0) ; if resultentry^.rep.size = 2 then ins(erx,loadreg+1,smone,0) end ; addressvalue(secondoperand) ; with addressed do if resultentry^.rep.size = 1 then ins(logicalins,loadreg,n,m) else doubleins(logicalins,loadreg,n,m) end end ; with resultentry^ do begin kind := result ; inregister := true ; reg := loadreg end end ; bindregistersto(resultentry) end ; stack(resultentry) ; freestackentry(leftoperand) ; freestackentry(rightoperand) end end (* binarysetoperation *) ; procedure setcomparison ( setoperator : optype ) ; var rightoperand,leftoperand,resultentry, firstoperand,secondoperand : stackentry ; localn : shortaddress ; localm : modifier ; logicalins : ordercode ; brnins : bze..bng ; brntype : (noncbranch,csetbranch,cclearbranch) ; newvalue,optimisable : boolean ; procedure loadandreduce (operand : stackentry) ; begin with operand^ do if (kind = result) and inregister then begin load(operand) ; (* to set loaded.reg & free registers*) if loaded.size = 2 then ins(orx,loaded.reg,loaded.reg + 1,0) end else begin get1register(loaded.reg) ; addressvalue(operand) ; with addressed do begin ins(ldx,loaded.reg,n,m) ; if size = 2 then ins(orx,loaded.reg,n+1,m) end end ; loaded.size := 1 end (* loadandreduce *) ; procedure analyse ( entry : stackentry ) ; begin if entry^.kind = konstant then with entry^.konstvalue do if size = 1 then optimisable := abs(ival1)<4096 else optimisable := (abs(ival1)<4096)and(abs(ival2)<4096) else optimisable := false end ; (* analyse *) begin (* setcomparison *) if codeistobegenerated then begin unstack(rightoperand) ; unstack(leftoperand) ; if setoperator = inop then if rightoperand^.rep.size = 1 then rangecheck(leftoperand,0,23) else rangecheck(leftoperand,0,47) ; new(resultentry) ; resultentry^.rep := booleanrepresentation ; if (rightoperand^.kind = konstant) and (leftoperand^.kind = konstant) then begin with leftoperand^.konstvalue do case setoperator of eqop : newvalue:= setval=rightoperand^.konstvalue.setval ; neop : newvalue:= setval#rightoperand^.konstvalue.setval ; leop : newvalue:= setval<=rightoperand^.konstvalue.setval; geop : newvalue:= setval>=rightoperand^.konstvalue.setval; inop : newvalue := bitrepfor(ival1,rightoperand^.rep.size) in rightoperand^.konstvalue.setval end (* case *) ; with resultentry^ do begin kind := konstant ; with konstvalue do begin size := 1 ; kind := boolvalue ; bval := newvalue end end end else begin brntype := noncbranch ; case setoperator of eqop , neop : begin if (rightoperand^.kind = result) and rightoperand^.inregister or (leftoperand^.kind = konstant) then begin firstoperand := rightoperand ; secondoperand := leftoperand end else begin firstoperand := leftoperand ; secondoperand := rightoperand end end ; inop , geop : begin firstoperand := leftoperand ; secondoperand := rightoperand end ; leop : begin firstoperand := rightoperand ; secondoperand := leftoperand end end (* case *) ; if empty(secondoperand) and (setoperator in [geop,leop,inop]) then with resultentry^ do begin kind := konstant ; with konstvalue do begin size := 1 ; kind := boolvalue ; bval := setoperator # inop end end else begin if (setoperator # inop) and empty(firstoperand) then begin (* will only apply to inclusion operators *) loadandreduce(secondoperand) ; brnins := bnz end else if empty(secondoperand) then begin (* will only apply to equality operators *) loadandreduce(firstoperand) ; if setoperator = eqop then brnins := bnz else brnins := bze end else begin analyse(secondoperand) ; if (setoperator # inop) and optimisable then begin (* making use of machine instructions *) (* capable of direct addressing *) load(firstoperand) ; with secondoperand^.konstvalue , loaded do begin if setoperator in [leop,geop] then begin ins(erx,reg,smone,0) ; if size = 2 then ins(erx,reg+1,smone,0) ; logicalins := andn end else logicalins := ern ; ins(logicalins,reg,ival1,0) ; if size = 2 then begin ins(logicalins,reg+1,ival2,0) ; ins(orx,reg,reg+1,0) end ; if setoperator = neop then brnins := bze else brnins := bnz end (* with *) end else begin case setoperator of eqop , neop : begin load(firstoperand) ; addressvalue(secondoperand) ; with loaded,addressed do if size = 1 then ins(txu,reg,n,m) else doubleins(txu,reg,n,m) ; if setoperator = eqop then brntype := csetbranch else brntype := cclearbranch end ; leop , geop : begin load(firstoperand) ; addressvalue(secondoperand) ; with loaded,addressed do if size = 1 then begin ins(andx,reg,n,m) ; ins(txu,reg,n,m) end else begin doubleins(andx,reg,n,m) ; doubleins(txu,reg,n,m) end ; brntype := csetbranch end ; inop : begin load(secondoperand) ; if loaded.size = 1 then begin localn:=singlewordbitmasks ; if firstoperand^.kind = konstant then begin localn := localn + firstoperand^. konstvalue.ival1; localm := 0 end else begin loadx(xref,firstoperand) ; localm := xref end ; ins(andx,loaded.reg,localn,localm) ; brnins := bze end else begin localn := 1 ; if firstoperand^.kind = konstant then begin localn := localn + firstoperand^. konstvalue.ival1; localm := 0 end else begin loadx(xref,firstoperand) ; localm := xref end ; shiftins(srcd,loaded.reg,localn, localm) ; brnins := bpz end end end (* case *) end end ; with resultentry^ do begin kind := condition ; if brntype = noncbranch then begin kindofcondition := xcondition ; falsejumpins := brnins ; inconditionregister := true ; condregister := loaded.reg end else begin kindofcondition := ccondition ; falseifset := (brntype = csetbranch) end end ; bindregistersto(resultentry) end end ; stack(resultentry) ; freestackentry(leftoperand) ; freestackentry(rightoperand) end end (* setcomparison *) ; (* ------ string arithmetic ------ *) procedure strngcomparison ( length : integer ; operator : optype ) ; var wordsfull,wordsused : addrrange ; lastwordfull,finaltestneeded : boolean ; maskneeded : addrrange ; firststring,secondstring,result : stackentry ; testins : txu..txl ; exit1,exit2,testloop : codesequence ; begin if codeistobegenerated then begin wordsfull := length div charsinword ; lastwordfull := (length mod charsinword = 0) ; if lastwordfull then wordsused := wordsfull else wordsused := wordsfull+1 ; if operator in [gtop,leop] then begin unstack(firststring) ; unstack(secondstring) end else begin unstack(secondstring) ; unstack(firststring) end ; if operator in [eqop,neop] then testins := txu else testins := txl ; new(result) ; with result^ do begin rep := booleanrepresentation ; kind := condition ; kindofcondition := multijumpcondition ; jumpcondition := (operator in [neop,gtop,ltop]) ; expectcodesequence(jumpdestination) end ; expectcodesequence(exit1) ; expectcodesequence(exit2) ; if wordsused <= 2 then begin load(firststring) ; addressvalue(secondstring) ; if wordsused = 2 then begin with addressed do ins(testins,loaded.reg,n,m) ; jumpins(brn,oncset,exit1) ; if testins = txl then begin with addressed do ins(txu,loaded.reg,n,m) ; jumpins(brn,oncset,exit2) end ; loaded.reg := loaded.reg+1 ; addressed.n := addressed.n+1 end ; finaltestneeded := true end else begin loadaddress(7,firststring) ; loadaddress(xref,secondstring) ; ins(ldx,xmod,7,0) ; constins(ldx,0,wordsfull) ; startcodesequence(testloop) ; ins(ldx,7,0,xmod) ; ins(testins,7,0,xref) ; jumpins(brn,oncset,exit1) ; if testins = txl then begin ins(txu,7,0,xref) ; jumpins(brn,oncset,exit2) end ; ins(adn,xmod,1,0) ; ins(adn,xref,1,0) ; ins(sbn,0,1,0) ; jumpins(bnz,0,testloop) ; if lastwordfull then finaltestneed := false else begin ins(ldx,7,0,xmod) ; loaded.reg := 7 ; with addressed do begin n := 0 ; m := xref end ; finaltestneeded := true end end ; if not lastwordfull then begin maskneeded := rtstringmasks-1 + length mod charsinword ; if firststring^.kind # konstant then ins(andx,loaded.reg,maskneeded,0) ; if secondstring^.kind # konstant then begin with addressed do begin ins(ldx,0,n,m) ; n :=0 ; m := 0 end ; ins(andx,0,maskneeded,0) end end ; if finaltestneeded then begin with addressed do ins(testins,loaded.reg,n,m) ; jumpins(brn,oncset,result^.jumpdestination) end ; linkcodesequence(exit1,result^.jumpdestination) ; nextiscodesequence(exit2) ; stack(result) ; freestackentry(firststring) ; freestackentry(secondstring) end end (* strngcomparison *) ; (* ------ constant ------ *) procedure stackconstant ( constvalue : valu ) ; var constentry : stackentry ; begin if codeistobegenerated then begin new(constentry) ; with constentry^ do begin rep.size := constvalue.size ; mayhaveoverflowed := false ; case constvalue.kind of intvalue , boolvalue , charvalue : begin if constvalue.ival1 < 0 then rep.bitsize := wordlength else rep.bitsize := bitsneededfor(constvalue.ival1) ; rep.max := constvalue.ival1 ; rep.min := constvalue.ival1 end ; realvalue : rep.floatingpoint := true ; setvalue : rep.floatingpoint := false ; stringvalue : if constvalue.size = 1 then rep.bitsize := wordlength else if constvalue.size = 2 then rep.floatingpoint := false end ; kind := konstant ; konstvalue := constvalue end ; stack(constentry) end end (* stackconstant *) ; (* --- 3. assignment -------------- *) procedure assignmentcode ( source,destination : stackentry ) ; var assigningzero : boolean ; size : addrrange ; begin size := destination^.rep.size ; if size > 2 then begin loadaddress(6,source) ; loadaddress(7,destination) ; while size > 512 do begin ins(move,6,0,0) ; ins(adn,6,512,0) ; ins(adn,7,512,0) ; size := size - 512 ; end ; ins(move,6,size mod 512,0) end else begin if size = 1 then rangecheck(source,destination^.rep.min, destination^.rep.max) ; if valueiszero(source) then assigningzero := true else begin load(source) ; assigningzero := false end ; address(destination) ; with addressed do if ispartword then if ischarposition then if assigningzero then begin ins(ldn,0,0,0) ; ins(dch,0,n,m) end else ins(dch,loaded.reg,n,m) else begin ins(ldx,0,rtmasktable+bitsize,0) ; if(shiftn#0) or (shiftm#0) then begin shiftins(slcs,0,shiftn,shiftm) ; if not assigningzero then shiftins(slls,loaded.reg,shiftn,shiftm) end ; ins(ands,0,n,m) ; if not assigningzero then ins(ors,loaded.reg,n,m) end else if size = 1 then if assigningzero then ins(stoz,0,n,m) else ins(sto,loaded.reg,n,m) else if assigningzero then doubleins(stoz,0,n,m) else if loaded.reg = fpa then begin ins(sfp,0,n,m) ; if source^.mayhaveoverflowed and locallyreqd[checks] then checkoverflow end else doubleins(sto,loaded.reg,n,m) end end (* assignmentcode *) ; procedure assign ; var expression,variable : stackentry ; begin if codeistobegenerated then begin unstack(expression) ; unstack(variable) ; assignmentcode(expression,variable) ; freestackentry(expression) ; freestackentry(variable) end end (* assign *) ; (* --- standard procedures ---------------------- *) (* --- *) (* --- file and associated procedures *) procedure fileopen ( elementrepresentation : typerepresentation ; packedfile, textfile : boolean ; permanent : boolean ; device : addrrange ) ; var filereference : stackentry ; begin if codeistobegenerated then begin unstack(filereference) ; loadaddress(4,filereference) ; systemcall(openroutine[textfile,permanent]) ; if permanent then copycode(device) ; if not textfile then copycode(elementrepresentation.size) ; freestackentry(filereference) end end (* fileopen *) ; procedure fileclose ( textfile : boolean ) ; var filereference : stackentry ; begin if codeistobegenerated then begin unstack(filereference) ; loadaddress(xref,filereference) ; systemcall(closeroutine[textfile]) ; freestackentry(filereference) end end (* fileclose *) ; procedure fileoperation( which : stdprocfuncs ; packedfile, textfile : boolean ; elementrepresentation: typerepresentation ); var filereference : stackentry ; begin if codeistobegenerated then begin unstack(filereference) ; loadaddress(xref,filereference) ; systemcall(fileops[which,textfile]) ; freestackentry(filereference) end end (* fileoperation *) ; procedure select ( whichfile : readorwritefile ) ; var filereference : stackentry ; begin if codeistobegenerated then begin unstack(filereference) ; loadaddress(0,filereference) ; ins(sto,0,rtaddressfor[whichfile],0) ; freestackentry(filereference) end end (* select *) ; procedure readoperation ( readmode : inputkind ) ; var valueread : stackentry ; xrefoverwritten : boolean ; function xrefneededtoaddress ( entry : stackentry ) : boolean ; begin with entry^ do if kind = reference then if partwordreference then if indexedpartword then if indexevaluated then xrefneededtoaddress := (wordaddress.staticlevel#level) and (wordaddress.staticlevel#globallevel) else xrefneededtoaddress := true else xrefneededtoaddress := false else xrefneededtoaddress := indexed else xrefneededtoaddress := kind = formalreference end (* xrefneededtoaddress *) ; begin (* readoperation*) if codeistobegenerated then begin saveallregisters ; new(valueread) ; with valueread^ do begin mayhaveoverflowed := false ; kind := result ; inregister := true ; reg := readreg[readmode] ; rep := readrep[readmode] end ; bindregistersto(valueread) ; stack(valueread) ; if readmode = charkind then begin ins(ldx,xref,rtaddressfor[readfile],0) ; ins(ldx,xmod,0,xref) ; ins(ldch,readreg[charkind],0,xmod) ; xrefoverwritten := xrefneededtoaddress(topstackentry^. nextentry) ; assign ; if xrefoverwritten then ins(ldx,xref,rtaddressfor[readfile],0) ; systemcall(gett) end else begin systemcall(readroutine[readmode]) ; assign end end end (* readoperation *) ; procedure writescalars ( writemode : outputkind ; format : formatkind ) ; var scalarvalue,fieldwidth,digitsafterpoint : stackentry ; begin if codeistobegenerated then begin if format = default then begin if writemode # charkind then begin saveregister(7) ; ins(ldn,7,defaultwidth[writemode],0) end end else begin if format = fixed then begin unstack(digitsafterpoint) ; loadx(6,digitsafterpoint) ; freestackentry(digitsafterpoint) end ; unstack(fieldwidth) ; loadx(7,fieldwidth) ; freestackentry(fieldwidth) end ; unstack(scalarvalue) ; if writemode = realkind then loadfpa(scalarvalue) else loadx(6,scalarvalue) ; if locallyreqd[checks] and scalarvalue^.mayhaveoverflowed then if writemode = realkind then systemcall(cfpv) else checkoverflow ; freestackentry(scalarvalue) ; if (writemode = charkind) and (format = default) then begin ins(ldx,xref,rtaddressfor[writefile],0) ; ins(ldx,xmod,0,xref) ; ins(dch,6,0,xmod) ; systemcall(putt) end else if (writemode = realkind) and (format = fixed) then systemcall(writefixedpoint) else systemcall(writeroutine[writemode]) end end (* writescalars *) ; procedure writestring ( actuallength : integer ; format : formatkind ) ; var stringvalue,fieldwidth : stackentry ; begin if codeistobegenerated then begin if format = default then begin saveregister(7) ; ins(ldn,7,actuallength,0) end else begin unstack(fieldwidth) ; loadx(7,fieldwidth) ; freestackentry(fieldwidth) end ; saveregister(6) ; ins(ldn,6,actuallength,0) ; unstack(stringvalue) ; loadaddress(5,stringvalue) ; freestackentry(stringvalue) ; systemcall(writesequence) end end (* writestring *) ; procedure readlayout ; begin if codeistobegenerated then begin ins(ldx,xref,rtaddressfor[readfile],0) ; systemcall(getmark) end end (* readlayout *) ; procedure writelayout ; var layoutvalue : stackentry ; begin if codeistobegenerated then begin unstack(layoutvalue) ; loadx(7,layoutvalue) ; ins(ldx,xref,rtaddressfor[writefile],0) ; systemcall(putmark) ; freestackentry(layoutvalue) end end (* writelayout *) ; procedure filefunction ( whichfunc : stdprocfuncs ) ; begin if codeistobegenerated then with topstackentry^ do begin rep := booleanrepresentation ; wordaddress.adjustment := wordaddress.adjustment + offsetfor[whichfunc] end end (* filefunction *) ; procedure packoperation ( which : stdprocfuncs ; lowerbound,upperbound : integer ; unpackedrepresentation , packedrepresentation : typerepresentation ; noofelements : integer ) ; var packarray,unpackarray : stackentry ; begin if codeistobegenerated then begin if which = packp then begin unstack(packarray) ; indexedreference(false,lowerbound,upperbound-noofelements+1, unpackedrepresentation) ; unstack(unpackarray) end else begin indexedreference(false,lowerbound,upperbound-noofelements+1, unpackedrepresentation) ; unstack(unpackarray) ; unstack(packarray) end ; if (packedrepresentation.size = 1) and ( packedrepresentation.bitsize <= 12) then begin (* elements can be packed or unpacked *) loadaddress(5,packarray) ; loadaddress(xref,unpackarray) ; ins(ldx,xmod,5,0) ; constins(ldx,5,noofelements) ; ins(adx,5,xref,0) ; if packedrepresentation.bitsize = 6 then if which = packp then systemcall(packcharacters) else systemcall(unpackcharacters) else begin ins(ldn,6,packedrepresentation.bitsize,0) ; if which = packp then systemcall(packnbits) else systemcall(unpacknbits) end end else begin (* elements cannot be packed or unpacked *) unpackarray^.rep := packarray^.rep ; if which = packp then assignmentcode(unpackarray,packarray) else assignmentcode(packarray,unpackarray) end ; freestackentry(packarray) ; freestackentry(unpackarray) end end (* packoperation *) ; procedure heapoperation ( which : stdprocfuncs ; reprequired : typerepresentation ) ; var pointerentry : stackentry ; begin if codeistobegenerated then begin unstack(pointerentry) ; if which = newp then begin saveallregisters ; ins(ngn,4,reprequired.size,0) ; systemcall(newop) ; address(pointerentry) ; with addressed do ins(sto,4,n,m) ; end else begin loadx(xref,pointerentry) ; saveregister(7) ; ins(ldn,7,reprequired.size,xref) ; systemcall(disposeop) end ; freestackentry(pointerentry) end end (* heapoperation *) ; procedure haltoperation ( messagelength : integer ) ; var stringentry : stackentry ; firstregister : register ; begin if codeistobegenerated then begin unstack(stringentry) ; addressvalue(stringentry) ; constins(ldx,6,messagelength) ; with addressed do ins(ldn,7,n,m) ; jumpindirectins(brn,0,proglinks[finishprogram]) ; freestackentry(stringentry) end end (* haltoperation *) ; procedure timeoperation ( which : stdprocfuncs ) ; var givenentry : stackentry ; begin if codeistobegenerated then begin new(givenentry) ; with givenentry ^ do begin kind := result ; inregister := true ; reg := 6 ; ins(give,6,givecode[which],0) ; case which of datep,timep : with rep do begin size := 2 ; floatingpoint := false end ; millp : begin ins(dvd,6,tentopower3,0) ; reg := 7 ; rep := integerrepresentation end end end ; bindregistersto(givenentry) ; stack(givenentry) ; assign end end (* timeoperation *) ; procedure iclins(fp:ordercode; xp:register; ap:runtimeaddress) ; var f : ordercode ; x : register ; n : directoperand ; begin if codeistobegenerated then begin f := fp ; x := xp ; n := ap.relativeaddress ; if (n < 0) or (n > 4095) then error(116) else if ap.blocklevel = globallevel then ins(f,x,n,0) else if ap.blocklevel = level then ins(f,x,n,1) else error(116) end end ; (* iclins *) (* --- control statements ----------------------- *) procedure jumponfalse ( var destination : codesequence ) ; var booleanentry : stackentry ; begin if codeistobegenerated then begin unstack(booleanentry) ; jumpif(booleanentry,false,destination) ; freestackentry(booleanentry) end end (* jumponfalse *) ; procedure labeljump ( var destination : codesequence ; var labellevel : disprange ) ; begin if codeistobegenerated then begin if labellevel = level then jumpins(brn,0,destination) else begin if labellevel = globallevel then ins(ldx,xlocal,linkbase+ord(stackbase),0) else setxtolevel(xlocal,labellevel) ; if reqd[dump] then ins(sto,xlocal,currframe,0) ; linkedjumpins(brn,0,destination) end end end (* labeljump *) ; procedure jump ( var destination : codesequence ) ; begin if codeistobegenerated then jumpins(brn,0,destination) end (* jump *) ; procedure opencase ( var caseswitch : codesequence ) ; begin if codeistobegenerated then begin load(topstackentry) ; if topstackentry^.rep.bitsize < 5 then ins(smo,0,loaded.reg,0) ; jumpins(brn,0,caseswitch) end end (* opencase *) ; procedure closecase ( firstcase : casentry ) ; var loadedcasevalue : stackentry ; directexitgenerated : boolean ; tablesize : integer ; casereg,checkreg : register ; switchtable : codesequence ; nexttablevalue,lasttablevalue : integer ; thiscase : casentry ; begin if codeistobegenerated then begin unstack(loadedcasevalue) ; if firstcase # nil then begin if loadedcasevalue^.rep.bitsize < 5 then begin directexitgenerated := true ; tablesize := loadedcasevalue^.rep.max + 1 ; nexttablevalue := 0 end else begin directexitgenerated := false ; nexttablevalue := firstcase^.casevalue ; if locallyreqd[checks] then begin thiscase := firstcase ; repeat lasttablevalue := thiscase^.casevalue ; thiscase := thiscase^.nextcase until thiscase = nil ; checkreg := 6 ; loadx(checkreg,loadedcasevalue) ; systemcall(checkcase) ; copycode(nexttablevalue) ; copycode(lasttablevalue-nexttablevalue+1) end else begin casereg := loadedcasevalue^.reg ; if nexttablevalue # 0 then constins(sbx,casereg,nexttablevalue) ; expectcodesequence(switchtable) ; ins(smo,0,casereg,0) ; jumpins(brn,0,switchtable) ; nextiscodesequence(switchtable) end end ; thiscase := firstcase ; repeat while nexttablevalue < thiscase^.casevalue do begin systemcall(caserror) ; nexttablevalue := nexttablevalue + 1 end ; jumpins(brn,0,thiscase^.caselimb) ; nexttablevalue := nexttablevalue + 1 ; thiscase := thiscase^.nextcase until thiscase = nil ; if directexitgenerated then while nexttablevalue < tablesize do begin systemcall(caserror) ; nexttablevalue := nexttablevalue + 1 end end ; freestackentry(loadedcasevalue) end end (* closecase *) ; procedure openfor ( increasing : boolean ; var startofloop, endofforstatement : codesequence ) ; var initial,final : operanddescription ; variable : stackentry ; initialreg,finalreg,jumpreg : register ; begin if codeistobegenerated then begin unstack(final.entry) ; unstack(initial.entry) ; unstack(variable) ; if initial.entry^.mayhaveoverflowed then final.entry^.mayhaveoverflowed := false ; with variable^.rep do if increasing then begin rangecheck(initial.entry,min,maxint) ; rangecheck(final.entry,-maxint,max) end else begin rangecheck(initial.entry,-maxint,max) ; rangecheck(final.entry,min,maxint) end ; analyse(final) ; analyse(initial) ; if not final.isconstant then begin load(final.entry) ; bindregistersto(final.entry) ; finalreg := loaded.reg ; saveregister(finalreg) ; lockregister(finalreg) end ; if not initial.iszero then begin load(initial.entry) ; initialreg := loaded.reg end ; address(variable) ; with addressed do if initial.iszero then ins(stoz,0,n,m) else ins(sto,initialreg,n,m) ; if initial.isconstant and final.isconstant then begin if increasing and (initial.cvalue > final.cvalue) or not increasing and (initial.cvalue < final.cvalue) then jumpins(brn,0,endofforstatement) end else begin if increasing then if final.iszero then begin ins(ngx,initialreg,initialreg,0) ; jumpreg := initialreg end else begin if final.isconstant then begin constins(ldx,0,final.cvalue) ; finalreg := 0 end ; if not initial.iszero then ins(sbx,finalreg,initialreg,0) ; jumpreg := finalreg end else if initial.iszero then begin ins(ngx,finalreg,finalreg,0) ; jumpreg := finalreg end else begin if not final.iszero then if final.isconstant then constins(sbx,initialreg,final.cvalue) else ins(sbx,initialreg,finalreg,0) ; jumpreg := initialreg end ; jumpins(bng,jumpreg,endofforstatement) end ; if not final.isconstant then unlockregister(finalreg) ; stack(final.entry) ; stack(variable) ; freestackentry(initial.entry) ; startcodesequence(startofloop) end end (* openfor *) ; procedure closefor ( increasing : boolean ; var startofloop : codesequence ) ; var variable : stackentry ; final : operanddescription ; begin if codeistobegenerated then begin unstack(variable) ; unstack(final.entry) ; address(variable) ; with addressed do begin ins(ldx,0,n,m) ; ins(ldn,4,1,0) ; if increasing then ins(ads,4,n,m) else ins(sbs,4,n,m) end ; analyse(final) ; if final.isconstant then begin if not final.iszero then constins(sbx,0,final.cvalue) end else begin addressvalue(final.entry) ; with addressed do ins(sbx,0,n,m) end ; jumpins(bnz,0,startofloop) ; freestackentry(final.entry) ; freestackentry(variable) end end (* closefor *) ; (* --- procedure and function calls ------------- *) procedure openparameterlist ( classofcall : idclass ) ; var formalbase : stackentry ; begin if codeistobegenerated then begin saveallregisters ; new(formalbase) ; with formalbase^ do begin kind := formalreference ; callisfunction := (classofcall = func) ; baseoffset := protectedformals ; formaloffset := baseoffset + firstformaloffset ; baseinxref := false end ; stack(formalbase) end end (* openparameterlist *) ; procedure passprocdesc ; var fn : addrrange ; fm : modifier ; begin with topstackentry^ do begin if not baseinxref then ins(ldx,xref,nextbase,xlocal) ; fn := formaloffset ; fm := xref ; normalise(fn,fm) ; doubleins(sto,4,fn,fm) ; baseinxref := (formaloffset < 4095) ; formaloffset := formaloffset + 2 ; protectedformals := formaloffset end ; bindregistersto(topstackentry) end (* passprocdesc *) ; procedure passactual ( blocklevel:disprange ; var body:codesequence ) ; var aftercall : codesequence ; begin if codeistobegenerated then begin setxtolevel(4,blocklevel) ; expectcodesequence(aftercall) ; jumpins(call,xmod,aftercall) ; jumpindirectins(call,5,body) ; nextiscodesequence(aftercall) ; ins(ldx,5,0,xmod) ; passprocdesc end end (* passactual *) ; procedure passformal ( formaladdress : runtimeaddress) ; var fn : addrrange ; fm : modifier ; begin if codeistobegenerated then begin fn := formaladdress.relativeaddress ; if formaladdress.blocklevel = level then fm := xlocal else begin setxtolevel(xmod,formaladdress.blocklevel) ; fm := xmod end ; normalise(fn,fm) ; doubleins(ldx,4,fn,fm) ; passprocdesc end end (* passformal *) ; procedure passreference ; var actualreference,formalreference : stackentry ; fn : addrrange ; fm : modifier ; xadd : register ; begin if codeistobegenerated then begin unstack(actualreference) ; unstack(formalreference) ; address(actualreference) ; with addressed do if (n # 0) or (m = xref) then begin ins(ldn,0,n,m) ; xadd := 0 end else xadd := m ; with formalreference^ do begin if not baseinxref then ins(ldx,xref,nextbase,xlocal) ; fn := formaloffset ; fm := xref ; normalise(fn,fm) ; ins(sto,xadd,fn,fm) ; baseinxref := formaloffset <= 4095 ; formaloffset := formaloffset + 1 ; protectedformals := formaloffset end ; bindregistersto(formalreference) ; stack(formalreference) ; freestackentry(actualreference) end end (* passreference *) ; procedure passvalue ( reprequired : typerepresentation ) ; var actualvalue,formalreference : stackentry ; begin if codeistobegenerated then begin unstack(actualvalue) ; unstack(formalreference) ; formalreference^.rep := reprequired ; assignmentcode(actualvalue,formalreference) ; with formalreference^ do begin baseinxref := (formaloffset < 4095) ; formaloffset := formaloffset + rep.size ; protectedformals := formaloffset end ; freestackentry(actualvalue) ; bindregistersto(formalreference) ; stack(formalreference) end end (* passvalue *) ; procedure closeparameterlist ; var formalbase : stackentry ; begin if codeistobegenerated then begin unstack(formalbase) ; with formalbase^ do begin if callisfunction or (formaloffset > baseoffset+firstformaloffset) then begin if not baseinxref then ins(ldx,xref,nextbase,xlocal) ; if baseoffset > 0 then constins(adx,xref,baseoffset) ; protectedformals := baseoffset end end ; freeregistersfrom(formalbase) ; freestackentry(formalbase) end end (* closeparameterlist *) ; procedure callactual (blocklevel : disprange ; var body : codesequence); begin if codeistobegenerated then begin if blocklevel # globallevel then setxtolevel(4,blocklevel) ; linkedjumpins(call,5,body) end end (* callactual *) ; procedure callformal ( formaladdress : runtimeaddress ) ; var fn : addrrange ; fm : modifier ; begin if codeistobegenerated then begin with formaladdress do begin fn := relativeaddress ; if blocklevel = level then fm := xlocal else begin setxtolevel(xmod,blocklevel) ; fm := xmod end end ; normalise(fn,fm) ; ins(ldx,4,fn,fm) ; fn := fn+1 ; normalise(fn,fm) ; ins(obey,0,fn,fm) end end (* callformal *) ; procedure takeresult ( representation : typerepresentation ) ; begin if codeistobegenerated then begin stackresult(representation) ; with topstackentry^ do begin mayhaveoverflowed := false ; if representation.size = 1 then reg := 4 else reg := fpa end ; bindregistersto(topstackentry) ; end end (* takeresult *) ; procedure leaveresult ( resultaddress : runtimeaddress ; representation : typerepresentation ) ; var fn : addrrange ; fm : modifier ; begin if codeistobegenerated then begin fn := resultaddress.relativeaddress ; fm := xlocal ; normalise(fn,fm) ; if representation.size = 1 then ins(ldx,4,fn,fm) else ins(lfp,0,fn,fm) end end (* leaveresult *) ; procedure setendprogram ; begin if codeistobegenerated then begin constins(ldx,7,okword) ; constins(ldx,6,2) ; nextiscodesequence(proglinks[finishprogram]) ; ins(sto,6,message,0) ; ins(sto,7,message+1,0) ; end end (* set end program *) ; (****************** directive analysis ***************) procedure analysedirective ; const unimplementeddirective = 297; misplaceddirective = 298; invaliddirective = 299; var directivetobelisted : boolean; option : optiontype; procedure identifyoption (word : alfa; var option : optiontype) ; begin option := checks; while (option<>other) and (word<>optionname[option]) do option := succ(option) end (* identifyoption *) ; procedure settfoption ( option : optiontype ) ; begin if (symbol = relop) and (operator = eqop) then begin if atheadofsource then begin readsymbol ; if symbol = ident then begin if spelling = 'true ' then setbooleanoption(option,true,false) else if spelling = 'false ' then setbooleanoption(option,false,false) else error(invaliddirective) end else error(invaliddirective) end else error(misplaceddirective) end else error(invaliddirective) end (* settfoption *) ; begin (* analysedirective *) directivetobelisted := true; readsymbol; if symbol = ident then begin identifyoption(spelling,option); case option of checks,dump,profile,retro,trace,listing: begin readsymbol; if symbol = ident then begin if option in [checks,trace,listing] then if spelling = 'on ' then setbooleanoption(option,true,true) else if spelling = 'off ' then setbooleanoption(option,false,true) else error(invaliddirective) else error(invaliddirective) end (* symbol = ident *) else settfoption(option) end ; margin,retromax,tracemin,tracemax: begin readsymbol; if (symbol = relop) and (operator = eqop) then begin readsymbol; if symbol = intconst then if constant.ival1>0 then setintegeroption(option,constant.ival1) else error(invaliddirective) else error(invaliddirective) end (* symbol = equals *) else error(invaliddirective); end; cdm,ebm: begin readsymbol ; settfoption(option) end; newpage: error(unimplementeddirective); title: error(unimplementeddirective); other: error(invaliddirective) end (* case *) end (* symbol = ident *) else error(invaliddirective); end (* analysedirective *) ; (* ****************************************************************** *) procedure startlist ( var list : idlist ) ; begin list.firstentry := nil ; list.lastentry := nil end (* startlist *) ; procedure appendid ( var list : idlist ; var id : identry ) ; begin if list.firstentry = nil then list.firstentry := id else list.lastentry^.next := id ; list.lastentry := id ; id^.next := nil end (* appendid *) ; procedure appendlists ( var list1,list2 : idlist ) ; begin if list1.firstentry = nil then list1 := list2 else if list2.firstentry # nil then begin list1.lastentry^.next := list2.firstentry ; list1.lastentry := list2.lastentry end end (* appendlists *) ; procedure initscope ; begin top:=0 ; level:=0 ; with display[0] do begin idscope := nil ; scope := bloc ; typechain := nil ; firstlabel := nil end end (* initscope *) ; procedure openscope ( kind : scopekind ) ; begin if top < displimit then begin top := top+1 ; with display[top] do begin idscope := nil ; scope := kind ; if kind = bloc then begin typechain := nil ; firstlabel := nil ; level := top end else fieldspacked := false end end else begin error(250) end end (* openscope *) ; procedure savescope ( var scope : scopecopy ) ; begin new(scope) ; scope ^ := display[top] ; top := top - 1 ; level := level - 1 end (* savescope *) ; procedure restorescope ( scope : scopecopy ) ; begin top := top + 1 ; level := level + 1 ; display[top] := scope ^ ; dispose(scope) end (* restorescope *) ; procedure closescope ; begin if display[top].scope = bloc then level := level-1 ; top := top-1 end (* closescope *) ; procedure disposescope ; procedure disposeids ( root : identry ) ; var thisformal,nextformal : formalentry ; begin if root # nil then with root^ do begin disposeids (leftlink) ; disposeids (rightlink) ; case klass of types : dispose(root,types) ; consts : dispose(root,consts) ; vars : dispose(root,vars) ; field : dispose(root,field) ; proc, func : begin if pfkind = actual then begin if forward then error(174) ; nextformal := formals ; while nextformal # nil do begin thisformal := nextformal ; nextformal := thisformal^.next ; dispose(thisformal) end ; end ; dispose(root,proc) end end end end (* disposeids *) ; procedure disposetypes ( firsttype : typentry ) ; var thistype,nexttype : typentry ; begin nexttype := firsttype ; while nexttype # nil do begin thistype := nexttype ; nexttype := thistype^.next ; case thistype^.form of scalars : dispose(thistype,scalars) ; subranges : dispose(thistype,subranges) ; pointers : dispose(thistype,pointers) ; sets : dispose(thistype,sets) ; arrays : dispose(thistype,arrays) ; records : begin disposeids(thistype^.fieldscope) ; dispose(thistype,records) end ; files : dispose(thistype,files) ; variantpart : dispose(thistype,variantpart) ; variant : dispose(thistype,variant) end end end (* disposetypes *) ; procedure disposelabels ( startlabel : labelentry ) ; var nextlab,thislab : labelentry ; begin nextlab := startlabel ; while nextlab # nil do begin thislab := nextlab ; if not thislab^.defined then error(168) ; nextlab := thislab^.nextlabel ; dispose(thislab) end end (* disposelabels *) ; begin (* disposescope *) with display[level] do begin disposeids(idscope) ; disposetypes(typechain) ; disposelabels(firstlabel) end end (* disposescope *) ; procedure newtype ( var entry : typentry ; formneeded : typeform ) ; var newentry : typentry ; begin (* newtype *) case formneeded of scalars : begin new(newentry,scalars,declared) ; with newentry^ do begin scalarkind := declared ; firstconst := nil end end ; subranges : begin new(newentry,subranges) ; with newentry^ do begin rangetype := nil ; min := 0 ; max := 1 end end ; pointers : begin new(newentry,pointers) ; with newentry^ do begin domaintype := nil end end ; sets : begin new(newentry,sets) ; with newentry^ do begin packedset := false ; basetype := nil end end ; arrays : begin new(newentry,arrays) ; with newentry^ do begin aeltype := nil ; inxtype := nil ; packedarray := false end end ; records : begin new(newentry,records) ; with newentry^ do begin packedrecord := false ; fieldscope := nil ; nonvarpart := nil ; varpart := nil end end ; files : begin new(newentry,files) ; with newentry^ do begin packedfile := false ; textfile := false ; feltype := nil end end ; variantpart : begin new(newentry,variantpart) ; with newentry^ do begin tagfield := nil ; firstvariant := nil end end ; variant : begin new(newentry,variant) ; with newentry^ do begin fstvarfield := nil ; nextvariant := nil ; subvarpart := nil ; with variantvalue do begin size := 1 ; kind := intvalue ; ival1 := 0 end end end end ; with newentry^ do begin form := formneeded ; representation := defaultrepresentation end ; with display[level] do begin newentry^.next := typechain ; typechain := newentry end ; tserialise(newentry) ; entry := newentry end (* newtype *) ; procedure newid ( var entry : identry ; classneeded : idclass ) ; var newentry,thisentry,lastentry : identry ; lefttaken : boolean ; begin (* newid *) (* create new entry of appropriate class *) case classneeded of types : new(newentry,types) ; consts: new(newentry,consts) ; vars : new(newentry,vars) ; field : new(newentry,field) ; proc : new(newentry,proc,declared) ; func : new(newentry,func,declared) end ; (* set name, klass, and default attributes *) with newentry^ do begin name := spelling ; idtype := nil ; leftlink := nil ; rightlink := nil ; next := nil ; klass := classneeded ; case klass of types : ; consts: with values do begin size := 1 ; kind := intvalue ; ival1 := 0 end ; vars : begin varparam := false ; varaddress := defaultaddress end ; field : with offset do begin wordoffset := 0 ; partword := false ; wordsize := 0 end ; proc, func : begin pfdeckind := declared ; pfkind := actual ; formals := nil ; expectcodesequence(codebody) ; assignable := false ; forward := false ; result := defaultaddress end end end ; (* enter in current scope *) thisentry := display[top].idscope ; if thisentry = nil then display[top].idscope := newentry else begin repeat lastentry := thisentry ; if thisentry^.name = spelling then (* name conflict,follow right link *) begin error(101) ; thisentry := thisentry^.rightlink ; lefttaken := false end else if thisentry^.name < spelling then begin thisentry := thisentry^.rightlink ; lefttaken := false end else begin thisentry := thisentry^.leftlink ; lefttaken := true end until thisentry = nil ; if lefttaken then lastentry^.leftlink := newentry else lastentry^.rightlink := newentry end ; entry := newentry end (* newid *) ; procedure searchlocalid (firstentry:identry ; var entry : identry ) ; label 1 ; begin (* searchlocalid *) while firstentry # nil do if firstentry^.name = spelling then goto 1 else if firstentry^.name < spelling then firstentry := firstentry^.rightlink else firstentry := firstentry^.leftlink ; 1: entry := firstentry end (* searchlocalid *) ; procedure searchid ( allowableclasses : setofidclass ; var entry : identry ) ; label 1 ; var thisentry,lastentry,newentry : identry ; misused,lefttaken : boolean ; index,ttop : disprange ; lclass : idclass ; function strongestof ( classes : setofidclass ) : idclass ; var lclass : idclass ; begin lclass := types ; while not(lclass in classes) do lclass := succ(lclass) ; strongestof := lclass end (* strongestof *) ; begin (* searchid *) misused := false ; for index := top downto 0 do begin thisentry := display[index].idscope ; while thisentry # nil do if thisentry^.name = spelling then if thisentry^.klass in allowableclasses then begin levelfound := index ; goto 1 end else begin misused := true ; thisentry := thisentry^.rightlink end else if thisentry^.name < spelling then thisentry := thisentry^.rightlink else thisentry := thisentry^.leftlink ; if misused then begin (* identifier(s) with correct spelling but wrong class - set defaultentry for misused identifier and jump out *) error(103) ; levelfound := level ; thisentry := defaultentry[strongestof(allowableclasses)] ; goto 1 end end (* for *) ; (* table exhausted - identifier not found. create an entry for the undeclared identifier, of appropriate class *) error(104) ; ttop := top ; top := level ; newid(thisentry,strongestof(allowableclasses)) ; top := ttop ; levelfound := level ; 1: entry := thisentry end (* searchid *) ; procedure newlabel ( var entry : labelentry ) ; label 1 ; var newentry,thisentry : labelentry ; newlabel : integer ; begin (* newlabel *) new(newentry) ; with newentry^ do begin labelvalue := constant.ival1 ; nextlabel := nil ; expectcodesequence(labelledcode) ; defined := false end ; with display[top] do begin thisentry := firstlabel ; newlabel := newentry^.labelvalue ; while thisentry # nil do if thisentry^.labelvalue = newlabel then begin error(166) ; goto 1 end else thisentry := thisentry^.nextlabel ; newentry^.nextlabel := firstlabel ; firstlabel := newentry end ; 1: entry := newentry end (* newlabel *) ; procedure searchlabel ( var entry : labelentry ) ; label 1 ; var index,ttop : disprange ; thisentry : labelentry ; begin (* searchlabel *) index := level ; repeat thisentry := display[index].firstlabel ; while thisentry # nil do if thisentry^.labelvalue = constant.ival1 then begin levelfound := index ; goto 1 end else thisentry := thisentry^.nextlabel ; index := index-1 until index = 0 ; (* label not found - report error and create an entry for the undeclared label *) error(167) ; ttop := top ; top := level ; newlabel(thisentry) ; top := ttop ; levelfound := level ; 1: entry := thisentry end (* searchlabel *) ; (* ---------------------- the syntax analyser ----------------------- *) procedure insymbol ; begin readsymbol ; preservetoken end (* insymbol *) ; procedure accept ( symbolexpected : symboltype ) ; begin if symbol = symbolexpected then insymbol else error(missingcodefor[symbolexpected]) end (* accept *) ; procedure skip (relevantsymbols : setofsymbols) ; begin while not (symbol in relevantsymbols) do insymbol end (* skip *) ; procedure checkcontext ( contextexpected : setofsymbols ) ; begin if not (symbol in contextexpected ) then begin error(6) ; skip(contextexpected) end end (* checkcontext *) ; procedure checknextorcontext ( symbolsexpected,defaultcontext : setofsymbols) ; begin if not ( symbol in symbolsexpected ) then begin error(6) ; skip(symbolsexpected + defaultcontext) end end (* checknextorcontext *) ; procedure programme ; type filentry = ^ filerec ; filerec = record name : alfa ; fileid : identry ; permanent : boolean ; device : addrrange ; next : filentry end ; var progid : identry ; permafiles : filentry ; procedure makeprogentry (progname : alfa) ; begin new(progid,prog) ; with progid^ do begin name := progname ; klass := prog end ; iserialise(progid) ; nameprogram(progname) ; end (* makeprogentry *) ; procedure newpermafile ( filename : alfa ) ; var entry : filentry ; begin new(entry) ; with entry^ do begin name := filename ; fileid := nil ; permanent := true ; getdevicefor(filename,device) ; next := permafiles end ; permafiles := entry end (* newpermafile *) ; procedure builtinfiles ; var thisfile : filentry ; begin inputfile := nil ; outputfile := nil ; thisfile := permafiles ; while thisfile # nil do with thisfile^ do begin if name = 'input ' then begin spelling := name ; newid(inputfile,vars) ; iserialise(inputfile) ; inputfile^.idtype := texttype ; setaddressfor(inputfile) ; fileid := inputfile end else if name = 'output ' then begin spelling := name ; newid(outputfile,vars) ; iserialise(outputfile) ; outputfile^.idtype := texttype ; setaddressfor(outputfile) ; fileid := outputfile end ; thisfile := next end end (* builtinfiles*) ; procedure defaultfiles ; begin newpermafile('input ') ; newpermafile('output ') ; end ; procedure block (blockcontext : setofsymbols ; blockfollower : symboltype ; blockidentry : identry ) ; type dlistentry = ^ domains ; domains = record name : alfa ; pointertype : typentry ; nextdomain : dlistentry end ; var subblockcontext : setofsymbols ; domainlist : dlistentry ; alltypesdefined : boolean ; nextlocalid : identry ; localidlist : idlist ; nextformal : identry ; scratchfiles : filentry ; procedure newfile( id : identry ) ; label 1 ; var entry : filentry ; begin if level = globallevel then begin entry := permafiles ; while entry # nil do if entry^.name = id^.name then begin if entry^.fileid = nil then entry^.fileid := id else error(101) ; goto 1 end else entry := entry^.next end ; new(entry) ; with entry^ do begin name := id^.name ; next := scratchfiles ; fileid := id ; permanent := false end ; scratchfiles := entry ; 1: end ; procedure openfiles( firstfile : filentry ) ; var thisfile : filentry ; begin thisfile := firstfile ; while thisfile # nil do with thisfile^ do begin if fileid = nil then error(177) else with fileid^, idtype^ do if feltype # nil then begin stackreference(false,varaddress, representation ) ; fileopen(feltype^.representation, packedfile,textfile, permanent,device ) ; end ; thisfile := next end end (* openfiles *) ; procedure closefiles(firstfile : filentry ) ; var thisfile, nextfile : filentry ; begin thisfile := firstfile ; while thisfile # nil do with thisfile^ do begin if fileid # nil then with fileid^, idtype^ do if feltype # nil then begin stackreference(false,varaddress, representation ) ; fileclose(textfile) end ; nextfile := next ; thisfile := nextfile end end (* closefiles *) ; function comptypes (type1,type2 : typentry) : boolean ; (* decides whether types pointed at by type1 and type2 are compatible *) function equivalent ( type1,type2 : typentry ; arepacked : boolean ) : boolean ; (* decides whether (discinct) types pointed at by type1 and type2 are equivalent. arepacked indicates whether types have occurred as sub-types within a packed structure type, in which case sub range bounds must be identical *) var stillequivalent : boolean ; const1,const2 : identry ; function compsubtypes ( type1,type2 : typentry ; arepacked : boolean ) : boolean ; begin if type1 = type2 then compsubtypes := true else if (type1=nil) or (type2=nil) then compsubtypes := true else compsubtypes := equivalent(type1,type2, arepacked) end (* compsubtypes *) ; function equalbounds ( type1,type2 : typentry ) : boolean ; var min1,max1,min2,max2 : integer ; begin getbounds(type1,min1,max1) ; getbounds(type2,min2,max2) ; equalbounds := (min1=min2) and (max1=max2) end (* equalbounds *) ; begin (* equivalent *) if type1^.form = type2^.form then case type1^.form of scalars : if (type1^.scalarkind = standard) or (type2^.scalarkind = standard) then equivalent := false else begin const1 := type1^.firstconst ; const2 := type2^.firstconst ; stillequivalent := true ; while stillequivalent and (const1#nil) and (const2#nil) do begin stillequivalent := const1^.name=const2^.name; const1 := const1^.next ; const2 := const2^.next end ; equivalent := stillequivalent and (const1=const2) end ; subranges : begin stillequivalent := comptypes(type1^.rangetype, type2^.rangetype) ; if stillequivalent and arepacked then if type1^.rangetype # realtype then stillequivalent:=equalbounds(type1,type2); equivalent := stillequivalent end ; pointers : equivalent := comptypes(type1^.domaintype, type2^.domaintype) ; sets : equivalent := (type1^.packedset=type2^.packedset) and compsubtypes(type1^.basetype, type2^.basetype, type1^.packedset) ; arrays : equivalent := (type1^.packedarray = type2^.packedarray) and comptypes(type1^.inxtype, type2^.inxtype) and equalbounds(type1^.inxtype, type2^.inxtype) and compsubtypes(type1^.aeltype, type2^.aeltype, type1^.packedarray); records : equivalent := false ; files : equivalent := (type1^.packedfile=type2^.packedfile) and compsubtypes(type1^.feltype, type2^.feltype, type1^.packedfile) ; end else (* type1^.form # type2^.form *) begin if type1^.form = subranges then stillequivalent := comptypes(type1^.rangetype,type2) else if type2^.form = subranges then stillequivalent := comptypes(type1,type2^.rangetype) else stillequivalent := false ; if stillequivalent and arepacked and (type1#realtype) and (type2#realtype) then stillequivalent := equalbounds(type1,type2) ; equivalent := stillequivalent end end (* equivalent *) ; begin (* comptypes *) ; if type1 = type2 then comptypes := true else if (type1=nil) or (type2=nil) then comptypes := true else comptypes := equivalent(type1,type2,false) end (* comptypes *) ; function string ( strgtype : typentry ) : boolean ; begin (* string *) string := false ; if strgtype # nil then with strgtype^ do if form = arrays then if comptypes(aeltype,chartype) then string := packedarray end (* string *) ; procedure stringtype( var stringentry : typentry ) ; var indextype,arraytype : typentry ; begin (* stringtype *) if constant.length = alfalength then stringentry := alfatype else begin newtype(indextype,subranges) ; with indextype^ do begin rangetype := inttype ; min := 1 ; max := constant.length ; end ; setrepresentationfor(indextype) ; newtype(arraytype,arrays) ; with arraytype^ do begin aeltype := chartype ; inxtype := indextype ; packedarray := true ; end ; setrepresentationfor(arraytype) ; stringentry := arraytype end end (* stringtype *) ; procedure inconstant( context : setofsymbols ; var constypentry : typentry ; var constvalu : valu ) ; var typeconst : typentry ; idconst : identry ; sign : (none,positive,negative) ; begin (* inconstant *) typeconst := nil ; with constvalu do begin size := 1 ; ival1 := 0 end ; checknextorcontext(constbegsys,context) ; if symbol in constbegsys then begin if symbol = charconst then begin typeconst := chartype ; constvalu := constant ; insymbol end else if symbol = stringconst then begin stringtype(typeconst) ; constvalu := constant ; insymbol end else begin sign := none ; if (symbol=addop)and(operator in [plus,minus]) then begin if operator = plus then sign := positive else sign := negative ; insymbol end ; if symbol = ident then begin searchid([consts],idconst) ; with idconst^ do begin typeconst := idtype ; constvalu := values end ; if sign # none then if typeconst = inttype then begin if sign = negative then constvalu.ival1 := -constvalu.ival1 end else if typeconst = realtype then begin if sign = negative then constvalu.rval := -constvalu.rval end else error(105) ; insymbol end else if symbol = intconst then begin typeconst := inttype ; constvalu := constant ; if sign = negative then constvalu.ival1 :=-constvalu.ival1 ; insymbol end else if symbol = realconst then begin typeconst := realtype ; constvalu := constant ; if sign = negative then constvalu.rval := -constvalu.rval ; insymbol end else begin error(106) ; skip(context) end end ; checkcontext(context) end ; constypentry := typeconst end (* inconstant *) ; procedure typ ( typecontext : setofsymbols ; var typefound : typentry ) ; label 9 ; var elementtype, dimension,lastdimension,indextype, lvarpart : typentry ; domainentry : dlistentry ; domainid,lnonvarpart : identry ; packflag : boolean ; procedure simpletype ( simtypcontext : setofsymbols ; var simtypentry : typentry ) ; var firstentry,workentry : typentry ; firstidentry : identry ; ttop : disprange ; workvalu : valu ; constlist : idlist ; constval : integer ; procedure subrnge ( firstype : typentry ; firstvalu : integer ) ; begin (* subrnge *) newtype(firstentry,subranges) ; with firstentry^ do begin rangetype := firstype ; min := firstvalu end ; accept(colon) ; inconstant(simtypcontext,workentry,workvalu) ; with firstentry^ do begin max := workvalu.ival1 ; if not(comptypes(firstype,workentry)) then error(107) else if firstype = realtype then begin error(175) ; rangetype := nil end else if string(firstype) then begin error(148) ; rangetype := nil end else begin if min > max then error(102) ; end end ; setrepresentationfor(firstentry) end (* subrnge *) ; begin (* simpletype *) checknextorcontext(simptypebegsys,simtypcontext) ; if symbol in simptypebegsys then begin if symbol = leftparent then begin ttop := top ; top := level ; newtype(firstentry,scalars) ; startlist(constlist) ; constval := 0 ; repeat insymbol ; if symbol = ident then begin newid(firstidentry,consts) ; iserialise(firstidentry) ; (*enum.const.*) with firstidentry^ do begin idtype := firstentry ; values.ival1 := constval ; values.size:=1; constval := constval + 1 end ; appendid(constlist,firstidentry) ; insymbol end else error(2) ; checkcontext(simtypcontext+[comma,rightparent]) until symbol # comma ; with firstentry^ do begin firstconst := constlist.firstentry ; end ; setrepresentationfor(firstentry) ; top := ttop ; accept(rightparent) end (* symbol = leftparent *) else if symbol = ident then begin searchid([types,consts],firstidentry) ; insymbol ; with firstidentry^ do if klass = consts then subrnge(idtype,values.ival1) else firstentry := idtype end else begin inconstant(simtypcontext + [colon], workentry,workvalu ) ; subrnge(workentry,workvalu.ival1) end ; simtypentry := firstentry ; checkcontext(simtypcontext) end else simtypentry := nil end (* simpletype *) ; procedure fieldlist ( fieldcontext : setofsymbols ; var nonvarpart : identry ; var varpart : typentry ) ; label 9, 19, 29 ; var fieldentry,firstsubfield : identry ; fields,fieldsofonetype : idlist ; fieldtype,tagtype,labeltype, variantentry,lastvariant,lastdistinctvariant, subvariantpart : typentry ; labelvalue : valu ; begin (* fieldlist *) checkcontext(fieldcontext+[ident,casesy]) ; startlist(fields) ; while symbol = ident do begin startlist(fieldsofonetype) ; while true do begin if symbol = ident then begin newid(fieldentry,field) ; iserialise(fieldentry) ; (*field*) appendid(fieldsofonetype,fieldentry) ; insymbol end else error(2) ; checknextorcontext([comma,colon],fieldcontext+ [semicolon,casesy]) ; if symbol # comma then goto 9 ; insymbol end ; 9: ; accept(colon) ; typ(fieldcontext + [casesy,semicolon],fieldtype) ; fieldentry := fieldsofonetype.firstentry ; while fieldentry # nil do with fieldentry^ do begin idtype := fieldtype ; fieldentry := next end ; appendlists(fields,fieldsofonetype) ; if symbol = semicolon then begin insymbol ; checknextorcontext([ident,casesy],fieldcontext) end else if symbol = casesy then error(14) end (* while symbol = ident *) ; nonvarpart := fields.firstentry ; if symbol = casesy then begin newtype(varpart,variantpart) ; insymbol ; if symbol = ident then begin newid(fieldentry,field) ; iserialise(fieldentry) ; (*tag-field*) insymbol ; accept(colon) ; simpletype(fieldcontext + [ofsy,leftparent], tagtype) ; if tagtype # nil then if tagtype^.form <= subranges then if comptypes(realtype,tagtype) then error(109) else begin varpart^.tagfield := fieldentry ; fieldentry^.idtype := tagtype ; end else error(110) end else begin error(2) ; skip(fieldcontext + [ofsy,leftparent]) end ; accept(ofsy) ; lastvariant := nil ; while true do begin lastdistinctvariant := lastvariant ; while true do begin inconstant(fieldcontext + [comma,colon,leftparent], labeltype,labelvalue) ; if not comptypes(tagtype,labeltype) then error(111) ; newtype(variantentry,variant) ; with variantentry^ do begin nextvariant := lastvariant ; variantvalue := labelvalue end ; lastvariant := variantentry ; if symbol # comma then goto 19 ; insymbol end ; 19: ; accept(colon) ; accept(leftparent) ; fieldlist(fieldcontext + [rightparent,semicolon], firstsubfield,subvariantpart) ; while variantentry # lastdistinctvariant do with variantentry^ do begin subvarpart := subvariantpart ; fstvarfield := firstsubfield ; variantentry := nextvariant end ; if symbol = rightparent then begin insymbol ; checkcontext(fieldcontext+[semicolon]) end else error(4) ; if symbol # semicolon then goto 29 ; insymbol end ; 29: ; varpart^.firstvariant := lastvariant end else varpart := nil end (* fieldlist *) ; begin (* typ *) checknextorcontext(typebegsys,typecontext) ; if symbol in typebegsys then begin if symbol in simptypebegsys then simpletype(typecontext,typefound) else if symbol = arrow then begin newtype(typefound,pointers) ; insymbol ; if symbol = ident then begin if alltypesdefined then begin searchid([types],domainid) ; typefound^.domaintype := domainid^.idtype end else begin new(domainentry) ; with domainentry^ do begin name := spelling ; pointertype := typefound ; nextdomain := domainlist end ; domainlist := domainentry end ; insymbol end else error(2) ; setrepresentationfor(typefound) end else begin if symbol = packedsy then begin packflag := true ; insymbol end else packflag := false ; checknextorcontext(typedels,typecontext) ; if symbol in typedels then case symbol of arraysy : begin insymbol ; accept(leftbracket) ; lastdimension := nil ; while true do begin newtype(dimension,arrays) ; with dimension^ do begin aeltype := lastdimension ; packedarray := packflag end ; lastdimension := dimension ; simpletype(typecontext + [comma,rightbracket,ofsy], indextype) ; if indextype # nil then if indextype^.form <= subranges then if comptypes(indextype,realtype) then error(109) else if indextype=inttype then error(149) else dimension^.inxtype:=indextyp else error(113) ; if symbol # comma then goto 9 ; insymbol end ; 9: ; accept(rightbracket) ; accept(ofsy) ; typ(typecontext,elementtype) ; repeat lastdimension := dimension^.aeltype ; dimension^.aeltype := elementtype ; setrepresentationfor(dimension) ; elementtype := dimension ; dimension := lastdimension until dimension = nil ; typefound := elementtype end ; recordsy : begin insymbol ; openscope(withst) ; fieldlist(typecontext-[semicolon]+[endsy], lnonvarpart,lvarpart) ; newtype(typefound,records) ; with typefound^ do begin packedrecord := packflag ; fieldscope := display[top].idscope ; nonvarpart := lnonvarpart ; varpart := lvarpart end ; closescope ; accept(endsy) ; setrepresentationfor(typefound) end ; setsy : begin insymbol ; accept(ofsy) ; newtype(typefound,sets) ; typefound^.packedset := packflag ; simpletype(typecontext,elementtype) ; if elementtype # nil then if elementtype^.form > subranges then error(115) else if comptypes(realtype,elementtype) then error(114) else if elementtype = inttype then error(169) else begin typefound^.basetype:=elementtype end ; setrepresentationfor(typefound) end ; filesy : begin insymbol ; accept(ofsy) ; typ(typecontext,elementtype) ; newtype(typefound,files) ; with typefound^ do begin packedfile := packflag ; textfile := packflag and comptypes(chartype, elementtype) ; feltype := elementtype ; end ; setrepresentationfor(typefound) end end (* case *) else typefound := nil ; end ; checkcontext(typecontext) end else typefound := nil end (* typ *) ; procedure labeldeclaration ; var thislabelentry : labelentry ; begin (* labeldeclaration *) repeat insymbol ; if symbol = intconst then begin newlabel(thislabelentry) ; insymbol end else error(15) ; checkcontext(subblockcontext + [comma,semicolon]) until symbol # comma ; if symbol = semicolon then begin insymbol ; checkcontext(subblockcontext) end else error(14) end (* labeldeclaration *) ; procedure constdeclaration ; var deconstid : identry ; deconstype : typentry ; deconstvalu : valu ; begin (* constdeclaration *) insymbol ; if symbol # ident then begin error(2) ; skip(subblockcontext + [ident]) end ; while symbol = ident do begin newid(deconstid,consts) ; insymbol ; if (symbol = relop) and (operator = eqop) then insymbol else error(16) ; inconstant(subblockcontext + [semicolon] , deconstype,deconstvalu ) ; appendid(localidlist,deconstid) ; deconstid^.idtype := deconstype ; deconstid^.values := deconstvalu ; if symbol = semicolon then begin insymbol ; checkcontext(subblockcontext + [ident]) end else error(14) end ; end (* constdeclaration *) ; procedure typedeclaration ; var newtypentry : typentry ; typidentry : identry ; begin (* typedeclaration *) insymbol ; alltypesdefined := false ; domainlist := nil ; if symbol # ident then begin error(2) ; skip(subblockcontext + [ident]) end ; while symbol = ident do begin newid(typidentry,types) ; insymbol ; if (symbol = relop) and (operator = eqop) then insymbol else error(16) ; typ(subblockcontext + [semicolon],newtypentry) ; appendid(localidlist,typidentry) ; typidentry^.idtype := newtypentry ; if symbol = semicolon then begin insymbol ; checkcontext(subblockcontext + [ident]) end else error(14) end (* while *) ; while domainlist # nil do with domainlist^ do begin spelling := name ; searchid([types],typidentry) ; pointertype^.domaintype := typidentry^.idtype ; domainlist := nextdomain end end (* typedeclaration *) ; procedure vardeclaration ; label 9 ; var varidentry,nextentry : identry ; varsofonetype : idlist ; vartypentry : typentry ; procedure valuefor ( vartype : typentry ; valuecontext : setofsymbols ) ; var consttype : typentry ; constvalu : valu ; begin if symbol = leftparent then begin repeat insymbol ; inconstant(valuecontext + [comma,rightparent], consttype,constvalue); initialvalue(constvalue) until symbol # comma ; if symbol = rightparent then begin insymbol ; checkcontext(valuecontext) end else error(4) end else begin inconstant(valuecontext,consttype,constvalue) ; initialvalue(constvalue) end end (* valuefor *) ; begin (* vardeclaration *) if level = globallevel then listaddresses ; insymbol ; alltypesdefined := true ; repeat startlist(varsofonetype) ; while true do begin if symbol = ident then begin newid(varidentry,vars) ; iserialise(varidentry) ; (*local variable*) appendid(varsofonetype,varidentry) ; insymbol end else error(2) ; checknextorcontext(subblockcontext + [valuesy,comma, colon] + typedels,[semicolon]) ; if symbol # comma then goto 9 ; insymbol end ; 9: ; accept(colon) ; typ(subblockcontext + [valuesy,semicolon] + typedels, vartypentry ) ; nextentry := varsofonetype.firstentry ; while nextentry # nil do with nextentry^ do begin idtype := vartypentry ; setaddressfor(nextentry) ; if (vartypentry # nil) and (vartypentry^.form = files) then newfile(nextentry) ; nextentry := next end ; appendlists(localidlist,varsofonetype) ; if symbol = semicolon then begin insymbol ; checkcontext(subblockcontext + [valuesy,ident]) end else error(14) until (symbol # ident) and not (symbol in typedels) ; listnoaddresses ; if symbol = valuesy then if level = globallevel then begin insymbol ; while symbol = ident do begin searchid([vars],varidentry) ; startinitialisationof(varidentry^.varaddress) ; insymbol ; if (symbol = relop) and (operator = eqop) then insymbol else error(16) ; valuefor(varidentry^.idtype, subblockcontext + [semicolon]) ; if symbol = semicolon then begin insymbol ; if not (symbol in subblockcontext + [ident]) then begin error(6) ; skip(subblockcontext) end end else error(14) end end else begin error(22) ; skip(subblockcontext) end end (* vardeclaration *) ; procedure procdeclaration ; var lsymbol : symboltype ; pfid,typeid : identry ; firstparam : formalentry ; functype : typentry ; alreadydeclared : boolean ; procedure parameterlist ( paramcontext : setofsymbols ; var params : formalentry ) ; label 9 ; var thisparam,nextparam,typeid : identry ; paramlist,paramsofonekind : idlist ; formallist,thisformal,lastformal : formalentry ; thistype : typentry ; varmode : boolean ; begin (* parameterlist *) startlist(paramlist) ; checknextorcontext(paramcontext + [leftparent], subblockcontext) ; formallist := nil ; if symbol = leftparent then begin if alreadydeclared then error(119) ; insymbol ; checknextorcontext(parambegsys,subblockcontext + [rightparent]) ; while symbol in parambegsys do begin startlist(paramsofonekind) ; case symbol of procsy : repeat insymbol ; if symbol = ident then begin newid(thisparam,proc) ; thisparam^.pfkind := formal ; setaddressfor(thisparam) ; appendid(paramsofonekind,thisparam) ; insymbol end else error(2) ; checkcontext(subblockcontext + [comma, semicolon,rightparent]) until symbol # comma ; funcsy : begin (* formal function parameters are chained in a sub-list until type can be inserted*) repeat insymbol ; if symbol = ident then begin newid(thisparam,func) ; thisparam^.pfkind := formal ; appendid(paramsofonekind,thisparam) ; insymbol end else error(2) ; if not(symbol in subblockcontext + [comma,colon]) then begin error(7) ; skip(subblockcontext + [comma,semicolon,rightparent]) end until symbol # comma ; if symbol = colon then begin insymbol ; if symbol = ident then begin searchid([types],typeid) ; thistype := typeid^.idtype ; if thistype # nil then if not(thistype^.form in [scalars,subranges,pointers]) then begin error(120) ; thistype := nil end ; nextparam :=paramsofonekind.firstentry; while nextparam # nil do begin setaddressfor(nextparam) ; nextparam^.idtype := thistype ; nextparam := nextparam^.next end ; insymbol end else error(2) ; checkcontext(subblockcontext + [semicolon, rightparent]) end else error(5) end ; varsy , ident : begin if symbol = varsy then begin varmode := true ; insymbol end else varmode := false ; while true do begin if symbol = ident then begin newid(thisparam,vars) ; iserialise(thisparam) ; (*f.param.*) thisparam^.varparam := varmode ; appendid(paramsofonekind,thisparam) ; insymbol end else error(2) ; if not(symbol in subblockcontext + [comma,colon]) then begin error(7) ; skip(subblockcontext + [comma,semicolon,rightparent]) end ; if symbol # comma then goto 9 ; insymbol end ; 9: ; if symbol = colon then begin thistype := nil ; insymbol ; if symbol = ident then begin searchid([types],typeid) ; thistype := typeid^.idtype ; insymbol end else error(2) ; if thistype # nil then if not varmode and (thistype^.form = files) then error(121) ; (* fill in type of formal variables *) nextparam := paramsofonekind.firstentry ; while nextparam # nil do begin nextparam^.idtype := thistype ; setaddressfor(nextparam) ; nextparam:= nextparam^.next end ; checkcontext(subblockcontext + [semicolon, rightparent]) end (* if symbol = colon *) else error(5) end end (* case *) ; appendlists(paramlist,paramsofonekind) ; if symbol = semicolon then begin insymbol ; checknextorcontext(subblockcontext+parambegsys, [rightparent]) end end (* while *) ; if symbol = rightparent then begin insymbol ; checkcontext(paramcontext + subblockcontext) end else error(4) ; thisparam := paramlist.firstentry ; lastformal := nil ; while thisparam # nil do begin new(thisformal) ; with thisformal^,thisparam^ do begin formaltype := idtype ; thisformal^.klass := klass ; if klass = vars then formalisvar := varparam ; thisformal^.next := nil end ; if lastformal = nil then formallist := thisformal else lastformal^.next := thisformal ; lastformal := thisformal ; thisparam := thisparam^.next end end (* if symbol = leftparent *) ; params := formallist end (* parameterlist *) ; begin (* procdeclaration *) startsavingtokens ; markbreak(blockhead) ; lsymbol := symbol ; insymbol ; alreadydeclared := false ; if symbol = ident then begin searchlocalid(display[top].idscope,pfid) ; if pfid # nil then with pfid^ do if klass = proc then alreadydeclared := forward and (lsymbol = procsy) and (pfkind = actual) else if klass = func then alreadydeclared := forward and (lsymbol = funcsy) and (pfkind = actual) ; insymbol end else begin error(2) ; spelling := '????????' end ; stopsavingtokens ; if not alreadydeclared then begin if lsymbol = procsy then newid(pfid,proc) else newid(pfid,func) ; iserialise(pfid) ; (* procedure/function block*) appendid(localidlist,pfid) ; openscope(bloc) ; openstackframe end else restorescope(pfid^.formalscope) ; if lsymbol = procsy then begin parameterlist([semicolon],firstparam) ; if not alreadydeclared then pfid^.formals := firstparam ; end else begin parameterlist([semicolon,colon],firstparam) ; if not alreadydeclared then pfid^.formals := firstparam ; if symbol = colon then begin insymbol ; if symbol = ident then begin if alreadydeclared then error(122) ; searchid([types],typeid) ; functype := typeid^.idtype ; pfid^.idtype := functype ; setaddressfor(pfid) ; if functype # nil then if not(functype^.form in [scalars,subranges,pointers]) then begin error(120) ; pfid^.idtype := nil end ; insymbol end else begin error(2) ; skip(subblockcontext + [semicolon]) end end else if not alreadydeclared then error(123) end ; accept(semicolon) ; if (symbol = ident) and(spelling = 'forward ') then begin if alreadydeclared then error(161) ; pfid^.forward := true ; savescope(pfid^.formalscope) ; startsavingtokens ; insymbol ; stopsavingtokens ; accept(semicolon) ; checkcontext(subblockcontext) end else begin pfid^.forward := false ; pfid^.assignable := true ; repeat block(subblockcontext,semicolon,pfid) ; if symbol = semicolon then begin insymbol ; if not(symbol in [beginsy,procsy,funcsy]) then begin error(6) ; skip(subblockcontext) end end else error(14) until symbol in [beginsy,procsy,funcsy] ; pfid^.assignable := false ; closestackframe ; filescope(pfid) ; disposescope ; closescope end end (* procdeclaration *) ; procedure body ; label 1 ; var endbody : boolean ; procedure statement ( statcontext : setofsymbols ) ; var labelfound : labelentry ; substatcontext : setofsymbols ; firstid : identry ; varpacked : boolean ; followingstatement : codesequence ; procedure expression (expcontext : setofsymbols) ; forward ; procedure selector (selectcontext : setofsymbols; varidentry : identry ) ; var localtype : typentry ; localid : identry ; lowerbound,upperbound : integer ; begin (* selector *) varpacked := false ; with varidentry^ do begin localtype := idtype ; if localtype # nil then case klass of vars : stackreference(varparam,varaddress, idtype^.representation) ; field : begin withreference(display[levelfound]. withbase,offset, localtype^. representation) ; varpacked := display[levelfound].fieldspacked end ; func : if pfdeckind = standard then error(150) else if (pfkind = formal) or not assignable then error(151) else stackreference(false,result, idtype^.representation) end (* case *) else stackreference(false,defaultaddress, defaultrepresentation) end (* with *) ; if not (symbol in selectsymbols + selectcontext) then begin error(59) ; localtype := nil ; skip(selectsymbols + selectcontext) end ; while symbol in selectsymbols do begin case symbol of leftbracket : begin repeat if localtype # nil then if localtype^.form # arrays then begin error(138) ; localtype := nil end ; insymbol ; expression(selectcontext + [comma,rightbracket]) ; if exptype # nil then if exptype^.form > subranges then error(113) ; if localtype # nil then begin with localtype^ do begin if comptypes(inxtype,exptype) then begin if (inxtype # nil) and (aeltype # nil) then begin varpacked := localtype^.packedarray ; getbounds(inxtype, lowerbound,upperbound); indexedreference(varpacked ,lowerbound,upperbound, aeltype^. representation) end end else error(139) end ; localtype := localtype^.aeltype end until symbol#comma ; accept(rightbracket) end ; period : begin if localtype # nil then if localtype^.form # records then begin error(140) ; localtype := nil end else varpacked := localtype^.packedrecord; insymbol ; if symbol = ident then begin if localtype # nil then begin searchlocalid(localtype^.fieldscope, localid ) ; if localid = nil then begin error(152) ; localtype := nil end else with localid^ do begin localtype := idtype ; if localtype # nil then fieldreference(offset, localtype^.representation) end end ; insymbol end else error(2) end ; arrow : begin if localtype # nil then begin with localtype^ do begin if form = pointers then begin localtype := domaintype ; varpacked := false ; if localtype # nil then pnterreference(localtype^. representation) end else if form = files then begin localtype := feltype ; varpacked := packedfile ; if localtype # nil then filereference(varpacked, textfile, localtype^.representation) end else error(141) ; end end ; insymbol end end ; if not (symbol in selectsymbols + selectcontext) then begin error(6) ; localtype := nil ; skip(selectsymbols + selectcontext) end end ; vartype := localtype ; end (* selector *) ; procedure call ( callcontext : setofsymbols; pfid :identry); var whichpf : stdprocfuncs ; procedure variable ( varcontext : setofsymbols ) ; var varid : identry ; begin if symbol = ident then begin searchid([vars,field],varid) ; insymbol end else begin error(2) ; varid := defaultentry[vars] end ; selector(varcontext,varid) end (* variable *) ; procedure fileprocedures ; begin variable(callcontext + [rightparent]) ; if vartype # nil then with vartype^ do if form = files then begin if feltype # nil then fileoperation(whichpf,packedfile, textfile, feltype^.representation) end else error(116) ; end (* fileprocedures *) ; procedure selectinput ; begin if inputfile = nil then error(178) else with inputfile^ do stackreference(varparam,varaddress, idtype^.representation) ; select(readfile) end ; procedure selectoutput ; begin if outputfile = nil then error(178) else with outputfile^ do stackreference(varparam,varaddress, idtype^.representation) ; select(writefile) end ; procedure readprocedure ; label 1 ; var filedetermined : boolean ; begin filedetermined := false ; while true do begin variable(callcontext + [comma,rightparent]) ; if vartype # nil then if comptypes(vartype,texttype) then if filedetermined then error(116) else select(readfile) else begin if not filedetermined then selectinput ; if comptypes(vartype,chartype) then readoperation(charkind) else if comptypes(vartype,realtype) then readoperation(realkind) else if comptypes(vartype,inttype) then readoperation(intkind) else error(116) end ; filedetermined := true ; if symbol # comma then goto 1 ; insymbol end ; 1: if whichpf = readlnp then readlayout end (* readprocedure *) ; procedure writeprocedure ; label 1 ; var exp1type : typentry ; writekind : outputkind ; format : formatkind ; filedetermined : boolean ; begin filedetermined := false ; while true do begin expression(callcontext + [comma,colon,rightparent]) ; exp1type := exptype ; if exptype # nil then if comptypes(exp1type,texttype) then if filedetermined then error(116) else select(writefile) else begin if not filedetermined then selectoutput ; if comptype(exp1type,chartype) then writekind := charkind else if comptype(exp1type,inttype) then writekind := intkind else if comptype(exp1type,realtype) then writekind := realkind else if comptype(exp1type,booltype) then writekind := boolkind else if string(exp1type) then writekind := stringkind else begin error(116) ; writekind := defaultkind end ; if symbol = colon then begin insymbol ; expression(callcontext + [comma,colon,rightparent]); if not comptypes(exptype,inttype) then error(116) ; if symbol = colon then begin insymbol ; expression(callcontext + [comma,rightparent]) ; if not comptypes(exptype,inttype) then error(116) ; if not comptypes(exp1type,realtype) then error(124) ; format := fixed end else format := floating end else format := default ; case writekind of intkind, realkind, charkind, boolkind : writescalars(writekind,format); stringkind : writestring(cardinality( exp1type^.inxtype),format); defaultkind : end end ; filedetermined := true ; if symbol # comma then goto 1 ; insymbol end ; 1: if whichpf = writelnp then begin stackconstant(linefeed) ; writelayout end end (* writeprocedure *) ; procedure pageprocedure ; begin variable(callcontext+[rightparent]) ; if comptypes(vartype,texttype) then begin select(writefile) ; stackconstant(pagethrow) ; writelayout end else error(116) end ; procedure packprocedure ; var lowerbound,upperbound : integer ; firstinxtype,firsteltype : typentry ; begin variable(callcontext + [comma,rightparent]) ; firstinxtype := nil ; firsteltype := nil ; if vartype # nil then with vartype^ do if form = arrays then begin if packedarray then error(116) ; firstinxtype := inxtype ; firsteltype := aeltype end else error(116) ; accept(comma) ; expression(callcontext + [comma,rightparent]) ; if exptype # nil then if exptype^.form # scalars then error(116) else if not comptypes(exptype,firstinxtype) then error(116) ; accept(comma) ; variable(callcontext + [rightparent]) ; if vartype # nil then with vartype^ do if form = arrays then begin if not packedarray then error(116) ; if not comptypes(aeltype,firsteltype) or not comptypes(inxtype,firstinxtype) then error(116) else if (firsteltype # nil) and (aeltype # nil) then begin getbounds(firstinxtype,lowerbound, upperbound) ; packoperation(packp,lowerbound, upperbound, firsteltype^.representation, aeltype^.representation , cardinality(inxtype) ) end end else error(116) ; end (* packprocedure *) ; procedure unpackprocedure ; var lowerbound,upperbound : integer ; secondinxtype,secondeltype, firstinxtype,firsteltype : typentry ; begin variable(callcontext + [comma,rightparent]) ; firstinxtype := nil ; firsteltype := nil ; if vartype # nil then with vartype^ do if form = arrays then begin if not packedarray then error(116) ; firstinxtype := inxtype ; firsteltype := aeltype end else error(116) ; accept(comma) ; variable(callcontext + [comma,rightparent]) ; secondinxtype := nil ; secondeltype := nil ; if vartype # nil then with vartype^ do if form = arrays then begin if packedarray then error(116) ; if not comptypes(aeltype,firsteltype) or not comptypes(inxtype,firstinxtype) then error(116) else begin secondinxtype := inxtype ; secondeltype := aeltype end end else error(116) ; accept(comma) ; expression(callcontext + [rightparent]) ; if exptype # nil then if exptype^.form # scalars then error(116) else if not comptypes(exptype,secondinxtype) then error(116) ; if (firsteltype#nil) and (secondeltype#nil) then begin getbounds(secondinxtype,lowerbound,upperbound) ; packoperation(unpackp, lowerbound,upperbound, secondeltype^.representation, firsteltype^.representation, cardinality(firstinxtype) ) end end (* unpackprocedure *) ; procedure heapprocedure ; label 1 ; var thisvarpart,thisvariant : typentry ; tagval : valu ; tagvaltype : typentry ; structureknown : boolean ; repneeded : typerepresentation ; begin variable(callcontext + [comma,rightparent]) ; thisvarpart := nil ; structureknown := false ; if vartype # nil then (* variable type pointer?*) with vartype^ do if form = pointers then begin if domaintype # nil then begin structureknown := true ; repneeded := domaintype^. representation ; if domaintype^.form = records then thisvarpart := domaintype^.varpart end end else begin error(116) ; structureknown := false end ; while symbol = comma do begin insymbol ; inconstant(callcontext + [comma,rightparent] , tagvaltype , tagval ) ; if string(tagvaltype) or (tagvaltype = realtype) then begin error(159) ; structureknown := false end else if structureknown then if thisvarpart = nil then begin error(158) ; structureknown := false end else if thisvarpart^.form # variantpart then begin error(162) ; structureknown := false end else if thisvarpart^.tagfield # nil then if comptypes(thisvarpart^.tagfield^. idtype,tagvaltype) then begin thisvariant := thisvarpart^.firstvariant ; while thisvariant # nil do with thisvariant^ do if variantvalue.ival1 = tagval.ival1 then begin thisvarpart:=subvarpart; repneeded := representation ; goto 1 end else thisvariant := nextvariant ; repneeded := thisvarpart^. representation ; thisvarpart := nil end else begin error(116) ; structureknown := false end ; 1: end (* while *) ; heapoperation(whichpf,repneeded) end (* heapprocedure *) ; procedure timeprocedure ; begin variable(callcontext + [rightparent]); case whichpf of datep,timep : if not comptypes(vartype,alfatype) then error(116) ; millp : if not comptypes(vartype,inttype) then error(116) end ; timeoperation(whichpf) end (* timeprocedure *) ; procedure haltprocedure ; begin expression(callcontext + [rightparent]) ; if not string(exptype) then error(116) else if exptype # nil then haltoperation(cardinality(exptype^.inxtype)) end (* haltprocedure *) ; procedure iclprocedure ; label 1 ; var f, x, n, m : integer ; labelfound : labelentry ; idfound : identry ; procedure posint(var val : integer ; max : integer ) ; var consttype : typentry ; constvalue : valu ; begin inconstant(callcontext + [comma,rightparent] , consttype , constvalue ); if not comptypes(consttype,inttype) then error(116) ; if (constvalue.ival1 < 0) or (constvalue.ival1 > max) then begin error(116) ; val := 0 end else val := constvalue.ival1 end (* posint *) ; begin (* iclprocedure *) posint(f,127) ; accept(comma) ; posint(x,7) ; accept(comma) ; if (f >= 050b) and (f < 100b) then if symbol = intconst then begin searchlabel(labelfound) ; jumpins(f,x,labelfound^.labelledcode) ; insymbol end else error(116) else begin if symbol = ident then begin searchid([consts,vars],idfound) ; if idfound^.klass = vars then begin iclins(f,x,idfound^.varaddress) ; insymbol ; goto 1 end end ; posint(n,4095) ; if symbol = comma then begin insymbol ; posint(m,3) end else m := 0 ; ins(f,x,n,m) ; 1: end end (* iclprocedure *) ; procedure calluserdefined ; var pfparamid : identry ; formparam,itsformparam : formalentry ; formtype : typentry ; callpfkind : idkind ; levelcalled : disprange ; reprequired : typerepresentation ; begin callpfkind := pfid^.pfkind ; if callpfkind = actual then begin formparam := pfid^.formals ; levelcalled := levelfound end else formparam := nil ; openparameterlist(pfid^.klass) ; if symbol = leftparent then begin repeat (* for each actual parameter *) if callpfkind = actual then (* must be corresponding formal *) if formparam = nil then error(126) ; insymbol ; if (formparam # nil) and (formparam^.klass in [proc,func]) then (* formal is procedure or function *) begin if symbol # ident then begin error(2) ; skip(callcontext + [comma,rightparent]) end else begin if formparam^.klass = proc then searchid([proc],pfparamid) else begin searchid([func],pfparamid) ; if not comptypes(pfparamid^.idtype, formparam^.formaltype) then error(128) end ; if pfparamid^.pfdeckind = standard then error(164) else if pfparamid^.pfkind = actual then begin (* ensure that a proc/func used as parameter to an other proc/ func has value params only *) itsformparam:=pfparamid^.formals ; while itsformparam # nil do with itsformparam^ do begin if klass # vars then error(170) else if formalisvar then error(170) ; itsformparam := next end ; passactual(levelfound, pfparamid^.codebody) end else passformal(pfparamid^. faddress) end (* symbol = ident *) ; insymbol ; checkcontext(callcontext + [comma, rightparent]) end (* formal procedure or function *) else if (formparam # nil) and (formparam^.formalisvar) then (* variable parameter *) begin variable(callcontext + [comma,rightparent]); (* actual variable parameter cannot be a component of a packed structure *) if varpacked then error(173) ; if not comptypes(vartype, formparam^.formaltype) then error(142) ; passreference end else (* value parameter *) begin expression(callcontext + [comma,rightparent]); if (callpfkind = actual) and (formparam # nil) then begin formtype := formparam^.formaltype ; if not comptypes(exptype,formtype) then if comptypes(formtype,realtype)and comptypes(exptype,inttype) then begin floatinteger(topofstack) ; exptype := realtype end else error(142) end ; if (formparam # nil) and (formparam^.formaltype # nil) then reprequired := formparam^. formaltype^.representation else if exptype # nil then reprequired := exptype^. representation else reprequired := defaultrepresentation ; passvalue(reprequired) end (* value parameter *) ; if formparam # nil then formparam := formparam^.next until symbol # comma ; accept(rightparent) end (* parameter list *) ; closeparameterlist ; if callpfkind = actual then begin if formparam # nil then error(126) ; callactual(levelcalled,pfid^.codebody) end else callformal(pfid^.faddress) ; if pfid^.klass = func then begin if pfid^.idtype # nil then takeresult(pfid^.idtype^.representation) ; exptype := pfid^.idtype end end (* calluserdefined *) ; begin (* call *) if pfid^.pfdeckind = standard then begin whichpf := pfid^.pfindex ; if symbol = leftparent then begin insymbol ; if pfid^.klass = proc then (* standard procedures *) case whichpf of getp,putp,resetp,rewritep: fileprocedures ; readlnp,readp : readprocedure ; writelnp,writep : writeprocedure ; newp,disposep: heapprocedure ; datep,timep,millp : timeprocedure ; haltp : haltprocedure ; pagep : pageprocedure ; iclp : iclprocedure ; packp : packprocedure ; unpackp : unpackprocedure end else begin (* standard functions *) if whichpf = addressf then begin variable(callcontext + [rightparent]) ; integerfunction(addressf) ; exptype := inttype end else begin expression(callcontext + [rightparent]) ; case whichpf of absf, sqrf: if comptypes(exptype,inttype) then integerfunction(whichpf) else if comptypes(exptype,realtype) then realfunction(whichpf) else begin error(125) ; exptype := inttype end ; oddf: begin if not comptypes(exptype,inttype) then error(125) ; integerfunction(oddf) ; exptype := booltype end ; succf, predf: begin if exptype # nil then if not ( exptype^.form in [scalars,subranges]) or comptypes(exptype,realtype) then begin error(125) ; exptype := nil end ; integerfunction(whichpf) end ; ordf: begin integerfunction(ordf) ; exptype := inttype end ; chrf: begin if not comptypes(exptype,inttype) then error(125) ; integerfunction(chrf) ; exptype := chartype end ; truncf, roundf: begin if not comptypes(exptype,realtype) then error(125) ; realfunction(whichpf) ; exptype := inttype end ; sinf, cosf, expf, lnf, sqrtf, arctanf: begin if comptypes(exptype,inttype) then floatinteger(topofstack) else if not comptypes(exptype,realtype) then error(125) ; realfunction(whichpf) ; exptype := realtype end ; cardf : begin if exptype # nil then if not ( exptype^.form = sets ) then error(125) ; integerfunction(cardf) ; exptype := inttype end ; eoff: begin if exptype # nil then if exptype^.form = files then filefunction(eoff) else error(125) ; exptype := booltype end ; eolnf : begin if comptypes(exptype,texttype) then filefunction(eolnf) else error(125) ; exptype := booltype end ; end (* case *) end end (* standard functions *) ; accept(rightparent) end else if whichpf in [readlnp,writelnp,pagep,eolnf,eoff] then case whichpf of readlnp : begin selectinput ; readlayout end ; writelnp : begin selectoutput ; stackconstant(linefeed) ; writelayout end ; pagep : begin selectoutput ; stackconstant(pagethrow) ; writelayout end ; eolnf, eoff : begin if inputfile = nil then error(178) else with inputfile^ do stackreference(varparam,varaddress, idtype^.representation) ; filefunction(whichpf) ; exptype := booltype end end (* case*) else error(9) end (* standard procedure or function *) else calluserdefined end (* call *) ; procedure subexpression(expcontext : setofsymbols) ; var lexptype : typentry ; expoperator : optype ; procedure simpleexpression (simexpcontext:setofsymbols) ; var sexptype : typentry ; sexpoperator : optype ; signed : boolean ; procedure plusminusmul ( firstoptype : typentry ; operator : optype ) ; begin if (firstoptype#nil)and(firstoptype^.form=sets) or (exptype#nil)and(exptype^.form=sets) then begin if comptypes(firstoptype,exptype) then begin if exptype = nil then exptype := firstoptype end else begin error(137) ; exptype := unisettype end ; binarysetoperation(operator) end else if comptypes(firstoptype,inttype) and comptypes(exptype,inttype) then begin exptype := inttype ; binaryintegeroperation(operator) end else begin if comptypes(firstoptype,inttype) then begin firstoptype := realtype ; floatinteger(nexttotop) end ; if comptypes(exptype,inttype) then begin exptype := realtype ; floatinteger(topofstack) end ; if comptypes(firstoptype,realtype) and comptypes(exptype,realtype) then begin exptype := realtype end else begin error(134) ; exptype := inttype end ; binaryrealoperation(operator) end end (* plusminusmul *) ; procedure term (termcontext : setofsymbols) ; var termtype : typentry ; loperator : optype ; procedure factor (factorcontext : setofsymbols) ; label 1 ; var lfacid : identry ; lfactype,compexptype : typentry ; begin if not ( symbol in facbegsys) then begin error(58) ; skip(factorcontext + facbegsys) ; exptype := nil end ; repeat if symbol in facbegsys then begin case symbol of ident : begin searchid([consts,vars,field,func] ,lfacid ) ; insymbol ; case lfacid^.klass of consts : with lfacid^ do begin stackconstant(values) ; exptype := idtype ; end ; vars, field : begin selector (factorcontext, lfacid) ; exptype := vartype end ; func : call(factorcontext,lfacid) end end ; intconst : begin stackconstant(constant) ; exptype := inttype ; insymbol end ; realconst : begin stackconstant(constant) ; exptype := realtype ; insymbol end ; charconst : begin stackconstant(constant) ; exptype := chartype ; insymbol end ; stringconst : begin stackconstant(constant) ; stringtype(exptype) ; insymbol end ; leftparent : begin insymbol ; subexpression(factorcontext + [rightparent]) ; accept(rightparent) end ; notsy : begin insymbol ; factor(factorcontext) ; if comptypes(exptype,booltype) then negateboolean else begin error(135) ; exptype := nil end end ; leftbracket : begin insymbol ; compexptype := nil ; lfactype := nil ; stackconstant(emptyset) ; if symbol=rightbracket then begin exptype := unisettype ; insymbol end else begin while true do begin expression(factorcontext + [comma,colon,rightbracket]); if exptype # nil then if exptype^.form > subranges then begin error(136) ; exptype := nil end else if compexptype =nil then begin compexptype := exptype ; new(lfactype, sets) ; with lfactype^ do begin form := sets ; packedset := false ; basetype := compexptype end ; setrepresentationf (lfactype) end else if not(comptypes( compexptype, exptype )) then error(137) ; if symbol=colon then begin insymbol ; expression(factorcontext + [comma,rightbracket]) ; if exptype # nil then if exptype^.form >subranges then begin error(136) ; exptype := nil end else if not(comptypes( compexptype, exptype )) then error(137) ; if compexptype # nil then rangeset(lfactype^. representation) end else begin if compexptype # nil then singletonset( lfactype^. representation) end ; binarysetoperation(plus) ; if symbol#comma then goto 1 ; insymbol end ; 1: ; accept(rightbracket) ; exptype := lfactype end end end ; checknextorcontext(factorcontext, facbegsys) end until symbol in factorcontext end (* factor *) ; begin (* term *) factor(termcontext + [mulop]) ; if (symbol=mulop) and (operator=andop) then binarybooleanoperation(andop,true) ; while symbol=mulop do begin termtype := exptype ; loperator := operator; insymbol ; factor(termcontext + [mulop]) ; case loperator of mul : plusminusmul(termtype,mul) ; rdiv : begin if comptypes(termtype,inttype) then begin floatinteger(nexttotop) ; termtype := realtype ; end ; if comptypes(exptype,inttype) then begin floatinteger(topofstack) ; exptype := realtype ; end ; if comptypes(termtype,realtype) and comptypes(exptype,realtype) then else error(134) ; exptype := realtype ; binaryrealoperation(rdiv) end ; idiv , imod : begin if comptypes(termtype,inttype) and comptypes(exptype,inttype) then else error(134) ; binaryintegeroperation(loperator) ; exptype := inttype end ; andop : begin if comptypes(termtype,booltype) and comptypes(exptype,booltype) then else error(134) ; binarybooleanoperation(andop,false) ; exptype := booltype end end (* case *) end end (* term *) ; begin (* simple expression *) signed := false ; if (symbol=addop)and(operator in [plus,minus]) then begin signed := operator=minus ; insymbol end ; term(simexpcontext + [addop]) ; if signed then if comptypes(exptype,inttype) then negateinteger else if comptypes(exptype,realtype) then negatereal else begin error(134) ; exptype := nil end ; if (symbol = addop) and (operator = orop) then binarybooleanoperation(orop,true) ; while symbol=addop do begin sexptype := exptype ; sexpoperator := operator ; insymbol ; term(simexpcontext + [addop]) ; case sexpoperator of plus : plusminusmul(sexptype,plus) ; minus : plusminusmul(sexptype,minus) ; orop : begin if comptypes(sexptype,booltype) and comptypes(exptype,booltype) then else error(134) ; binarybooleanoperation(orop,false) ; exptype := booltype end end (* case *) end end (* simple expression *) ; begin (* subexpression *) simpleexpression(expcontext + [relop]) ; if symbol=relop then begin excludeconditions ; lexptype := exptype ; expoperator := operator ; insymbol ; simpleexpression(expcontext) ; excludeconditions ; if expoperator = inop then begin if exptype # nil then if exptype^.form = sets then if comptypes(lexptype,exptype^.basetype) then setcomparison(inop) else error(129) else error(130) end else if lexptype # nil then begin if not(comptypes(lexptype,exptype)) then if comptypes(lexptype,inttype) then begin floatinteger(nexttotop) ; lexptype := realtype end else if comptypes(exptype,inttype) then begin floatinteger(topofstack) ; exptype := realtype end ; if comptypes(lexptype,exptype) then begin case lexptype^.form of scalars, subranges : if comptypes(lexptype,realtype) then realcomparison(expoperator) else integercomparison(expoperator) ; pointers : if expoperator in [ltop,leop,gtop, geop] then error(131) else integercomparison(expoperator) ; sets : if expoperator in [ltop,gtop] then error(132) else setcomparison(expoperator) ; arrays : if not(string(exptype)) then error(133) else strngcomparison( cardinality( exptype^.inxtype), expoperator) ; records, files : error(133) end ; end else error(129) end ; exptype := booltype ; end end (* subexpression *) ; procedure expression ; begin (* expression *) subexpression(expcontext) ; excludeconditions end (* expression *) ; procedure condition(condcontext : setofsymbols) ; begin (* condition *) subexpression(condcontext) ; if not comptypes(exptype,booltype) then error(144) end (* condition *) ; procedure assignment ( varid : identry ) ; var lvartype : typentry ; begin (* assignment *) selector(substatcontext + [becomes],varid) ; lvartype := vartype ; if symbol = becomes then begin insymbol ; expression(substatcontext) ; if (lvartype#nil) and (exptype#nil) then begin if comptypes(lvartype,realtype) and comptypes(exptype,inttype) then begin floatinteger(topofstack) ; exptype := realtype end ; if comptypes(lvartype,exptype) then case lvartype^.form of scalars , subranges , pointers , sets , arrays , records : assign ; files : error(146) end else error(129) end end else error(51) end (* assignment *) ; procedure compoundstatement ; begin (* compoundstatement *) repeat insymbol ; statement(statcontext + [semicolon,endsy]) until symbol # semicolon ; accept(endsy) end (* compoundstatement *) ; procedure ifstatement ; var forfalseaction : codesequence ; begin (* ifstatement *) insymbol ; condition(substatcontext + [thensy]) ; expectcodesequence(forfalseaction) ; jumponfalse(forfalseaction) ; accept(thensy) ; countnextflowunit ; (*then-limb*) statement(statcontext + [elsesy]) ; if symbol = elsesy then begin jump(followingstatement) ; nextiscodesequence(forfalseaction) ; countnextflowunit ; (*else-limb*) insymbol ; statement(statcontext) ; end else nextiscodesequence(forfalseaction) end (* ifstatement *) ; procedure casestatement ; label 1, 9, 29 ; var casetype,labeltype : typentry ; labelvalue : valu ; firstcase,lastcase, thiscase,newcase : casentry ; switchcode : codesequence ; begin (* casestatement *) insymbol ; expression(substatcontext + [ofsy,comma,colon]) ; casetype := exptype ; if casetype # nil then if (casetype^.form>subranges) or comptypes(casetype,realtype) then begin error(144) ; casetype := nil end ; expectcodesequence(switchcode) ; opencase(switchcode) ; accept(ofsy) ; firstcase := nil ; lastcase := nil ; repeat markbreak(caselabellist) ; while true do begin inconstant(substatcontext + [comma,colon], labeltype,labelvalue) ; if labeltype # nil then if comptypes(labeltype,casetype) then begin thiscase := firstcase ; lastcase := nil ; while thiscase # nil do begin if thiscase^.casevalue >= labelvalue.ival1 then begin if thiscase^.casevalue = labelvalue.ival1 then error(156); goto 1 end ; lastcase := thiscase ; thiscase := thiscase^.nextcase end ; 1: new(newcase) ; with newcase^ do begin casevalue := labelvalue.ival1 ; startcodesequence(caselimb) ; nextcase := thiscase end ; if lastcase = nil then firstcase := newcase else lastcase^.nextcase := newcase end else error(147) ; if symbol # comma then goto 9 ; insymbol end ; 9: ; accept(colon) ; countnextflowunit ; (*case-limb*) statement(statcontext + [semicolon]) ; jump(followingstatement) ; if symbol = semicolon then insymbol else if symbol # endsy then begin if symbol in statcontext then begin error(13) ; goto 29 end ; error(14) end until symbol = endsy ; nextiscodesequence(switchcode) ; closecase(firstcase) ; newcase := firstcase ; while newcase # nil do begin thiscase := newcase ; newcase := thiscase^.nextcase ; dispose(thiscase) end ; insymbol ; 29: end (* casestatement *) ; procedure whilestatement ; var totestcondition : codesequence ; begin (* whilestatement *) startcodesequence(totestcondition) ; insymbol ; countnextflowunit ; (*while-condition*) flowpoint ; (*while-expression*) condition(substatcontext + [dosy]) ; jumponfalse(followingstatement) ; accept(dosy) ; countnextflowunit ; (*while-body*) statement(statcontext) ; jump(totestcondition) ; end (* whilestatement *) ; procedure repeatstatement ; var thisstatement : codesequence ; begin (* repeatstatement *) startcodesequence(thisstatement) ; countnextflowunit ; (*repeat-body*) repeat insymbol ; statement(statcontext + [semicolon,untilsy]) ; until symbol # semicolon ; if symbol = untilsy then begin flowpoint ; (*until-clause*) insymbol ; condition(substatcontext) ; jumponfalse(thisstatement) ; end else error(53) end (* repeatstatement *) ; procedure forstatement ; var lvarid : identry ; lvartype : typentry ; increasing : boolean ; startofloop : codesequence ; begin (* forstatement *) insymbol ; if symbol = ident then begin searchid([vars],lvarid) ; lvartype := lvarid^.idtype ; if not (levelfound in [1,level]) then error(155) ; if lvartype # nil then if (lvartype^.form > subranges) or comptypes(lvartype,realtype) then begin error(143) ; lvartype := nil end else with lvarid^ do stackreference(varparam,varaddress, idtype^.representation) ; insymbol end else begin lvartype := nil ; error(2) ; skip(substatcontext + [becomes,tosy,dosy]) end ; if symbol = becomes then begin insymbol ; expression(substatcontext + [tosy,dosy]); if exptype # nil then if exptype^.form > subranges then error(144) else if not comptypes(lvartype,exptype) then error(145) end else begin error(51) ; skip(substatcontext + [tosy,dosy]) end ; if symbol = tosy then begin increasing := (operator = plus) ; insymbol ; expression(substatcontext + [dosy]) ; if exptype # nil then if exptype^.form > subranges then error(144) else if not comptypes(lvartype,exptype) then error(145) end else begin increasing := true ; error(55) ; skip(substatcontext + [dosy]) end ; openfor(increasing,startofloop,followingstatement) ; accept(dosy) ; countnextflowunit ; (*for-body*) statement(statcontext) ; closefor(increasing,startofloop) end (* forstatement *) ; procedure withstatement ; var recordid : identry ; base : stackentry ; begin (* withstatement *) insymbol ; if symbol = ident then begin searchid([vars,field],recordid) ; insymbol end else begin error(2) ; recordid := defaultentry[vars] end ; selector(substatcontext + [comma,dosy],recordid) ; openscope(withst) ; openwith(base) ; if vartype # nil then if vartype^.form = records then with display[top] do begin idscope := vartype^.fieldscope ; fieldspacked := vartype^.packedrecord ; withbase := base end else error(140) ; if symbol = comma then withstatement else begin accept(dosy) ; statement(statcontext) end ; closewith ; closescope end (* withstatement *) ; procedure gotostatement ; var labelfound : labelentry ; begin (* gotostatement *) insymbol ; if symbol = intconst then begin searchlabel(labelfound) ; labeljump(labelfound^.labelledcode,levelfound) ; insymbol end else error(15) end (* gotostatement *) ; begin (* statement *) substatcontext := statcontext + statbegsys ; if symbol = intconst then begin searchlabel(labelfound) ; if levelfound # level then begin error(176) ; newlabel(labelfound) end ; with labelfound^ do if defined then error(165) else begin nextiscodesequence(labelledcode) ; defined := true end ; markbreak(statlabel) ; insymbol ; accept(colon) end ; if not(symbol in substatcontext + [ident]) then begin error(6) ; skip(substatcontext) end ; if not (symbol in statbegsys + [ident]) then flowpoint ; (*dummy-statement*) while symbol in statbegsys + [ident] do begin openstatement(source.linenumber,symbol) ; flowpoint ; (*any statement*) expectcodesequence(followingstatement) ; case symbol of ident : begin searchid([vars,field,func,proc],firstid) ; insymbol ; if firstid^.klass = proc then call(statcontext,firstid) else assignment(firstid) end ; beginsy : compoundstatement ; gotosy : gotostatement ; ifsy : ifstatement ; casesy : casestatement ; whilesy : whilestatement ; repeatsy : repeatstatement ; forsy : forstatement ; withsy : withstatement end (* case *) ; closstatement ; nextiscodesequence(followingstatement) ; if symbol in statbegsys then error(14) else if not(symbol in statcontext-blockbegsys) then begin error(6) ; skip(substatcontext) end end (* while *) end (* statement *) ; begin (* body *) endbody := false ; listaddresses ; startsavingtokens ; markbreak(blockbody) ; initflowanalysisofbody ; if level = globallevel then begin enterprogram(progid) ; flowpoint ; (*program-block-body*) openfiles(permafiles) end else begin enterbody(blockidentry) ; flowpoint (*block-body*) end ; openfiles(scratchfiles) ; repeat if symbol=beginsy then insymbol ; while true do begin statement(blockcontext + [semicolon,endsy]) ; if symbol#semicolon then goto 1 ; insymbol end ; 1: ; if symbol=endsy then begin insymbol ; if symbol=blockfollower then endbody :=true end ; if not endbody then begin error(6) ; skip(blockcontext + statbegsys + [endsy]) end until endbody or (symbol in blockcontext) ; closefiles(scratchfiles) ; if level = globallevel then begin setendprogram ; closefiles(permafiles) ; leaveprogram end else begin if (blockidentry^.klass=func) and (blockidentry^.idtype # nil) then leaveresult(blockidentry^.result, blockidentry^.idtype^.representation) ; leavebody end ; stopsavingtokens ; listnoaddresses end (* body *) ; begin (* block *) scratchfiles := nil ; subblockcontext := blockbegsys + statbegsys - [casesy] ; startlist(localidlist) ; repeat if symbol=labelsy then labeldeclaration ; if symbol=constsy then constdeclaration ; if symbol=typesy then typedeclaration ; if symbol=varsy then vardeclaration ; while symbol in [procsy,funcsy] do procdeclaration ; if symbol#beginsy then if symbol in blockbegsys then error(21) else if symbol in statbegsys then error(17) else begin error(18) ; skip(subblockcontext) end until symbol in statbegsys ; body ; end (* block *) ; begin (* programme *) permafiles := nil ; if symbol = programsy then begin startsavingtokens ; listaddresses ; insymbol ; if symbol = ident then makeprogentry(spelling) ; accept(ident) ; stopsavingtokens ; if symbol = leftparent then begin repeat insymbol ; if symbol = ident then newpermafile(spelling) ; accept(ident) ; checknextorcontext([comma,rightparent], [semicolon]+blockbegsys) until symbol # comma ; accept(rightparent) end else defaultfiles ; listnoaddresses ; accept(semicolon) end else begin makeprogentry('pascal ') ; defaultfiles end ; openscope(bloc) ; openstackframe ; builtinfiles ; repeat block(blockbegsys,period,nil) until symbol = period ; closestackframe ; filescope(progid) ; disposescope end (* programme *) ; procedure initsetsofsymbols ; begin blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy, beginsy] ; constbegsys := [addop,intconst,realconst,charconst,stringconst, ident] ; simptypebegsys := constbegsys + [leftparent] ; typedels := [arraysy,recordsy,setsy,filesy] ; typebegsys := simptypebegsys + typedels + [arrow,packedsy] ; statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy, casesy] ; facbegsys := [intconst,realconst,charconst,stringconst,ident, leftparent,leftbracket,notsy] ; selectsymbols := [arrow,period,leftbracket ] ; parambegsy := [procsy,funcsy,varsy,ident] ; end (* initsetsofsymbols *) ; procedure initsemantictables ; procedure stdtypentries ; var entry : typentry ; begin (* stdtypentries *) new(inttype,scalars,standard) ; with inttype^ do begin representation := integerrepresentation ; form := scalars ; scalarkind := standard ; end ; new(realtype,scalars,standard) ; with realtype^ do begin representation := realrepresentation ; form := scalars ; scalarkind := standard ; end ; new(chartype,scalars,standard) ; with chartype^ do begin representation := charrepresentation ; form := scalars ; scalarkind := standard ; end ; new(booltype,scalars,declared) ; with booltype^ do begin representation := booleanrepresentation ; form := scalars ; scalarkind := declared ; end ; new(niltype,pointers) ; with niltype^ do begin representation := pointerrepresentation ; form := pointers ; domaintype := nil end ; new(layouttype,scalars,declared) ; with layouttype^ do begin representation := layoutrepresentation ; form := scalars ; scalarkind := declared end ; new(unisettype,sets) ; with unisettype^ do begin form := sets ; packedset := false ; basetype := nil end ; setrepresentationfor(unisettype) ; new(texttype,files) ; with texttype^ do begin form := files ; packedfile := true ; textfile := true ; feltype := chartype end ; setrepresentationfor(texttype) ; new(codeftype,files) ; with codeftype^ do begin form := files ; packedfile := false ; textfile := false ; feltype := inttype end ; setrepresentationfor(codeftype) ; new(entry,subranges) ; with entry^ do begin form := subranges ; rangetype := inttype ; min := 1 ; max := alfalength end ; setrepresentationfor(entry) ; new(alfatype,arrays) ; with alfatype^ do begin form := arrays ; aeltype := chartype ; packedarray := true ; inxtype := entry end ; setrepresentationfor(alfatype) ; end (* stdtypentries *) ; procedure stdidentries ; var entry,lastentry : identry ; pfname : stdprocfuncs ; begin (* stdidentries *) spelling := 'integer ' ; newid(entry,types) ; entry^.idtype := inttype ; spelling := 'real ' ; newid(entry,types) ; entry^.idtype := realtype ; spelling := 'char ' ; newid(entry,types) ; entry^.idtype := chartype ; spelling := 'boolean ' ; newid(entry,types) ; entry^.idtype := booltype ; spelling := 'text ' ; newid(entry,types) ; entry^.idtype := texttype ; spelling := 'alfa ' ; newid(entry,types) ; entry^.idtype := alfatype ; spelling := 'maxint ' ; newid(entry,consts) ; with entry^ do begin idtype := inttype ; values.ival1 := 37777777b end ; spelling := 'nil ' ; newid(entry,consts) ; with entry^ do begin idtype := niltype ; values.ival1 := nilvalue end ; spelling := 'true ' ; newid(entry,consts) ; with entry^ do begin idtype := booltype ; values.ival1 := 1 end ; lastentry := entry ; spelling := 'false ' ; newid(entry,consts) ; with entry^ do begin idtype := booltype ; next := lastentry end ; booltype^.firstconst := entry ; spelling := 'eol ' ; newid(entry,consts) ; entry^.idtype := layouttype ; layouttype^.firstconst := entry ; for pfname := getp to unpackp do begin spelling := stdpfnames[pfname] ; newid(entry,proc) ; with entry^ do begin pfdeckind := standard ; pfindex := pfname end end ; for pfname := absf to eolnf do begin spelling := stdpfnames[pfname] ; newid(entry,func) ; with entry^ do begin idtype := inttype ; pfdeckind := standard ; pfindex := pfname end end end (* stdidentries *) ; procedure enterdefaults ; var lclass : idclass ; begin (* enterdefaults *) spelling := 'default0' ; for lclass := types to func do begin spelling[8] := chr(ord(lclass)) ; newid(defaultentry[lclass],lclass) end end (* enterdefaults *) ; begin (* initsemantictables *) initscope ; stdtypentries ; stdidentries ; filestdtypes ; enterdefaults end (* initsemantictables *) ; begin initoptions ; initdiagnostics ; initlisting ; initcodegeneration ; insymbol ; initsetsofsymbols ; initsemantictables ; programme ; enddiagnostics ; endcodegeneration ; endlisting ; if errorcount = 0 then halt('cc') else halt('ce') end.