procedure getstrprocedure putstrsprocedure getlabprocedure putlabprocedure pshcstprocedure putcstprocedure pshstcprocedure putstcprocedure ininamprocedure putparlstprocedure putnamprocedure putnamsprocedure inidspprocedure putdspprocedure putsubprocedure putdspsprocedure putpileprocedure getfilprocedure putfilprocedure getcasprocedure putcasprocedure gettagprocedure puttagprocedure pshwthprocedure popwthfunction strequri: (unknown)procedure writevfunction lenpv: (unknown)procedure writevpprocedure strassvfprocedure strassvrprocedure strassveprocedure strassvcprocedure strassfvfunction strequvv: (unknown)function strltnvv: (unknown)function strequvf: (unknown)function strltnvf: (unknown)function strchr: (unknown)procedure strchrassprocedure getsqtprocedure strcatvrfunction bnot: (unknown)function bor: (unknown)function band: (unknown)function bxor: (unknown)procedure erroreprocedure errorvprocedure prtdspprocedure prtlnkfunction incact: (unknown)function fileeof: (unknown)function fileeoln: (unknown)procedure wrtsrclinprocedure readlinefunction eofinp: (unknown)function eol: (unknown)function ch: (unknown)function bufnxt: (unknown)procedure readinpprocedure errmsgprocedure endoflineprocedure outlineprocedure marklinefunction inpriv: (unknown)procedure errorprocedure chkstdprocedure prtsymprocedure insymbolprocedure nextchprocedure optionsprocedure switchfunction pwrten: (unknown)procedure plcchrprocedure escchrfunction match: (unknown)procedure pushbackprocedure prtclassprocedure prtformprocedure prtfpatprocedure prtlvlsymprocedure prtsymsprocedure enteridprocedure searchsectionprocedure schsecidnenmfunction inclass: (unknown)procedure searchidnenmprocedure searchidneprocedure schsecidneprocedure searchidprocedure getboundsfunction span: (unknown)function spana: (unknown)function isbyte: (unknown)function basetype: (unknown)function issub: (unknown)function alignquot: (unknown)procedure alignuprocedure aligndprocedure alignauprocedure wrtctpprocedure wrtstpprocedure prtstpprocedure prtctpprocedure printtablesprocedure markerprocedure markstpprocedure markctpprocedure followstpprocedure followctpprocedure chkrefsfunction chkext: (unknown)function chkfix: (unknown)function hasproc: (unknown)function hasfunc: (unknown)function ovrpf: (unknown)procedure genlabelprocedure wrttypcprocedure wrttypsubprocedure nxtctiprocedure nxtctisprocedure wrtchrprocedure wrtintprocedure wrtrfdprocedure wrtvarprocedure wrtenmprocedure wrttypfunction digits: (unknown)procedure prtlabeluprocedure prtlabelfunction lenlabel: (unknown)procedure prtlabelcprocedure prtflabelprocedure prtfxlabelprocedure prtfxlabelcfunction lenflabel: (unknown)procedure prtflabelcprocedure prtpartypcprocedure prtpartypprocedure searchlabelprocedure newlabelprocedure prtlabelsprocedure intmsgneolprocedure intmsgprocedure spfmsgfunction intt: (unknown)function realt: (unknown)function chart: (unknown)function bolt: (unknown)function stringt: (unknown)function arrayt: (unknown)function sett: (unknown)function ptrt: (unknown)function simt: (unknown)function ordt: (unknown)function filet: (unknown)function complext: (unknown)procedure lftjstprocedure par1procedure par2procedure meslprocedure mesprocedure mestfunction mestn: (unknown)procedure gen0procedure gen1sprocedure gen1procedure gen2procedure gentypindicatorprocedure gen0tprocedure gen1tsprocedure gen1tprocedure gen2tprocedure genujpxjpcalprocedure gencjpprocedure genipjprocedure gencupcufprocedure gencipcifprocedure gencuvcvfprocedure genlpaprocedure gensuvprocedure genctaivtcvbprocedure gensfrprocedure genmstprocedure genscafunction filecomponent: (unknown)function filecomponentre: (unknown)function comptypes: (unknown)function cmppar: (unknown)function cmpparlst: (unknown)procedure skipprocedure arrtmpprocedure constfactorprocedure consttermprocedure constexprprocedure checkbndsfunction containers: (unknown)function containerbase: (unknown)procedure loadprocedure gettmpprocedure puttmpprocedure puttmpsprocedure clrtmpprocedure loadaddressprocedure storeprocedure containeropfunction parnum: (unknown)function partype: (unknown)function cmptyp: (unknown)function ischrcst: (unknown)procedure fndopr1procedure fndopr2function isopr: (unknown)function taggedrec: (unknown)procedure selectorfunction schblk: (unknown)procedure checkvrntprocedure fixparprocedure callprocedure variableprocedure chkhdrprocedure getputresetrewriteprocedureprocedure pageprocedureprocedure readprocedureprocedure writeprocedureprocedure packprocedureprocedure unpackprocedureprocedure newdisposeprocedureprocedure absfunctionprocedure sqrfunctionprocedure truncfunctionprocedure roundfunctionprocedure oddfunctionprocedure ordfunctionprocedure chrfunctionprocedure predsuccfunctionprocedure eofeolnfunctionprocedure assignprocedureprocedure closeupdateappendprocedureprocedure positionprocedureprocedure deleteprocedureprocedure changeprocedureprocedure lengthlocationfunctionprocedure existsfunctionprocedure haltprocedureprocedure assertprocedureprocedure throwprocedureprocedure referprocedureprocedure seterrprocedureprocedure maxfunctionprocedure callnonstandardprocedure nxtprcfunction cmplst: (unknown)function psize: (unknown)procedure callop1procedure callop2function fungible: (unknown)procedure expressionprocedure simpleexpressionprocedure termprocedure factorprocedure declareprocedure resolvepprocedure typprocedure simpletypeprocedure fieldlistprocedure ordertagprocedure labeldeclarationprocedure constdeclarationprocedure typedeclarationprocedure wrtsymprocedure vardeclarationprocedure fixeddeclarationprocedure fixeditemprocedure procdeclarationprocedure pushlvlprocedure parameterlistprocedure joinlistsfunction compparamovl: (unknown)function conpar: (unknown)function comp: (unknown)procedure chkovlparfunction fndovlgrp: (unknown)function parmspc: (unknown)procedure parmoffprocedure parmrgprocedure bodyprocedure addlvlprocedure sublvlprocedure genfjpfunction fndactovl: (unknown)procedure statementprocedure assignmentprocedure gotostatementprocedure compoundstatementprocedure ifstatementprocedure casestatementfunction casecount: (unknown)procedure repeatstatementprocedure whilestatementprocedure forstatementprocedure withstatementprocedure trystatementprocedure externalheaderprocedure initvirtprocedure schvirtprocedure openinputprocedure errprocedure nxtincprocedure insertuseprocedure closeinputprocedure putinpprocedure cancelfwdprocedure usesjoinsfunction schnam: (unknown)function searchext: (unknown)procedure modulepprocedure stdnamesprocedure enterstdtypesprocedure entstdnamesprocedure entstdprocfuncprocedure entstdtypprocedure entstdintcstprocedure entstdrlcstprocedure entstdhdrprocedure entstdexpprocedure enterundeclprocedure exitundeclprocedure paroptprocedure setflgprocedure plcoptprocedure initscalarsprocedure initsetsprocedure inittablesprocedure reswordsprocedure symbolsprocedure ratorsprocedure procmnemonicsprocedure instrmnemonicsprocedure chartypesprocedure initdxType: integer
Type: integer
strglgth used to define the size of all strings in pcom and pint. With the
string quanta system, string lengths are effectively unlimited, but thereType: integer
Type: integer
stackelsize = minimum size for 1 stackelement
= kstackalType: integer
Type: integer
Type: integer
Type: integer
Type: integer
maximum characters in id string (basically, a full line)
Type: integer
Type: integer
Type: array
Type: integer
standard exceptions. Used for extension routines, this is a subset.
Type: integer
Type: integer
Type: integer
Type: scalar
Type: scalar
Type: set
Type: scalar
Type: pointer
Here is the variable length string containment to save on space. strings
strings are only stored in their length rounded to the nearest 10th.Type: set
Type: scalar
Type: pointer
Type: record
Type: subrange
Type: subrange
Type: subrange
Type: scalar
Type: scalar
Type: subrange
Type: array
Type: pointer
Type: pointer
Type: scalar
Type: set
Type: scalar
Type: array
Type: array
Type: array
Type: array
Type: array
Type: subrange
Type: record
Type: scalar
Type: scalar
Type: scalar
Type: scalar
Type: record
Type: pointer
Type: subrange
Type: record
Type: record
Type: record
Type: record
Type: subrange
Type: scalar
Type: pointer
Type: array
Type: text
Type: scalar
Type: record
Type: integer
Type: array
Type: subrange
Type: scalar
Type: scalar
Type: record
Type: integer
Type: array
Type: subrange
Type: boolean
Type: integer
Type: subrange
Type: subrange
Type: boolean
Type: boolean
Type: boolean
-- u: Check undefined tagfields, candidate
and finalType: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: pointer
Type: subrange
Type: subrange
Type: record
Type: set
Type: set
Type: set
Type: set
Type: set
Type: set
Type: set
Type: set
Type: set
Type: array
Type: array
Type: array
Type: array
Type: array
Type: array
Type: array
Type: array
Type: array
Type: array
Type: integer
Type: integer
Type: integer
Type: integer
Type: array
Type: integer
Type: array
Type: subrange
Type: scalar
allows referencing of noninteger constants by an index
(instead of a pointer), which can be stored in the p2-fieldType: integer
Recycling tracking counters, used to check for new/dispose mismatches.
Type: integer
serial numbers to label structure and identifier entries for dumps
Type: integer
Type: boolean
Type: subrange
flag for if error number list entries were printed
Type: subrange
Type: pointer
Type: pointer
Type: array
Type: array
Type: subrange
STRING HANDLING LIBRARY
function lcase: (unknown)function lcase: (unknown)function len: (unknown)function len: (unknown)procedure copyprocedure copyfunction copy: (unknown)function copy: (unknown)procedure copyprocedure catfunction cat: (unknown)function cat: (unknown)function cat: (unknown)function cat: (unknown)function comp: (unknown)function comp: (unknown)function comp: (unknown)function comp: (unknown)function compp: (unknown)Version numbers
64 bit Machine Parameter block (MPB)
Character Level Parsing Library
procedure openparprocedure opencommandfunction endlin: (unknown)function chkchr: (unknown)procedure getchrprocedure skpspcprocedure parlabprocedure parnumprocedure parfilprocedure parstrEXTENDED FUNCTION LIBRARY
procedure listprocedure listprocedure brknamprocedure brknamprocedure brknamprocedure maknamfunction maknam: (unknown)function maknam: (unknown)function maknam: (unknown)function maknam: (unknown)function maknam: (unknown)function maknam: (unknown)function maknam: (unknown)function maknam: (unknown)procedure fulnamfunction fulnam: (unknown)function optchr: (unknown)| 1 | {******************************************************************************* |
| 2 | * * |
| 3 | * PASCAL-P6 PORTABLE INTERPRETER * |
| 4 | * * |
| 5 | * LICENSING: * |
| 6 | * * |
| 7 | * Copyright (c) 2022, Scott A. Franco * |
| 8 | * All rights reserved. * |
| 9 | * * |
| 10 | * Redistribution and use in source and binary forms, with or without * |
| 11 | * modification, are permitted provided that the following conditions are met: * |
| 12 | * * |
| 13 | * 1. Redistributions of source code must retain the above copyright notice, * |
| 14 | * this list of conditions and the following disclaimer. * |
| 15 | * 2. Redistributions in binary form must reproduce the above copyright * |
| 16 | * notice, this list of conditions and the following disclaimer in the * |
| 17 | * documentation and/or other materials provided with the distribution. * |
| 18 | * * |
| 19 | * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * |
| 20 | * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * |
| 21 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * |
| 22 | * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE * |
| 23 | * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * |
| 24 | * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * |
| 25 | * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * |
| 26 | * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN * |
| 27 | * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * |
| 28 | * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * |
| 29 | * POSSIBILITY OF SUCH DAMAGE. * |
| 30 | * * |
| 31 | * The views and conclusions contained in the software and documentation are * |
| 32 | * those of the authors and should not be interpreted as representing official * |
| 33 | * policies, either expressed or implied, of the Pascal-P6 project. * |
| 34 | * * |
| 35 | * Portable Pascal assembler/interpreter * |
| 36 | * ************************************* * |
| 37 | * * |
| 38 | * Pascal P6 * |
| 39 | * * |
| 40 | * ETH May 76 * |
| 41 | * * |
| 42 | * Authors: * |
| 43 | * Urs Ammann * |
| 44 | * Kesav Nori * |
| 45 | * Christian Jacobi * |
| 46 | * K. Jensen * |
| 47 | * N. Wirth * |
| 48 | * * |
| 49 | * Address: * |
| 50 | * Institut Fuer Informatik * |
| 51 | * Eidg. Technische Hochschule * |
| 52 | * CH-8096 Zuerich * |
| 53 | * * |
| 54 | * This code is fully documented in the book * |
| 55 | * "Pascal Implementation" * |
| 56 | * by Steven Pemberton and Martin Daniels * |
| 57 | * published by Ellis Horwood, Chichester, UK * |
| 58 | * ISBN: 0-13-653-0311 * |
| 59 | * (also available in Japanese) * |
| 60 | * * |
| 61 | * Steven Pemberton, CWI/AA, * |
| 62 | * Kruislaan 413, 1098 SJ Amsterdam, NL * |
| 63 | * Steven.Pemberton@cwi.nl * |
| 64 | * * |
| 65 | * Adaption from P5 to P6 by: * |
| 66 | * * |
| 67 | * Scott A. Franco * |
| 68 | * samiam@moorecad.com * |
| 69 | * * |
| 70 | * The comments marked with brackets are mine [sam] * |
| 71 | * * |
| 72 | * Please see accompanying documentation concerning this software. * |
| 73 | * * |
| 74 | * ---------------------------------------------------------------------------- * |
| 75 | * * |
| 76 | * LICENSE * |
| 77 | * * |
| 78 | * ---------------------------------------------------------------------------- * |
| 79 | * * |
| 80 | * This software is based on, and represents an enhanced version, of Pascal-P5, * |
| 81 | * which is itself based on Pascal-P4, and was enhanced from that version * |
| 82 | * substantially. * |
| 83 | * * |
| 84 | * Pascal-P4 is unlicensed and exists in the public domain. It has: * |
| 85 | * * |
| 86 | * 1. Been acknowledged as public domain by the author, Niklaus Wirth at ETH * |
| 87 | * Zurich. * |
| 88 | * * |
| 89 | * 2. Has been freely distributed since 1976 with only charges for printing and * |
| 90 | * shipping costs. * |
| 91 | * * |
| 92 | * 3. Has been used as the basis for many projects, both paid and free, by * |
| 93 | * other authors. * |
| 94 | * * |
| 95 | * I, Scott Franco, have extensively expanded the original software. The * |
| 96 | * the changes made by me are held in copyright by me and released under the * |
| 97 | * BSD "2-clause" license, the least restrictive open source license available. * |
| 98 | * * |
| 99 | *******************************************************************************} |
| 100 | |
| 101 | program pcom(output,command); |
| 102 | |
| 103 | joins services, { services } |
| 104 | parse; { command line parsing } |
| 105 | |
| 106 | uses endian, { endian mode } |
| 107 | mpb, { machine parameter block } |
| 108 | version, { current version number } |
| 109 | strings; { string handling } |
| 110 | |
| 111 | label 99; { terminate immediately } |
| 112 | |
| 113 | const |
| 114 | |
| 115 | { ************************************************************************ |
| 116 | |
| 117 | Program object sizes and characteristics, sync with pint. These define |
| 118 | the machine specific characteristics of the target. |
| 119 | |
| 120 | The configurations are as follows: |
| 121 | |
| 122 | type #bits 16 #bits 32 #bits 64 |
| 123 | =========================================================== |
| 124 | integer 16 32 64 |
| 125 | real 32 64 64 |
| 126 | char 8 8 |
| 127 | boolean 8 8 |
| 128 | set 256 256 |
| 129 | pointers 16 32 64 |
| 130 | marks 16 32 64 (bytes) |
| 131 | File logical number 8 8 8 |
| 132 | |
| 133 | Both endian types are supported. There is no alignment needed, but you |
| 134 | may wish to use alignment to tune the runtime speed. |
| 135 | |
| 136 | The machine characteristics dependent on byte accessable machines. This |
| 137 | table is all you should need to adapt to any byte addressable machine. |
| 138 | |
| 139 | } |
| 140 | |
| 141 | { ******************* end of pcom and pint common parameters *********** } |
| 142 | |
| 143 | displimit = 300; |
| 144 | maxlevel = 255; |
| 145 | { strglgth used to define the size of all strings in pcom and pint. With the |
| 146 | string quanta system, string lengths are effectively unlimited, but there |
| 147 | it still sets the size of some buffers in pcom. } |
| 148 | strglgth = 2000; |
| 149 | fileal = charal; |
| 150 | (* stackelsize = minimum size for 1 stackelement |
| 151 | = k*stackal |
| 152 | stackal = scm(all other al-constants) |
| 153 | charmax = scm(charsize,charal) |
| 154 | scm = smallest common multiple *) |
| 155 | parmal = stackal; |
| 156 | parmsize = stackelsize; |
| 157 | recal = stackal; |
| 158 | maxaddr = pmmaxint; |
| 159 | maxsp = 115; { number of standard procedures/functions } |
| 160 | maxins = 130; { maximum number of instructions } |
| 161 | maxids = 250; { maximum characters in id string (basically, a full line) } |
| 162 | maxstd = 84; { number of standard identifiers } |
| 163 | maxres = 66; { number of reserved words } |
| 164 | reslen = 9; { maximum length of reserved words } |
| 165 | explen = 32; { length of exception names } |
| 166 | maxrld = 22; { maximum length of real in digit form } |
| 167 | varsqt = 10; { variable string quanta } |
| 168 | prtlln = 10; { number of label characters to print in dumps } |
| 169 | minocc = 50; { minimum occupancy for case tables } |
| 170 | varmax = 1000; { maximum number of logical variants to track } |
| 171 | cstoccmax=4000; cixmax=10000; |
| 172 | fillen = maxids; |
| 173 | extsrc = '.pas'; { extention for source file } |
| 174 | maxftl = 519; { maximum fatal error } |
| 175 | parfld = 24; { field length for intermediate parameters } |
| 176 | |
| 177 | { default field sizes for write } |
| 178 | intdeff = 11; { default field length for integer } |
| 179 | reldeff = 22; { default field length for real } |
| 180 | chrdeff = 1; { default field length for char (usually 1) } |
| 181 | boldeff = 5; { default field length for boolean (usually 5 for 'false' } |
| 182 | |
| 183 | { command line parsing } |
| 184 | maxlin = 20000; { size of source line buffer } |
| 185 | maxopt = 28; { number of options } |
| 186 | optlen = 10; { maximum length of option words } |
| 187 | |
| 188 | { standard exceptions. Used for extension routines, this is a subset. } |
| 189 | CommandLineTooLong = 1; |
| 190 | FunctionNotImplemented = 2; |
| 191 | FileDeleteFail = 3; |
| 192 | FileNameChangeFail = 4; |
| 193 | |
| 194 | type |
| 195 | |
| 196 | (*describing:*) |
| 197 | (*************) |
| 198 | |
| 199 | (*basic symbols*) |
| 200 | (***************) |
| 201 | |
| 202 | symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop, |
| 203 | lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow, |
| 204 | colon,becomes,range,labelsy,constsy,typesy,varsy,funcsy,progsy, |
| 205 | procsy,setsy,packedsy,arraysy,recordsy,filesy,beginsy,ifsy, |
| 206 | casesy,repeatsy,whilesy,forsy,withsy,gotosy,endsy,elsesy,untilsy, |
| 207 | ofsy,dosy,tosy,downtosy,thensy,nilsy,forwardsy,modulesy,usessy, |
| 208 | privatesy,externalsy,viewsy,fixedsy,processsy,monitorsy,sharesy, |
| 209 | classsy,issy,overloadsy,overridesy,referencesy,joinssy,staticsy, |
| 210 | inheritedsy,selfsy,virtualsy,trysy,exceptsy,extendssy,onsy, |
| 211 | resultsy,operatorsy,outsy,propertysy,channelsy,streamsy,othersy, |
| 212 | hexsy,octsy,binsy,numsy); |
| 213 | operatort = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop, |
| 214 | neop,eqop,inop,noop,xorop,notop,bcmop); |
| 215 | setofsys = set of symbol; |
| 216 | chtp = (letter,number,special,illegal, |
| 217 | chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace,chlcmt,chrem, |
| 218 | chhex,choct,chbin); |
| 219 | { Here is the variable length string containment to save on space. strings |
| 220 | strings are only stored in their length rounded to the nearest 10th. } |
| 221 | strvsp = ^strvs; { pointer to variable length id string } |
| 222 | strvs = record { id string variable length } |
| 223 | str: packed array [1..varsqt] of char; { data contained } |
| 224 | next: strvsp { next } |
| 225 | end; |
| 226 | |
| 227 | (*constants*) |
| 228 | (***********) |
| 229 | setty = set of setlow..sethigh; |
| 230 | cstclass = (reel,pset,strg); |
| 231 | csp = ^ constant; |
| 232 | constant = record |
| 233 | next: csp; { next entry link } |
| 234 | case cclass: cstclass of |
| 235 | reel: (rval: real); |
| 236 | pset: (pval: setty); |
| 237 | strg: (slgth: 0..strglgth; sval: strvsp) |
| 238 | end; |
| 239 | |
| 240 | valu = record case intval: boolean of |
| 241 | true: (ival: integer); |
| 242 | false: (valp: csp) |
| 243 | end; |
| 244 | |
| 245 | (*data structures*) |
| 246 | (*****************) |
| 247 | levrange = 0..maxlevel; addrrange = -maxaddr..maxaddr; stkoff = -maxaddr..maxaddr; |
| 248 | structform = (scalar,subrange,pointer,power,arrays,arrayc,records,files, |
| 249 | tagfld,variant,exceptf); |
| 250 | declkind = (standard,declared); |
| 251 | varinx = 0..varmax; |
| 252 | vartbl = array [0..varmax] of integer; { variant value to logical table } |
| 253 | vartpt = ^vartbl; |
| 254 | stp = ^ structure; |
| 255 | ctp = ^ identifier; |
| 256 | |
| 257 | structure = record |
| 258 | snm: integer; { serial number } |
| 259 | next: stp; { next entry link } |
| 260 | marked: boolean; (*for test phase only*) |
| 261 | size: addrrange; |
| 262 | packing: boolean; { packing status } |
| 263 | case form: structform of |
| 264 | scalar: (case scalkind: declkind of |
| 265 | declared: (fconst: ctp); standard: ()); |
| 266 | subrange: (rangetype: stp; min,max: valu); |
| 267 | pointer: (eltype: stp); |
| 268 | power: (elset: stp; matchpack: boolean); |
| 269 | arrays: (aeltype,inxtype: stp; tmpl: integer); |
| 270 | arrayc: (abstype: stp); |
| 271 | records: (fstfld: ctp; recvar: stp; recyc: stp); |
| 272 | files: (filtype: stp); |
| 273 | tagfld: (tagfieldp: ctp; fstvar: stp; vart: vartpt; |
| 274 | varts: varinx); |
| 275 | variant: (nxtvar,subvar,caslst: stp; varfld: ctp; |
| 276 | varval: valu; varln: integer); |
| 277 | exceptf: () |
| 278 | end; |
| 279 | |
| 280 | (*names*) |
| 281 | (*******) |
| 282 | |
| 283 | idclass = (types,konst,fixedt,vars,field,proc,func,alias); |
| 284 | setofids = set of idclass; |
| 285 | idkind = (actual,formal); |
| 286 | idstr = packed array [1..maxids] of char; |
| 287 | restr = packed array [1..reslen] of char; |
| 288 | expstr = packed array [1..explen] of char; |
| 289 | csstr = packed array [1..strglgth] of char; |
| 290 | rlstr = packed array [1..maxrld] of char; |
| 291 | keyrng = 1..33; { range of standard call keys } |
| 292 | filnam = packed array [1..fillen] of char; { filename strings } |
| 293 | lininx = 1..maxlin; { index for source line buffer } |
| 294 | linbuf = packed array [lininx] of char; { buffer for source lines } |
| 295 | optinx = 1..optlen; { index for option name } |
| 296 | optstr = packed array [optinx] of char; { option name string } |
| 297 | filptr = ^filrec; |
| 298 | filrec = record next: filptr; fn: filnam; mn: strvsp; f: text; |
| 299 | priv: boolean; linecount, lineout: integer; |
| 300 | sb: linbuf; si: lininx; sl: 0..maxlin; lo: boolean; |
| 301 | fio: boolean; use: boolean; uselist: filptr end; |
| 302 | partyp = (ptval, ptvar, ptview, ptout); |
| 303 | { procedure function attribute } |
| 304 | fpattr = (fpanone,fpaoverload,fpastatic,fpavirtual,fpaoverride); |
| 305 | identifier = record |
| 306 | snm: integer; { serial number } |
| 307 | name: strvsp; llink, rlink: ctp; |
| 308 | idtype: stp; next: ctp; keep: boolean; |
| 309 | refer: boolean; |
| 310 | case klass: idclass of |
| 311 | types: (); |
| 312 | konst: (values: valu); |
| 313 | vars: (vkind: idkind; vlev: levrange; vaddr: addrrange; |
| 314 | isloc: boolean; threat: boolean; forcnt: integer; |
| 315 | part: partyp; hdr: boolean; vext: boolean; |
| 316 | vmod: filptr; inilab: integer; skplab: integer; |
| 317 | ininxt: ctp; dblptr: boolean); |
| 318 | fixedt: (floc: integer; fext: boolean; fmod: filptr); |
| 319 | field: (fldaddr: addrrange; varnt: stp; varlb: ctp; |
| 320 | tagfield: boolean; taglvl: integer; |
| 321 | varsaddr: addrrange; varssize: addrrange; |
| 322 | vartl: integer); |
| 323 | proc, func: (pfaddr: addrrange; pflist: ctp; { param list } |
| 324 | pfnum: integer; { number of parameters } |
| 325 | locpar: addrrange; { size of parameters } |
| 326 | locstr: addrrange; { start of locals } |
| 327 | locspc: addrrange; { space occupied by locals } |
| 328 | asgn: boolean; { assigned } |
| 329 | pext: boolean; pmod: filptr; pfattr: fpattr; |
| 330 | pfvaddr: addrrange; pfvid: ctp; |
| 331 | grppar, grpnxt: ctp; |
| 332 | case pfdeckind: declkind of |
| 333 | standard: (key: keyrng); |
| 334 | declared: (pflev: levrange; pfname: integer; |
| 335 | case pfkind: idkind of |
| 336 | actual: (forwdecl, sysrot, extern: boolean); |
| 337 | formal: ())); |
| 338 | alias: (actid: ctp; { actual id }) |
| 339 | end; |
| 340 | |
| 341 | where = (blck,crec,vrec,rec); |
| 342 | |
| 343 | (*expressions*) |
| 344 | (*************) |
| 345 | attrkind = (cst,varbl,expr); |
| 346 | vaccess = (drct,indrct,inxd); |
| 347 | |
| 348 | attr = record symptr: ctp; typtr: stp; spv: boolean; |
| 349 | case kind: attrkind of |
| 350 | cst: (cval: valu); |
| 351 | varbl: (packing: boolean; packcom: boolean; |
| 352 | tagfield: boolean; taglvl: integer; varnt: stp; |
| 353 | ptrref: boolean; vartagoff: addrrange; |
| 354 | varssize: addrrange; vartl: integer; pickup: boolean; |
| 355 | dblptr: boolean; |
| 356 | case access: vaccess of |
| 357 | drct: (vlevel: levrange; dplmt: addrrange); |
| 358 | indrct: (idplmt: addrrange); |
| 359 | inxd: ()); |
| 360 | expr: () |
| 361 | end; |
| 362 | |
| 363 | (*labels*) |
| 364 | (********) |
| 365 | lbp = ^ labl; |
| 366 | labl = record { 'goto' label } |
| 367 | nextlab: lbp; { next list link } |
| 368 | defined: boolean; { label defining point was seen } |
| 369 | labval, { numeric value of label } |
| 370 | labname: integer; { internal sequental name of label } |
| 371 | labid: strvsp; { id in case of identifier label } |
| 372 | vlevel: levrange; { procedure level of definition } |
| 373 | slevel: integer; { statement level of definition } |
| 374 | ipcref: boolean; { was referenced by another proc/func } |
| 375 | minlvl: integer; { minimum goto reference statement lvl } |
| 376 | bact: boolean; { containing block is active } |
| 377 | refer: boolean { was referred to } |
| 378 | end; |
| 379 | |
| 380 | disprange = 0..displimit; |
| 381 | disprec = record (*=blck: id is variable id*) |
| 382 | fname: ctp; flabel: lbp; (*=crec: id is field id in record with*) |
| 383 | fconst: csp; fstruct: stp; |
| 384 | packing: boolean; { used for with derived from packed } |
| 385 | packcom: boolean; { used for with derived from packed } |
| 386 | ptrref: boolean; { used for with derived from pointer } |
| 387 | define: boolean; { is this a defining block? } |
| 388 | modnam: strvsp; { module name for block (if exists) } |
| 389 | inilst: ctp; { initializer list } |
| 390 | oprprc: array [operatort] of ctp; { operator functions } |
| 391 | case occur: where of (* constant address*) |
| 392 | crec: (clev: levrange; (*=vrec: id is field id in record with*) |
| 393 | cdspl: addrrange);(* variable address*) |
| 394 | vrec: (vdspl: addrrange); |
| 395 | blck: (bname: ctp); { block id } |
| 396 | rec: () |
| 397 | end; (* --> procedure withstatement*) |
| 398 | |
| 399 | { external file tracking entries } |
| 400 | extfilep = ^filerec; |
| 401 | filerec = record filename:idstr; nextfile:extfilep end; |
| 402 | |
| 403 | { case statement tracking entries } |
| 404 | cip = ^caseinfo; |
| 405 | caseinfo = record next: cip; |
| 406 | csstart: integer; |
| 407 | cslabs,cslabe: integer |
| 408 | end; |
| 409 | |
| 410 | { tag tracking entries } |
| 411 | ttp = ^tagtrk; |
| 412 | tagtrk = record |
| 413 | ival: integer; |
| 414 | next: ttp |
| 415 | end; |
| 416 | |
| 417 | { 'with' tracking entries } |
| 418 | wtp = ^wthtrk; |
| 419 | wthtrk = record next: wtp; |
| 420 | sl: integer |
| 421 | end; |
| 422 | |
| 423 | stdrng = 1..maxstd; { range of standard name entries } |
| 424 | oprange = 0..maxins; |
| 425 | modtyp = (mtprogram, mtmodule); { type of current module } |
| 426 | byte = 0..255; { 8-bit byte } |
| 427 | bytfil = packed file of byte; { untyped file of bytes } |
| 428 | { temp entries for sets } |
| 429 | tmpptr = ^tmpety; |
| 430 | tmpety = record |
| 431 | next: tmpptr; { next set temp in line } |
| 432 | occu: boolean; { occupied status } |
| 433 | auto: boolean; { clear automatically } |
| 434 | off: stkoff; { stack offset } |
| 435 | len: addrrange { length } |
| 436 | end; |
| 437 | errptr = ^errlin; |
| 438 | errlin = record { line error tracking } |
| 439 | next: errptr; { next entry } |
| 440 | errlin: integer; { line number } |
| 441 | end; |
| 442 | filext = packed array [1..4] of char; { filename extension } |
| 443 | |
| 444 | (*-------------------------------------------------------------------------*) |
| 445 | |
| 446 | var |
| 447 | |
| 448 | prd: text; { input source file } |
| 449 | prr: text; { output code file } |
| 450 | |
| 451 | prdval: boolean; { input source file parsed } |
| 452 | prrval: boolean; { output intermediate file parsed } |
| 453 | prdopn: boolean; { input source file open } |
| 454 | prropn: boolean; { output intermediate file open } |
| 455 | |
| 456 | (*returned by source program scanner |
| 457 | insymbol: |
| 458 | **********) |
| 459 | |
| 460 | sy: symbol; (*last symbol*) |
| 461 | op: operatort; (*classification of last symbol*) |
| 462 | val: valu; (*value of last constant*) |
| 463 | lgth: integer; (*length of last string constant*) |
| 464 | id: idstr; (*last identifier (possibly truncated)*) |
| 465 | kk: 1..maxids; (*nr of chars in last identifier*) |
| 466 | |
| 467 | { pushback system, last and next variables } |
| 468 | lsy: symbol; lop: operatort; lval: valu; llgth: integer; |
| 469 | lid: idstr; lkk: 1..maxids; |
| 470 | nsy: symbol; nop: operatort; nval: valu; nlgth: integer; |
| 471 | nid: idstr; nkk: 1..maxids; nvalid: boolean; |
| 472 | |
| 473 | (*counters:*) |
| 474 | (***********) |
| 475 | |
| 476 | chcnt: integer; (*character counter*) |
| 477 | ic,gc: addrrange; (*data location and instruction counter*) |
| 478 | lc,lcs: stkoff; |
| 479 | |
| 480 | (*switches:*) |
| 481 | (***********) |
| 482 | |
| 483 | dp: boolean; (*declaration part*) |
| 484 | list: boolean; { -- l: source program listing } |
| 485 | dolineinfo: boolean; { -- z: Output line information on listing } |
| 486 | prcode: boolean; { -- c: print symbolic code } |
| 487 | prtables: boolean; { -- t: displaying ident and struct tables } |
| 488 | chkvar: boolean; { -- v: check variant records } |
| 489 | debug: boolean; { -- d: Debug checks } |
| 490 | chkref: boolean; { -- r: Reference checks } |
| 491 | chkudtc, chkudtf: boolean; { -- u: Check undefined tagfields, candidate |
| 492 | and final } |
| 493 | iso7185: boolean; { -- s: restrict to iso7185 language } |
| 494 | dodmplex: boolean; { -- x: dump lexical } |
| 495 | doprtryc: boolean; { -- z: dump recycling tracker counts } |
| 496 | doprtlab: boolean; { -- b: print labels } |
| 497 | dodmpdsp: boolean; { -- y: dump the display } |
| 498 | chkvbk: boolean; { -- i: check VAR block violations } |
| 499 | experr: boolean; { -- ee/experror: expanded error |
| 500 | descriptions } |
| 501 | |
| 502 | { switches passed through to pint } |
| 503 | |
| 504 | { -- o: check arithmetic overflow } |
| 505 | { -- g: dump label definitions } |
| 506 | { -- f: perform source level debugging } |
| 507 | { -- m: break heap returned blocks as occupied } |
| 508 | { -- h: add source line sets to code } |
| 509 | { -- n: obey heap space recycle requests } |
| 510 | { -- p: check reuse of freed entry } |
| 511 | { -- q: check undefined accesses } |
| 512 | { -- w: enter debugger on run } |
| 513 | { -- a: enter debugger on fault } |
| 514 | { -- e: output P-machine code deck and stop } |
| 515 | |
| 516 | { unused options } |
| 517 | |
| 518 | { -- j } |
| 519 | { -- k } |
| 520 | { -- z } |
| 521 | |
| 522 | (*pointers:*) |
| 523 | (***********) |
| 524 | parmptr, |
| 525 | intptr,crdptr,realptr,charptr, |
| 526 | boolptr,nilptr,textptr, |
| 527 | exceptptr,stringptr,pstringptr, |
| 528 | byteptr,vectorptr,matrixptr, |
| 529 | abyteptr,scharptr: stp; (*pointers to entries of standard ids*) |
| 530 | utypptr,ucstptr,uvarptr, |
| 531 | ufldptr,uprcptr,ufctptr, (*pointers to entries for undeclared ids*) |
| 532 | fwptr: ctp; (*head of chain of forw decl type ids*) |
| 533 | outputptr,inputptr, |
| 534 | prdptr,prrptr,errorptr, |
| 535 | listptr,commandptr: ctp; { pointers to default files } |
| 536 | usclrptr: ctp; { used to satisfy broken record tag fields } |
| 537 | fextfilep: extfilep; (*head of chain of external files*) |
| 538 | wthstk: wtp; { stack of with entries active } |
| 539 | |
| 540 | (*bookkeeping of declaration levels:*) |
| 541 | (************************************) |
| 542 | |
| 543 | level: levrange; (*current static level*) |
| 544 | disx, (*level of last id searched by searchid*) |
| 545 | top: disprange; (*top of display*) |
| 546 | ptop: disprange; { top of pile } |
| 547 | |
| 548 | display: (*where: means:*) |
| 549 | array [disprange] of disprec; |
| 550 | |
| 551 | pile: { pile of joined/class contexts } |
| 552 | array [disprange] of disprec; |
| 553 | |
| 554 | (*error messages:*) |
| 555 | (*****************) |
| 556 | |
| 557 | errinx: 0..10; (*nr of errors in current source line*) |
| 558 | errlist: |
| 559 | array [1..10] of |
| 560 | packed record pos: integer; |
| 561 | nmr: 1..maxftl |
| 562 | end; |
| 563 | |
| 564 | |
| 565 | |
| 566 | (*expression compilation:*) |
| 567 | (*************************) |
| 568 | |
| 569 | gattr: attr; (*describes the expr currently compiled*) |
| 570 | |
| 571 | (*structured constants:*) |
| 572 | (***********************) |
| 573 | |
| 574 | constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys, |
| 575 | statbegsys,typedels,pfbegsys: setofsys; |
| 576 | chartp : array[char] of chtp; |
| 577 | rw: array [1..maxres(*nr. of res. words*)] of restr; |
| 578 | rsy: array [1..maxres(*nr. of res. words*)] of symbol; |
| 579 | ssy: array [char] of symbol; |
| 580 | rop: array [1..maxres(*nr. of res. words*)] of operatort; |
| 581 | sop: array [char] of operatort; |
| 582 | na: array [stdrng] of restr; |
| 583 | mn: array [0..maxins] of packed array [1..3] of char; |
| 584 | sna: array [1..maxsp] of packed array [1..4] of char; |
| 585 | cdx: array [0..maxins] of integer; |
| 586 | cdxs: array [1..6, 1..8] of integer; |
| 587 | pdx: array [1..maxsp] of integer; |
| 588 | ordint: array [char] of integer; |
| 589 | |
| 590 | intlabel,mxint10,maxpow10: integer; |
| 591 | entname: integer; |
| 592 | errtbl: array [1..maxftl] of integer; { error occurence tracking } |
| 593 | errltb: array [1..maxftl] of errptr; { error line tracking } |
| 594 | toterr: integer; { total errors in program } |
| 595 | topnew, topmin: integer; |
| 596 | cstptr: array [1..cstoccmax] of csp; |
| 597 | cstptrix: 0..cstoccmax; |
| 598 | (*allows referencing of noninteger constants by an index |
| 599 | (instead of a pointer), which can be stored in the p2-field |
| 600 | of the instruction record until writeout. |
| 601 | --> procedure load, procedure writeout*) |
| 602 | curmod: modtyp; { type of current module } |
| 603 | nammod: strvsp; { name of current module } |
| 604 | incstk: filptr; { stack of included files } |
| 605 | inclst: filptr; { discard list for includes } |
| 606 | tmplst: tmpptr; { list of active temps } |
| 607 | tmpfre: tmpptr; { free temp entries } |
| 608 | |
| 609 | { Recycling tracking counters, used to check for new/dispose mismatches. } |
| 610 | strcnt: integer; { strings } |
| 611 | cspcnt: integer; { constants } |
| 612 | stpcnt: integer; { structures } |
| 613 | ctpcnt: integer; { identifiers } |
| 614 | lbpcnt: integer; { label counts } |
| 615 | filcnt: integer; { file tracking counts } |
| 616 | cipcnt: integer; { case entry tracking counts } |
| 617 | ttpcnt: integer; { tag tracking entry counts } |
| 618 | wtpcnt: integer; { with tracking entry counts } |
| 619 | |
| 620 | { serial numbers to label structure and identifier entries for dumps } |
| 621 | ctpsnm: integer; |
| 622 | stpsnm: integer; |
| 623 | |
| 624 | breakflag: boolean; { user break signaled } |
| 625 | |
| 626 | f: boolean; { flag for if error number list entries were printed } |
| 627 | i: 1..maxftl; { index for error number tracking array } |
| 628 | oi: 1..maxopt; oni: optinx; |
| 629 | ep, epl: errptr; { error line pointers } |
| 630 | srcfil(fillen): string; { name of input source file } |
| 631 | desfil(fillen): string; { name of output destination file } |
| 632 | errfil(fillen): string; { name of error output file } |
| 633 | p(fillen), n(fillen), e(fillen): string; { filename components } |
| 634 | errf: text; { error output file } |
| 635 | errfopn: boolean; { error file is open } |
| 636 | errfval: boolean; { error file was specified } |
| 637 | |
| 638 | fp: filptr; |
| 639 | ii: lininx; |
| 640 | |
| 641 | { command line parsing } |
| 642 | cmdhan: parse.parhan; { parse handle for command line } |
| 643 | option: array [1..maxopt] of boolean; { option array } |
| 644 | options: array [1..maxopt] of boolean; { option was set array } |
| 645 | opts: array [1..maxopt] of optstr; { short option names } |
| 646 | optsl: array [1..maxopt] of optstr; { long option names } |
| 647 | incbuf: linbuf; { include file buffer } |
| 648 | |
| 649 | (*-------------------------------------------------------------------------*) |
| 650 | |
| 651 | { recycling controls } |
| 652 | |
| 653 | (*-------------------------------------------------------------------------*) |
| 654 | |
| 655 | { get string quanta } |
| 656 | procedure getstr(var p: strvsp); |
| 657 | begin |
| 658 | new(p); { get new entry } |
| 659 | strcnt := strcnt+1 { count } |
| 660 | end; |
| 661 | |
| 662 | { recycle string quanta list } |
| 663 | procedure putstrs(p: strvsp); |
| 664 | var p1: strvsp; |
| 665 | begin |
| 666 | while p <> nil do begin |
| 667 | p1 := p; p := p^.next; dispose(p1); strcnt := strcnt-1 |
| 668 | end |
| 669 | end; |
| 670 | |
| 671 | { get label entry } |
| 672 | procedure getlab(var p: lbp); |
| 673 | begin |
| 674 | new(p); { get new entry } |
| 675 | lbpcnt := lbpcnt+1 { add to count } |
| 676 | end; |
| 677 | |
| 678 | { recycle label entry } |
| 679 | procedure putlab(p: lbp); |
| 680 | begin |
| 681 | putstrs(p^.labid); { release any id label } |
| 682 | dispose(p); { release entry } |
| 683 | lbpcnt := lbpcnt-1 { remove from count } |
| 684 | end; |
| 685 | |
| 686 | { push constant entry to list } |
| 687 | procedure pshcst(p: csp); |
| 688 | begin |
| 689 | { push to constant list } |
| 690 | p^.next := display[top].fconst; |
| 691 | display[top].fconst := p; |
| 692 | cspcnt := cspcnt+1 { count entries } |
| 693 | end; |
| 694 | |
| 695 | { recycle constant entry } |
| 696 | procedure putcst(p: csp); |
| 697 | begin |
| 698 | { recycle string if present } |
| 699 | if p^.cclass = strg then putstrs(p^.sval); |
| 700 | { release entry } |
| 701 | case p^.cclass of |
| 702 | reel: dispose(p, reel); |
| 703 | pset: dispose(p, pset); |
| 704 | strg: dispose(p, strg) |
| 705 | end; |
| 706 | cspcnt := cspcnt-1 { remove from count } |
| 707 | end; |
| 708 | |
| 709 | { push structure entry to list } |
| 710 | procedure pshstc(p: stp); |
| 711 | begin |
| 712 | { push to structures list } |
| 713 | p^.next := display[top].fstruct; |
| 714 | display[top].fstruct := p; |
| 715 | stpcnt := stpcnt+1; { count entries } |
| 716 | stpsnm := stpsnm+1; { identify entry in dumps } |
| 717 | p^.snm := stpsnm |
| 718 | end; |
| 719 | |
| 720 | { recycle structure entry } |
| 721 | procedure putstc(p: stp); |
| 722 | begin |
| 723 | { release entry } |
| 724 | case p^.form of |
| 725 | scalar: if p^.scalkind = declared then dispose(p, scalar, declared) |
| 726 | else dispose(p, scalar, standard); |
| 727 | subrange: dispose(p, subrange); |
| 728 | pointer: dispose(p, pointer); |
| 729 | power: dispose(p, power); |
| 730 | arrays: dispose(p, arrays); |
| 731 | arrayc: dispose(p, arrayc); |
| 732 | records: dispose(p, records); |
| 733 | files: dispose(p, files); |
| 734 | tagfld: begin dispose(p^.vart); dispose(p, tagfld) end; |
| 735 | variant: dispose(p, variant); |
| 736 | exceptf: dispose(p, exceptf) |
| 737 | end; |
| 738 | stpcnt := stpcnt-1 |
| 739 | end; |
| 740 | |
| 741 | { initialize and register identifier entry } |
| 742 | procedure ininam(p: ctp); |
| 743 | begin |
| 744 | ctpcnt := ctpcnt+1; { count entry } |
| 745 | { clear fixed entries } |
| 746 | p^.idtype := nil; p^.keep := false; p^.refer := false; |
| 747 | p^.name := nil; p^.llink := nil; p^.rlink := nil; p^.next := nil; |
| 748 | ctpsnm := ctpsnm+1; { identify entry in dumps } |
| 749 | p^.snm := ctpsnm |
| 750 | end; |
| 751 | |
| 752 | procedure putnam(p: ctp); forward; |
| 753 | |
| 754 | { recycle parameter list } |
| 755 | procedure putparlst(p: ctp); |
| 756 | var p1: ctp; |
| 757 | begin |
| 758 | while p <> nil do begin |
| 759 | p1 := p; p := p^.next; |
| 760 | putnam(p1) { release } |
| 761 | end |
| 762 | end; |
| 763 | |
| 764 | { recycle identifier entry } |
| 765 | procedure putnam(p: ctp); |
| 766 | var p1: ctp; |
| 767 | begin |
| 768 | if (p^.klass = proc) or (p^.klass = func) then begin |
| 769 | putparlst(p^.pflist); p^.pflist := nil; |
| 770 | if p = p^.grppar then while p^.grpnxt <> nil do begin |
| 771 | { scavenge the group list } |
| 772 | p1 := p^.grpnxt; p^.grpnxt := p1^.grpnxt; |
| 773 | putnam(p1) { release } |
| 774 | end |
| 775 | end; |
| 776 | if p^.klass <> alias then putstrs(p^.name); { release name string } |
| 777 | { release entry according to class } |
| 778 | case p^.klass of |
| 779 | types: dispose(p, types); |
| 780 | konst: dispose(p, konst); |
| 781 | vars: dispose(p, vars); |
| 782 | fixedt: dispose(p, fixedt); |
| 783 | field: dispose(p, field); |
| 784 | proc: if p^.pfdeckind = standard then dispose(p, proc, standard) |
| 785 | else if p^.pfkind = actual then |
| 786 | dispose(p, proc, declared, actual) |
| 787 | else dispose(p, proc, declared, formal); |
| 788 | func: if p^.pfdeckind = standard then dispose(p, func, standard) |
| 789 | else if p^.pfkind = actual then |
| 790 | dispose(p, func, declared, actual) |
| 791 | else dispose(p, func, declared, formal); |
| 792 | alias: dispose(p, alias) |
| 793 | end; |
| 794 | ctpcnt := ctpcnt-1 { remove from count } |
| 795 | end; |
| 796 | |
| 797 | { recycle identifier tree } |
| 798 | procedure putnams(p: ctp); |
| 799 | begin |
| 800 | if p <> nil then begin |
| 801 | putnams(p^.llink); { release left } |
| 802 | putnams(p^.rlink); { release right } |
| 803 | { "keep" means it is a parameter and stays with it's procedure or |
| 804 | function entry. } |
| 805 | if not p^.keep then putnam(p) { release the id entry } |
| 806 | end |
| 807 | end; |
| 808 | |
| 809 | { initialize display record } |
| 810 | procedure inidsp(var dr: disprec); |
| 811 | var oi: operatort; |
| 812 | begin |
| 813 | with dr do begin |
| 814 | fname := nil; |
| 815 | flabel := nil; |
| 816 | fconst := nil; |
| 817 | fstruct := nil; |
| 818 | packing := false; |
| 819 | packcom := false; |
| 820 | ptrref := false; |
| 821 | define := false; |
| 822 | modnam := nil; |
| 823 | inilst := nil; |
| 824 | for oi := mul to bcmop do oprprc[oi] := nil |
| 825 | end |
| 826 | end; |
| 827 | |
| 828 | { scrub display level } |
| 829 | procedure putdsp(var dr: disprec); |
| 830 | var llp: lbp; lvp: csp; lsp: stp; oi: operatort; |
| 831 | { release substructure } |
| 832 | procedure putsub(p: stp); |
| 833 | var p1: stp; |
| 834 | begin |
| 835 | { clear record recycle list if record } |
| 836 | if p^.form = records then begin |
| 837 | { clear structure list } |
| 838 | while p^.recyc <> nil do begin |
| 839 | { remove top of list } |
| 840 | p1 := p^.recyc; p^.recyc := p1^.next; |
| 841 | putsub(p1) { release that element } |
| 842 | end; |
| 843 | putnams(p^.fstfld) { clear id list } |
| 844 | end else if p^.form = tagfld then begin |
| 845 | if p^.tagfieldp <> nil then |
| 846 | { recycle anonymous tag fields } |
| 847 | if p^.tagfieldp^.name = nil then putnam(p^.tagfieldp) |
| 848 | end; |
| 849 | putstc(p) { release head entry } |
| 850 | end; |
| 851 | begin { putdsp } |
| 852 | putnams(dr.fname); { dispose of identifier tree } |
| 853 | { dispose of label list } |
| 854 | while dr.flabel <> nil do begin |
| 855 | llp := dr.flabel; dr.flabel := llp^.nextlab; putlab(llp) |
| 856 | end; |
| 857 | { dispose of constant list } |
| 858 | while dr.fconst <> nil do begin |
| 859 | lvp := dr.fconst; dr.fconst := lvp^.next; putcst(lvp) |
| 860 | end; |
| 861 | { dispose of structure list } |
| 862 | while dr.fstruct <> nil do begin |
| 863 | { remove top from list } |
| 864 | lsp := dr.fstruct; dr.fstruct := lsp^.next; putsub(lsp) |
| 865 | end; |
| 866 | { dispose of module name } |
| 867 | putstrs(dr.modnam); |
| 868 | for oi := mul to bcmop do |
| 869 | if dr.oprprc[oi] <> nil then putnam(dr.oprprc[oi]); |
| 870 | end; { putdsp } |
| 871 | |
| 872 | { scrub all display levels until given } |
| 873 | procedure putdsps(l: disprange); |
| 874 | var t: disprange; |
| 875 | begin |
| 876 | if l > top then begin |
| 877 | writeln('*** Error: Compiler internal error'); |
| 878 | goto 99 |
| 879 | end; |
| 880 | t := top; |
| 881 | while t > l do begin |
| 882 | putdsp(display[t]); t := t-1 |
| 883 | end |
| 884 | end; |
| 885 | |
| 886 | { scrub the pile } |
| 887 | procedure putpile; |
| 888 | var t: disprange; |
| 889 | begin |
| 890 | if ptop > 0 then for t := ptop-1 downto 0 do putdsp(pile[t]) |
| 891 | end; |
| 892 | |
| 893 | { get external file entry } |
| 894 | procedure getfil(var p: extfilep); |
| 895 | begin |
| 896 | new(p); { get new entry } |
| 897 | filcnt := filcnt+1 { count entry } |
| 898 | end; |
| 899 | |
| 900 | { recycle external file entry } |
| 901 | procedure putfil(p: extfilep); |
| 902 | begin |
| 903 | dispose(p); { release entry } |
| 904 | filcnt := filcnt-1 { count entry } |
| 905 | end; |
| 906 | |
| 907 | { get case tracking entry } |
| 908 | procedure getcas(var p: cip); |
| 909 | begin |
| 910 | new(p); { get new entry } |
| 911 | cipcnt := cipcnt+1 { count entry } |
| 912 | end; |
| 913 | |
| 914 | { recycle case tracking entry } |
| 915 | procedure putcas(p: cip); |
| 916 | begin |
| 917 | dispose(p); { release entry } |
| 918 | cipcnt := cipcnt-1 { count entry } |
| 919 | end; |
| 920 | |
| 921 | { get tag tracking entry } |
| 922 | procedure gettag(var p: ttp); |
| 923 | begin |
| 924 | new(p); { get new entry } |
| 925 | ttpcnt := ttpcnt+1 { count entry } |
| 926 | end; |
| 927 | |
| 928 | { recycle tag tracking entry } |
| 929 | procedure puttag(p: ttp); |
| 930 | begin |
| 931 | dispose(p); { release entry } |
| 932 | ttpcnt := ttpcnt-1 { count entry } |
| 933 | end; |
| 934 | |
| 935 | { push to with stack } |
| 936 | procedure pshwth(sl: integer); |
| 937 | var p: wtp; |
| 938 | begin |
| 939 | new(p); { get a new entry } |
| 940 | p^.next := wthstk; { push to stack } |
| 941 | wthstk := p; |
| 942 | p^.sl := sl; { mark level } |
| 943 | wtpcnt := wtpcnt+1 { count entry } |
| 944 | end; |
| 945 | |
| 946 | { pop from with stack } |
| 947 | procedure popwth; |
| 948 | var p: wtp; |
| 949 | begin |
| 950 | if wthstk = nil then begin |
| 951 | writeln; writeln('*** Compiler error: with stack underflow'); |
| 952 | goto 99 |
| 953 | end else begin |
| 954 | p := wthstk; |
| 955 | wthstk := p^.next; |
| 956 | dispose(p); |
| 957 | wtpcnt := wtpcnt-1 |
| 958 | end |
| 959 | end; |
| 960 | |
| 961 | (*-------------------------------------------------------------------------*) |
| 962 | |
| 963 | { character and string quanta functions } |
| 964 | |
| 965 | (*-------------------------------------------------------------------------*) |
| 966 | |
| 967 | { find reserved word string equal to id string } |
| 968 | function strequri(a: restr; var b: idstr): boolean; |
| 969 | var m: boolean; i: integer; |
| 970 | begin |
| 971 | m := true; |
| 972 | for i := 1 to reslen do if lcase(a[i]) <> lcase(b[i]) then m := false; |
| 973 | for i := reslen+1 to maxids do if b[i] <> ' ' then m := false; |
| 974 | strequri := m |
| 975 | end { equstr }; |
| 976 | |
| 977 | { write variable length id string to file } |
| 978 | procedure writev(var f: text; s: strvsp; fl: integer); |
| 979 | var i: integer; c: char; |
| 980 | begin i := 1; |
| 981 | while fl > 0 do begin |
| 982 | c := ' '; if s <> nil then begin c := s^.str[i]; i := i+1 end; |
| 983 | write(f, c); fl := fl-1; |
| 984 | if i > varsqt then begin s := s^.next; i := 1 end |
| 985 | end |
| 986 | end; |
| 987 | |
| 988 | { find padded length of variable length id string } |
| 989 | function lenpv(s: strvsp): integer; |
| 990 | var lc, cc, i: integer; |
| 991 | begin lc := 0; cc := 0; |
| 992 | while s <> nil do begin |
| 993 | for i := 1 to varsqt do begin |
| 994 | cc := cc+1; if s^.str[i] <> ' ' then lc := cc |
| 995 | end; |
| 996 | s := s^.next |
| 997 | end; |
| 998 | lenpv := lc |
| 999 | end; |
| 1000 | |
| 1001 | { write padded string to file } |
| 1002 | procedure writevp(var f: text; s: strvsp); |
| 1003 | var l, cc, i: integer; |
| 1004 | begin l := lenpv(s); cc := 0; |
| 1005 | while s <> nil do begin |
| 1006 | for i := 1 to varsqt do begin |
| 1007 | cc := cc+1; if cc <= l then write(f, s^.str[i]) |
| 1008 | end; |
| 1009 | s := s^.next |
| 1010 | end |
| 1011 | end; |
| 1012 | |
| 1013 | { assign identifier fixed to variable length string, including allocation } |
| 1014 | procedure strassvf(var a: strvsp; var b: idstr); |
| 1015 | var i, j, l: integer; p, lp: strvsp; |
| 1016 | begin l := maxids; p := nil; a := nil; j := 1; lp := nil; |
| 1017 | while (l > 1) and (b[l] = ' ') do l := l-1; { find length of fixed string } |
| 1018 | if b[l] = ' ' then l := 0; |
| 1019 | for i := 1 to l do begin |
| 1020 | if j > varsqt then p := nil; |
| 1021 | if p = nil then begin |
| 1022 | getstr(p); p^.next := nil; j := 1; |
| 1023 | if a = nil then a := p else lp^.next := p; lp := p |
| 1024 | end; |
| 1025 | p^.str[j] := b[i]; j := j+1 |
| 1026 | end; |
| 1027 | if p <> nil then for j := j to varsqt do p^.str[j] := ' ' |
| 1028 | end; |
| 1029 | |
| 1030 | { assign reserved word fixed to variable length string, including allocation } |
| 1031 | procedure strassvr(var a: strvsp; b: restr); |
| 1032 | var i, j, l: integer; p, lp: strvsp; |
| 1033 | begin l := reslen; p := nil; a := nil; lp := nil; j := 1; |
| 1034 | while (l > 1) and (b[l] = ' ') do l := l-1; { find length of fixed string } |
| 1035 | if b[l] = ' ' then l := 0; |
| 1036 | for i := 1 to l do begin |
| 1037 | if j > varsqt then p := nil; |
| 1038 | if p = nil then begin |
| 1039 | getstr(p); p^.next := nil; j := 1; |
| 1040 | if a = nil then a := p else lp^.next := p; lp := p |
| 1041 | end; |
| 1042 | p^.str[j] := b[i]; j := j+1 |
| 1043 | end; |
| 1044 | if p <> nil then for j := j to varsqt do p^.str[j] := ' ' |
| 1045 | end; |
| 1046 | |
| 1047 | { assign exception word fixed to variable length string, including allocation } |
| 1048 | procedure strassve(var a: strvsp; b: expstr); |
| 1049 | var i, j, l: integer; p, lp: strvsp; |
| 1050 | begin l := explen; p := nil; a := nil; lp := nil; j := 1; |
| 1051 | while (l > 1) and (b[l] = ' ') do l := l-1; { find length of fixed string } |
| 1052 | if b[l] = ' ' then l := 0; |
| 1053 | for i := 1 to l do begin |
| 1054 | if j > varsqt then p := nil; |
| 1055 | if p = nil then begin |
| 1056 | getstr(p); p^.next := nil; j := 1; |
| 1057 | if a = nil then a := p else lp^.next := p; lp := p |
| 1058 | end; |
| 1059 | p^.str[j] := b[i]; j := j+1 |
| 1060 | end; |
| 1061 | if p <> nil then for j := j to varsqt do p^.str[j] := ' ' |
| 1062 | end; |
| 1063 | |
| 1064 | { assign constant string fixed to variable length string, including allocation } |
| 1065 | procedure strassvc(var a: strvsp; b: csstr; l: integer); |
| 1066 | var i, j: integer; p, lp: strvsp; |
| 1067 | begin p := nil; a := nil; lp := nil; j := 1; |
| 1068 | for i := 1 to l do begin |
| 1069 | if j > varsqt then p := nil; |
| 1070 | if p = nil then begin |
| 1071 | getstr(p); p^.next := nil; j := 1; |
| 1072 | if a = nil then a := p else lp^.next := p; lp := p |
| 1073 | end; |
| 1074 | p^.str[j] := b[i]; j := j+1 |
| 1075 | end; |
| 1076 | if p <> nil then for j := j to varsqt do p^.str[j] := ' ' |
| 1077 | end; |
| 1078 | |
| 1079 | { assign variable length string to fixed identifier } |
| 1080 | procedure strassfv(var a: idstr; b: strvsp); |
| 1081 | var i, j: integer; |
| 1082 | begin for i := 1 to maxids do a[i] := ' '; i := 1; |
| 1083 | while b <> nil do begin |
| 1084 | for j := 1 to varsqt do begin a[i] := b^.str[j]; i := i+1 end; |
| 1085 | b := b^.next |
| 1086 | end |
| 1087 | end; |
| 1088 | |
| 1089 | { compare variable length id strings } |
| 1090 | function strequvv(a, b: strvsp): boolean; |
| 1091 | var m: boolean; i: integer; |
| 1092 | begin |
| 1093 | m := true; |
| 1094 | while (a <> nil) and (b <> nil) do begin |
| 1095 | for i := 1 to varsqt do if lcase(a^.str[i]) <> lcase(b^.str[i]) then m := false; |
| 1096 | a := a^.next; b := b^.next |
| 1097 | end; |
| 1098 | if a <> b then m := false; |
| 1099 | strequvv := m |
| 1100 | end; |
| 1101 | |
| 1102 | { compare variable length id strings, a < b } |
| 1103 | function strltnvv(a, b: strvsp): boolean; |
| 1104 | var i: integer; ca, cb: char; |
| 1105 | begin ca := ' '; cb := ' '; |
| 1106 | while (a <> nil) or (b <> nil) do begin |
| 1107 | i := 1; |
| 1108 | while (i <= varsqt) and ((a <> nil) or (b <> nil)) do begin |
| 1109 | if a <> nil then ca := lcase(a^.str[i]) else ca := ' '; |
| 1110 | if b <> nil then cb := lcase(b^.str[i]) else cb := ' '; |
| 1111 | if ca <> cb then begin a := nil; b := nil end; |
| 1112 | i := i+1 |
| 1113 | end; |
| 1114 | if a <> nil then a := a^.next; if b <> nil then b := b^.next |
| 1115 | end; |
| 1116 | strltnvv := ca < cb |
| 1117 | end; |
| 1118 | |
| 1119 | { compare variable length id string to fixed } |
| 1120 | function strequvf(a: strvsp; var b: idstr): boolean; |
| 1121 | var m: boolean; i, j: integer; c: char; |
| 1122 | begin |
| 1123 | m := true; j := 1; |
| 1124 | for i := 1 to maxids do begin |
| 1125 | c := ' '; if a <> nil then begin c := a^.str[j]; j := j+1 end; |
| 1126 | if lcase(c) <> lcase(b[i]) then m := false; |
| 1127 | if j > varsqt then begin a := a^.next; j := 1 end |
| 1128 | end; |
| 1129 | strequvf := m |
| 1130 | end; |
| 1131 | |
| 1132 | { compare variable length id string to fixed, a < b } |
| 1133 | function strltnvf(a: strvsp; var b: idstr): boolean; |
| 1134 | var i, j, f: integer; c: char; |
| 1135 | begin |
| 1136 | i := 1; j := 1; |
| 1137 | while i < maxids do begin |
| 1138 | c := ' '; if a <> nil then begin c := a^.str[j]; j := j+1 end; |
| 1139 | if lcase(c) <> lcase(b[i]) then begin f := i; i := maxids end else i := i+1; |
| 1140 | if j > varsqt then begin a := a^.next; j := 1 end |
| 1141 | end; |
| 1142 | strltnvf := lcase(c) < lcase(b[f]) |
| 1143 | end; |
| 1144 | |
| 1145 | { get character from variable length string } |
| 1146 | function strchr(a: strvsp; x: integer): char; |
| 1147 | var c: char; i: integer; q: integer; |
| 1148 | begin |
| 1149 | c := ' '; i := 1; q := 1; |
| 1150 | while i < x do begin |
| 1151 | if q >= varsqt then begin q := 1; if a <> nil then a := a^.next end |
| 1152 | else q := q+1; |
| 1153 | i := i+1 |
| 1154 | end; |
| 1155 | if a <> nil then c := a^.str[q]; |
| 1156 | strchr := c |
| 1157 | end; |
| 1158 | |
| 1159 | { put character to variable length string } |
| 1160 | |
| 1161 | procedure strchrass(var a: strvsp; x: integer; c: char); |
| 1162 | var i: integer; q: integer; p, l: strvsp; |
| 1163 | procedure getsqt; |
| 1164 | var y: integer; |
| 1165 | begin |
| 1166 | if p = nil then begin getstr(p); for y := 1 to varsqt do p^.str[y] := ' '; |
| 1167 | p^.next := nil; if a = nil then a := p else l^.next := p |
| 1168 | end |
| 1169 | end; |
| 1170 | begin |
| 1171 | i := 1; q := 1; p := a; l := nil; |
| 1172 | getsqt; |
| 1173 | while i < x do begin |
| 1174 | if q >= varsqt then begin q := 1; l := p; p := p^.next; getsqt end |
| 1175 | else q := q+1; |
| 1176 | i := i+1 |
| 1177 | end; |
| 1178 | p^.str[q] := c |
| 1179 | end; |
| 1180 | |
| 1181 | { concatenate reserved word fixed to variable length string, including |
| 1182 | allocation } |
| 1183 | procedure strcatvr(var a: strvsp; b: restr); |
| 1184 | var i, j, l: integer; |
| 1185 | begin l := reslen; |
| 1186 | while (l > 1) and (b[l] = ' ') do l := l-1; { find length of fixed string } |
| 1187 | if b[l] = ' ' then l := 0; |
| 1188 | j := lenpv(a); j := j+1; |
| 1189 | for i := 1 to l do begin strchrass(a, j, b[i]); j := j+1 end |
| 1190 | end; |
| 1191 | |
| 1192 | (*-------------------------------------------------------------------------*) |
| 1193 | |
| 1194 | { Boolean integer emulation } |
| 1195 | |
| 1196 | (*-------------------------------------------------------------------------*) |
| 1197 | |
| 1198 | function bnot(a: integer): integer; |
| 1199 | var i, r, p: integer; |
| 1200 | begin |
| 1201 | r := 0; p := 1; i := maxint; |
| 1202 | while i <> 0 do begin |
| 1203 | if not odd(a) then r := r+p; |
| 1204 | a := a div 2; i := i div 2; |
| 1205 | if i > 0 then p := p*2 |
| 1206 | end; |
| 1207 | bnot := r |
| 1208 | end; |
| 1209 | |
| 1210 | function bor(a, b: integer): integer; |
| 1211 | var i, r, p: integer; |
| 1212 | begin |
| 1213 | r := 0; p := 1; i := maxint; |
| 1214 | while i <> 0 do begin |
| 1215 | if odd(a) or odd(b) then r := r+p; |
| 1216 | a := a div 2; b := b div 2; i := i div 2; |
| 1217 | if i > 0 then p := p*2 |
| 1218 | end; |
| 1219 | bor := r |
| 1220 | end; |
| 1221 | |
| 1222 | function band(a, b: integer): integer; |
| 1223 | var i, r, p: integer; |
| 1224 | begin |
| 1225 | r := 0; p := 1; i := maxint; |
| 1226 | while i <> 0 do begin |
| 1227 | if odd(a) and odd(b) then r := r+p; |
| 1228 | a := a div 2; b := b div 2; i := i div 2; |
| 1229 | if i > 0 then p := p*2 |
| 1230 | end; |
| 1231 | band := r |
| 1232 | end; |
| 1233 | |
| 1234 | function bxor(a, b: integer): integer; |
| 1235 | var i, r, p: integer; |
| 1236 | begin |
| 1237 | r := 0; p := 1; i := maxint; |
| 1238 | while i <> 0 do begin |
| 1239 | if odd(a) <> odd(b) then r := r+p; |
| 1240 | a := a div 2; b := b div 2; i := i div 2; |
| 1241 | if i > 0 then p := p*2 |
| 1242 | end; |
| 1243 | bxor := r |
| 1244 | end; |
| 1245 | |
| 1246 | (*--------------------------------------------------------------------*) |
| 1247 | |
| 1248 | { Language extension routines } |
| 1249 | |
| 1250 | { support I/O errors from extension library } |
| 1251 | |
| 1252 | procedure errore(e: integer); |
| 1253 | begin writeln; write('*** I/O error: '); |
| 1254 | case e of |
| 1255 | FileDeleteFail: writeln('File delete fail'); |
| 1256 | FileNameChangeFail: writeln('File name change fail'); |
| 1257 | CommandLineTooLong: writeln('Command line too long'); |
| 1258 | FunctionNotImplemented: writeln('Function not implemented'); |
| 1259 | end; |
| 1260 | goto 99 |
| 1261 | end; |
| 1262 | |
| 1263 | procedure errorv(v: integer); |
| 1264 | |
| 1265 | begin |
| 1266 | errore(v) |
| 1267 | end; |
| 1268 | |
| 1269 | (*-------------------------------------------------------------------------*) |
| 1270 | |
| 1271 | { dump the display } |
| 1272 | procedure prtdsp; |
| 1273 | var i: integer; |
| 1274 | procedure prtlnk(p: ctp; f: integer); |
| 1275 | var i: integer; |
| 1276 | begin |
| 1277 | if p <> nil then begin |
| 1278 | for i := 1 to f do write(' '); |
| 1279 | writev(output, p^.name, 10); writeln; |
| 1280 | if p^.llink <> nil then prtlnk(p^.llink, f+3); |
| 1281 | if p^.rlink <> nil then prtlnk(p^.rlink, f+3) |
| 1282 | end |
| 1283 | end; |
| 1284 | begin |
| 1285 | writeln; |
| 1286 | writeln('Display:'); |
| 1287 | writeln; |
| 1288 | for i := 0 to displimit do if display[i].fname <> nil then begin |
| 1289 | |
| 1290 | writeln('level ', i:1); |
| 1291 | writeln; |
| 1292 | prtlnk(display[i].fname, 0); |
| 1293 | writeln |
| 1294 | |
| 1295 | end; |
| 1296 | writeln; |
| 1297 | end; |
| 1298 | |
| 1299 | { this block of functions wraps source reads ******************************* } |
| 1300 | |
| 1301 | function incact: boolean; |
| 1302 | begin |
| 1303 | incact := incstk^.fio |
| 1304 | end; |
| 1305 | |
| 1306 | function fileeof: boolean; |
| 1307 | begin |
| 1308 | if incact then fileeof := eof(incstk^.f) else fileeof := eof(prd); |
| 1309 | end; |
| 1310 | |
| 1311 | function fileeoln: boolean; |
| 1312 | begin |
| 1313 | if incact then fileeoln := eoln(incstk^.f) |
| 1314 | else fileeoln := eoln(prd); |
| 1315 | end; |
| 1316 | |
| 1317 | procedure wrtsrclin; |
| 1318 | begin |
| 1319 | if not incstk^.lo then begin |
| 1320 | if dolineinfo then begin |
| 1321 | write(incstk^.linecount:6,' ':2); |
| 1322 | if dp then write(lc:7) else write(ic:7); |
| 1323 | write(' ') |
| 1324 | end; |
| 1325 | writeln(incstk^.sb:incstk^.sl); |
| 1326 | incstk^.lo := true |
| 1327 | end |
| 1328 | end; |
| 1329 | |
| 1330 | procedure readline; |
| 1331 | var ovf: boolean; |
| 1332 | i: lininx; |
| 1333 | begin |
| 1334 | ovf := false; |
| 1335 | incstk^.sl := 0; incstk^.si := 1; for i := 1 to maxlin do incstk^.sb[i] := ' '; |
| 1336 | if not fileeof then begin |
| 1337 | while not fileeoln do begin |
| 1338 | if incact then read(incstk^.f, incstk^.sb[incstk^.si]) |
| 1339 | else read(prd, incstk^.sb[incstk^.si]); |
| 1340 | if incstk^.sl = maxlin-1 then begin |
| 1341 | if not ovf then |
| 1342 | begin writeln; writeln('*** Input line too long, truncated') end; |
| 1343 | ovf := true |
| 1344 | end else begin incstk^.sl := incstk^.sl+1; incstk^.si := incstk^.si+1 end |
| 1345 | end; |
| 1346 | if incact then readln(incstk^.f) |
| 1347 | else readln(prd); |
| 1348 | incstk^.linecount := incstk^.linecount+1; incstk^.lo := false; |
| 1349 | if list then wrtsrclin |
| 1350 | end; |
| 1351 | incstk^.si := 1; incstk^.lo := false; |
| 1352 | if prcode then |
| 1353 | if incstk^.sl = 0 then writeln(prr, '!') |
| 1354 | else writeln(prr, '! ', incstk^.sb:incstk^.sl) |
| 1355 | end; |
| 1356 | |
| 1357 | function eofinp: boolean; |
| 1358 | begin |
| 1359 | if incstk^.sl <> 0 then eofinp := false else eofinp := fileeof |
| 1360 | end; |
| 1361 | |
| 1362 | function eol: boolean; |
| 1363 | begin |
| 1364 | if eofinp then eol := true |
| 1365 | else if incstk^.si > incstk^.sl then eol := true |
| 1366 | else eol := false |
| 1367 | end; |
| 1368 | |
| 1369 | function ch: char; |
| 1370 | begin |
| 1371 | if not eol then ch := incstk^.sb[incstk^.si] else ch := ' ' |
| 1372 | end; |
| 1373 | |
| 1374 | function bufnxt: char; |
| 1375 | begin |
| 1376 | if not eol then bufnxt := incstk^.sb[incstk^.si+1] else bufnxt := ' ' |
| 1377 | end; |
| 1378 | |
| 1379 | procedure readinp; |
| 1380 | begin |
| 1381 | if incstk^.si > incstk^.sl+1 then readline |
| 1382 | else incstk^.si := incstk^.si+1 |
| 1383 | end; |
| 1384 | |
| 1385 | { ************************************************************************** } |
| 1386 | |
| 1387 | procedure errmsg(var f: text; ferrnr: integer); |
| 1388 | begin case ferrnr of |
| 1389 | 1: write(f, 'Error in simple type'); |
| 1390 | 2: write(f, 'Identifier expected'); |
| 1391 | 3: write(f, '''program'' expected'); |
| 1392 | 4: write(f, ''')'' expected'); |
| 1393 | 5: write(f, ''':'' expected'); |
| 1394 | 6: write(f, 'Illegal symbol'); |
| 1395 | 7: write(f, 'Error in parameter list'); |
| 1396 | 8: write(f, '''of'' expected'); |
| 1397 | 9: write(f, '''('' expected'); |
| 1398 | 10: write(f, 'Error in type'); |
| 1399 | 11: write(f, '''['' expected'); |
| 1400 | 12: write(f, ''']'' expected'); |
| 1401 | 13: write(f, '''end'' expected'); |
| 1402 | 14: write(f, ''';'' expected'); |
| 1403 | 15: write(f, 'Integer expected'); |
| 1404 | 16: write(f, '''='' expected'); |
| 1405 | 17: write(f, '''begin'' expected'); |
| 1406 | 18: write(f, 'Error in declaration part'); |
| 1407 | 19: write(f, 'Error in field-list'); |
| 1408 | 20: write(f, ''','' expected'); |
| 1409 | 21: write(f, '''.'' expected'); |
| 1410 | 22: write(f, 'Integer or identifier expected'); |
| 1411 | 23: write(f, '''except'' expected'); |
| 1412 | 24: write(f, '''on'' or ''except'' expected'); |
| 1413 | 25: write(f, 'Illegal source character'); |
| 1414 | 26: write(f, 'String constant too long'); |
| 1415 | 27: write(f, ''','' or '')'' expected'); |
| 1416 | 28: write(f, '''array'' expected'); |
| 1417 | 29: write(f, ''','' or ''end'' expected'); |
| 1418 | 30: write(f, '''..'' expected'); |
| 1419 | |
| 1420 | 50: write(f, 'Error in constant'); |
| 1421 | 51: write(f, ''':='' expected'); |
| 1422 | 52: write(f, '''then'' expected'); |
| 1423 | 53: write(f, '''until'' expected'); |
| 1424 | 54: write(f, '''do'' expected'); |
| 1425 | 55: write(f, '''to''/''downto'' expected'); |
| 1426 | 56: write(f, '''if'' expected'); |
| 1427 | 57: write(f, '''file'' expected'); |
| 1428 | 58: write(f, 'Error in factor'); |
| 1429 | 59: write(f, 'Error in variable'); |
| 1430 | |
| 1431 | 101: write(f, 'Identifier declared twice'); |
| 1432 | 102: write(f, 'Low bound exceeds highbound'); |
| 1433 | 103: write(f, 'Identifier is not of appropriate class'); |
| 1434 | 104: write(f, 'Identifier not declared'); |
| 1435 | 105: write(f, 'Sign not allowed'); |
| 1436 | 106: write(f, 'Number expected'); |
| 1437 | 107: write(f, 'Incompatible subrange types'); |
| 1438 | 109: write(f, 'Type must not be real'); |
| 1439 | 110: write(f, 'Tagfield type must be scalar or subrange'); |
| 1440 | 111: write(f, 'Incompatible with tagfield type'); |
| 1441 | 112: write(f, 'Index type must not be real'); |
| 1442 | 113: write(f, 'Index type must be scalar or subrange'); |
| 1443 | 114: write(f, 'Base type must not be real'); |
| 1444 | 115: write(f, 'Base type must be scalar or subrange'); |
| 1445 | 116: write(f, 'Error in type of standard procedure parameter'); |
| 1446 | 117: write(f, 'Unsatisfied forward reference'); |
| 1447 | 118: write(f, 'Forward reference type identifier in variable declaration'); |
| 1448 | 119: write(f, 'Forward declared; repetition of parameter list not allowed'); |
| 1449 | 120: write(f, 'Function result type must be scalar, subrange or pointer'); |
| 1450 | 121: write(f, 'File value parameter, or parameter containing file, not allowed'); |
| 1451 | 122: write(f, 'Forward declared function; repetition of result type not allowed'); |
| 1452 | 123: write(f, 'Missing result type in function declaration'); |
| 1453 | 124: write(f, 'F-format for real only'); |
| 1454 | 125: write(f, 'Error in type of standard function parameter'); |
| 1455 | 126: write(f, 'Number of parameters does not agree with declaration'); |
| 1456 | 127: write(f, 'Illegal parameter substitution'); |
| 1457 | 128: write(f, 'Result type of parameter function does not agree with declaration'); |
| 1458 | 129: write(f, 'Type conflict of operands'); |
| 1459 | 130: write(f, 'Expression is not of set type'); |
| 1460 | 131: write(f, 'Tests on equality allowed only'); |
| 1461 | 132: write(f, 'Strict inclusion not allowed'); |
| 1462 | 133: write(f, 'File comparison not allowed'); |
| 1463 | 134: write(f, 'Illegal type of operand(s)'); |
| 1464 | 135: write(f, 'Type of operand must be Boolean'); |
| 1465 | 136: write(f, 'Set element type must be scalar or subrange'); |
| 1466 | 137: write(f, 'Set element types not compatible'); |
| 1467 | 138: write(f, 'Type of variable is not array'); |
| 1468 | 139: write(f, 'Index type is not compatible with declaration'); |
| 1469 | 140: write(f, 'Type of variable is not record'); |
| 1470 | 141: write(f, 'Type of variable must be file or pointer'); |
| 1471 | 142: write(f, 'Illegal parameter substitution'); |
| 1472 | 143: write(f, 'Illegal type of loop control variable'); |
| 1473 | 144: write(f, 'Illegal type of expression'); |
| 1474 | 145: write(f, 'Type conflict'); |
| 1475 | 146: write(f, 'Assignment of files not allowed'); |
| 1476 | 147: write(f, 'Label type incompatible with selecting expression'); |
| 1477 | 148: write(f, 'Subrange bounds must be scalar'); |
| 1478 | 149: write(f, 'Index type must not be integer'); |
| 1479 | 150: write(f, 'Assignment to standard function is not allowed'); |
| 1480 | 151: write(f, 'Assignment to formal function is not allowed'); |
| 1481 | 152: write(f, 'No such field in this record'); |
| 1482 | 153: write(f, 'Type error in read'); |
| 1483 | 154: write(f, 'Actual parameter must be a variable'); |
| 1484 | 155: write(f, 'Control variable must not be declared on intermediate'); |
| 1485 | 156: write(f, 'Multidefined case label'); |
| 1486 | 157: write(f, 'Too many cases in case statement'); |
| 1487 | 158: write(f, 'Missing corresponding variant declaration'); |
| 1488 | 159: write(f, 'Real or string tagfields not allowed'); |
| 1489 | 160: ; |
| 1490 | 161: write(f, 'Again forward declared'); |
| 1491 | 162: write(f, 'Parameter size must be constant'); |
| 1492 | 163: write(f, 'Missing variant in declaration'); |
| 1493 | 164: write(f, 'Substitution of standard proc/func not allowed'); |
| 1494 | 165: write(f, 'Multidefined label'); |
| 1495 | 166: write(f, 'Multideclared label'); |
| 1496 | 167: write(f, 'Undeclared label'); |
| 1497 | 168: write(f, 'Undefined label'); |
| 1498 | 169: write(f, 'Error in base set'); |
| 1499 | 170: write(f, 'Value parameter expected'); |
| 1500 | 171: write(f, 'Standard file was redeclared'); |
| 1501 | 172: write(f, 'Undeclared external file'); |
| 1502 | 173: write(f, 'Fortran procedure or function expected'); |
| 1503 | 174: write(f, 'Pascal procedure or function expected'); |
| 1504 | 175: write(f, 'Missing file "input" in program heading'); |
| 1505 | 176: write(f, 'Missing file "output" in program heading'); |
| 1506 | 177: write(f, 'Assiqnment to function identifier not allowed here'); |
| 1507 | 178: write(f, 'Multidefined record variant'); |
| 1508 | 179: write(f, 'X-opt of actual proc/funcdoes not match formal declaration'); |
| 1509 | 180: write(f, 'Control variable must not be formal'); |
| 1510 | 181: write(f, 'Constant part of address out of ranqe'); |
| 1511 | 182: write(f, 'identifier too long'); |
| 1512 | 183: write(f, 'For index variable must be local to this block'); |
| 1513 | 184: write(f, 'Interprocedure goto does not reference outter block of destination'); |
| 1514 | 185: write(f, 'Goto references deeper nested statement'); |
| 1515 | 186: begin write(f, 'Label referenced by goto at lesser statement level or '); |
| 1516 | write(f, 'differently nested statement') end; |
| 1517 | 187: write(f, 'Goto references label in different nested statement'); |
| 1518 | 188: write(f, 'Label referenced by goto in different nested statement'); |
| 1519 | 189: write(f, 'Parameter lists of formal and actual parameters not congruous'); |
| 1520 | 190: write(f, 'File component may not contain other files'); |
| 1521 | 191: write(f, 'Cannot assign from file or component containing files'); |
| 1522 | 192: write(f, 'Assignment to function that is not active'); |
| 1523 | 193: write(f, 'Function does not assign to result'); |
| 1524 | 194: write(f, 'Exponent too large'); |
| 1525 | 195: write(f, 'For loop index is threatened'); |
| 1526 | 197: write(f, 'Var parameter cannot be packed'); |
| 1527 | 198: write(f, 'Var parameter cannot be a tagfield'); |
| 1528 | 199: write(f, 'Var parameter must be same type'); |
| 1529 | 200: write(f, 'Tagfield constants must cover entire tagfield type'); |
| 1530 | 201: write(f, 'Error in real constant: digit expected'); |
| 1531 | 202: write(f, 'String constant must not exceed source line'); |
| 1532 | 203: write(f, 'Integer constant exceeds range'); |
| 1533 | 204: write(f, '8 or 9 in octal number'); |
| 1534 | 205: write(f, 'Zero string not allowed'); |
| 1535 | 206: write(f, 'Integer part of real constant exceeds ranqe'); |
| 1536 | 207: write(f, 'Digit beyond radix'); |
| 1537 | 208: write(f, 'Type must be string'); |
| 1538 | 209: write(f, '''procedure'' or ''function'' expected'); |
| 1539 | 210: write(f, 'No function active to set result'); |
| 1540 | 211: write(f, 'Anonymous function result must be at function end'); |
| 1541 | 212: write(f, 'Function result assigned before result given'); |
| 1542 | 213: write(f, 'Cannot take boolean integer operation on negative'); |
| 1543 | 214: write(f, 'Must apply $, & or % posfix modifier to integer'); |
| 1544 | 215: write(f, 'Must apply * (padded string field) to string'); |
| 1545 | 216: write(f, 'Original and forwarded procedure/function parameters not congruous'); |
| 1546 | 217: write(f, 'Missing file ''prd'' in program heading'); |
| 1547 | 218: write(f, 'Missing file ''prr'' in program heading'); |
| 1548 | 219: write(f, 'Missing file ''error'' in program heading'); |
| 1549 | 220: write(f, 'Missing file ''list'' in program heading'); |
| 1550 | 221: write(f, 'Missing file ''command'' in program heading'); |
| 1551 | 222: write(f, 'Value out of character range'); |
| 1552 | 223: write(f, 'Type converter/restrictor must be scalar or subrange'); |
| 1553 | 224: write(f, 'Type to be converted must be scalar or subrange'); |
| 1554 | 225: write(f, 'In constant range first value must be less than or equal to second'); |
| 1555 | 226: write(f, 'Type of variable is not exception'); |
| 1556 | 227: write(f, 'Type too complex to track'); |
| 1557 | 228: write(f, 'Cannot apply ''virtual'' attribute to nested procedure or function'); |
| 1558 | 229: write(f, 'Cannot apply ''override'' attribute to nested procedure or function'); |
| 1559 | 230: write(f, 'Cannot override virtual from same module, must be external'); |
| 1560 | 231: write(f, 'No virtual found to override'); |
| 1561 | 232: write(f, 'Cannot overload virtual procedure or function'); |
| 1562 | 233: write(f, 'Inherited not applied to user procedure/function call'); |
| 1563 | 234: write(f, 'Inherited applied to non-virtual procedure/function'); |
| 1564 | 235: write(f, 'Override not defined for inherited call'); |
| 1565 | 236: write(f, 'Type error in write'); |
| 1566 | 237: write(f, 'Array size too large'); |
| 1567 | 238: write(f, 'Invalid array length, must be >= 1'); |
| 1568 | 239: write(f, 'Variant case exceeds allowable range'); |
| 1569 | 240: write(f, 'Header parameter already included'); |
| 1570 | 241: write(f, 'Invalid tolken separator'); |
| 1571 | 242: write(f, 'Identifier referenced before defining point'); |
| 1572 | 243: write(f, 'Initializer expression must be integer'); |
| 1573 | 244: write(f, 'Type incorrect for fixed'); |
| 1574 | 245: write(f, 'Initializer incompatible with fixed element'); |
| 1575 | 246: write(f, 'Initializer out of range of fixed element type'); |
| 1576 | 247: write(f, 'Incorrect number of initializers for type'); |
| 1577 | 248: write(f, 'Fixed cannot contain variant record'); |
| 1578 | 249: write(f, 'New overload ambiguous with previous'); |
| 1579 | 250: write(f, 'Too many nested scopes of identifiers'); |
| 1580 | 251: write(f, 'Too many nested procedures and/or functions'); |
| 1581 | 252: write(f, 'Too many forward references of procedure entries'); |
| 1582 | 253: write(f, 'Procedure too long'); |
| 1583 | 254: write(f, 'Too many long constants in this procedure'); |
| 1584 | 255: write(f, 'Too many errors on this source line'); |
| 1585 | 256: write(f, 'Too many external references'); |
| 1586 | 257: write(f, 'Too many externals'); |
| 1587 | 258: write(f, 'Too many local files'); |
| 1588 | 259: write(f, 'Expression too complicated'); |
| 1589 | 260: write(f, 'Too many exit labels'); |
| 1590 | 261: write(f, 'Label beyond valid integral value (>9999)'); |
| 1591 | 262: write(f, 'Function/procedure cannot be applied to text files'); |
| 1592 | 263: write(f, 'No function to open/close external files'); |
| 1593 | 264: write(f, 'External file not found'); |
| 1594 | 265: write(f, 'Filename too long'); |
| 1595 | 266: write(f, '''private'' has no meaning here'); |
| 1596 | 267: write(f, 'Too many nested module joins'); |
| 1597 | 268: write(f, 'Qualified identifier not found'); |
| 1598 | 269: write(f, 'Number of initializers for parameterised declaration do not ', |
| 1599 | 'match'); |
| 1600 | 270: write(f, 'Container array type specified without initializer(s)'); |
| 1601 | 271: write(f, 'Number of initializers does not match container array levels'); |
| 1602 | 272: write(f, 'Cannot declare container array in fixed context'); |
| 1603 | 273: write(f, 'Must be container array'); |
| 1604 | 274: write(f, 'Function result type must be scalar, subrange, pointer, set, ', |
| 1605 | 'array or record'); |
| 1606 | 275: write(f, 'Number of parameters does not agree with declaration of any ', |
| 1607 | 'overload'); |
| 1608 | 276: write(f, 'Different overload parameters converge with different modes'); |
| 1609 | 277: write(f, 'No overload found to match parameter'); |
| 1610 | 278: write(f, 'Must be variable reference'); |
| 1611 | 279: write(f, '''procedure'', ''function'' or ''operator'' expected'); |
| 1612 | 280: write(f, 'Attribute has no meaning used on operator overload'); |
| 1613 | 281: write(f, 'Expression/assignment operator expected'); |
| 1614 | 282: write(f, 'Overload operator is ambiguous with system operator'); |
| 1615 | 283: write(f, 'New operator overload ambiguous with previous'); |
| 1616 | 284: write(f, 'Different operator overload parameters converge with ', |
| 1617 | 'different modes'); |
| 1618 | 285: write(f, 'Parameter type not allowed in operator overload parameter '); |
| 1619 | 286: write(f, 'Parameter mode not allowed in operator overload parameter '); |
| 1620 | 287: write(f, 'Variable reference is not addressable'); |
| 1621 | 288: write(f, 'Left side of assignment overload operator must be out mode'); |
| 1622 | 289: write(f, 'Var parameter must be compatible with parameter'); |
| 1623 | 290: write(f, 'Cannot threaten view parameter'); |
| 1624 | 291: write(f, 'Set element out of implementation range'); |
| 1625 | 292: write(f, 'Function expected in this context'); |
| 1626 | 293: write(f, 'Procedure expected in this context'); |
| 1627 | 294: write(f, 'Cannot overload an external declaration'); |
| 1628 | 295: write(f, 'procedure or function external property does not match'); |
| 1629 | 296: write(f, 'Cannot apply field to constant string on read'); |
| 1630 | 297: write(f, 'No procedure or function found to overload'); |
| 1631 | 298: write(f, 'No matching forwarded overload'); |
| 1632 | |
| 1633 | 300: write(f, 'Division by zero'); |
| 1634 | 301: write(f, 'No case provided for this value'); |
| 1635 | 302: write(f, 'Index expression out of bounds'); |
| 1636 | 303: write(f, 'Value to be assigned is out of bounds'); |
| 1637 | 304: write(f, 'Element expression out of range'); |
| 1638 | 305: write(f, 'Cannot use non-decimal with real format'); |
| 1639 | 306: write(f, 'Integer overflow'); |
| 1640 | |
| 1641 | 397: write(f, 'Feature not valid in ISO 7185 Pascal'); |
| 1642 | 398: write(f, 'Implementation restriction'); |
| 1643 | { as of the implementation of full ISO 7185, this error is no longer used } |
| 1644 | 399: write(f, 'Feature not implemented'); |
| 1645 | |
| 1646 | { * marks spared compiler errors } |
| 1647 | 400,401,402,403,404,406,407, 500,501,502,503, |
| 1648 | 504,505,506,507,508,509,510,511,512,513,514,515, |
| 1649 | 516,517,518,{*}519: write(f, 'Compiler internal error'); |
| 1650 | end |
| 1651 | end; |
| 1652 | |
| 1653 | procedure endofline; |
| 1654 | var lastpos,freepos,currpos,currnmr,f,j,k: integer; df: boolean; |
| 1655 | begin |
| 1656 | if errinx > 0 then (*output error messages*) |
| 1657 | begin |
| 1658 | if not list then wrtsrclin; |
| 1659 | if errfval then begin { write source line to error file } |
| 1660 | if dolineinfo then begin |
| 1661 | write(errf, incstk^.linecount:6,' ':2); |
| 1662 | if dp then write(errf, lc:7) else write(errf, ic:7); |
| 1663 | write(errf, ' ') |
| 1664 | end; |
| 1665 | writeln(errf, incstk^.sb:incstk^.sl) |
| 1666 | end; |
| 1667 | if errfval then write(errf, incstk^.linecount:6,' **** ':9) |
| 1668 | else write(incstk^.linecount:6,' **** ':9); |
| 1669 | lastpos := -1; freepos := 1; |
| 1670 | for k := 1 to errinx do |
| 1671 | begin |
| 1672 | with errlist[k] do |
| 1673 | begin currpos := pos; currnmr := nmr end; |
| 1674 | if currpos = lastpos then begin |
| 1675 | if errfval then write(errf, ',') |
| 1676 | else write(',') |
| 1677 | end else |
| 1678 | begin |
| 1679 | while freepos < currpos do |
| 1680 | begin |
| 1681 | if errfval then write(errf, ' ') |
| 1682 | else write(' '); |
| 1683 | freepos := freepos + 1 end; |
| 1684 | if errfval then write(errf, '^') |
| 1685 | else write('^'); |
| 1686 | lastpos := currpos |
| 1687 | end; |
| 1688 | if currnmr < 10 then f := 1 |
| 1689 | else if currnmr < 100 then f := 2 |
| 1690 | else f := 3; |
| 1691 | if errfval then write(errf, currnmr:f) |
| 1692 | else write(currnmr:f); |
| 1693 | freepos := freepos + f + 1 |
| 1694 | end; |
| 1695 | if errfval then writeln(errf) |
| 1696 | else writeln; |
| 1697 | if experr then begin |
| 1698 | for k := 1 to errinx do |
| 1699 | begin df := false; |
| 1700 | for j := 1 to k-1 do |
| 1701 | if errlist[j].nmr = errlist[k].nmr then df := true; |
| 1702 | if not df then begin |
| 1703 | if errfval then begin |
| 1704 | write(errf, incstk^.linecount:6,' **** ':9); |
| 1705 | write(errf, errlist[k].nmr:3, ' '); |
| 1706 | errmsg(errf, errlist[k].nmr); writeln(errf) |
| 1707 | end else begin |
| 1708 | write(incstk^.linecount:6,' **** ':9); |
| 1709 | write(errlist[k].nmr:3, ' '); |
| 1710 | errmsg(output, errlist[k].nmr); writeln |
| 1711 | end |
| 1712 | end |
| 1713 | end |
| 1714 | end; |
| 1715 | errinx := 0; |
| 1716 | end; |
| 1717 | chcnt := 0 |
| 1718 | end (*endofline*) ; |
| 1719 | |
| 1720 | { output lines passed to intermediate } |
| 1721 | procedure outline; |
| 1722 | begin |
| 1723 | while incstk^.lineout < incstk^.linecount do begin |
| 1724 | incstk^.lineout := incstk^.lineout+1; |
| 1725 | { output line marker in intermediate file } |
| 1726 | if not eofinp and prcode then begin |
| 1727 | writeln(prr, ':', incstk^.lineout:1); |
| 1728 | end |
| 1729 | end |
| 1730 | end; |
| 1731 | |
| 1732 | procedure markline; |
| 1733 | begin |
| 1734 | outline; |
| 1735 | if prcode then writeln(prr, ':', incstk^.linecount:1) |
| 1736 | end; |
| 1737 | |
| 1738 | { check in private section } |
| 1739 | function inpriv: boolean; |
| 1740 | begin inpriv := false; |
| 1741 | if incact then inpriv := incstk^.priv |
| 1742 | end; |
| 1743 | |
| 1744 | procedure error(ferrnr: integer); |
| 1745 | var ep: errptr; |
| 1746 | begin |
| 1747 | if not incact then begin { supress errors in includes } |
| 1748 | |
| 1749 | { This diagnostic is here because error buffers error numbers til the end |
| 1750 | of line, and sometimes you need to know exactly where they occurred. } |
| 1751 | { |
| 1752 | writeln; writeln('error: ', ferrnr:1); |
| 1753 | } |
| 1754 | |
| 1755 | errtbl[ferrnr] := errtbl[ferrnr]+1; { track this error } |
| 1756 | { track error lines } |
| 1757 | new(ep); ep^.errlin := incstk^.linecount; ep^.next := errltb[ferrnr]; |
| 1758 | errltb[ferrnr] := ep; |
| 1759 | if errinx >= 9 then |
| 1760 | begin errlist[10].nmr := 255; errinx := 10 end |
| 1761 | else |
| 1762 | begin errinx := errinx + 1; |
| 1763 | errlist[errinx].nmr := ferrnr |
| 1764 | end; |
| 1765 | errlist[errinx].pos := chcnt; |
| 1766 | toterr := toterr+1 |
| 1767 | end |
| 1768 | end (*error*) ; |
| 1769 | |
| 1770 | { chkstd: called whenever a non-ISO7185 construct is being processed } |
| 1771 | procedure chkstd; |
| 1772 | begin |
| 1773 | if iso7185 then error(397) |
| 1774 | end; |
| 1775 | |
| 1776 | procedure prtsym(sy: symbol); |
| 1777 | begin |
| 1778 | case sy of |
| 1779 | ident: write('ident'); intconst: write('intconst'); |
| 1780 | realconst: write('realconst'); stringconst: write('string const'); |
| 1781 | notsy: write('not'); mulop: write('*'); addop: write('+'); |
| 1782 | relop: write('<'); lparent: write('('); rparent: write(')'); |
| 1783 | lbrack: write('['); rbrack: write(']'); comma: write(','); |
| 1784 | semicolon: write(';'); period: write('.'); arrow: write('^'); |
| 1785 | colon: write(':'); becomes: write(':='); range: write('..'); |
| 1786 | labelsy: write('label'); constsy: write('const'); typesy: write('type'); |
| 1787 | varsy: write('var'); funcsy: write('function'); progsy: write('program'); |
| 1788 | procsy: write('procedure'); setsy: write('set'); |
| 1789 | packedsy: write('packed'); arraysy: write('array'); |
| 1790 | recordsy: write('record'); filesy: write('file'); |
| 1791 | beginsy: write('begin'); ifsy: write('if'); casesy: write('case'); |
| 1792 | repeatsy: write('repeat'); whilesy: write('while'); |
| 1793 | forsy: write('for'); withsy: write('with'); gotosy: write('goto'); |
| 1794 | endsy: write('end'); elsesy: write('else'); untilsy: write('until'); |
| 1795 | ofsy: write('of'); dosy: write('do'); tosy: write('to'); |
| 1796 | downtosy: write('downto'); thensy: write('then'); |
| 1797 | forwardsy: write('forward'); modulesy: write('module'); |
| 1798 | usessy: write('uses'); privatesy:write('private'); |
| 1799 | externalsy: write('external'); viewsy: write('view'); |
| 1800 | fixedsy: write('fixed'); processsy: write('process'); |
| 1801 | monitorsy: write('monitor'); sharesy: write('share'); |
| 1802 | classsy: write('class'); issy: write('is'); |
| 1803 | overloadsy: write('overload'); overridesy: write('override'); |
| 1804 | referencesy: write('reference'); joinssy: write('joins'); |
| 1805 | staticsy: write('static'); inheritedsy: write('inherited'); |
| 1806 | selfsy: write('self'); virtualsy: write('virtual'); |
| 1807 | trysy: write('try'); exceptsy: write('except'); |
| 1808 | extendssy: write('extends'); onsy: write('on'); |
| 1809 | resultsy: write('result'); operatorsy: write('operator'); |
| 1810 | outsy: write('out'); propertysy: write('property'); |
| 1811 | channelsy: write('channel'); streamsy: write('stream'); |
| 1812 | othersy: write('<other>'); hexsy: write('$'); octsy: write('&'); |
| 1813 | binsy: write('%'); numsy: write('#'); |
| 1814 | end |
| 1815 | end; |
| 1816 | |
| 1817 | procedure insymbol; |
| 1818 | (*read next basic symbol of source program and return its |
| 1819 | description in the global variables sy, op, id, val and lgth*) |
| 1820 | label 1, 2; |
| 1821 | var i,k,v,r: integer; |
| 1822 | string: csstr; |
| 1823 | lvp: csp; test, ferr: boolean; |
| 1824 | iscmte: boolean; |
| 1825 | ev: integer; |
| 1826 | rv: real; |
| 1827 | sgn: integer; |
| 1828 | strend: boolean; |
| 1829 | |
| 1830 | procedure nextch; |
| 1831 | begin if eol then endofline; |
| 1832 | if not eofinp then |
| 1833 | begin readinp; |
| 1834 | chcnt := chcnt + 1 |
| 1835 | end |
| 1836 | else |
| 1837 | begin writeln(' *** eof ','encountered'); |
| 1838 | test := false |
| 1839 | end |
| 1840 | end; |
| 1841 | |
| 1842 | procedure options; |
| 1843 | var |
| 1844 | ch1 : char; dummy: boolean; |
| 1845 | optst: optstr; oni: optinx; oi: 1..maxopt; |
| 1846 | procedure switch(var opt: boolean); |
| 1847 | var oni: optinx; |
| 1848 | begin |
| 1849 | if (ch='+') or (ch='-') then begin |
| 1850 | opt := ch = '+'; |
| 1851 | option[oi] := opt; |
| 1852 | if prcode then begin |
| 1853 | write(prr, 'o', ' ':7); |
| 1854 | for oni := 1 to optlen do |
| 1855 | if optsl[oi, oni] <> ' ' then write(prr, optsl[oi, oni]); |
| 1856 | writeln(prr, ch) |
| 1857 | end; |
| 1858 | nextch; |
| 1859 | end else begin { just default to on } |
| 1860 | opt := true; |
| 1861 | option[oi] := true; |
| 1862 | if prcode then begin |
| 1863 | write(prr, 'o', ' ':7); |
| 1864 | for oni := 1 to optlen do |
| 1865 | if optsl[oi, oni] <> ' ' then write(prr, optsl[oi, oni]); |
| 1866 | writeln(prr, '+') |
| 1867 | end |
| 1868 | end |
| 1869 | end; { switch() } |
| 1870 | begin { options() } |
| 1871 | nextch; |
| 1872 | repeat |
| 1873 | oni := 1; optst := ' '; |
| 1874 | while ch in ['a'..'z', 'A'..'Z', '0'..'9'] do begin |
| 1875 | ch1 := lcase(ch); |
| 1876 | if optst[oni] = ' ' then optst[oni] := ch1; |
| 1877 | if oni < optlen then oni := oni+1; |
| 1878 | nextch |
| 1879 | end; |
| 1880 | oi := 1; |
| 1881 | while (oi < maxopt) and (optst <> opts[oi]) and (optst <> optsl[oi]) do |
| 1882 | oi := oi+1; |
| 1883 | if (optst = opts[oi]) or (optst = optsl[oi]) then case oi of |
| 1884 | 1: switch(dummy); |
| 1885 | 2: switch(doprtlab); |
| 1886 | 3: if prrval then switch(prcode); |
| 1887 | 4: switch(debug); |
| 1888 | 5: switch(dummy); |
| 1889 | 6: switch(dummy); |
| 1890 | 7: switch(dummy); |
| 1891 | 8: switch(dummy); |
| 1892 | 9: switch(chkvbk); |
| 1893 | 10: switch(experr); |
| 1894 | 11: switch(dummy); |
| 1895 | 12: if not incact then begin |
| 1896 | switch(list); if not list then writeln(output) |
| 1897 | end; |
| 1898 | 13: switch(dummy); |
| 1899 | 14: switch(dummy); |
| 1900 | 15: switch(dummy); |
| 1901 | 16: switch(dummy); |
| 1902 | 17: switch(dummy); |
| 1903 | 18: switch(chkref); |
| 1904 | 19: switch(iso7185); |
| 1905 | 20: switch(prtables); |
| 1906 | 21: switch(chkudtc); |
| 1907 | 22: switch(chkvar); |
| 1908 | 23: switch(dummy); |
| 1909 | 24: switch(dodmplex); |
| 1910 | 25: switch(dodmpdsp); |
| 1911 | 26: switch(dummy); |
| 1912 | 27: switch(dummy); |
| 1913 | end else begin |
| 1914 | { skip all likely option chars } |
| 1915 | while ch in ['a'..'z','A'..'Z','+','-','0'..'9','_'] do |
| 1916 | nextch; |
| 1917 | end; |
| 1918 | ch1 := ch; if ch1 = ',' then nextch |
| 1919 | until ch1 <> ',' |
| 1920 | end (*options*) ; |
| 1921 | |
| 1922 | function pwrten(e: integer): real; |
| 1923 | var t: real; { accumulator } |
| 1924 | p: real; { current power } |
| 1925 | begin |
| 1926 | p := 1.0e+1; { set 1st power } |
| 1927 | t := 1.0; { initalize result } |
| 1928 | repeat |
| 1929 | if odd(e) then t := t*p; { if bit set, add this power } |
| 1930 | e := e div 2; { index next bit } |
| 1931 | p := sqr(p) { find next power } |
| 1932 | until e = 0; |
| 1933 | pwrten := t |
| 1934 | end; |
| 1935 | |
| 1936 | procedure plcchr(c: char); |
| 1937 | begin |
| 1938 | if not eol then begin |
| 1939 | lgth := lgth+1; |
| 1940 | if lgth <= strglgth then string[lgth] := c |
| 1941 | end |
| 1942 | end; |
| 1943 | |
| 1944 | procedure escchr; |
| 1945 | type escstr = packed array [1..5] of char; { escape string } |
| 1946 | var c: char; l: 0..4; i: 1..5; |
| 1947 | |
| 1948 | function match(es: escstr): boolean; |
| 1949 | var i: 1..5; |
| 1950 | begin |
| 1951 | i := 1; |
| 1952 | { move to first mismatch or end } |
| 1953 | while (es[i] = incstk^.sb[incstk^.si+i-1]) and (es[i] <> ' ') and |
| 1954 | (i <= 4) do i := i+1; |
| 1955 | match := es[i] = ' ' |
| 1956 | end; |
| 1957 | |
| 1958 | begin |
| 1959 | c := ' '; { set none found } |
| 1960 | if match('xoff ') then begin c := chr(19); l := 4 end |
| 1961 | else if match('dle ') then begin c := chr(16); l := 3 end |
| 1962 | else if match('dc1 ') then begin c := chr(17); l := 3 end |
| 1963 | else if match('xon ') then begin c := chr(17); l := 3 end |
| 1964 | else if match('dc2 ') then begin c := chr(18); l := 3 end |
| 1965 | else if match('dc3 ') then begin c := chr(19); l := 3 end |
| 1966 | else if match('dc4 ') then begin c := chr(20); l := 3 end |
| 1967 | else if match('nak ') then begin c := chr(21); l := 3 end |
| 1968 | else if match('syn ') then begin c := chr(22); l := 3 end |
| 1969 | else if match('etb ') then begin c := chr(23); l := 3 end |
| 1970 | else if match('can ') then begin c := chr(24); l := 3 end |
| 1971 | else if match('nul ') then begin c := chr(0); l := 3 end |
| 1972 | else if match('soh ') then begin c := chr(1); l := 3 end |
| 1973 | else if match('stx ') then begin c := chr(2); l := 3 end |
| 1974 | else if match('etx ') then begin c := chr(3); l := 3 end |
| 1975 | else if match('eot ') then begin c := chr(4); l := 3 end |
| 1976 | else if match('enq ') then begin c := chr(5); l := 3 end |
| 1977 | else if match('ack ') then begin c := chr(6); l := 3 end |
| 1978 | else if match('bel ') then begin c := chr(7); l := 3 end |
| 1979 | else if match('sub ') then begin c := chr(26); l := 3 end |
| 1980 | else if match('esc ') then begin c := chr(27); l := 3 end |
| 1981 | else if match('del ') then begin c := chr(127); l := 3 end |
| 1982 | else if match('bs ') then begin c := chr(8); l := 2 end |
| 1983 | else if match('ht ') then begin c := chr(9); l := 2 end |
| 1984 | else if match('lf ') then begin c := chr(10); l := 2 end |
| 1985 | else if match('vt ') then begin c := chr(11); l := 2 end |
| 1986 | else if match('ff ') then begin c := chr(12); l := 2 end |
| 1987 | else if match('cr ') then begin c := chr(13); l := 2 end |
| 1988 | else if match('so ') then begin c := chr(14); l := 2 end |
| 1989 | else if match('si ') then begin c := chr(15); l := 2 end |
| 1990 | else if match('em ') then begin c := chr(25); l := 2 end |
| 1991 | else if match('fs ') then begin c := chr(28); l := 2 end |
| 1992 | else if match('gs ') then begin c := chr(29); l := 2 end |
| 1993 | else if match('rs ') then begin c := chr(30); l := 2 end |
| 1994 | else if match('us ') then begin c := chr(31); l := 2 end; |
| 1995 | if c <> ' ' then begin { found escape } |
| 1996 | plcchr(c); |
| 1997 | for i := 1 to l do nextch { skip escape sequence } |
| 1998 | end else { place common forced } |
| 1999 | begin plcchr(ch); nextch end |
| 2000 | end; |
| 2001 | |
| 2002 | begin (*insymbol*) |
| 2003 | { copy current to last scanner block } |
| 2004 | lsy := sy; lop := op; lval := val; llgth := lgth; lid := id; lkk := kk; |
| 2005 | if nvalid then begin { there is a lookahead } |
| 2006 | { copy next to current } |
| 2007 | sy := nsy; op := nop; val := nval; lgth := nlgth; id := nid; kk := nkk; |
| 2008 | nvalid := false; { set no next now } |
| 2009 | goto 2 { skip getting next tolken } |
| 2010 | end; |
| 2011 | outline; |
| 2012 | 1: |
| 2013 | { Skip both spaces and controls. This allows arbitrary formatting characters |
| 2014 | in the source. } |
| 2015 | repeat while (ch <= ' ') and not eol do nextch; |
| 2016 | test := eol; |
| 2017 | if test then nextch |
| 2018 | until not test; |
| 2019 | if chartp[ch] = illegal then |
| 2020 | begin sy := othersy; op := noop; |
| 2021 | error(25); nextch |
| 2022 | end |
| 2023 | else |
| 2024 | case chartp[ch] of |
| 2025 | letter: |
| 2026 | begin k := 0; ferr := true; for i := 1 to maxids do id[i] := ' '; |
| 2027 | repeat |
| 2028 | if k < maxids then |
| 2029 | begin k := k + 1; id[k] := ch end |
| 2030 | else if ferr then begin error(182); ferr := false end; |
| 2031 | nextch |
| 2032 | until not (chartp[ch] in [letter, number]); |
| 2033 | if k >= kk then kk := k |
| 2034 | else |
| 2035 | repeat id[kk] := ' '; kk := kk - 1 |
| 2036 | until kk = k; |
| 2037 | sy := ident; op := noop; |
| 2038 | if k <= reslen then |
| 2039 | for i := 1 to maxres do |
| 2040 | if strequri(rw[i], id) then |
| 2041 | begin sy := rsy[i]; op := rop[i]; |
| 2042 | { if in ISO 7185 mode and keyword is extended, then revert it |
| 2043 | to label. Note that forward and external get demoted to |
| 2044 | "word symbols" in ISO 7185 } |
| 2045 | if iso7185 and ((sy >= forwardsy) or (op > noop)) then |
| 2046 | begin sy := ident; op := noop end |
| 2047 | end; |
| 2048 | end; |
| 2049 | chhex, choct, chbin, number: |
| 2050 | begin op := noop; i := 0; r := 10; |
| 2051 | if chartp[ch] = chhex then begin chkstd; r := 16; nextch end |
| 2052 | else if chartp[ch] = choct then begin chkstd; r := 8; nextch end |
| 2053 | else if chartp[ch] = chbin then begin chkstd; r := 2; nextch end; |
| 2054 | if (r = 10) or (chartp[ch] = number) or (chartp[ch] = letter) then |
| 2055 | begin |
| 2056 | v := 0; |
| 2057 | repeat |
| 2058 | if ch <> '_' then |
| 2059 | if v <= pmmaxint div r then |
| 2060 | v := v*r+ordint[ch] |
| 2061 | else begin error(203); v := 0 end; |
| 2062 | nextch |
| 2063 | until (chartp[ch] <> number) and ((ch <> '_') or iso7185) and |
| 2064 | ((chartp[ch] <> letter) or (r < 16) or iso7185); |
| 2065 | { separator must be non-alpha numeric or 'e' with decimal radix } |
| 2066 | if ((chartp[ch] = letter) and not ((lcase(ch) = 'e') and (r = 10))) or |
| 2067 | (chartp[ch] = number) then error(241); |
| 2068 | val.intval := true; |
| 2069 | val.ival := v; |
| 2070 | sy := intconst; |
| 2071 | if ((ch = '.') and (bufnxt <> '.') and (bufnxt <> ')')) or |
| 2072 | (lcase(ch) = 'e') then |
| 2073 | begin |
| 2074 | { its a real, reject non-decimal radixes } |
| 2075 | if r <> 10 then error(305); |
| 2076 | rv := v; ev := 0; |
| 2077 | if ch = '.' then begin |
| 2078 | nextch; |
| 2079 | if chartp[ch] <> number then error(201); |
| 2080 | repeat |
| 2081 | rv := rv*10+ordint[ch]; nextch; ev := ev-1 |
| 2082 | until chartp[ch] <> number; |
| 2083 | end; |
| 2084 | if lcase(ch) = 'e' then |
| 2085 | begin nextch; sgn := +1; |
| 2086 | if (ch = '+') or (ch ='-') then begin |
| 2087 | if ch = '-' then sgn := -1; |
| 2088 | nextch |
| 2089 | end; |
| 2090 | if chartp[ch] <> number then error(201) |
| 2091 | else begin ferr := true; i := 0; |
| 2092 | repeat |
| 2093 | if ferr then begin |
| 2094 | if i <= mxint10 then i := i*10+ordint[ch] |
| 2095 | else begin error(194); ferr := false end; |
| 2096 | end; |
| 2097 | nextch |
| 2098 | until chartp[ch] <> number; |
| 2099 | if i > maxexp then begin |
| 2100 | i := 0; |
| 2101 | if ferr then error(194) |
| 2102 | end; |
| 2103 | ev := ev+i*sgn |
| 2104 | end |
| 2105 | end; |
| 2106 | if ev < 0 then rv := rv/pwrten(ev) else rv := rv*pwrten(ev); |
| 2107 | new(lvp,reel); pshcst(lvp); sy:= realconst; |
| 2108 | lvp^.cclass := reel; |
| 2109 | with lvp^ do lvp^.rval := rv; |
| 2110 | val.intval := false; |
| 2111 | val.valp := lvp |
| 2112 | end |
| 2113 | end else { convert radix to symbol } |
| 2114 | if r = 16 then sy := hexsy |
| 2115 | else if r = 8 then sy := octsy |
| 2116 | else sy := binsy |
| 2117 | end; |
| 2118 | chstrquo: |
| 2119 | begin nextch; lgth := 0; sy := stringconst; op := noop; strend := false; |
| 2120 | for i := 1 to strglgth do string[i] := ' '; |
| 2121 | repeat |
| 2122 | { force character if '\' and not ISO 7185 mode } |
| 2123 | if (ch = chr(92)) and not iso7185 then begin |
| 2124 | nextch; { skip '\' } |
| 2125 | if ch in ['$','&','%','0'..'9'] then begin |
| 2126 | { character code } |
| 2127 | v := 0; k := 1; |
| 2128 | { parse in radix and only correct number of digits to keep from |
| 2129 | eating follow on characters } |
| 2130 | if ch = '$' then begin nextch; |
| 2131 | if not (ch in ['0'..'9','a'..'f','A'..'F']) then error(207); |
| 2132 | while (ch in ['0'..'9', 'a'..'f', 'A'..'F']) and |
| 2133 | (k <= 2) do begin |
| 2134 | v := v*16+ordint[ch]; nextch; k := k+1 |
| 2135 | end |
| 2136 | end else if ch = '&' then begin nextch; |
| 2137 | if not (ch in ['0'..'7']) then error(207); |
| 2138 | while (ch in ['0'..'7']) and (k <= 3) do begin |
| 2139 | v := v*8+ordint[ch]; nextch; k := k+1 |
| 2140 | end |
| 2141 | end else if ch = '%' then begin nextch; |
| 2142 | if not (ch in ['0'..'1']) then error(207); |
| 2143 | while (ch in ['0'..'1']) and (k <= 8) do begin |
| 2144 | v := v*2+ordint[ch]; nextch; k := k+1 |
| 2145 | end |
| 2146 | end else begin |
| 2147 | while (ch in ['0'..'9']) and (k <= 3) do begin |
| 2148 | v := v*10+ordint[ch]; nextch; k := k+1 |
| 2149 | end |
| 2150 | end; |
| 2151 | if v > ordmaxchar then error(222); |
| 2152 | plcchr(chr(v)); |
| 2153 | end else escchr { process force sequence } |
| 2154 | end else if ch = '''' then |
| 2155 | begin nextch; |
| 2156 | if ch = '''' then |
| 2157 | begin plcchr(ch); nextch end else strend := true |
| 2158 | end |
| 2159 | else begin plcchr(ch); nextch end { place regular char } |
| 2160 | until eol or strend; |
| 2161 | if eol and not strend then error(202); |
| 2162 | if lgth = 1 then begin |
| 2163 | { this is an artifact of the original code. If the string is a |
| 2164 | single character, we store it as an integer even though the |
| 2165 | symbol stays a string } |
| 2166 | val.intval := true; val.ival := ord(string[1]) |
| 2167 | end else begin |
| 2168 | if (lgth = 0) and iso7185 then error(205); |
| 2169 | new(lvp,strg); pshcst(lvp); |
| 2170 | lvp^.cclass:=strg; |
| 2171 | if lgth > strglgth then |
| 2172 | begin error(26); lgth := strglgth end; |
| 2173 | with lvp^ do |
| 2174 | begin slgth := lgth; strassvc(sval, string, strglgth) end; |
| 2175 | val.intval := false; |
| 2176 | val.valp := lvp |
| 2177 | end |
| 2178 | end; |
| 2179 | chcolon: |
| 2180 | begin op := noop; nextch; |
| 2181 | if ch = '=' then |
| 2182 | begin sy := becomes; nextch end |
| 2183 | else sy := colon |
| 2184 | end; |
| 2185 | chperiod: |
| 2186 | begin op := noop; nextch; |
| 2187 | if ch = '.' then begin sy := range; nextch end |
| 2188 | else if ch = ')' then begin sy := rbrack; nextch end |
| 2189 | else sy := period |
| 2190 | end; |
| 2191 | chlt: |
| 2192 | begin nextch; sy := relop; |
| 2193 | if ch = '=' then |
| 2194 | begin op := leop; nextch end |
| 2195 | else |
| 2196 | if ch = '>' then |
| 2197 | begin op := neop; nextch end |
| 2198 | else op := ltop |
| 2199 | end; |
| 2200 | chgt: |
| 2201 | begin nextch; sy := relop; |
| 2202 | if ch = '=' then |
| 2203 | begin op := geop; nextch end |
| 2204 | else op := gtop |
| 2205 | end; |
| 2206 | chlparen: |
| 2207 | begin nextch; |
| 2208 | if ch = '*' then |
| 2209 | begin nextch; |
| 2210 | if (ch = '$') and not incact then options; |
| 2211 | repeat |
| 2212 | while (ch <> '}') and (ch <> '*') and not eofinp do nextch; |
| 2213 | iscmte := ch = '}'; nextch |
| 2214 | until iscmte or (ch = ')') or eofinp; |
| 2215 | if not iscmte then nextch; goto 1 |
| 2216 | end |
| 2217 | else if ch = '.' then begin sy := lbrack; nextch end |
| 2218 | else sy := lparent; |
| 2219 | op := noop |
| 2220 | end; |
| 2221 | chlcmt: |
| 2222 | begin nextch; |
| 2223 | if ch = '$' then options; |
| 2224 | repeat |
| 2225 | while (ch <> '}') and (ch <> '*') and not eofinp do nextch; |
| 2226 | iscmte := ch = '}'; nextch |
| 2227 | until iscmte or (ch = ')') or eofinp; |
| 2228 | if not iscmte then nextch; goto 1 |
| 2229 | end; |
| 2230 | chrem: |
| 2231 | begin chkstd; |
| 2232 | repeat nextch until eol; { '!' skip next line } |
| 2233 | goto 1 |
| 2234 | end; |
| 2235 | special: |
| 2236 | begin sy := ssy[ch]; op := sop[ch]; |
| 2237 | nextch |
| 2238 | end; |
| 2239 | chspace: sy := othersy |
| 2240 | end; (*case*) |
| 2241 | |
| 2242 | if dodmplex then begin { lexical dump } |
| 2243 | |
| 2244 | writeln; |
| 2245 | write('symbol: '); prtsym(sy); |
| 2246 | if sy in [ident,intconst,realconst,stringconst] then |
| 2247 | case sy of |
| 2248 | ident: write(': ', id:10); |
| 2249 | intconst: write(': ', val.ival:1); |
| 2250 | realconst: write(': ', val.valp^.rval: 9); |
| 2251 | stringconst: begin write(': '''); |
| 2252 | if val.intval then write(chr(val.ival)) |
| 2253 | else writev(output, val.valp^.sval, val.valp^.slgth); |
| 2254 | write('''') |
| 2255 | end; |
| 2256 | end; |
| 2257 | writeln |
| 2258 | |
| 2259 | end; |
| 2260 | 2:; |
| 2261 | end (*insymbol*) ; |
| 2262 | |
| 2263 | procedure pushback; |
| 2264 | begin |
| 2265 | if nvalid then error(506); { multiple pushbacks } |
| 2266 | { put current tolken to future } |
| 2267 | nsy := sy; nop := op; nval := val; nlgth := lgth; nid := id; nkk := kk; |
| 2268 | { get current from last } |
| 2269 | sy := lsy; op := lop; val := lval; lgth := llgth; id := lid; kk := lkk; |
| 2270 | nvalid := true { set there is a next tolken } |
| 2271 | end; |
| 2272 | |
| 2273 | procedure prtclass(klass: idclass); |
| 2274 | begin |
| 2275 | case klass of |
| 2276 | types: write('types'); |
| 2277 | konst: write('konst'); |
| 2278 | fixedt: write('fixedt'); |
| 2279 | vars: write('vars'); |
| 2280 | field: write('field'); |
| 2281 | proc: write('proc'); |
| 2282 | func: write('func'); |
| 2283 | alias: write('alias'); |
| 2284 | end |
| 2285 | end; |
| 2286 | |
| 2287 | procedure prtform(form: structform); |
| 2288 | begin |
| 2289 | case form of |
| 2290 | scalar: write('scalar'); |
| 2291 | subrange: write('subrange'); |
| 2292 | pointer: write('pointer'); |
| 2293 | power: write('power'); |
| 2294 | arrays: write('arrays'); |
| 2295 | arrayc: write('arrayc'); |
| 2296 | records: write('records'); |
| 2297 | files: write('files'); |
| 2298 | tagfld: write('tagfld'); |
| 2299 | variant: write('variant'); |
| 2300 | exceptf: write('exceptf'); |
| 2301 | end |
| 2302 | end; |
| 2303 | |
| 2304 | procedure prtfpat(fpat: fpattr); |
| 2305 | begin |
| 2306 | case fpat of |
| 2307 | fpanone: write('none'); |
| 2308 | fpaoverload: write('overload'); |
| 2309 | fpastatic: write('static'); |
| 2310 | fpavirtual: write('virtual'); |
| 2311 | fpaoverride: write('override'); |
| 2312 | end |
| 2313 | end; |
| 2314 | |
| 2315 | function digits(i: integer): integer; forward; |
| 2316 | |
| 2317 | procedure prtlvlsym; |
| 2318 | var di: disprange; lc: integer; |
| 2319 | procedure prtsyms(fcp: ctp); |
| 2320 | begin |
| 2321 | if fcp <> nil then begin |
| 2322 | writevp(output, fcp^.name); |
| 2323 | write(': ', fcp^.snm:1, ' '); |
| 2324 | lc := lc+lenpv(fcp^.name)+2+digits(fcp^.snm)+1; |
| 2325 | if lc >= 80 then begin writeln; lc := 1 end; |
| 2326 | prtsyms(fcp^.llink); |
| 2327 | prtsyms(fcp^.rlink) |
| 2328 | end |
| 2329 | end; |
| 2330 | begin lc := 1; |
| 2331 | for di := top downto 0 do begin |
| 2332 | write('level: ', di:1, ' '); |
| 2333 | prtsyms(display[di].fname); |
| 2334 | writeln |
| 2335 | end |
| 2336 | end; |
| 2337 | |
| 2338 | procedure enterid(fcp: ctp); |
| 2339 | (*enter id pointed at by fcp into the name-table, |
| 2340 | which on each declaration level is organised as |
| 2341 | an unbalanced binary tree*) |
| 2342 | var lcp, lcp1: ctp; lleft: boolean; |
| 2343 | begin |
| 2344 | lcp := display[top].fname; |
| 2345 | if lcp = nil then |
| 2346 | display[top].fname := fcp |
| 2347 | else |
| 2348 | begin |
| 2349 | repeat lcp1 := lcp; |
| 2350 | if strequvv(lcp^.name, fcp^.name) then begin |
| 2351 | (*name conflict, follow right link*) |
| 2352 | if incact then begin |
| 2353 | writeln; write('*** Duplicate in uses/joins: '); |
| 2354 | writevp(output, fcp^.name); |
| 2355 | writeln |
| 2356 | end; |
| 2357 | { give appropriate error } |
| 2358 | if lcp^.klass = alias then error(242) else error(101); |
| 2359 | lcp := lcp^.rlink; lleft := false |
| 2360 | end else |
| 2361 | if strltnvv(lcp^.name, fcp^.name) then |
| 2362 | begin lcp := lcp^.rlink; lleft := false end |
| 2363 | else begin lcp := lcp^.llink; lleft := true end |
| 2364 | until lcp = nil; |
| 2365 | if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp |
| 2366 | end; |
| 2367 | fcp^.llink := nil; fcp^.rlink := nil |
| 2368 | end (*enterid*) ; |
| 2369 | |
| 2370 | procedure searchsection(fcp: ctp; var fcp1: ctp); |
| 2371 | (*to find record fields and forward declared procedure id's |
| 2372 | --> procedure proceduredeclaration |
| 2373 | --> procedure selector*) |
| 2374 | label 1; |
| 2375 | begin |
| 2376 | while fcp <> nil do |
| 2377 | if strequvf(fcp^.name, id) then goto 1 |
| 2378 | else if strltnvf(fcp^.name, id) then fcp := fcp^.rlink |
| 2379 | else fcp := fcp^.llink; |
| 2380 | 1: if fcp <> nil then |
| 2381 | if fcp^.klass = alias then fcp := fcp^.actid; |
| 2382 | fcp1 := fcp |
| 2383 | end (*searchsection*) ; |
| 2384 | |
| 2385 | procedure schsecidnenm(lcp: ctp; fidcls: setofids; var fcp: ctp; |
| 2386 | var mm: boolean); |
| 2387 | var lcp1: ctp; |
| 2388 | |
| 2389 | function inclass(lcp: ctp): ctp; |
| 2390 | var fcp, lcp1: ctp; |
| 2391 | begin fcp := nil; |
| 2392 | if lcp^.klass in [proc,func] then begin |
| 2393 | lcp1 := lcp^.grppar; |
| 2394 | while lcp1 <> nil do begin |
| 2395 | if lcp1^.klass in fidcls then fcp := lcp1; |
| 2396 | lcp1 := lcp1^.grpnxt |
| 2397 | end; |
| 2398 | if fcp <> nil then fcp := lcp { in class, use top entry } |
| 2399 | end else if lcp^.klass in fidcls then fcp := lcp; |
| 2400 | inclass := fcp |
| 2401 | end; |
| 2402 | |
| 2403 | begin |
| 2404 | mm := false; fcp := nil; |
| 2405 | while lcp <> nil do begin |
| 2406 | if strequvf(lcp^.name, id) then begin |
| 2407 | lcp1 := lcp; if lcp1^.klass = alias then lcp1 := lcp1^.actid; |
| 2408 | lcp1 := inclass(lcp1); |
| 2409 | if lcp1 <> nil then begin fcp := lcp1; lcp := nil end |
| 2410 | else begin mm := true; lcp := lcp^.rlink end |
| 2411 | end else |
| 2412 | if strltnvf(lcp^.name, id) then lcp := lcp^.rlink |
| 2413 | else lcp := lcp^.llink |
| 2414 | end |
| 2415 | end (*searchidnenm*) ; |
| 2416 | |
| 2417 | procedure searchidnenm(fidcls: setofids; var fcp: ctp; var mm: boolean); |
| 2418 | label 1; |
| 2419 | var disxl: disprange; |
| 2420 | begin |
| 2421 | mm := false; disx := 0; |
| 2422 | for disxl := top downto 0 do |
| 2423 | begin |
| 2424 | schsecidnenm(display[disxl].fname, fidcls, fcp, mm); |
| 2425 | if fcp <> nil then begin disx := disxl; goto 1 end |
| 2426 | end; |
| 2427 | 1:; |
| 2428 | end (*searchidnenm*) ; |
| 2429 | |
| 2430 | procedure searchidne(fidcls: setofids; var fcp: ctp); |
| 2431 | var mm: boolean; |
| 2432 | begin |
| 2433 | searchidnenm(fidcls, fcp, mm); |
| 2434 | if mm then error(103) |
| 2435 | end (*searchidne*) ; |
| 2436 | |
| 2437 | procedure schsecidne(lcp: ctp; fidcls: setofids; var fcp: ctp); |
| 2438 | var mm: boolean; |
| 2439 | begin |
| 2440 | schsecidnenm(lcp, fidcls, fcp, mm); |
| 2441 | if mm then error(103) |
| 2442 | end (*searchidne*) ; |
| 2443 | |
| 2444 | procedure searchid(fidcls: setofids; var fcp: ctp); |
| 2445 | var lcp, lcp1: ctp; pn, fpn: disprange; pdf: boolean; |
| 2446 | begin |
| 2447 | pdf := false; |
| 2448 | searchidne(fidcls, lcp); { perform no error search } |
| 2449 | if lcp = nil then begin |
| 2450 | { search module leader in the pile } |
| 2451 | if ptop > 0 then for pn := ptop-1 downto 0 do |
| 2452 | if strequvf(pile[pn].modnam, id) then begin fpn := pn; pdf := true end; |
| 2453 | if pdf then begin { module name was found } |
| 2454 | insymbol; if sy <> period then error(21) else insymbol; |
| 2455 | if sy <> ident then error(2) |
| 2456 | else schsecidne(pile[fpn].fname,fidcls,lcp); { search qualifed name } |
| 2457 | if lcp = nil then begin error(268); pdf := false end { not found } |
| 2458 | end |
| 2459 | end; |
| 2460 | if lcp <> nil then begin { found } |
| 2461 | lcp^.refer := true; |
| 2462 | if (disx <> top) and (display[top].define) and not pdf then begin |
| 2463 | { downlevel, create an alias and link to bottom } |
| 2464 | new(lcp1, alias); ininam(lcp1); lcp1^.klass := alias; |
| 2465 | lcp1^.name := lcp^.name; lcp1^.actid := lcp; |
| 2466 | enterid(lcp1) |
| 2467 | end |
| 2468 | end else begin (*search not successful |
| 2469 | --> procedure simpletype*) |
| 2470 | error(104); |
| 2471 | (*to avoid returning nil, reference an entry |
| 2472 | for an undeclared id of appropriate class |
| 2473 | --> procedure enterundecl*) |
| 2474 | if types in fidcls then lcp := utypptr |
| 2475 | else |
| 2476 | if (vars in fidcls) or (fixedt in fidcls) then lcp := uvarptr |
| 2477 | else |
| 2478 | if field in fidcls then lcp := ufldptr |
| 2479 | else |
| 2480 | if konst in fidcls then lcp := ucstptr |
| 2481 | else |
| 2482 | if proc in fidcls then lcp := uprcptr |
| 2483 | else lcp := ufctptr |
| 2484 | end; |
| 2485 | fcp := lcp |
| 2486 | end (*searchid*) ; |
| 2487 | |
| 2488 | procedure getbounds(fsp: stp; var fmin,fmax: integer); |
| 2489 | (*get internal bounds of subrange or scalar type*) |
| 2490 | (*assume fsp<>intptr and fsp<>realptr*) |
| 2491 | begin |
| 2492 | fmin := 0; fmax := 0; |
| 2493 | if fsp <> nil then |
| 2494 | with fsp^ do |
| 2495 | if form = subrange then |
| 2496 | begin fmin := min.ival; fmax := max.ival end |
| 2497 | else |
| 2498 | if fsp = charptr then |
| 2499 | begin fmin := ordminchar; fmax := ordmaxchar |
| 2500 | end |
| 2501 | else |
| 2502 | if fsp = intptr then |
| 2503 | begin fmin := -pmmaxint; fmax := pmmaxint |
| 2504 | end |
| 2505 | else |
| 2506 | if fconst <> nil then |
| 2507 | fmax := fconst^.values.ival |
| 2508 | end (*getbounds*) ; |
| 2509 | |
| 2510 | { get span of type } |
| 2511 | function span(fsp: stp): integer; |
| 2512 | var fmin, fmax: integer; |
| 2513 | begin |
| 2514 | getbounds(fsp, fmin, fmax); span := fmax-fmin+1 |
| 2515 | end; |
| 2516 | |
| 2517 | { get span of array index } |
| 2518 | function spana(fsp: stp): integer; |
| 2519 | begin |
| 2520 | if fsp <> nil then begin |
| 2521 | if fsp^.form <> arrays then error(512); |
| 2522 | { if the index type is nil, assume string and take the array size as the |
| 2523 | span } |
| 2524 | if fsp^.inxtype = nil then spana := fsp^.size |
| 2525 | else spana := span(fsp^.inxtype) |
| 2526 | end |
| 2527 | end; |
| 2528 | |
| 2529 | function isbyte(fsp: stp): boolean; |
| 2530 | { check structure is byte } |
| 2531 | var fmin, fmax: integer; |
| 2532 | begin |
| 2533 | getbounds(fsp, fmin, fmax); |
| 2534 | isbyte := (fmin >= 0) and (fmax <= 255) |
| 2535 | end; |
| 2536 | |
| 2537 | function basetype(fsp: stp): stp; |
| 2538 | { remove any subrange types } |
| 2539 | function issub(fsp: stp): boolean; |
| 2540 | begin |
| 2541 | if fsp <> nil then issub := fsp^.form = subrange |
| 2542 | else issub := false |
| 2543 | end; |
| 2544 | begin |
| 2545 | if fsp <> nil then |
| 2546 | while issub(fsp) do |
| 2547 | fsp := fsp^.rangetype; |
| 2548 | basetype := fsp |
| 2549 | end; |
| 2550 | |
| 2551 | { alignment for general memory placement } |
| 2552 | function alignquot(fsp: stp): integer; |
| 2553 | begin |
| 2554 | alignquot := 1; |
| 2555 | if fsp <> nil then |
| 2556 | with fsp^ do |
| 2557 | case form of |
| 2558 | scalar: if fsp=intptr then alignquot := intal |
| 2559 | else if fsp=boolptr then alignquot := boolal |
| 2560 | else if scalkind=declared then alignquot := intal |
| 2561 | else if fsp=charptr then alignquot := charal |
| 2562 | else if fsp=realptr then alignquot := realal |
| 2563 | else (*parmptr*) alignquot := parmal; |
| 2564 | subrange: alignquot := alignquot(rangetype); |
| 2565 | pointer: alignquot := adral; |
| 2566 | power: alignquot := setal; |
| 2567 | files: alignquot := fileal; |
| 2568 | arrays: alignquot := alignquot(aeltype); |
| 2569 | arrayc: alignquot := alignquot(abstype); |
| 2570 | records: alignquot := recal; |
| 2571 | exceptf: alignquot := exceptal; |
| 2572 | variant,tagfld: error(501) |
| 2573 | end |
| 2574 | end (*alignquot*); |
| 2575 | |
| 2576 | procedure alignu(fsp: stp; var flc: addrrange); |
| 2577 | var k,l: integer; |
| 2578 | begin |
| 2579 | k := alignquot(fsp); |
| 2580 | l := flc-1; |
| 2581 | flc := l + k - (k+l) mod k |
| 2582 | end (*align*); |
| 2583 | |
| 2584 | procedure alignd(fsp: stp; var flc: stkoff); |
| 2585 | var k,l: integer; |
| 2586 | begin |
| 2587 | k := alignquot(fsp); |
| 2588 | if (flc mod k) <> 0 then begin |
| 2589 | l := flc+1; |
| 2590 | flc := l - k + (k-l) mod k |
| 2591 | end |
| 2592 | end (*align*); |
| 2593 | |
| 2594 | { align address, upwards } |
| 2595 | procedure alignau(algn: addrrange; var flc: addrrange); |
| 2596 | var l: integer; |
| 2597 | begin |
| 2598 | l := flc-1; |
| 2599 | flc := l + algn - (algn+l) mod algn |
| 2600 | end (*alignau*); |
| 2601 | |
| 2602 | procedure wrtctp(ip: ctp); |
| 2603 | begin |
| 2604 | if ip = nil then write('<nil>':intdig) else write(ip^.snm:intdig) |
| 2605 | end; |
| 2606 | |
| 2607 | procedure wrtstp(sp: stp); |
| 2608 | begin |
| 2609 | if sp = nil then write('<nil>':intdig) else write(sp^.snm:intdig) |
| 2610 | end; |
| 2611 | |
| 2612 | procedure prtstp(sp: stp); |
| 2613 | begin |
| 2614 | if sp = nil then write('<nil>':intdig) |
| 2615 | else with sp^ do begin |
| 2616 | write(sp^.snm:intdig); |
| 2617 | write(' ', size:intdig, ' '); |
| 2618 | case form of |
| 2619 | scalar: begin write('scalar':intdig, ' '); |
| 2620 | if scalkind = standard then write('standard':intdig) |
| 2621 | else begin write('declared':intdig,' '); wrtctp(fconst) end |
| 2622 | end; |
| 2623 | subrange: begin |
| 2624 | write('subrange':intdig,' '); wrtstp(rangetype); write(' '); |
| 2625 | if rangetype <> realptr then |
| 2626 | write(min.ival:intdig, ' ', max.ival:intdig) |
| 2627 | else |
| 2628 | if (min.valp <> nil) and (max.valp <> nil) then begin |
| 2629 | write(' '); write(min.valp^.rval:9); |
| 2630 | write(' '); write(max.valp^.rval:9) |
| 2631 | end |
| 2632 | end; |
| 2633 | pointer: begin write('pointer':intdig,' '); wrtstp(eltype) end; |
| 2634 | power: begin write('set':intdig,' '); wrtstp(elset); write(' '); |
| 2635 | write(matchpack:intdig) end; |
| 2636 | arrays: begin |
| 2637 | write('array':intdig,' '); wrtstp(inxtype); write(' '); |
| 2638 | wrtstp(aeltype); end; |
| 2639 | arrayc: begin write('array':intdig,' '); wrtstp(abstype) end; |
| 2640 | records: begin |
| 2641 | write('record':intdig,' '); wrtctp(fstfld); write(' '); |
| 2642 | wrtstp(recvar); write(' '); wrtstp(recyc) |
| 2643 | end; |
| 2644 | files: begin write('file':intdig,' '); wrtstp(filtype) end; |
| 2645 | tagfld: begin write('tagfld':intdig,' '); wrtctp(tagfieldp); |
| 2646 | write(' '); wrtstp(fstvar) |
| 2647 | end; |
| 2648 | variant: begin write('variant':intdig,' '); wrtstp(nxtvar); |
| 2649 | write(' '); wrtstp(subvar); write(' '); wrtstp(caslst); |
| 2650 | write(' '); wrtctp(varfld); |
| 2651 | write(' ',varval.ival:intdig, ' ', varln:intdig) |
| 2652 | end; |
| 2653 | exceptf: begin write('except':intdig) end |
| 2654 | end (*case*) |
| 2655 | end |
| 2656 | end; |
| 2657 | |
| 2658 | procedure prtctp(cp: ctp); |
| 2659 | begin |
| 2660 | if cp = nil then write('<nil>':intdig) |
| 2661 | else with cp^ do begin |
| 2662 | write(cp^.snm:intdig); write(' '); writev(output, name, intdig); |
| 2663 | write(' '); wrtctp(llink); write(' '); wrtctp(rlink); write(' '); |
| 2664 | wrtstp(idtype); write(' '); |
| 2665 | case klass of |
| 2666 | types: write('type':intdig); |
| 2667 | konst: begin write('constant':intdig,' '); wrtctp(next); write(' '); |
| 2668 | if idtype <> nil then |
| 2669 | if idtype = realptr then |
| 2670 | begin |
| 2671 | if values.valp <> nil then write(values.valp^.rval:9) |
| 2672 | end |
| 2673 | else |
| 2674 | if idtype^.form = arrays then (*stringconst*) |
| 2675 | begin |
| 2676 | if values.valp <> nil then |
| 2677 | begin |
| 2678 | with values.valp^ do writev(output, sval, slgth) |
| 2679 | end |
| 2680 | end |
| 2681 | else write(values.ival:intdig) |
| 2682 | end; |
| 2683 | vars: begin write('variable':intdig, ' '); |
| 2684 | if vkind = actual then write('actual':intdig) |
| 2685 | else write('formal':intdig); |
| 2686 | write(' '); wrtctp(next); |
| 2687 | write(' ', vlev:intdig,' ',vaddr:intdig, ' '); |
| 2688 | if threat then write('threat':intdig) else write(' ':intdig); |
| 2689 | write(' ', forcnt:intdig, ' '); |
| 2690 | case part of |
| 2691 | ptval: write('value':intdig, ' '); |
| 2692 | ptvar: write('var':intdig, ' '); |
| 2693 | ptview: write('view':intdig, ' '); |
| 2694 | ptout:write('out':intdig, ' '); |
| 2695 | end; |
| 2696 | if hdr then write('header':intdig, ' ') else write(' ':intdig, ' '); |
| 2697 | if vext then write('external':intdig, ' ') else write(' ':intdig, ' '); |
| 2698 | if vext then write(vmod^.fn:intdig, ' ') else write(' ':intdig, ' '); |
| 2699 | write(inilab:intdig, ' '); wrtctp(ininxt); |
| 2700 | write(' ', dblptr:intdig); |
| 2701 | end; |
| 2702 | fixedt: begin write('fixed':intdig, ' '); |
| 2703 | if floc >= 0 then write(floc:intdig) else writev(output, name, intdig); |
| 2704 | write(' '); |
| 2705 | if fext then write('external':intdig) else write(' ':intdig); |
| 2706 | if fext then write(fmod^.fn:intdig) else write(' ':intdig) |
| 2707 | end; |
| 2708 | field: begin write('field':intdig,' '); wrtctp(next); write(' '); |
| 2709 | write(fldaddr:intdig,' '); wrtstp(varnt); write(' '); |
| 2710 | wrtctp(varlb); write(' '); |
| 2711 | if tagfield then write('tagfield':intdig) else write(' ':intdig); |
| 2712 | write(' ', taglvl:intdig, ' ',varsaddr:intdig, ' ', varssize:intdig); |
| 2713 | write(' ', vartl:intdig) |
| 2714 | end; |
| 2715 | proc, |
| 2716 | func: begin |
| 2717 | if klass = proc then write('procedure':intdig, ' ') |
| 2718 | else write('function':intdig, ' '); |
| 2719 | write(pfaddr:intdig, ' '); wrtctp(pflist); write(' '); |
| 2720 | if asgn then write('assigned':intdig, ' ') else write(' ':intdig, ' '); |
| 2721 | if pext then write('external':intdig, ' ') else write(' ':intdig, ' '); |
| 2722 | if pext then write(pmod^.fn:intdig) else write(' ':intdig); write(' '); |
| 2723 | case pfattr of |
| 2724 | fpanone: write(' ':intdig); |
| 2725 | fpaoverload: write('overload':intdig); |
| 2726 | fpastatic: write('static':intdig); |
| 2727 | fpavirtual: write('virtual':intdig); |
| 2728 | fpaoverride: write('override': intdig); |
| 2729 | end; |
| 2730 | write(' ', pfvaddr:intdig, ' '); wrtctp(pfvid); write(' '); wrtctp(grppar); |
| 2731 | write(' '); wrtctp(grpnxt); write(' '); |
| 2732 | if pfdeckind = standard then |
| 2733 | write('standard':intdig, ' ', key:intdig) |
| 2734 | else |
| 2735 | begin write('declared':intdig,' '); wrtctp(pflist); write(' '); |
| 2736 | write(pflev:intdig,' ',pfname:intdig, ' '); |
| 2737 | if pfkind = actual then |
| 2738 | begin write('actual':intdig, ' '); |
| 2739 | if forwdecl then write('forward':intdig, ' ') |
| 2740 | else write('not forward':intdig, ' '); |
| 2741 | if sysrot then write('system routine':intdig) |
| 2742 | else write('not system routine':intdig); |
| 2743 | if extern then write('external':intdig) |
| 2744 | else write('not external':intdig) |
| 2745 | end |
| 2746 | else write('formal':intdig) |
| 2747 | end |
| 2748 | end; |
| 2749 | alias: begin write('alias':intdig, ' '); wrtctp(actid); end; |
| 2750 | end (*case*); |
| 2751 | end |
| 2752 | end; |
| 2753 | |
| 2754 | procedure printtables(fb: boolean); |
| 2755 | (*print data structure and name table*) |
| 2756 | |
| 2757 | var i, lim: disprange; |
| 2758 | |
| 2759 | procedure marker; |
| 2760 | (*mark data structure entries to avoid multiple printout*) |
| 2761 | var i: integer; |
| 2762 | |
| 2763 | procedure markctp(fp: ctp); forward; |
| 2764 | |
| 2765 | procedure markstp(fp: stp); |
| 2766 | (*mark data structures, prevent cycles*) |
| 2767 | begin |
| 2768 | if fp <> nil then |
| 2769 | with fp^ do |
| 2770 | begin marked := true; |
| 2771 | case form of |
| 2772 | scalar: ; |
| 2773 | subrange: markstp(rangetype); |
| 2774 | pointer: (*don't mark eltype: cycle possible; will be marked |
| 2775 | anyway, if fp = true*) ; |
| 2776 | power: markstp(elset) ; |
| 2777 | arrays: begin markstp(aeltype); markstp(inxtype) end; |
| 2778 | arrayc: markstp(abstype); |
| 2779 | records: begin markctp(fstfld); markstp(recvar) end; |
| 2780 | files: markstp(filtype); |
| 2781 | tagfld: markstp(fstvar); |
| 2782 | variant: begin markstp(nxtvar); markstp(subvar) end; |
| 2783 | exceptf: ; |
| 2784 | end (*case*) |
| 2785 | end (*with*) |
| 2786 | end (*markstp*); |
| 2787 | |
| 2788 | procedure markctp(fp: ctp); |
| 2789 | begin |
| 2790 | if fp <> nil then |
| 2791 | with fp^ do |
| 2792 | begin markctp(llink); markctp(rlink); |
| 2793 | markstp(idtype) |
| 2794 | end |
| 2795 | end (*markctp*); |
| 2796 | |
| 2797 | begin (*marker*) |
| 2798 | for i := top downto lim do |
| 2799 | markctp(display[i].fname) |
| 2800 | end (*marker*); |
| 2801 | |
| 2802 | procedure followctp(fp: ctp); forward; |
| 2803 | |
| 2804 | procedure followstp(fp: stp); |
| 2805 | begin |
| 2806 | if fp <> nil then |
| 2807 | with fp^ do |
| 2808 | if marked then |
| 2809 | begin marked := false; write('S: '); prtstp(fp); writeln; |
| 2810 | case form of |
| 2811 | scalar: ; |
| 2812 | subrange: followstp(rangetype); |
| 2813 | pointer: ; |
| 2814 | power: followstp(elset); |
| 2815 | arrays: begin followstp(aeltype); followstp(inxtype) end; |
| 2816 | arrayc: followstp(abstype); |
| 2817 | records: begin followctp(fstfld); followstp(recvar) end; |
| 2818 | files: followstp(filtype); |
| 2819 | tagfld: followstp(fstvar); |
| 2820 | variant: begin followstp(nxtvar); followstp(subvar) end; |
| 2821 | exceptf: ; |
| 2822 | end (*case*) |
| 2823 | end (*if marked*) |
| 2824 | end (*followstp*); |
| 2825 | |
| 2826 | procedure followctp(fp: ctp); |
| 2827 | begin |
| 2828 | if fp <> nil then |
| 2829 | with fp^ do |
| 2830 | begin write('C: '); prtctp(fp); writeln; |
| 2831 | followctp(llink); followctp(rlink); |
| 2832 | followstp(idtype) |
| 2833 | end (*with*) |
| 2834 | end (*followctp*); |
| 2835 | |
| 2836 | begin (*printtables*) |
| 2837 | writeln(output); writeln(output); writeln(output); |
| 2838 | if fb then lim := 0 |
| 2839 | else begin lim := top; write(' local') end; |
| 2840 | writeln(' tables:', top:1, '-', lim:1, ':'); writeln(output); |
| 2841 | writeln('C: ', 'Entry #':intdig, ' ', 'Id':intdig, ' ', 'llink':intdig, ' ', |
| 2842 | 'rlink':intdig, ' ', 'Typ':intdig, ' ', 'Class':intdig); |
| 2843 | writeln('S: ', 'Entry #':intdig, ' ', 'Size':intdig, ' ', 'Form ':intdig); |
| 2844 | write('==============================================================='); |
| 2845 | writeln('=========================='); |
| 2846 | marker; |
| 2847 | for i := top downto lim do |
| 2848 | begin writeln('Level: ', i:1); followctp(display[i].fname) end; |
| 2849 | writeln(output); |
| 2850 | if not eol then write(' ':chcnt+16) |
| 2851 | end (*printtables*); |
| 2852 | |
| 2853 | procedure chkrefs(h, p: ctp; var w: boolean); |
| 2854 | begin |
| 2855 | if chkref then begin |
| 2856 | if p <> nil then begin |
| 2857 | chkrefs(h, p^.llink, w); { check left } |
| 2858 | chkrefs(h, p^.rlink, w); { check right } |
| 2859 | if not p^.refer and (p^.klass <> alias) and not incact then begin |
| 2860 | if not w then writeln; writev(output, p^.name, lenpv(p^.name)); |
| 2861 | write(' unreferenced at block ending on line: ', |
| 2862 | incstk^.linecount:1); |
| 2863 | if h <> nil then |
| 2864 | begin write(' in function/procedure: '); |
| 2865 | writev(output, h^.name, lenpv(h^.name)) end; |
| 2866 | writeln; |
| 2867 | w := true |
| 2868 | end |
| 2869 | end |
| 2870 | end |
| 2871 | end; |
| 2872 | |
| 2873 | function chkext(fcp: ctp): boolean; |
| 2874 | begin chkext := false; |
| 2875 | if fcp <> nil then begin |
| 2876 | if fcp^.klass = vars then chkext := fcp^.vext |
| 2877 | else if fcp^.klass = fixedt then chkext := fcp^.fext |
| 2878 | else if (fcp^.klass = proc) or (fcp^.klass = func) then |
| 2879 | chkext := fcp^.pext |
| 2880 | end |
| 2881 | end; |
| 2882 | |
| 2883 | function chkfix(fcp: ctp): boolean; |
| 2884 | begin chkfix := false; |
| 2885 | if fcp <> nil then chkfix := fcp^.klass = fixedt |
| 2886 | end; |
| 2887 | |
| 2888 | { id contains a procedure in overload list } |
| 2889 | function hasproc(fcp: ctp): boolean; |
| 2890 | begin hasproc := false; |
| 2891 | if fcp <> nil then |
| 2892 | if fcp^.klass in [proc, func] then begin |
| 2893 | fcp := fcp^.grppar; |
| 2894 | while fcp <> nil do begin |
| 2895 | if fcp^.klass = proc then hasproc := true; |
| 2896 | fcp := fcp^.grpnxt |
| 2897 | end |
| 2898 | end |
| 2899 | end; |
| 2900 | |
| 2901 | { id contains a function in overload list } |
| 2902 | function hasfunc(fcp: ctp): boolean; |
| 2903 | begin hasfunc := false; |
| 2904 | if fcp <> nil then |
| 2905 | if fcp^.klass in [proc, func] then begin |
| 2906 | fcp := fcp^.grppar; |
| 2907 | while fcp <> nil do begin |
| 2908 | if fcp^.klass = func then hasfunc := true; |
| 2909 | fcp := fcp^.grpnxt |
| 2910 | end |
| 2911 | end |
| 2912 | end; |
| 2913 | |
| 2914 | { return override procedure/function from list } |
| 2915 | function ovrpf(fcp: ctp): ctp; |
| 2916 | var rcp: ctp; |
| 2917 | begin rcp := nil; |
| 2918 | if fcp <> nil then |
| 2919 | if fcp^.klass in [proc, func] then begin |
| 2920 | fcp := fcp^.grppar; |
| 2921 | while fcp <> nil do begin |
| 2922 | if fcp^.pfattr = fpaoverride then rcp := fcp; |
| 2923 | fcp := fcp^.grpnxt |
| 2924 | end |
| 2925 | end; |
| 2926 | ovrpf := rcp |
| 2927 | end; |
| 2928 | |
| 2929 | procedure genlabel(var nxtlab: integer); |
| 2930 | begin intlabel := intlabel + 1; |
| 2931 | nxtlab := intlabel |
| 2932 | end (*genlabel*); |
| 2933 | |
| 2934 | { write shorthand type } |
| 2935 | procedure wrttypc(var f: text; tp: stp; fl: integer); |
| 2936 | const maxtrk = 4000; |
| 2937 | var typtrk: array [1..maxtrk] of stp; cti: integer; err: boolean; |
| 2938 | |
| 2939 | procedure wrttypsub(tp: stp); |
| 2940 | var x, y, fi: integer; |
| 2941 | |
| 2942 | procedure nxtcti; |
| 2943 | begin |
| 2944 | cti := cti+1; if cti <= maxtrk then typtrk[cti] := nil |
| 2945 | end; |
| 2946 | |
| 2947 | procedure nxtctis(i: integer); |
| 2948 | var x: integer; |
| 2949 | begin |
| 2950 | for x := 1 to i do nxtcti |
| 2951 | end; |
| 2952 | |
| 2953 | procedure wrtchr(c: char); |
| 2954 | begin |
| 2955 | write(f, c); nxtcti |
| 2956 | end; |
| 2957 | |
| 2958 | procedure wrtint(i: integer); |
| 2959 | var p, d: integer; |
| 2960 | begin |
| 2961 | p := 10; d := 1; |
| 2962 | while (i >= p) and (p < maxpow10) do begin p := p*10; d := d+1 end; |
| 2963 | write(f, i:1); |
| 2964 | nxtctis(d) |
| 2965 | end; |
| 2966 | |
| 2967 | procedure wrtrfd(fld: ctp); |
| 2968 | begin |
| 2969 | while fld <> nil do begin |
| 2970 | with fld^ do begin |
| 2971 | writev(f, name, lenpv(name)); nxtctis(lenpv(name)); |
| 2972 | wrtchr(':'); |
| 2973 | if klass = field then wrtint(fldaddr) else wrtchr('?'); |
| 2974 | wrtchr(':'); wrttypsub(idtype); |
| 2975 | end; |
| 2976 | fld := fld^.next; |
| 2977 | if fld <> nil then wrtchr(',') |
| 2978 | end |
| 2979 | end; |
| 2980 | |
| 2981 | procedure wrtvar(sp: stp); |
| 2982 | begin |
| 2983 | while sp <> nil do with sp^ do |
| 2984 | if form = variant then begin |
| 2985 | wrtint(varval.ival); wrtchr('('); wrtrfd(varfld); wrtchr(')'); |
| 2986 | sp := nxtvar |
| 2987 | end else sp := nil |
| 2988 | end; |
| 2989 | |
| 2990 | { enums are backwards, so print thus } |
| 2991 | procedure wrtenm(ep: ctp; i: integer); |
| 2992 | begin |
| 2993 | if ep <> nil then begin |
| 2994 | wrtenm(ep^.next, i+1); |
| 2995 | writev(f, ep^.name, lenpv(ep^.name)); nxtctis(lenpv(ep^.name)); |
| 2996 | if i > 0 then wrtchr(',') |
| 2997 | end |
| 2998 | end; |
| 2999 | |
| 3000 | begin { wrttypsub } |
| 3001 | if cti > maxtrk then begin |
| 3002 | if not err then error(227); |
| 3003 | err := true |
| 3004 | end else typtrk[cti] := tp; { track this type entry } |
| 3005 | if tp <> nil then with tp^ do case form of |
| 3006 | scalar: begin |
| 3007 | if tp = intptr then wrtchr('i') |
| 3008 | else if tp = boolptr then wrtchr('b') |
| 3009 | else if tp = charptr then wrtchr('c') |
| 3010 | else if tp = realptr then wrtchr('n') |
| 3011 | else if scalkind = declared then |
| 3012 | begin wrtchr('x'); wrtchr('('); wrtenm(fconst, 0); |
| 3013 | wrtchr(')') end |
| 3014 | else wrtchr('?') |
| 3015 | end; |
| 3016 | subrange: begin |
| 3017 | wrtchr('x'); wrtchr('('); wrtint(min.ival); wrtchr(','); |
| 3018 | wrtint(max.ival); wrtchr(')'); |
| 3019 | wrttypsub(rangetype) |
| 3020 | end; |
| 3021 | pointer: begin |
| 3022 | wrtchr('p'); fi := 0; y := cti; |
| 3023 | if y > maxtrk then y := maxtrk; |
| 3024 | if eltype <> nil then |
| 3025 | for x := y downto 1 do if typtrk[x] = eltype then fi := x; |
| 3026 | { if there is a cycle, output type digest position, otherwise |
| 3027 | the actual type } |
| 3028 | if fi > 0 then wrtint(fi) else wrttypsub(eltype) |
| 3029 | end; |
| 3030 | power: begin wrtchr('s'); wrttypsub(elset) end; |
| 3031 | arrays: begin wrtchr('a'); wrttypsub(inxtype); wrttypsub(aeltype) end; |
| 3032 | arrayc: begin wrtchr('v'); wrttypsub(abstype) end; |
| 3033 | records: begin wrtchr('r'); wrtchr('('); wrtrfd(fstfld); |
| 3034 | if recvar <> nil then if recvar^.form = tagfld then |
| 3035 | begin wrtchr(','); wrtrfd(recvar^.tagfieldp); |
| 3036 | wrtchr('('); wrtvar(recvar^.fstvar); |
| 3037 | wrtchr(')') end; |
| 3038 | wrtchr(')') end; |
| 3039 | files: begin wrtchr('f'); wrttypsub(filtype) end; |
| 3040 | variant: wrtchr('?'); |
| 3041 | exceptf: wrtchr('e') |
| 3042 | end else wrtchr('?') |
| 3043 | end; |
| 3044 | |
| 3045 | begin { wrttypc } |
| 3046 | cti := 1; { set 1st position in tracking } |
| 3047 | err := false; { set no error } |
| 3048 | wrttypsub(tp); { issue type } |
| 3049 | fl := fl+cti { count characters } |
| 3050 | end; |
| 3051 | |
| 3052 | procedure wrttyp(var f: text; tp: stp); |
| 3053 | var fl: integer; |
| 3054 | begin |
| 3055 | fl := 0; wrttypc(f, tp, fl) |
| 3056 | end; |
| 3057 | |
| 3058 | function digits(i: integer): integer; |
| 3059 | var dc: integer; |
| 3060 | begin |
| 3061 | dc := 0; if i < 0 then begin i := -i; dc := dc+1 end; |
| 3062 | if i = 0 then dc := 1 |
| 3063 | else while i > 0 do begin i := i div 10; dc := dc+1 end; |
| 3064 | digits := dc |
| 3065 | end; |
| 3066 | |
| 3067 | procedure prtlabelu(labname: integer); |
| 3068 | begin |
| 3069 | write(prr, 'l '); writevp(prr, nammod); write(prr, '.', labname:1) |
| 3070 | end; |
| 3071 | |
| 3072 | procedure prtlabel(labname: integer); |
| 3073 | begin |
| 3074 | if prcode then prtlabelu(labname) |
| 3075 | end; |
| 3076 | |
| 3077 | function lenlabel(labnam: integer): integer; |
| 3078 | begin |
| 3079 | lenlabel := 2+lenpv(nammod)+1+digits(labnam) |
| 3080 | end; |
| 3081 | |
| 3082 | procedure prtlabelc(labname: integer; var fl: integer); |
| 3083 | begin |
| 3084 | prtlabel(labname); fl := fl+lenlabel(labname) |
| 3085 | end; |
| 3086 | |
| 3087 | procedure prtflabel(fcp: ctp); |
| 3088 | begin |
| 3089 | if prcode then begin |
| 3090 | write(prr, 'l '); |
| 3091 | if fcp^.klass = vars then writevp(prr, fcp^.vmod^.mn) |
| 3092 | else if fcp^.klass = fixedt then writevp(prr, fcp^.fmod^.mn) |
| 3093 | else writevp(prr, fcp^.pmod^.mn); |
| 3094 | write(prr, '.'); |
| 3095 | writevp(prr, fcp^.name) |
| 3096 | end |
| 3097 | end; |
| 3098 | |
| 3099 | procedure prtfxlabel(fcp: ctp); |
| 3100 | begin |
| 3101 | if prcode then begin |
| 3102 | write(prr, 'l '); |
| 3103 | writevp(prr, nammod); |
| 3104 | write(prr, '.'); |
| 3105 | if fcp^.floc >= 1 then write(prr, fcp^.floc:1) |
| 3106 | else writevp(prr, fcp^.name) |
| 3107 | end |
| 3108 | end; |
| 3109 | |
| 3110 | procedure prtfxlabelc(fcp: ctp; var fl: integer); |
| 3111 | begin |
| 3112 | prtfxlabel(fcp); |
| 3113 | if fcp^.floc >= 0 then fl := fl+2+lenpv(nammod)+1+digits(fcp^.floc) |
| 3114 | else fl := fl+2+lenpv(nammod)+1+lenpv(fcp^.name) |
| 3115 | end; |
| 3116 | |
| 3117 | function lenflabel(fcp: ctp): integer; |
| 3118 | var ll: integer; |
| 3119 | begin |
| 3120 | ll := 2+1+lenpv(fcp^.name); |
| 3121 | if fcp^.klass = vars then ll := ll+lenpv(fcp^.vmod^.mn) |
| 3122 | else if fcp^.klass = fixedt then ll := ll+lenpv(fcp^.fmod^.mn) |
| 3123 | else ll := ll+lenpv(fcp^.pmod^.mn); |
| 3124 | lenflabel := ll |
| 3125 | end; |
| 3126 | |
| 3127 | procedure prtflabelc(fcp: ctp; var fl: integer); |
| 3128 | begin |
| 3129 | prtflabel(fcp); fl := fl+lenflabel(fcp) |
| 3130 | end; |
| 3131 | |
| 3132 | procedure prtpartypc(fcp: ctp; fl: integer); |
| 3133 | var plst: ctp; |
| 3134 | begin |
| 3135 | plst := fcp^.pflist; |
| 3136 | while plst <> nil do begin |
| 3137 | if prcode then begin |
| 3138 | if plst^.klass in [proc, func] then begin |
| 3139 | write(prr, 'q('); prtpartypc(plst, fl); write(prr, ')'); fl := fl+3; |
| 3140 | if plst^.klass = func then begin |
| 3141 | write(prr, ':'); fl := fl+1; wrttypc(prr, plst^.idtype, fl) |
| 3142 | end |
| 3143 | end else wrttypc(prr, plst^.idtype, fl); |
| 3144 | if plst^.next <> nil then begin write(prr, '_'); fl := fl+1 end |
| 3145 | end; |
| 3146 | plst := plst^.next |
| 3147 | end |
| 3148 | end; |
| 3149 | |
| 3150 | procedure prtpartyp(fcp: ctp); |
| 3151 | var fl: integer; |
| 3152 | begin |
| 3153 | fl := 0; prtpartypc(fcp, fl) |
| 3154 | end; |
| 3155 | |
| 3156 | procedure searchlabel(var llp: lbp; level: disprange; isid: boolean); |
| 3157 | var fllp: lbp; { found label entry } |
| 3158 | lv: integer; |
| 3159 | begin lv := -1; |
| 3160 | if not isid then if val.intval then lv := val.ival; |
| 3161 | fllp := nil; { set no label found } |
| 3162 | llp := display[level].flabel; { index top of label list } |
| 3163 | while llp <> nil do begin { traverse } |
| 3164 | if isid and (llp^.labid <> nil) then begin { id type label } |
| 3165 | if strequvf(llp^.labid, id) then begin |
| 3166 | fllp := llp; { set entry found } |
| 3167 | llp := nil { stop } |
| 3168 | end else llp := llp^.nextlab { next in list } |
| 3169 | end else if not isid and (llp^.labval = lv) then begin { found } |
| 3170 | fllp := llp; { set entry found } |
| 3171 | llp := nil { stop } |
| 3172 | end else llp := llp^.nextlab { next in list } |
| 3173 | end; |
| 3174 | llp := fllp { return found entry or nil } |
| 3175 | end; |
| 3176 | |
| 3177 | procedure newlabel(var llp: lbp; isid: boolean); |
| 3178 | var lbname: integer; |
| 3179 | begin |
| 3180 | with display[top] do |
| 3181 | begin getlab(llp); |
| 3182 | with llp^ do |
| 3183 | begin labid := nil; labval := 0; |
| 3184 | if isid then strassvf(labid, id) { id type label } |
| 3185 | else labval := val.ival; { numeric type label } |
| 3186 | if labval > 9999 then error(261); |
| 3187 | genlabel(lbname); defined := false; nextlab := flabel; |
| 3188 | labname := lbname; vlevel := level; slevel := 0; |
| 3189 | ipcref := false; minlvl := pmmaxint; bact := false; |
| 3190 | refer := false |
| 3191 | end; |
| 3192 | flabel := llp |
| 3193 | end |
| 3194 | end; |
| 3195 | |
| 3196 | procedure prtlabels; |
| 3197 | var llp: lbp; { found label entry } |
| 3198 | begin |
| 3199 | writeln; |
| 3200 | writeln('Labels: '); |
| 3201 | writeln; |
| 3202 | llp := display[level].flabel; { index top of label list } |
| 3203 | while llp <> nil do with llp^ do begin { traverse } |
| 3204 | writeln('label: ', labval:1, ' defined: ', defined, |
| 3205 | ' internal: ', labname:1, ' vlevel: ', vlevel:1, |
| 3206 | ' slevel: ', slevel:1, ' ipcref: ', ipcref:1, |
| 3207 | ' minlvl: ', minlvl:1); |
| 3208 | writeln(' bact: ', bact); |
| 3209 | llp := llp^.nextlab { next in list } |
| 3210 | end |
| 3211 | end; |
| 3212 | |
| 3213 | procedure intmsgneol(intcod: integer); |
| 3214 | begin |
| 3215 | if prcode then begin |
| 3216 | write(prr, ' ! '); |
| 3217 | case intcod of |
| 3218 | 0: write(prr, 'Absolute value integer'); |
| 3219 | 1: write(prr, 'Absolute value real'); |
| 3220 | 2: write(prr, 'Add integers'); |
| 3221 | 3: write(prr, 'Add reals'); |
| 3222 | 4: write(prr, 'And booleans'); |
| 3223 | 5: write(prr, 'Set difference'); |
| 3224 | 6: write(prr, 'Divide integers'); |
| 3225 | 7: write(prr, 'Divide reals'); |
| 3226 | 8: write(prr, 'Load constant(t)'); |
| 3227 | 9: write(prr, 'Convert sos stack to float'); |
| 3228 | 10: write(prr, 'Convert tos to float'); |
| 3229 | 11: write(prr, 'Set inclusion'); |
| 3230 | 12: write(prr, 'Set intersection'); |
| 3231 | 13: write(prr, 'Inclusive or booleans'); |
| 3232 | 14: write(prr, 'Modulo integers'); |
| 3233 | 15: write(prr, 'Multiply integers'); |
| 3234 | 16: write(prr, 'Multiply reals'); |
| 3235 | 17: write(prr, 'Negate integer'); |
| 3236 | 18: write(prr, 'Negate real'); |
| 3237 | 19: write(prr, 'Not(t)'); |
| 3238 | 20: write(prr, 'Odd'); |
| 3239 | 21: write(prr, 'Subtract integer'); |
| 3240 | 22: write(prr, 'Subtract real'); |
| 3241 | 23: write(prr, 'Singleton set'); |
| 3242 | 24: write(prr, 'Square of integer'); |
| 3243 | 25: write(prr, 'Square of real'); |
| 3244 | 26: write(prr, 'Store to address(t)'); |
| 3245 | 27: write(prr, 'Truncate real to integer'); |
| 3246 | 28: write(prr, 'Set union'); |
| 3247 | 29: write(prr, 'Stop execution'); |
| 3248 | 30: write(prr, 'Call system procedure/function'); |
| 3249 | 31: write(prr, 'Decrement(t)'); |
| 3250 | 32: write(prr, 'Return indirect procedure/function'); |
| 3251 | 33: write(prr, 'False jump'); |
| 3252 | 34: write(prr, 'Increment(t)'); |
| 3253 | 35: write(prr, 'Load indirect(t)'); |
| 3254 | 36: write(prr, 'Scale array access'); |
| 3255 | 37: write(prr, 'Load global address'); |
| 3256 | 38: write(prr, 'Load constant string address'); |
| 3257 | 39: write(prr, 'Load global value(t)'); |
| 3258 | 40: write(prr, 'Move(copy)'); |
| 3259 | 41: write(prr, 'Mark(frame) stack'); |
| 3260 | 42: write(prr, 'Return from procedure/function(t)'); |
| 3261 | 43: write(prr, 'Store global value(t)'); |
| 3262 | 44: write(prr, 'Table(case) jump'); |
| 3263 | 45: write(prr, 'Bounds check(t)'); |
| 3264 | 46: write(prr, 'Call user procedure'); |
| 3265 | 47: write(prr, 'Equal(t)'); |
| 3266 | 48: write(prr, 'Greater than or equal(t)'); |
| 3267 | 49: write(prr, 'Greater than(t)'); |
| 3268 | 50: write(prr, 'Load local address'); |
| 3269 | 51: write(prr, 'Load constant(t)'); |
| 3270 | 52: write(prr, 'Less than or equal(t)'); |
| 3271 | 53: write(prr, 'Less than(t)'); |
| 3272 | 54: write(prr, 'Load local value(t)'); |
| 3273 | 55: write(prr, 'Not equal(t)'); |
| 3274 | 56: write(prr, 'Store local(t)'); |
| 3275 | 57: write(prr, 'Unconditional jump'); |
| 3276 | 58: write(prr, 'Ordinal(t)'); |
| 3277 | 59: write(prr, 'Character from integer'); |
| 3278 | 60: write(prr, 'Throw case error'); |
| 3279 | 61: write(prr, 'Round float to integer'); |
| 3280 | 62: write(prr, 'Pack array from unpacked'); |
| 3281 | 63: write(prr, 'Unpack array from packed'); |
| 3282 | 64: write(prr, 'Range set'); |
| 3283 | 66: write(prr, 'Interprocedure jump'); |
| 3284 | 67: write(prr, 'Call indirect procedure'); |
| 3285 | 68: write(prr, 'Load procedure address'); |
| 3286 | 71: write(prr, 'Dump tos'); |
| 3287 | 72: write(prr, 'Swap tos with sos'); |
| 3288 | 73: write(prr, 'True jump'); |
| 3289 | 74: write(prr, 'Load procedure/function address'); |
| 3290 | 75: write(prr, 'Check tagfield for active variants'); |
| 3291 | 76: write(prr, 'Duplicate tos(t)'); |
| 3292 | 77: write(prr, 'Terminate active variant check'); |
| 3293 | 78: write(prr, 'Start active variant check'); |
| 3294 | 79: write(prr, 'Invalidate address'); |
| 3295 | 80: write(prr, 'Bounds check for record pointer(t)'); |
| 3296 | 81: write(prr, 'Check tagfield assignment'); |
| 3297 | 82: write(prr, 'Invalidate tagged variant(t)'); |
| 3298 | 83: write(prr, 'Exclusive or'); |
| 3299 | 84: write(prr, 'Begin exception frame'); |
| 3300 | 85: write(prr, 'End exception frame'); |
| 3301 | 86: write(prr, 'Handle next exception frame'); |
| 3302 | 87: write(prr, 'Compare and jump'); |
| 3303 | 89: write(prr, 'Call initializer code strip'); |
| 3304 | 90: write(prr, 'Return code strip'); |
| 3305 | 91: write(prr, 'Call virtual procedure'); |
| 3306 | 92: write(prr, 'Set virtual procedure/function vector'); |
| 3307 | 93: write(prr, 'Variable reference block start'); |
| 3308 | 94: write(prr, 'Variable reference block end'); |
| 3309 | 95: write(prr, 'Check change to tagfield(t)'); |
| 3310 | 96: write(prr, 'Vector initialize stack'); |
| 3311 | 97: write(prr, 'Vector initialize pointer global'); |
| 3312 | 98: write(prr, 'Load complex pointer'); |
| 3313 | 99: write(prr, 'Compare simple templates'); |
| 3314 | 100: write(prr, 'Compare complex templates'); |
| 3315 | 101: write(prr, 'Assign simple pointer data'); |
| 3316 | 102: write(prr, 'Assign pointer complex'); |
| 3317 | 103: write(prr, 'Simple container index'); |
| 3318 | 104: write(prr, 'Complex container index'); |
| 3319 | 105: write(prr, 'Load complex fixed container'); |
| 3320 | 106: write(prr, 'Maximum dimension of array'); |
| 3321 | 107: write(prr, 'Vector dispose array'); |
| 3322 | 108: write(prr, 'Simplify complex pointer'); |
| 3323 | 109: write(prr, 'Copy complex container to stack'); |
| 3324 | 110: write(prr, 'Store complex pointer'); |
| 3325 | 111: write(prr, 'Load complex pointer'); |
| 3326 | 112: write(prr, 'Vector initialize dynamic'); |
| 3327 | 113: write(prr, 'Vector dispose array'); |
| 3328 | 114: write(prr, 'Load constant address'); |
| 3329 | 115: write(prr, 'Copy to buffer'); |
| 3330 | 116: write(prr, 'Copy procedure parameter'); |
| 3331 | 117: write(prr, 'Copy result'); |
| 3332 | 118: write(prr, 'Load stack address'); |
| 3333 | 119: write(prr, 'With block start'); |
| 3334 | 120: write(prr, 'With block end'); |
| 3335 | 121: write(prr, 'Set function result'); |
| 3336 | 122: write(prr, 'Call user function'); |
| 3337 | 123: write(prr, 'Call indirect function'); |
| 3338 | 124: write(prr, 'Make fat pointer from components'); |
| 3339 | 125: write(prr, 'Call virtual function'); |
| 3340 | 126: write(prr, 'Load stack complex pointer'); |
| 3341 | 127: write(prr, 'Copy length from complex pointer'); |
| 3342 | 128: write(prr, 'Store structured value from stack'); |
| 3343 | 129: write(prr, 'Store exception vector'); |
| 3344 | 130: write(prr, 'Make dynamic complex pointer'); |
| 3345 | end |
| 3346 | end |
| 3347 | end; |
| 3348 | |
| 3349 | procedure intmsg(intcod: integer); |
| 3350 | begin |
| 3351 | intmsgneol(intcod); |
| 3352 | if prcode then writeln(prr) |
| 3353 | end; |
| 3354 | |
| 3355 | procedure spfmsg(sypcod: integer); |
| 3356 | begin |
| 3357 | if prcode then case sypcod of |
| 3358 | 1: writeln(prr, 'Get file buffer text'); |
| 3359 | 2: writeln(prr, 'Put file buffer text'); |
| 3360 | 3: writeln(prr, 'Read integer from text file'); |
| 3361 | 4: writeln(prr, 'Read real from text file'); |
| 3362 | 5: writeln(prr, 'Read character from text file'); |
| 3363 | 6: writeln(prr, 'Write integer to text file decimal'); |
| 3364 | 8: writeln(prr, 'Write real to text file'); |
| 3365 | 9: writeln(prr, 'Write character to text file'); |
| 3366 | 10: writeln(prr, 'Write string to text file'); |
| 3367 | 12: writeln(prr, 'Allocate dynamic variable'); |
| 3368 | 14: writeln(prr, 'Find eoln of text file'); |
| 3369 | 15: writeln(prr, 'Find sine'); |
| 3370 | 16: writeln(prr, 'Find cosine'); |
| 3371 | 17: writeln(prr, 'Find exponential'); |
| 3372 | 18: writeln(prr, 'Find square root'); |
| 3373 | 19: writeln(prr, 'Find logarithm'); |
| 3374 | 20: writeln(prr, 'Find arctangent'); |
| 3375 | 21: writeln(prr, 'Read next line from text file'); |
| 3376 | 22: writeln(prr, 'Write next line to text file'); |
| 3377 | 24: writeln(prr, 'Page text file'); |
| 3378 | 25: writeln(prr, 'Reset file text'); |
| 3379 | 26: writeln(prr, 'Rewrite file text'); |
| 3380 | 27: writeln(prr, 'Write boolean to text file'); |
| 3381 | 28: writeln(prr, 'Write real to text in fixed point'); |
| 3382 | 29: writeln(prr, 'Dispose dynamic variable'); |
| 3383 | 30: writeln(prr, 'Write binary variable'); |
| 3384 | 31: writeln(prr, 'Write integer to binary file'); |
| 3385 | 32: writeln(prr, 'Write real to binary file'); |
| 3386 | 33: writeln(prr, 'Write character to binary file'); |
| 3387 | 34: writeln(prr, 'Write boolean to binary file'); |
| 3388 | 35: writeln(prr, 'Read binary file to variable'); |
| 3389 | 36: writeln(prr, 'Reset file binary'); |
| 3390 | 37: writeln(prr, 'Rewrite file binary'); |
| 3391 | 38: writeln(prr, 'Get file buffer binary'); |
| 3392 | 39: writeln(prr, 'Put file buffer binary'); |
| 3393 | 40: writeln(prr, 'Read integer from text file with range check'); |
| 3394 | 41: writeln(prr, 'Read character from text file with range check'); |
| 3395 | 42: writeln(prr, 'Allocate dynamic tagged record'); |
| 3396 | 43: writeln(prr, 'Dispose dynamic tagged record'); |
| 3397 | 44: writeln(prr, 'Find eof of text file'); |
| 3398 | 45: writeln(prr, 'Find eof of binary file'); |
| 3399 | 46: writeln(prr, 'File buffer validate text'); |
| 3400 | 47: writeln(prr, 'File buffer validate binary'); |
| 3401 | 48: writeln(prr, 'Write byte to binary file'); |
| 3402 | 49: writeln(prr, 'Assign filename text'); |
| 3403 | 50: writeln(prr, 'Close text file'); |
| 3404 | 51: writeln(prr, 'Postition file binary'); |
| 3405 | 52: writeln(prr, 'Update file'); |
| 3406 | 53: writeln(prr, 'Append text file'); |
| 3407 | 54: writeln(prr, 'Delete file'); |
| 3408 | 55: writeln(prr, 'Change file name'); |
| 3409 | 56: writeln(prr, 'Find length of binary file'); |
| 3410 | 57: writeln(prr, 'Find location of binary file'); |
| 3411 | 58: writeln(prr, 'Find file exists'); |
| 3412 | 59: writeln(prr, 'Assign file name binary'); |
| 3413 | 60: writeln(prr, 'Close binary file'); |
| 3414 | 61: writeln(prr, 'Append binary file'); |
| 3415 | 62: writeln(prr, 'Halt program'); |
| 3416 | 63: writeln(prr, 'Assert value'); |
| 3417 | 64: writeln(prr, 'Assert value with message'); |
| 3418 | 65: writeln(prr, 'Write integer to text file in hexadecimal'); |
| 3419 | 66: writeln(prr, 'Write integer to text file in octal'); |
| 3420 | 67: writeln(prr, 'Write integer to text file in binary'); |
| 3421 | 68: writeln(prr, 'Write passed string to text file'); |
| 3422 | 69: writeln(prr, 'Write integer to text file in decimal with leading zeros'); |
| 3423 | 70: writeln(prr, 'Write integer to text file in hexadecimal with leading zeros'); |
| 3424 | 71: writeln(prr, 'Write integer to text file in octal with leading zeros'); |
| 3425 | 72: writeln(prr, 'Write integer to text file in binary with leading zeros'); |
| 3426 | 73: writeln(prr, 'Read string'); |
| 3427 | 74: writeln(prr, 'Read integer from text file with range check and field'); |
| 3428 | 75: writeln(prr, 'Read integer from text file with field'); |
| 3429 | 76: writeln(prr, 'Real real from text file with field'); |
| 3430 | 77: writeln(prr, 'Read character from text file with range check and field'); |
| 3431 | 78: writeln(prr, 'Read character from text file with field'); |
| 3432 | 79: writeln(prr, 'Read string witrh field'); |
| 3433 | 80: writeln(prr, 'Read padded string'); |
| 3434 | 81: writeln(prr, 'Assign external filename to text file'); |
| 3435 | 82: writeln(prr, 'Assign external filename to binary file'); |
| 3436 | 83: writeln(prr, 'Read external integer'); |
| 3437 | 84: writeln(prr, 'Read external real'); |
| 3438 | 85: writeln(prr, 'Throw exception'); |
| 3439 | 86: writeln(prr, 'Read and match constant string'); |
| 3440 | 87: writeln(prr, 'Read byte integer from text file'); |
| 3441 | 88: writeln(prr, 'Read byte integer from text file with field'); |
| 3442 | 89: writeln(prr, 'Read byte integer from text file with range check'); |
| 3443 | 90: writeln(prr, 'Read byte integer from text file with range check and field'); |
| 3444 | 91: writeln(prr, 'Read integer from text file in radix 16'); |
| 3445 | 92: writeln(prr, 'Read integer from text file in radix 8'); |
| 3446 | 93: writeln(prr, 'Read integer from text file in radix 2'); |
| 3447 | 94: writeln(prr, 'Read integer from text file in radix 16 with field'); |
| 3448 | 95: writeln(prr, 'Read integer from text file in radix 8 with field'); |
| 3449 | 96: writeln(prr, 'Read integer from text file in radix 8 with field'); |
| 3450 | 97: writeln(prr, 'Read integer from text file in radix 16 with range check'); |
| 3451 | 98: writeln(prr, 'Read integer from text file in radix 8 with range check'); |
| 3452 | 99: writeln(prr, 'Read integer from text file in radix 2 with range check'); |
| 3453 | 100: writeln(prr, 'Read integer from text file in radix 16 with range check and field'); |
| 3454 | 101: writeln(prr, 'Read integer from text file in radix 8 with range check and field'); |
| 3455 | 102: writeln(prr, 'Read integer from text file in radix 2 with range check and field'); |
| 3456 | 103: writeln(prr, 'Read byte integer from text file in radix 16'); |
| 3457 | 104: writeln(prr, 'Read byte integer from text file in radix 8'); |
| 3458 | 105: writeln(prr, 'Read byte integer from text file in radix 2'); |
| 3459 | 106: writeln(prr, 'Read byte integer from text file in radix 16 with field'); |
| 3460 | 107: writeln(prr, 'Read byte integer from text file in radix 8 with field'); |
| 3461 | 108: writeln(prr, 'Read byte integer from text file in radix 8 with field'); |
| 3462 | 109: writeln(prr, 'Read byte integer from text file in radix 16 with range check'); |
| 3463 | 110: writeln(prr, 'Read byte integer from text file in radix 8 with range check'); |
| 3464 | 111: writeln(prr, 'Read byte integer from text file in radix 2 with range check'); |
| 3465 | 112: writeln(prr, 'Read byte integer from text file in radix 16 with range check and field'); |
| 3466 | 113: writeln(prr, 'Read byte integer from text file in radix 8 with range check and field'); |
| 3467 | 114: writeln(prr, 'Read byte integer from text file in radix 2 with range check and field'); |
| 3468 | 115: writeln(prr, 'Set program error return'); |
| 3469 | end |
| 3470 | end; |
| 3471 | |
| 3472 | { check integer or subrange of } |
| 3473 | function intt(fsp: stp): boolean; |
| 3474 | var t: stp; |
| 3475 | begin intt := false; |
| 3476 | if fsp <> nil then begin |
| 3477 | t := basetype(fsp); |
| 3478 | if t = intptr then intt := true |
| 3479 | end |
| 3480 | end; |
| 3481 | |
| 3482 | { check real } |
| 3483 | function realt(fsp: stp): boolean; |
| 3484 | begin realt := false; |
| 3485 | if fsp <> nil then |
| 3486 | if fsp = realptr then realt := true |
| 3487 | end; |
| 3488 | |
| 3489 | { the type test for character includes very broad definitions of char, |
| 3490 | including packed character arrays of 1 length, and even packed character |
| 3491 | array containers, because they could be length 1 } |
| 3492 | function chart(fsp: stp): boolean; |
| 3493 | var t: stp; fmin, fmax: integer; |
| 3494 | begin chart := false; |
| 3495 | if fsp <> nil then begin |
| 3496 | t := basetype(fsp); |
| 3497 | if t = charptr then chart := true |
| 3498 | else if (t^.form = arrays) and t^.packing then begin |
| 3499 | if (t^.inxtype = nil) and (t^.size = 1) then chart := true |
| 3500 | else if chart(t^.aeltype) and intt(t^.inxtype) then begin |
| 3501 | getbounds(t^.inxtype,fmin,fmax); |
| 3502 | if (fmin = 1) and (fmax = 1) then chart := true |
| 3503 | end |
| 3504 | end else if (t^.form = arrayc) and t^.packing then begin |
| 3505 | if chart(t^.abstype) then chart := true |
| 3506 | end |
| 3507 | end |
| 3508 | end; |
| 3509 | |
| 3510 | { check boolean } |
| 3511 | function bolt(fsp: stp): boolean; |
| 3512 | var t: stp; |
| 3513 | begin bolt := false; |
| 3514 | if fsp <> nil then begin |
| 3515 | t := basetype(fsp); |
| 3516 | if t = boolptr then bolt := true |
| 3517 | end |
| 3518 | end; |
| 3519 | |
| 3520 | function stringt(fsp: stp) : boolean; |
| 3521 | var fmin, fmax: integer; |
| 3522 | begin stringt := false; |
| 3523 | if fsp <> nil then |
| 3524 | if (fsp^.form = arrays) or (fsp^.form = arrayc) then |
| 3525 | if fsp^.packing then begin |
| 3526 | if fsp^.form = arrays then begin |
| 3527 | { if the index is nil, either the array is a string constant or the |
| 3528 | index type was in error. Either way, we call it a string } |
| 3529 | if fsp^.inxtype = nil then stringt := true |
| 3530 | else begin |
| 3531 | { common string must pass test of 1..N where N>1 } |
| 3532 | getbounds(fsp^.inxtype,fmin,fmax); |
| 3533 | stringt := (fsp^.aeltype = charptr) and (fmin = 1) and (fmax > 1) |
| 3534 | end |
| 3535 | end else stringt := fsp^.abstype = charptr |
| 3536 | end |
| 3537 | end (*stringt*); |
| 3538 | |
| 3539 | { check array type, fixed or container } |
| 3540 | function arrayt(fsp: stp): boolean; |
| 3541 | begin |
| 3542 | if fsp = nil then arrayt := false |
| 3543 | else arrayt := (fsp^.form = arrays) or (fsp^.form = arrayc); |
| 3544 | end; |
| 3545 | |
| 3546 | { check set type } |
| 3547 | function sett(fsp: stp): boolean; |
| 3548 | begin |
| 3549 | if fsp = nil then sett := false |
| 3550 | else sett := fsp^.form = power |
| 3551 | end; |
| 3552 | |
| 3553 | { check pointer type } |
| 3554 | function ptrt(fsp: stp): boolean; |
| 3555 | begin |
| 3556 | if fsp = nil then ptrt := false |
| 3557 | else ptrt := fsp^.form = pointer |
| 3558 | end; |
| 3559 | |
| 3560 | { check simple type } |
| 3561 | function simt(fsp: stp): boolean; |
| 3562 | begin |
| 3563 | if fsp = nil then simt := false |
| 3564 | else simt := (fsp^.form = scalar) or (fsp^.form = subrange) |
| 3565 | end; |
| 3566 | |
| 3567 | { check ordinal type } |
| 3568 | function ordt(fsp: stp): boolean; |
| 3569 | begin |
| 3570 | if fsp = nil then ordt := false |
| 3571 | else ordt := ((fsp^.form = scalar) or (fsp^.form = subrange)) and |
| 3572 | not realt(fsp) |
| 3573 | end; |
| 3574 | |
| 3575 | { check file type } |
| 3576 | function filet(fsp: stp): boolean; |
| 3577 | begin |
| 3578 | if fsp = nil then filet := false |
| 3579 | else filet := fsp^.form = files |
| 3580 | end; |
| 3581 | |
| 3582 | { check complex pointer } |
| 3583 | function complext(fsp: stp): boolean; |
| 3584 | begin complext := false; |
| 3585 | if fsp <> nil then complext := fsp^.form = arrayc |
| 3586 | end; |
| 3587 | |
| 3588 | procedure lftjst(fl: integer); |
| 3589 | begin |
| 3590 | if (fl > 0) and prcode then write(prr, ' ':fl) |
| 3591 | end; |
| 3592 | |
| 3593 | procedure par1(a: integer); |
| 3594 | begin |
| 3595 | if prcode then write(prr,a:1); |
| 3596 | lftjst(parfld-1-digits(a)) |
| 3597 | end; |
| 3598 | |
| 3599 | procedure par2(a, b: integer); |
| 3600 | begin |
| 3601 | write(prr,a:1, ' ', b:1); |
| 3602 | lftjst(parfld-1-(digits(a)+digits(b)+1)) |
| 3603 | end; |
| 3604 | |
| 3605 | procedure mesl(i: integer); |
| 3606 | begin topnew := topnew + i; |
| 3607 | if topnew < topmin then topmin := topnew; |
| 3608 | if toterr = 0 then |
| 3609 | if (topnew > 0) and prcode then error(500) { stack should never go positive } |
| 3610 | end; |
| 3611 | |
| 3612 | procedure mes(i: integer); |
| 3613 | begin mesl(cdx[i]) end; |
| 3614 | |
| 3615 | procedure mest(i: integer; fsp: stp); |
| 3616 | |
| 3617 | function mestn(fsp: stp): integer; |
| 3618 | var ss: integer; |
| 3619 | begin ss := 1; |
| 3620 | if fsp<>nil then |
| 3621 | with fsp^ do |
| 3622 | case form of |
| 3623 | scalar: if fsp=intptr then ss := 1 |
| 3624 | else |
| 3625 | if fsp=boolptr then ss := 3 |
| 3626 | else |
| 3627 | if fsp=charptr then ss := 4 |
| 3628 | else |
| 3629 | if scalkind = declared then ss := 1 |
| 3630 | else ss := 2; |
| 3631 | subrange: ss := mestn(rangetype); |
| 3632 | pointer, |
| 3633 | files, |
| 3634 | exceptf: ss := 5; |
| 3635 | power: ss := 6; |
| 3636 | records,arrays,arrayc: ss := 7; |
| 3637 | tagfld,variant: error(501) |
| 3638 | end; |
| 3639 | mestn := ss |
| 3640 | end; |
| 3641 | |
| 3642 | begin (*mest*) |
| 3643 | if (cdx[i] < 1) or (cdx[i] > 6) then error(502); |
| 3644 | mesl(cdxs[cdx[i]][mestn(fsp)]); |
| 3645 | end (*mest*); |
| 3646 | |
| 3647 | procedure gen0(fop: oprange); |
| 3648 | begin |
| 3649 | if prcode then |
| 3650 | begin write(prr,mn[fop]:11); lftjst(5+parfld-1); intmsg(fop) end; |
| 3651 | ic := ic + 1; mes(fop) |
| 3652 | end (*gen0*) ; |
| 3653 | |
| 3654 | procedure gen1s(fop: oprange; fp2: integer; symptr: ctp); |
| 3655 | var k, j: integer; p: strvsp; fl: integer; |
| 3656 | begin |
| 3657 | if prcode then |
| 3658 | begin write(prr,mn[fop]:11); |
| 3659 | if fop = 30 then |
| 3660 | begin write(prr,' ':5,sna[fp2]:4); fl := 4; |
| 3661 | mesl(pdx[fp2]); |
| 3662 | end |
| 3663 | else |
| 3664 | begin |
| 3665 | if fop = 38 then |
| 3666 | begin with cstptr[fp2]^ do begin p := sval; j := 1; |
| 3667 | write(prr,' ':5,slgth:1,' '''); fl := digits(slgth)+2; |
| 3668 | for k := 1 to lenpv(p) do begin |
| 3669 | if p^.str[j] = '''' then |
| 3670 | begin write(prr, ''''''); fl := fl+2 end |
| 3671 | else begin write(prr,p^.str[j]:1); fl := fl+1 end; |
| 3672 | j := j+1; if j > varsqt then begin |
| 3673 | p := p^.next; j := 1 |
| 3674 | end |
| 3675 | end |
| 3676 | end; |
| 3677 | write(prr,''''); fl := fl+1 |
| 3678 | end |
| 3679 | else if fop = 42 then |
| 3680 | begin write(prr,chr(fp2)); write(prr, ' ':4); fl := 0 end |
| 3681 | else if fop = 67 then |
| 3682 | begin write(prr,' ':5, fp2:1); fl := digits(fp2) end |
| 3683 | else if fop = 105 then begin |
| 3684 | write(prr,' ':5); fl := 0; prtlabelc(fp2, fl) |
| 3685 | end else if chkext(symptr) then begin |
| 3686 | write(prr,' ':5); fl := 0; prtflabelc(symptr, fl) |
| 3687 | end else if chkfix(symptr) then begin |
| 3688 | write(prr,' ':5); fl := 0; prtfxlabelc(symptr, fl) |
| 3689 | end else begin write(prr,' ':5, fp2:1); fl := digits(fp2) end; |
| 3690 | if fop = 42 then mes(0) |
| 3691 | else if fop = 71 then mesl(fp2) |
| 3692 | else mes(fop) |
| 3693 | end; |
| 3694 | lftjst(parfld-1-fl); |
| 3695 | if fop = 30 then |
| 3696 | begin intmsgneol(fop); write(prr, ': '); spfmsg(fp2) end |
| 3697 | else intmsg(fop) |
| 3698 | end; |
| 3699 | ic := ic + 1 |
| 3700 | end (*gen1s*) ; |
| 3701 | |
| 3702 | procedure gen1(fop: oprange; fp2: integer); |
| 3703 | begin |
| 3704 | gen1s(fop, fp2, nil) |
| 3705 | end; |
| 3706 | |
| 3707 | procedure gen2(fop: oprange; fp1,fp2: integer); |
| 3708 | var k : integer; dc: integer; |
| 3709 | begin |
| 3710 | if prcode then |
| 3711 | begin write(prr,mn[fop]:11); |
| 3712 | case fop of |
| 3713 | 42: begin |
| 3714 | write(prr,chr(fp1),' ':4); par1(fp2); |
| 3715 | mes(0) |
| 3716 | end; |
| 3717 | 45,50,54,56,74,62,63,81,82,96,97,102,104,109,112,115,116,117,124,128, |
| 3718 | 129: |
| 3719 | begin |
| 3720 | write(prr,' ':5); par2(fp1, fp2); |
| 3721 | if fop = 116 then mesl(-fp2) |
| 3722 | else if fop = 117 then mesl(fp2-fp1) |
| 3723 | else mes(fop) |
| 3724 | end; |
| 3725 | 47,48,49,52,53,55: |
| 3726 | begin write(prr,chr(fp1)); |
| 3727 | if chr(fp1) = 'm' then begin write(prr,' ':4); par1(fp2) end |
| 3728 | else lftjst(4+parfld-1); |
| 3729 | case chr(fp1) of |
| 3730 | 'i': mesl(cdxs[cdx[fop]][1]); |
| 3731 | 'r': mesl(cdxs[cdx[fop]][2]); |
| 3732 | 'b': mesl(cdxs[cdx[fop]][3]); |
| 3733 | 'c': mesl(cdxs[cdx[fop]][4]); |
| 3734 | 'a': mesl(cdxs[cdx[fop]][5]); |
| 3735 | 's': mesl(cdxs[cdx[fop]][6]); |
| 3736 | 'm': mesl(cdxs[cdx[fop]][7]); |
| 3737 | 'v': mesl(cdxs[cdx[fop]][8]); |
| 3738 | end |
| 3739 | end; |
| 3740 | 51: |
| 3741 | begin |
| 3742 | case fp1 of |
| 3743 | 1: begin write(prr,'i',' ':4); par1(fp2); |
| 3744 | mesl(cdxs[cdx[fop]][1]) |
| 3745 | end; |
| 3746 | 2: begin write(prr,'r',' ':4); |
| 3747 | with cstptr[fp2]^ do write(prr,rval:23); |
| 3748 | dc := 23; { gpc is constant folding this to an error } |
| 3749 | if dc < parfld-1 then lftjst(parfld-dc-1); |
| 3750 | mesl(cdxs[cdx[fop]][2]); |
| 3751 | end; |
| 3752 | 3: begin write(prr,'b',' ':4); par1(fp2); |
| 3753 | mesl(cdxs[cdx[fop]][3]) |
| 3754 | end; |
| 3755 | 4: begin write(prr,'n'); |
| 3756 | mesl(-ptrsize) |
| 3757 | end; |
| 3758 | 6: begin |
| 3759 | if chartp[chr(fp2)] = illegal then |
| 3760 | { output illegal characters as numbers } |
| 3761 | begin write(prr,'c',' ':4); par1(fp2) end |
| 3762 | else |
| 3763 | write(prr,'c',' ':4, '''',chr(fp2),''''); |
| 3764 | lftjst(parfld-1-3); |
| 3765 | mesl(cdxs[cdx[fop]][4]) |
| 3766 | end; |
| 3767 | 5: begin write(prr,'s',' ':4, '('); dc := 1; |
| 3768 | with cstptr[fp2]^ do |
| 3769 | for k := setlow to sethigh do |
| 3770 | if k in pval then begin |
| 3771 | write(prr,k:4); dc := dc+4 |
| 3772 | end; |
| 3773 | write(prr,')'); dc := dc+1; |
| 3774 | if dc < parfld-1 then lftjst(parfld-dc-1); |
| 3775 | mesl(cdxs[cdx[fop]][6]) |
| 3776 | end |
| 3777 | end |
| 3778 | end |
| 3779 | end; |
| 3780 | intmsg(fop) |
| 3781 | end; |
| 3782 | ic := ic + 1 |
| 3783 | end (*gen2*) ; |
| 3784 | |
| 3785 | procedure gentypindicator(fsp: stp); |
| 3786 | begin |
| 3787 | if (fsp <> nil) and prcode then |
| 3788 | with fsp^ do |
| 3789 | case form of |
| 3790 | scalar: if fsp=intptr then write(prr,'i') |
| 3791 | else |
| 3792 | if fsp=boolptr then write(prr,'b') |
| 3793 | else |
| 3794 | if fsp=charptr then write(prr,'c') |
| 3795 | else |
| 3796 | if scalkind = declared then begin |
| 3797 | if fsp^.size = 1 then write(prr, 'x') |
| 3798 | else write(prr,'i') |
| 3799 | end else write(prr,'r'); |
| 3800 | subrange: if fsp^.size = 1 then write(prr, 'x') |
| 3801 | else gentypindicator(rangetype); |
| 3802 | pointer, |
| 3803 | files, |
| 3804 | exceptf: write(prr,'a'); |
| 3805 | power: write(prr,'s'); |
| 3806 | records,arrays,arrayc: write(prr,'m'); |
| 3807 | tagfld,variant: error(503) |
| 3808 | end |
| 3809 | end (*typindicator*); |
| 3810 | |
| 3811 | procedure gen0t(fop: oprange; fsp: stp); |
| 3812 | begin |
| 3813 | if prcode then begin |
| 3814 | write(prr,mn[fop]:11); gentypindicator(fsp); |
| 3815 | lftjst(4+parfld-1); |
| 3816 | intmsg(fop) |
| 3817 | end; |
| 3818 | ic := ic + 1; mest(fop, fsp) |
| 3819 | end (*gen0t*); |
| 3820 | |
| 3821 | procedure gen1ts(fop: oprange; fp2: integer; fsp: stp; symptr: ctp); |
| 3822 | var fl: integer; |
| 3823 | begin |
| 3824 | if prcode then begin |
| 3825 | write(prr,mn[fop]:11); gentypindicator(fsp); write(prr, ' ':4); fl := 0; |
| 3826 | if chkext(symptr) then prtflabelc(symptr, fl) |
| 3827 | else if chkfix(symptr) then prtfxlabelc(symptr, fl) |
| 3828 | else begin write(prr,fp2:1); fl := digits(fp2) end; |
| 3829 | lftjst(parfld-1-fl); |
| 3830 | intmsg(fop) |
| 3831 | end; |
| 3832 | ic := ic + 1; mest(fop, fsp) |
| 3833 | end (*gen1ts*); |
| 3834 | |
| 3835 | procedure gen1t(fop: oprange; fp2: integer; fsp: stp); |
| 3836 | begin |
| 3837 | gen1ts(fop, fp2, fsp, nil) |
| 3838 | end; |
| 3839 | |
| 3840 | procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp); |
| 3841 | begin |
| 3842 | if prcode then begin |
| 3843 | write(prr,mn[fop]:11); gentypindicator(fsp); write(prr,' ':4); |
| 3844 | par2(fp1, fp2); intmsg(fop) |
| 3845 | end; |
| 3846 | ic := ic + 1; mest(fop, fsp) |
| 3847 | end (*gen2t*); |
| 3848 | |
| 3849 | procedure genujpxjpcal(fop: oprange; fp2: integer); |
| 3850 | var fl: integer; |
| 3851 | begin |
| 3852 | if prcode then begin |
| 3853 | write(prr,mn[fop]:11, ' ':5); fl := 0; |
| 3854 | prtlabelc(fp2, fl); |
| 3855 | lftjst(parfld-1-fl); |
| 3856 | intmsg(fop) |
| 3857 | end; |
| 3858 | ic := ic + 1; mes(fop) |
| 3859 | end (*genujpxjpcal*); |
| 3860 | |
| 3861 | procedure gencjp(fop: oprange; fp1,fp2,fp3: integer); |
| 3862 | var fl: integer; |
| 3863 | begin |
| 3864 | if prcode then begin |
| 3865 | write(prr,mn[fop]:11, ' ':5); fl := 0; |
| 3866 | write(prr, fp1:1,' ',fp2:1,' '); fl := fl+digits(fp1)+1+digits(fp2)+1; |
| 3867 | prtlabelc(fp3, fl); |
| 3868 | lftjst(parfld-1-fl); |
| 3869 | intmsg(fop) |
| 3870 | end; |
| 3871 | ic := ic + 1; mes(fop) |
| 3872 | end (*gencjp*); |
| 3873 | |
| 3874 | procedure genipj(fop: oprange; fp1, fp2: integer); |
| 3875 | var fl: integer; |
| 3876 | begin |
| 3877 | if prcode then begin |
| 3878 | write(prr,mn[fop]:11,' ':5); fl := 0; |
| 3879 | write(prr, fp1:1,' '); fl := fl+digits(fp1); prtlabelc(fp2, fl); |
| 3880 | lftjst(parfld-1-fl); intmsg(fop) |
| 3881 | end; |
| 3882 | ic := ic + 1; mes(fop) |
| 3883 | end (*genipj*); |
| 3884 | |
| 3885 | procedure gencupcuf(fop: oprange; fp1,fp2: integer; fcp: ctp); |
| 3886 | var fl: integer; sizalg: addrrange; |
| 3887 | begin |
| 3888 | if prcode then |
| 3889 | begin |
| 3890 | write(prr,mn[fop]:11, ' ':5); fl := 0; |
| 3891 | if chkext(fcp) then begin |
| 3892 | prtflabelc(fcp, fl); |
| 3893 | write(prr, '@'); { this keeps the user from aliasing it } |
| 3894 | if fcp^.klass = proc then write(prr, 'p') else write(prr, 'f'); |
| 3895 | fl := fl+2; |
| 3896 | if fcp^.pflist <> nil then begin |
| 3897 | write(prr, '_'); fl := fl+1; |
| 3898 | prtpartypc(fcp, fl) |
| 3899 | end |
| 3900 | end else prtlabelc(fp2, fl); |
| 3901 | if fcp <> nil then begin |
| 3902 | write(prr, ' ', fcp^.pfnum:1); fl := fl+1+digits(fcp^.pfnum); |
| 3903 | if fop = 122(*cuf*) then if fcp <> nil then if fcp^.idtype <> nil then |
| 3904 | begin write(prr, ' '); |
| 3905 | if realt(fcp^.idtype) then write(prr, '1') |
| 3906 | else if sett(fcp^.idtype) then write(prr, '2') |
| 3907 | else if fcp^.idtype^.form > power then write(prr, '3') |
| 3908 | else write(prr, '0'); |
| 3909 | sizalg := fcp^.idtype^.size; alignau(stackal, sizalg); |
| 3910 | write(prr, ' ', fcp^.idtype^.size:1, ' ', sizalg:1); |
| 3911 | fl := fl+2+1+digits(fcp^.idtype^.size)+1+digits(sizalg) |
| 3912 | end |
| 3913 | end else begin write(prr, ' 0'); fl := fl+1 end; |
| 3914 | lftjst(parfld-1-fl); |
| 3915 | intmsg(fop); |
| 3916 | mesl(fp1) |
| 3917 | end; |
| 3918 | ic := ic + 1 |
| 3919 | end; |
| 3920 | |
| 3921 | procedure gencipcif(fop: oprange; fcp: ctp); |
| 3922 | var fl: integer; sizalg: addrrange; |
| 3923 | begin |
| 3924 | if prcode then begin |
| 3925 | write(prr,mn[fop]:11,' ':4); fl := 0; |
| 3926 | if fcp <> nil then begin |
| 3927 | write(prr, ' ', fcp^.pfnum:1); fl := fl+digits(fcp^.pfnum); |
| 3928 | if fop = 123(*cif*) then |
| 3929 | begin write(prr, ' '); |
| 3930 | if realt(fcp^.idtype) then write(prr, '1') |
| 3931 | else if sett(fcp^.idtype) then write(prr, '2') |
| 3932 | else if fcp^.idtype^.form > power then write(prr, '3') |
| 3933 | else write(prr, '0'); |
| 3934 | sizalg := fcp^.idtype^.size; alignau(stackal, sizalg); |
| 3935 | write(prr, ' ', fcp^.idtype^.size:1, ' ', sizalg:1); |
| 3936 | fl := fl+2+1+digits(fcp^.idtype^.size)+1+digits(sizalg) |
| 3937 | end |
| 3938 | end; |
| 3939 | lftjst(parfld-1-fl); |
| 3940 | intmsg(fop) |
| 3941 | end; |
| 3942 | ic := ic + 1; mes(123(*cif*)) |
| 3943 | end (*gen0*) ; |
| 3944 | |
| 3945 | procedure gencuvcvf(fop: oprange; fp1,fp2: integer; fcp, fcp2: ctp); |
| 3946 | var fl: integer; sizalg: addrrange; |
| 3947 | begin |
| 3948 | if prcode then begin |
| 3949 | write(prr,mn[fop]:11,' ':5); fl := 0; |
| 3950 | if fcp <> nil then begin |
| 3951 | if chkext(fcp2) then prtflabelc(fcp2, fl) |
| 3952 | else begin write(prr,fp2:1); fl := digits(fp2) end; |
| 3953 | write(prr, ' ', fcp^.pfnum:1); fl := fl+digits(fcp^.pfnum); |
| 3954 | if fop = 125(*cvf*) then |
| 3955 | begin write(prr, ' '); |
| 3956 | if realt(fcp^.idtype) then write(prr, '1') |
| 3957 | else if sett(fcp^.idtype) then write(prr, '2') |
| 3958 | else if fcp^.idtype^.form > power then write(prr, '3') |
| 3959 | else write(prr, '0'); |
| 3960 | sizalg := fcp^.idtype^.size; alignau(stackal, sizalg); |
| 3961 | write(prr, ' ', fcp^.idtype^.size:1, ' ', sizalg:1); |
| 3962 | fl := fl+2+1+digits(fcp^.idtype^.size)+1+digits(sizalg) |
| 3963 | end; |
| 3964 | lftjst(parfld-1-fl); |
| 3965 | intmsg(fop); |
| 3966 | mesl(fp1) |
| 3967 | end |
| 3968 | end; |
| 3969 | ic := ic + 1 |
| 3970 | end; |
| 3971 | |
| 3972 | procedure genlpa(fp1,fp2: integer); |
| 3973 | var fl: integer; |
| 3974 | begin |
| 3975 | if prcode then |
| 3976 | begin |
| 3977 | write(prr,mn[68(*lpa*)]:11,' ':5, fp2:1, ' '); fl := digits(fp2)+1; |
| 3978 | prtlabelc(fp1, fl); |
| 3979 | lftjst(parfld-1-fl); |
| 3980 | intmsg(68(*lpa*)); |
| 3981 | end; |
| 3982 | ic := ic + 1; mes(68) |
| 3983 | end (*genlpa*); |
| 3984 | |
| 3985 | procedure gensuv(fp1, fp2: integer; sym: ctp); |
| 3986 | var fl: integer; |
| 3987 | begin |
| 3988 | if prcode then begin |
| 3989 | write(prr,mn[92(*suv*)]:11, ' ':5); fl := 0; |
| 3990 | prtlabelc(fp1, fl); |
| 3991 | if chkext(sym) then |
| 3992 | begin write(prr, ' '); fl := fl+1; prtflabelc(sym, fl) end |
| 3993 | else begin write(prr, ' ', fp2:1); fl := fl+digits(fp2)+1 end; |
| 3994 | lftjst(parfld-1-fl); |
| 3995 | intmsg(92(*suv*)) |
| 3996 | end; |
| 3997 | ic := ic + 1; mes(92) |
| 3998 | end; |
| 3999 | |
| 4000 | procedure genctaivtcvb(fop: oprange; fp1,fp2,fp3: integer; fsp: stp); |
| 4001 | var fl: integer; |
| 4002 | begin if fp3 < 0 then error(511); |
| 4003 | if prcode then |
| 4004 | begin write(prr,mn[fop]:11); fl := 0; |
| 4005 | if fop <> 81(*cta*) then |
| 4006 | begin gentypindicator(fsp); write(prr,' ':4) end else write(prr, ' ':5); |
| 4007 | write(prr,fp1:1,' ',fp2:1,' '); fl := fl+digits(fp1)+1+digits(fp2)+1; |
| 4008 | prtlabelc(fp3, fl); |
| 4009 | lftjst(parfld-1-fl); |
| 4010 | intmsg(fop); |
| 4011 | mes(fop); |
| 4012 | end; |
| 4013 | ic := ic + 1 |
| 4014 | end (*genctaivtcvb*); |
| 4015 | |
| 4016 | procedure gensfr(lb: integer); |
| 4017 | var fl: integer; |
| 4018 | begin |
| 4019 | if prcode then begin |
| 4020 | write(prr,mn[121(*sfr*)]:11, ' ':5); fl := 0; |
| 4021 | prtlabelc(lb, fl); |
| 4022 | lftjst(parfld-1-fl); |
| 4023 | intmsg(121(*sfr*)) |
| 4024 | end |
| 4025 | end; |
| 4026 | |
| 4027 | procedure genmst(lev: levrange; fp1,fp2: integer); |
| 4028 | var fl: integer; |
| 4029 | begin |
| 4030 | if prcode then begin |
| 4031 | write(prr,mn[41(*mst*)]:11, ' ':5); fl := 0; |
| 4032 | write(prr, lev:1, ' '); fl := fl+digits(lev)+1; |
| 4033 | prtlabelc(fp1, fl); write(prr, ' '); fl := fl+1; prtlabelc(fp2, fl); |
| 4034 | lftjst(parfld-1-fl); |
| 4035 | intmsg(41(*mst*)) |
| 4036 | end |
| 4037 | end; |
| 4038 | |
| 4039 | procedure gensca(c: char); |
| 4040 | begin |
| 4041 | if prcode then begin |
| 4042 | write(prr,mn[(*lca*)38]:11, ' ':5); |
| 4043 | write(prr,'1 '''); |
| 4044 | if c = '''' then write(prr,'''') else write(prr,c); |
| 4045 | write(prr,''''); |
| 4046 | lftjst(parfld-1-5); |
| 4047 | intmsg((*lca*)38); |
| 4048 | mes(38) |
| 4049 | end |
| 4050 | end; |
| 4051 | |
| 4052 | function comptypes(fsp1,fsp2: stp) : boolean; forward; |
| 4053 | |
| 4054 | { check structure is, or contains, a file } |
| 4055 | function filecomponent(fsp: stp): boolean; |
| 4056 | var f: boolean; |
| 4057 | { tour identifier tree } |
| 4058 | function filecomponentre(lcp: ctp): boolean; |
| 4059 | var f: boolean; |
| 4060 | begin |
| 4061 | f := false; { set not file by default } |
| 4062 | if lcp <> nil then with lcp^ do begin |
| 4063 | if filecomponent(idtype) then f := true; |
| 4064 | if filecomponentre(llink) then f := true; |
| 4065 | if filecomponentre(rlink) then f := true |
| 4066 | end; |
| 4067 | filecomponentre := f |
| 4068 | end; |
| 4069 | begin |
| 4070 | f := false; { set not a file by default } |
| 4071 | if fsp <> nil then with fsp^ do case form of |
| 4072 | scalar: ; |
| 4073 | subrange: ; |
| 4074 | pointer: ; |
| 4075 | power: ; |
| 4076 | arrays: if filecomponent(aeltype) then f := true; |
| 4077 | arrayc: if filecomponent(abstype) then f := true; |
| 4078 | records: if filecomponentre(fstfld) then f := true; |
| 4079 | files: f := true; |
| 4080 | tagfld: ; |
| 4081 | variant: ; |
| 4082 | exceptf: ; |
| 4083 | end; |
| 4084 | filecomponent := f |
| 4085 | end; |
| 4086 | |
| 4087 | function comptypes(fsp1,fsp2: stp) : boolean; |
| 4088 | (*decide whether structures pointed at by fsp1 and fsp2 are compatible*) |
| 4089 | var ty1, ty2: stp; |
| 4090 | begin |
| 4091 | comptypes := false; { set default is false } |
| 4092 | { remove any subranges } |
| 4093 | fsp1 := basetype(fsp1); |
| 4094 | fsp2 := basetype(fsp2); |
| 4095 | { Check equal. Aliases of the same type will also be equal. } |
| 4096 | if fsp1 = fsp2 then comptypes := true |
| 4097 | else |
| 4098 | if (fsp1 <> nil) and (fsp2 <> nil) then |
| 4099 | { if the structure forms are the same, or they are both array types } |
| 4100 | if (fsp1^.form = fsp2^.form) or (arrayt(fsp1) and arrayt(fsp2)) then |
| 4101 | case fsp1^.form of |
| 4102 | scalar: ; |
| 4103 | { Subranges are compatible if either type is a subrange of the |
| 4104 | other, or if the base type is the same. } |
| 4105 | subrange: ; { done above } |
| 4106 | { Sets are compatible if they have the same base types and packed/ |
| 4107 | unpacked status, or one of them is the empty set. The empty set |
| 4108 | is indicated by a nil base type, which is identical to a base |
| 4109 | type in error. Either way, we treat them as compatible. |
| 4110 | |
| 4111 | Set types created for set constants have a flag that disables |
| 4112 | packing matches. This is because set constants can be packed or |
| 4113 | unpacked by context. } |
| 4114 | power: comptypes := (comptypes(fsp1^.elset, fsp2^.elset) and |
| 4115 | ((fsp1^.packing = fsp2^.packing) or |
| 4116 | not fsp1^.matchpack or |
| 4117 | not fsp2^.matchpack)) or |
| 4118 | (fsp1^.elset = nil) or (fsp2^.elset = nil); |
| 4119 | { Arrays are compatible if they are string types and equal in size, |
| 4120 | or are one or both containers, equally packed, and with equal |
| 4121 | base types } |
| 4122 | arrays, |
| 4123 | arrayc: begin |
| 4124 | if ((fsp1^.form = arrayc) or (fsp2^.form = arrayc)) and |
| 4125 | (fsp1^.packing = fsp2^.packing) then begin |
| 4126 | { one or both are containers and have same packing status } |
| 4127 | if fsp1^.form = arrays then ty1 := fsp1^.aeltype |
| 4128 | else ty1 := fsp1^.abstype; |
| 4129 | if fsp2^.form = arrays then ty2 := fsp2^.aeltype |
| 4130 | else ty2 := fsp2^.abstype; |
| 4131 | { compatible if bases are compatible } |
| 4132 | comptypes := comptypes(ty1, ty2) |
| 4133 | end else |
| 4134 | { note containers have no size to compare, but will test as |
| 4135 | compatible arrays before this string test is applied } |
| 4136 | comptypes := stringt(fsp1) and stringt(fsp2) and |
| 4137 | (fsp1^.size = fsp2^.size ); |
| 4138 | end; |
| 4139 | { Pointers, must either be the same type or aliases of the same |
| 4140 | type, or one must be nil. The nil pointer is indicated by a nil |
| 4141 | base type, which is identical to a base type in error. Either |
| 4142 | way, we treat them as compatible. } |
| 4143 | pointer: comptypes := (fsp1^.eltype = nil) or (fsp2^.eltype = nil); |
| 4144 | { records and files must either be the same type or aliases of the |
| 4145 | same type } |
| 4146 | records: ; |
| 4147 | files: |
| 4148 | end (*case*) |
| 4149 | else (*fsp1^.form <> fsp2^.form*) |
| 4150 | { subranges of a base type match the base type } |
| 4151 | if fsp1^.form = subrange then |
| 4152 | comptypes := fsp1^.rangetype = fsp2 |
| 4153 | else |
| 4154 | if fsp2^.form = subrange then |
| 4155 | comptypes := fsp1 = fsp2^.rangetype |
| 4156 | else comptypes := false |
| 4157 | else comptypes := true { one of the types is in error } |
| 4158 | end (*comptypes*) ; |
| 4159 | |
| 4160 | function cmpparlst(pla, plb: ctp): boolean; forward; |
| 4161 | |
| 4162 | { compare two parameters } |
| 4163 | function cmppar(pa, pb: ctp): boolean; |
| 4164 | begin cmppar := false; |
| 4165 | if (pa <> nil) and (pb <> nil) then |
| 4166 | if (pa^.klass in [proc,func]) or (pb^.klass in [proc,func]) then begin |
| 4167 | if cmpparlst(pa^.pflist, pb^.pflist) |
| 4168 | then cmppar := comptypes(pa^.idtype,pb^.idtype) |
| 4169 | end else cmppar := comptypes(pa^.idtype,pb^.idtype) |
| 4170 | end; |
| 4171 | |
| 4172 | { compare parameter lists } |
| 4173 | function cmpparlst(pla, plb: ctp): boolean; |
| 4174 | begin cmpparlst := true; |
| 4175 | while (pla <> nil) and (plb <> nil) do begin |
| 4176 | if not cmppar(pla,plb) then cmpparlst := false; |
| 4177 | pla := pla^.next; plb := plb^.next |
| 4178 | end; |
| 4179 | if (pla <> nil) or (plb <> nil) then cmpparlst := false |
| 4180 | end; |
| 4181 | |
| 4182 | procedure skip(fsys: setofsys); |
| 4183 | (*skip input string until relevant symbol found*) |
| 4184 | begin |
| 4185 | if not eofinp then |
| 4186 | begin while not(sy in fsys) and (not eofinp) do insymbol; |
| 4187 | if not (sy in fsys) then insymbol |
| 4188 | end |
| 4189 | end (*skip*) ; |
| 4190 | |
| 4191 | { output fixed array template } |
| 4192 | procedure arrtmp(sp: stp); |
| 4193 | var tp: stp; lc: integer; l, h: integer; |
| 4194 | begin |
| 4195 | if sp <> nil then begin |
| 4196 | { check fixed array type } |
| 4197 | if sp^.form = arrays then begin |
| 4198 | { count levels } |
| 4199 | lc := 0; |
| 4200 | tp := sp; while tp <> nil do |
| 4201 | if tp^.form = arrays then begin lc := lc+1; tp := tp^.aeltype end |
| 4202 | else tp := nil; |
| 4203 | write(prr, 't',' ':7); |
| 4204 | genlabel(sp^.tmpl); prtlabelu(sp^.tmpl); |
| 4205 | write(prr, ' ', lc:1); |
| 4206 | while sp <> nil do |
| 4207 | if sp^.form = arrays then begin getbounds(sp^.inxtype, l, h); |
| 4208 | write(prr, ' ', h-l+1:1); lc := lc+1; sp := sp^.aeltype |
| 4209 | end else sp := nil; |
| 4210 | writeln(prr) |
| 4211 | end |
| 4212 | end |
| 4213 | end; |
| 4214 | |
| 4215 | procedure constexpr(fsys: setofsys; var fsp: stp; var fvalu: valu); forward; |
| 4216 | |
| 4217 | procedure constfactor(fsys: setofsys; var fsp: stp; var fvalu: valu); |
| 4218 | var lsp: stp; lcp: ctp; lvp: csp; test: boolean; lv: valu; i: integer; |
| 4219 | begin lsp := nil; fvalu.intval := true; fvalu.ival := 0; |
| 4220 | if not(sy in constbegsys) then |
| 4221 | begin error(50); skip(fsys+constbegsys) end; |
| 4222 | if sy in constbegsys then |
| 4223 | begin |
| 4224 | if sy = lparent then begin chkstd; |
| 4225 | insymbol; constexpr(fsys+[rparent], fsp, fvalu); |
| 4226 | if sy = rparent then insymbol else error(4); |
| 4227 | lsp := fsp |
| 4228 | end else if sy = notsy then begin chkstd; |
| 4229 | insymbol; constfactor(fsys+[rparent], fsp, fvalu); |
| 4230 | if (fsp <> intptr) and (fsp <> boolptr) then error(134) |
| 4231 | else if fvalu.ival < 0 then error(213) |
| 4232 | else fvalu.ival := bnot(fvalu.ival); |
| 4233 | { not boolean does not quite work here } |
| 4234 | if fsp = boolptr then fvalu.ival := band(fvalu.ival, 1); |
| 4235 | lsp := fsp |
| 4236 | end else if sy = stringconst then |
| 4237 | begin |
| 4238 | { note: this is a bit redundant since insymbol does this |
| 4239 | conversion } |
| 4240 | if lgth = 1 then lsp := charptr |
| 4241 | else |
| 4242 | begin |
| 4243 | new(lsp,arrays); pshstc(lsp); |
| 4244 | with lsp^ do |
| 4245 | begin form := arrays; aeltype := charptr; inxtype := nil; |
| 4246 | tmpl := -1; size := lgth*charsize; packing := true |
| 4247 | end; |
| 4248 | arrtmp(lsp) { output fixed template } |
| 4249 | end; |
| 4250 | fvalu := val; insymbol |
| 4251 | end |
| 4252 | else if sy = lbrack then begin |
| 4253 | { set } |
| 4254 | insymbol; |
| 4255 | new(lvp,pset); pshcst(lvp); lvp^.cclass := pset; lvp^.pval := []; |
| 4256 | if sy <> rbrack then repeat |
| 4257 | constexpr(fsys+[rbrack,comma,range], fsp, fvalu); |
| 4258 | if not fvalu.intval then error(134); |
| 4259 | if sy = range then begin |
| 4260 | insymbol; lv := fvalu; |
| 4261 | constexpr(fsys+[rbrack,comma], fsp, fvalu); |
| 4262 | if not fvalu.intval then error(134); |
| 4263 | if (lv.ival < setlow) or (lv.ival > sethigh) or |
| 4264 | (fvalu.ival < setlow) or (fvalu.ival > sethigh) then error(291) |
| 4265 | else for i := lv.ival to fvalu.ival do lvp^.pval := lvp^.pval+[i] |
| 4266 | end else begin |
| 4267 | if (fvalu.ival < setlow) or (fvalu.ival > sethigh) then error(291) |
| 4268 | else lvp^.pval := lvp^.pval+[fvalu.ival] |
| 4269 | end; |
| 4270 | test := sy <> comma; |
| 4271 | if not test then insymbol |
| 4272 | until test; |
| 4273 | if sy = rbrack then insymbol else error(12); |
| 4274 | fvalu.intval := false; fvalu.valp := lvp; |
| 4275 | new(lsp,power); pshstc(lsp); |
| 4276 | with lsp^ do |
| 4277 | begin form:=power; elset:=nil; size:=setsize; packing := false; |
| 4278 | matchpack := false end; |
| 4279 | end else |
| 4280 | begin |
| 4281 | if sy = ident then |
| 4282 | begin searchid([konst],lcp); |
| 4283 | with lcp^ do |
| 4284 | begin lsp := idtype; fvalu := values end; |
| 4285 | insymbol; |
| 4286 | end |
| 4287 | else |
| 4288 | if sy = intconst then |
| 4289 | begin lsp := intptr; fvalu := val; insymbol end |
| 4290 | else |
| 4291 | if sy = realconst then |
| 4292 | begin lsp := realptr; fvalu := val; insymbol end |
| 4293 | else |
| 4294 | begin error(106); skip(fsys) end |
| 4295 | end; |
| 4296 | if not (sy in fsys) then |
| 4297 | begin error(6); skip(fsys) end |
| 4298 | end; |
| 4299 | fsp := lsp |
| 4300 | end (*constfactor*) ; |
| 4301 | |
| 4302 | procedure constterm(fsys: setofsys; var fsp: stp; var fvalu: valu); |
| 4303 | var lvp: csp; lv: valu; lop: operatort; lsp: stp; |
| 4304 | begin |
| 4305 | constfactor(fsys+[mulop], fsp, fvalu); |
| 4306 | while (sy = mulop) and (op in [mul,rdiv,idiv,imod,andop]) do begin |
| 4307 | chkstd; lv := fvalu; lsp := fsp; lop := op; insymbol; |
| 4308 | constfactor(fsys+[mulop], fsp, fvalu); |
| 4309 | lvp := nil; |
| 4310 | if ((lop in [mul,minus]) and ((lsp = realptr) or (fsp = realptr))) or |
| 4311 | (lop = rdiv) then |
| 4312 | begin new(lvp,reel); pshcst(lvp); lvp^.cclass := reel end; |
| 4313 | case lop of { operator } |
| 4314 | { * } mul: if (lsp = intptr) and (fsp = intptr) then begin |
| 4315 | if (lv.ival <> 0) and (fvalu.ival <> 0) then |
| 4316 | if abs(lv.ival) > pmmaxint div abs(fvalu.ival) then |
| 4317 | begin error(306); fvalu.ival := 0 end |
| 4318 | else fvalu.ival := lv.ival*fvalu.ival |
| 4319 | end else if (lsp = realptr) and (fsp = realptr) then |
| 4320 | lvp^.rval := lv.valp^.rval*fvalu.valp^.rval |
| 4321 | else if (lsp = realptr) and (fsp = intptr) then |
| 4322 | lvp^.rval := lv.valp^.rval*fvalu.ival |
| 4323 | else if (lsp = intptr) and (fsp = realptr) then |
| 4324 | lvp^.rval := lv.ival*fvalu.valp^.rval |
| 4325 | else error(134); |
| 4326 | { / } rdiv: if (lsp = intptr) and (fsp = intptr) then |
| 4327 | lvp^.rval := lv.ival/fvalu.ival |
| 4328 | else if (lsp = realptr) and (fsp = realptr) then |
| 4329 | lvp^.rval := lv.valp^.rval/fvalu.valp^.rval |
| 4330 | else if (lsp = realptr) and (fsp = intptr) then |
| 4331 | lvp^.rval := lv.valp^.rval/fvalu.ival |
| 4332 | else if (lsp = intptr) and (fsp = realptr) then |
| 4333 | lvp^.rval := lv.ival/fvalu.valp^.rval |
| 4334 | else error(134); |
| 4335 | { div } idiv: if (lsp = intptr) and (fsp = intptr) then |
| 4336 | fvalu.ival := lv.ival div fvalu.ival |
| 4337 | else error(134); |
| 4338 | { mod } imod: if (lsp = intptr) and (fsp = intptr) then |
| 4339 | fvalu.ival := lv.ival mod fvalu.ival |
| 4340 | else error(134); |
| 4341 | { and } andop: if ((lsp = intptr) and (fsp = intptr)) or |
| 4342 | ((lsp = boolptr) and (fsp = boolptr)) then |
| 4343 | if (lv.ival < 0) or (fvalu.ival < 0) then error(213) |
| 4344 | else fvalu.ival := band(lv.ival, fvalu.ival) |
| 4345 | else error(134); |
| 4346 | end; |
| 4347 | if lvp <> nil then |
| 4348 | begin fvalu.intval := false; fvalu.valp := lvp end; { place result } |
| 4349 | { mixed types or / = real } |
| 4350 | if (lsp = realptr) or (lop = rdiv) then fsp := realptr |
| 4351 | end |
| 4352 | end (*constterm*) ; |
| 4353 | |
| 4354 | procedure constexpr(fsys: setofsys; var fsp: stp; var fvalu: valu); |
| 4355 | var sign: (none,pos,neg); lvp,svp: csp; lv: valu; lop: operatort; lsp: stp; |
| 4356 | begin sign := none; svp := nil; |
| 4357 | if (sy = addop) and (op in [plus,minus]) then |
| 4358 | begin if op = plus then sign := pos else sign := neg; |
| 4359 | insymbol |
| 4360 | end; |
| 4361 | constterm(fsys+[addop], fsp, fvalu); |
| 4362 | if sign > none then begin { apply sign to number } |
| 4363 | if (fsp <> intptr) and (fsp <> realptr) then error(106); |
| 4364 | if sign = neg then { must flip sign } |
| 4365 | if fsp = intptr then fvalu.ival := -fvalu.ival |
| 4366 | else if fsp = realptr then begin new(lvp,reel); pshcst(lvp); |
| 4367 | lvp^.cclass := reel; lvp^.rval := -fvalu.valp^.rval; |
| 4368 | fvalu.valp := lvp; svp := lvp; |
| 4369 | end else begin fvalu.intval := true; fvalu.ival := 0 end |
| 4370 | end; |
| 4371 | while (sy = addop) and (op in [plus,minus,orop,xorop]) do begin |
| 4372 | chkstd; lv := fvalu; lsp := fsp; lop := op; insymbol; |
| 4373 | constterm(fsys+[addop], fsp, fvalu); |
| 4374 | lvp := nil; |
| 4375 | if (lop in [plus,minus]) and ((lsp = realptr) or (fsp = realptr)) then |
| 4376 | begin new(lvp,reel); pshcst(lvp); lvp^.cclass := reel end; |
| 4377 | case lop of { operator } |
| 4378 | { + } plus: if (lsp = intptr) and (fsp = intptr) then begin |
| 4379 | if (lv.ival<0) = (fvalu.ival<0) then |
| 4380 | if pmmaxint-abs(lv.ival) < abs(fvalu.ival) then |
| 4381 | begin error(306); fvalu.ival := 0 end |
| 4382 | else fvalu.ival := lv.ival+fvalu.ival |
| 4383 | end else if (lsp = realptr) and (fsp = realptr) then |
| 4384 | lvp^.rval := lv.valp^.rval+fvalu.valp^.rval |
| 4385 | else if (lsp = realptr) and (fsp = intptr) then |
| 4386 | lvp^.rval := lv.valp^.rval+fvalu.ival |
| 4387 | else if (lsp = intptr) and (fsp = realptr) then |
| 4388 | lvp^.rval := lv.ival+fvalu.valp^.rval |
| 4389 | else error(134); |
| 4390 | { - } minus: if (lsp = intptr) and (fsp = intptr) then begin |
| 4391 | if (lv.ival<0) <> (fvalu.ival>0) then |
| 4392 | if pmmaxint-abs(lv.ival) < abs(fvalu.ival) then |
| 4393 | begin error(306); fvalu.ival := 0 end |
| 4394 | else fvalu.ival := lv.ival-fvalu.ival |
| 4395 | end else if (lsp = realptr) and (fsp = realptr) then |
| 4396 | lvp^.rval := lv.valp^.rval-fvalu.valp^.rval |
| 4397 | else if (lsp = realptr) and (fsp = intptr) then |
| 4398 | lvp^.rval := lv.valp^.rval-fvalu.ival |
| 4399 | else if (lsp = intptr) and (fsp = realptr) then |
| 4400 | lvp^.rval := lv.ival-fvalu.valp^.rval |
| 4401 | else error(134); |
| 4402 | { or } orop: if ((lsp = intptr) and (fsp = intptr)) or |
| 4403 | ((lsp = boolptr) and (fsp = boolptr)) then |
| 4404 | if (lv.ival < 0) or (fvalu.ival < 0) then error(213) |
| 4405 | else fvalu.ival := bor(lv.ival, fvalu.ival) |
| 4406 | else error(134); |
| 4407 | { xor } xorop: if ((lsp = intptr) and (fsp = intptr)) or |
| 4408 | ((lsp = boolptr) and (fsp = boolptr)) then |
| 4409 | if (lv.ival < 0) or (fvalu.ival < 0) then error(213) |
| 4410 | else fvalu.ival := bxor(lv.ival, fvalu.ival) |
| 4411 | else error(134) |
| 4412 | end; |
| 4413 | { if left negated, recycle it just once } |
| 4414 | if svp <> nil then begin putcst(svp); svp := nil end; |
| 4415 | if lvp <> nil then fvalu.valp := lvp; { place result } |
| 4416 | if lsp = realptr then fsp := realptr { mixed types = real } |
| 4417 | end |
| 4418 | end (*constexpr*) ; |
| 4419 | |
| 4420 | procedure checkbnds(fsp: stp); |
| 4421 | var lmin,lmax: integer; |
| 4422 | fsp2: stp; |
| 4423 | begin |
| 4424 | if fsp <> nil then begin |
| 4425 | { if set use the base type for the check } |
| 4426 | fsp2 := fsp; |
| 4427 | if fsp^.form = power then fsp := fsp^.elset; |
| 4428 | if fsp <> nil then |
| 4429 | if fsp <> intptr then |
| 4430 | if fsp <> realptr then |
| 4431 | if fsp^.form <= subrange then |
| 4432 | begin |
| 4433 | getbounds(fsp,lmin,lmax); |
| 4434 | gen2t(45(*chk*),lmin,lmax,fsp2) |
| 4435 | end |
| 4436 | end |
| 4437 | end (*checkbnds*); |
| 4438 | |
| 4439 | { find number of containers } |
| 4440 | function containers(lsp: stp): integer; |
| 4441 | var cc: integer; |
| 4442 | begin cc := 0; |
| 4443 | while lsp <> nil do |
| 4444 | if lsp^.form = arrayc then begin lsp := lsp^.abstype; cc := cc+1 end |
| 4445 | else lsp := nil; |
| 4446 | containers := cc |
| 4447 | end; |
| 4448 | |
| 4449 | { find base size of container or array series } |
| 4450 | function containerbase(lsp: stp): integer; |
| 4451 | var bp: stp; |
| 4452 | begin bp := nil; |
| 4453 | while lsp <> nil do |
| 4454 | if lsp^.form = arrayc then lsp := lsp^.abstype |
| 4455 | else if lsp^.form = arrays then lsp := lsp^.aeltype |
| 4456 | else begin bp := lsp; lsp := nil end; |
| 4457 | if bp = nil then containerbase := 0 |
| 4458 | else containerbase := bp^.size |
| 4459 | end; |
| 4460 | |
| 4461 | procedure load; |
| 4462 | begin |
| 4463 | with gattr do |
| 4464 | if typtr <> nil then |
| 4465 | begin |
| 4466 | case kind of |
| 4467 | cst: if (typtr^.form <= subrange) and (typtr <> realptr) then |
| 4468 | if typtr = boolptr then gen2(51(*ldc*),3,cval.ival) |
| 4469 | else |
| 4470 | if typtr=charptr then |
| 4471 | gen2(51(*ldc*),6,cval.ival) |
| 4472 | else gen2(51(*ldc*),1,cval.ival) |
| 4473 | else |
| 4474 | if typtr = nilptr then gen2(51(*ldc*),4,0) |
| 4475 | else |
| 4476 | if cstptrix >= cstoccmax then error(254) |
| 4477 | else |
| 4478 | begin cstptrix := cstptrix + 1; |
| 4479 | cstptr[cstptrix] := cval.valp; |
| 4480 | if typtr = realptr then |
| 4481 | gen2(51(*ldc*),2,cstptrix) |
| 4482 | else |
| 4483 | gen2(51(*ldc*),5,cstptrix) |
| 4484 | end; |
| 4485 | varbl: case access of |
| 4486 | drct: if vlevel<=1 then begin |
| 4487 | if (chkext(symptr) or chkfix(symptr)) and |
| 4488 | (dplmt <> 0) then begin |
| 4489 | { labeled base with offset, need to change |
| 4490 | to address load with offset } |
| 4491 | if chkfix(symptr) then |
| 4492 | gen1s(114(*lto*),dplmt,symptr) |
| 4493 | else gen1s(37(*lao*),dplmt,symptr); |
| 4494 | gen1t(35(*ind*),dplmt,typtr); |
| 4495 | end else begin |
| 4496 | if chkfix(symptr) then |
| 4497 | gen1ts(8(*ltc*),dplmt,typtr,symptr) |
| 4498 | else gen1ts(39(*ldo*),dplmt,typtr,symptr) |
| 4499 | end |
| 4500 | end else |
| 4501 | gen2t(54(*lod*),level-(level-vlevel),dplmt, |
| 4502 | typtr); |
| 4503 | indrct: gen1t(35(*ind*),idplmt,typtr); |
| 4504 | inxd: error(400) |
| 4505 | end; |
| 4506 | expr: ; { already loaded } |
| 4507 | end; |
| 4508 | kind := expr; |
| 4509 | { operand is loaded, and subranges are now normalized to their |
| 4510 | base type } |
| 4511 | typtr := basetype(typtr); |
| 4512 | symptr := nil { break variable association } |
| 4513 | end |
| 4514 | end (*load*) ; |
| 4515 | |
| 4516 | procedure gettmp(var a: stkoff; len: addrrange; auto: boolean); |
| 4517 | var p, fp: tmpptr; |
| 4518 | begin |
| 4519 | fp := nil; p := tmplst; alignau(stackal, len); |
| 4520 | while p <> nil do begin if not p^.occu and (p^.len = len) then fp := p; p := p^.next end; |
| 4521 | if fp = nil then begin |
| 4522 | if tmpfre <> nil then begin fp := tmpfre; tmpfre := tmpfre^.next end |
| 4523 | else new(fp); |
| 4524 | fp^.next := tmplst; tmplst := fp; |
| 4525 | lc := lc-len; fp^.off := lc; |
| 4526 | fp^.len := len |
| 4527 | end; |
| 4528 | fp^.occu := true; |
| 4529 | fp^.auto := auto; |
| 4530 | a := fp^.off; |
| 4531 | { uncomment for diagnostic } |
| 4532 | { |
| 4533 | writeln; writeln('gettmp: address: ', a:1, ' occu: ', fp^.occu, ' auto: ', fp^.auto) |
| 4534 | } |
| 4535 | end; |
| 4536 | |
| 4537 | procedure puttmp(a: stkoff); |
| 4538 | var p, fp: tmpptr; |
| 4539 | begin |
| 4540 | { uncomment for diagnostic } |
| 4541 | { |
| 4542 | writeln; writeln('puttmp: address: ', a:1); |
| 4543 | } |
| 4544 | fp := nil; p := tmplst; |
| 4545 | while p <> nil do begin if p^.off = a then fp := p; p := p^.next end; |
| 4546 | if fp = nil then error(518); |
| 4547 | fp^.occu := false |
| 4548 | end; |
| 4549 | |
| 4550 | procedure puttmps; |
| 4551 | var p: tmpptr; |
| 4552 | begin |
| 4553 | if tmplst <> nil then begin |
| 4554 | p := tmplst; |
| 4555 | while p^.next <> nil do p := p^.next; |
| 4556 | p^.next := tmpfre |
| 4557 | end else tmpfre := tmplst; |
| 4558 | tmplst := nil |
| 4559 | end; |
| 4560 | |
| 4561 | procedure clrtmp; |
| 4562 | var p: tmpptr; |
| 4563 | begin |
| 4564 | p := tmplst; |
| 4565 | while p <> nil do |
| 4566 | begin if p^.auto then p^.occu := false; |
| 4567 | p := p^.next |
| 4568 | end |
| 4569 | end; |
| 4570 | |
| 4571 | procedure loadaddress; |
| 4572 | var tmpoff: stkoff; lsize: addrrange; |
| 4573 | begin |
| 4574 | tmpoff := 0; { set no temp } |
| 4575 | with gattr do |
| 4576 | if typtr <> nil then |
| 4577 | begin |
| 4578 | case kind of |
| 4579 | cst: if stringt(typtr) then |
| 4580 | if cstptrix >= cstoccmax then error(254) |
| 4581 | else |
| 4582 | begin cstptrix := cstptrix + 1; |
| 4583 | cstptr[cstptrix] := cval.valp; |
| 4584 | gen1(38(*lca*),cstptrix) |
| 4585 | end |
| 4586 | else error(403); |
| 4587 | varbl: case access of |
| 4588 | drct: if vlevel <= 1 then begin |
| 4589 | if chkfix(symptr) then |
| 4590 | gen1s(114(*lto*),dplmt,symptr) |
| 4591 | else gen1s(37(*lao*),dplmt,symptr); |
| 4592 | { if there is an offset left in the address, |
| 4593 | apply it now } |
| 4594 | if ({chkext(symptr) or} chkfix(symptr)) and |
| 4595 | (dplmt <> 0) then |
| 4596 | gen1t(34(*inc*),idplmt,nilptr); |
| 4597 | end else gen2(50(*lda*),level-(level-vlevel),dplmt); |
| 4598 | indrct: if idplmt <> 0 then |
| 4599 | gen1t(34(*inc*),idplmt,nilptr); |
| 4600 | inxd: error(404) |
| 4601 | end; |
| 4602 | expr: begin |
| 4603 | gettmp(tmpoff, typtr^.size, true); lsize := typtr^.size; |
| 4604 | gen2(50(*lda*),level,tmpoff); |
| 4605 | alignau(stackal,lsize); |
| 4606 | gen2(128(*sfs*),typtr^.size,lsize); |
| 4607 | mesl(lsize+ptrsize); |
| 4608 | gen2(50(*lda*),level,tmpoff) |
| 4609 | end; |
| 4610 | end; |
| 4611 | if typtr^.form = arrayc then if pickup then begin |
| 4612 | { it's a container, load a complex pointer based on that } |
| 4613 | if dblptr then gen0(111(*ldp*)) else begin |
| 4614 | gen0(98(*lcp*)); |
| 4615 | { if level is at bottom, simplify the template } |
| 4616 | if containers(typtr) = 1 then gen0(108(*spc*)) |
| 4617 | end |
| 4618 | end; |
| 4619 | kind := varbl; access := indrct; idplmt := tmpoff; packing := false; |
| 4620 | symptr := nil { break variable association } |
| 4621 | end |
| 4622 | end (*loadaddress*) ; |
| 4623 | |
| 4624 | procedure store(var fattr: attr); |
| 4625 | var lsize: addrrange; |
| 4626 | begin |
| 4627 | with fattr do |
| 4628 | if typtr <> nil then |
| 4629 | case access of |
| 4630 | drct: if vlevel <= 1 then gen1ts(43(*sro*),dplmt,typtr,symptr) |
| 4631 | else gen2t(56(*str*),level-(level-vlevel),dplmt,typtr); |
| 4632 | indrct: if idplmt <> 0 then error(401) |
| 4633 | else if typtr^.form in [records,arrays] then begin |
| 4634 | lsize := typtr^.size; |
| 4635 | alignu(parmptr,lsize); |
| 4636 | gen2t(26(*sto*),typtr^.size, lsize,typtr); |
| 4637 | mesl(adrsize+lsize) |
| 4638 | end else |
| 4639 | gen0t(26(*sto*),typtr); |
| 4640 | inxd: error(402) |
| 4641 | end |
| 4642 | end (*store*) ; |
| 4643 | |
| 4644 | { rationalize binary container operator } |
| 4645 | procedure containerop(var lattr: attr); |
| 4646 | var cc: integer; len:addrrange; |
| 4647 | begin |
| 4648 | { check one or both operands is container } |
| 4649 | if (lattr.typtr^.form = arrayc) or |
| 4650 | (gattr.typtr^.form = arrayc) then begin |
| 4651 | { one or both are containers, find the index level } |
| 4652 | if lattr.typtr^.form = arrayc then |
| 4653 | cc := containers(lattr.typtr) |
| 4654 | else |
| 4655 | cc := containers(gattr.typtr); |
| 4656 | if gattr.kind = expr then begin |
| 4657 | { have to pull pointer over stack bubble } |
| 4658 | len := gattr.typtr^.size; |
| 4659 | alignu(parmptr,len); |
| 4660 | gen1(118(*lsa*),len); |
| 4661 | gen0(126(*lsp*)); |
| 4662 | gen1(118(*lsa*),ptrsize*2) |
| 4663 | end; |
| 4664 | if gattr.typtr^.form = arrays then begin |
| 4665 | { right is fixed } |
| 4666 | if cc = 1 then begin |
| 4667 | { load simple template } |
| 4668 | gen2(51(*ldc*),1,spana(gattr.typtr)); |
| 4669 | gen1(72(*swp*),stackelsize); |
| 4670 | gen2(124(*mpc*),0,0) |
| 4671 | end else |
| 4672 | { load complex fixed template } |
| 4673 | gen1(105(*lft*),gattr.typtr^.tmpl) |
| 4674 | end else if lattr.typtr^.form = arrays then begin |
| 4675 | { left is fixed } |
| 4676 | if cc = 1 then begin |
| 4677 | { load simple template } |
| 4678 | gen2(51(*ldc*),1,spana(lattr.typtr)); |
| 4679 | gen1(72(*swp*),ptrsize*3); { swap under right side and fix addr } |
| 4680 | gen2(124(*mpc*),1,1) |
| 4681 | end else |
| 4682 | { load complex fixed template } |
| 4683 | gen1(105(*lft*),lattr.typtr^.tmpl) |
| 4684 | end; |
| 4685 | { compare templates } |
| 4686 | if cc = 1 then gen0(99(*cps*)) { simple compare } |
| 4687 | else gen1(100(*cpc*),cc); { complex compare } |
| 4688 | end |
| 4689 | end; |
| 4690 | |
| 4691 | function parnum(fcp: ctp): integer; |
| 4692 | var pn: integer; |
| 4693 | begin |
| 4694 | pn := 0; fcp := fcp^.pflist; |
| 4695 | while fcp <> nil do begin pn := pn+1; fcp := fcp^.next end; |
| 4696 | parnum := pn |
| 4697 | end; |
| 4698 | |
| 4699 | function partype(fcp: ctp; pn: integer): stp; |
| 4700 | begin fcp := fcp^.pflist; |
| 4701 | while (pn > 1) and (fcp <> nil) do begin fcp := fcp^.next; pn := pn-1 end; |
| 4702 | if fcp = nil then partype := nil else partype := fcp^.idtype |
| 4703 | end; |
| 4704 | |
| 4705 | { compare parameter type to actual type } |
| 4706 | function cmptyp(pt, at: stp): boolean; |
| 4707 | begin cmptyp := false; |
| 4708 | if comptypes(pt, at) then cmptyp := true |
| 4709 | else if realt(pt) and intt(at) then cmptyp := true |
| 4710 | end; |
| 4711 | |
| 4712 | function ischrcst(var at: attr): boolean; |
| 4713 | begin |
| 4714 | ischrcst := (at.typtr = charptr) and (at.kind = cst) |
| 4715 | end; |
| 4716 | |
| 4717 | { find matching uary operator overload } |
| 4718 | procedure fndopr1(opr: operatort; var fcp: ctp); |
| 4719 | var dt: disprange; fcp2: ctp; |
| 4720 | begin fcp := nil; |
| 4721 | if not iso7185 then begin |
| 4722 | dt := top; { search top down } |
| 4723 | repeat |
| 4724 | while (dt > 0) and (display[dt].oprprc[opr] = nil) do dt := dt-1; |
| 4725 | fcp2 := display[dt].oprprc[opr]; |
| 4726 | fcp := nil; { set not found } |
| 4727 | while fcp2 <> nil do begin |
| 4728 | if parnum(fcp2) = 1 then |
| 4729 | if cmptyp(partype(fcp2, 1), gattr.typtr) then fcp := fcp2; |
| 4730 | fcp2 := fcp2^.grpnxt |
| 4731 | end; |
| 4732 | if dt > 0 then dt := dt-1 |
| 4733 | until (fcp <> nil) or (dt = 0) |
| 4734 | end |
| 4735 | end; |
| 4736 | |
| 4737 | { find matching binary operator overload } |
| 4738 | procedure fndopr2(opr: operatort; var lattr: attr; var fcp: ctp); |
| 4739 | var dt: disprange; fcp2: ctp; |
| 4740 | begin fcp := nil; |
| 4741 | if not iso7185 then begin |
| 4742 | dt := top; { search top down } |
| 4743 | repeat |
| 4744 | while (dt > 0) and (display[dt].oprprc[opr] = nil) do dt := dt-1; |
| 4745 | fcp2 := display[dt].oprprc[opr]; |
| 4746 | fcp := nil; { set not found } |
| 4747 | while fcp2 <> nil do begin |
| 4748 | if parnum(fcp2) = 2 then |
| 4749 | if cmptyp(partype(fcp2, 1), lattr.typtr) then |
| 4750 | if cmptyp(partype(fcp2, 2), gattr.typtr) then fcp := fcp2; |
| 4751 | fcp2 := fcp2^.grpnxt |
| 4752 | end; |
| 4753 | if dt > 0 then dt := dt-1 |
| 4754 | until (fcp <> nil) or (dt = 0) |
| 4755 | end |
| 4756 | end; |
| 4757 | |
| 4758 | procedure expression(fsys: setofsys; threaten: boolean); forward; |
| 4759 | |
| 4760 | procedure callop1(fcp: ctp); forward; |
| 4761 | |
| 4762 | procedure callop2(fcp: ctp; var lattr: attr); forward; |
| 4763 | |
| 4764 | { check any overloads exist for given operator } |
| 4765 | function isopr(opt: operatort): boolean; |
| 4766 | var dt: disprange; |
| 4767 | begin isopr := false; |
| 4768 | dt := top; |
| 4769 | while (dt > 0) and (display[dt].oprprc[opt] = nil) do dt := dt-1; |
| 4770 | isopr := display[dt].oprprc[opt] <> nil |
| 4771 | end; |
| 4772 | |
| 4773 | function taggedrec(fsp: stp): boolean; |
| 4774 | var b: boolean; |
| 4775 | begin b := false; |
| 4776 | if fsp <> nil then |
| 4777 | if fsp^.form = tagfld then b := true |
| 4778 | else if fsp^.form = records then |
| 4779 | if fsp^.recvar <> nil then |
| 4780 | b := fsp^.recvar^.form = tagfld; |
| 4781 | taggedrec := b |
| 4782 | end; |
| 4783 | |
| 4784 | procedure selector(fsys: setofsys; fcp: ctp; skp: boolean); |
| 4785 | var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer; |
| 4786 | id: stp; lastptr: boolean; cc: integer; ct: boolean; |
| 4787 | function schblk(fcp: ctp): boolean; |
| 4788 | var i: disprange; f: boolean; |
| 4789 | begin |
| 4790 | f := false; |
| 4791 | for i := top downto 2 do |
| 4792 | if display[i].occur = blck then |
| 4793 | if display[i].bname <> nil then |
| 4794 | if display[i].bname^.grppar = fcp^.grppar then |
| 4795 | f := true; |
| 4796 | schblk := f |
| 4797 | end; |
| 4798 | procedure checkvrnt(lcp: ctp); |
| 4799 | var vp: stp; vl: ctp; gattrs: attr; |
| 4800 | begin |
| 4801 | if chkvar then begin |
| 4802 | if lcp^.klass = field then begin |
| 4803 | vp := lcp^.varnt; vl := lcp^.varlb; |
| 4804 | if (vp <> nil) and (vl <> nil) then |
| 4805 | if (vl^.name <> nil) or chkudtf then begin { is a variant } |
| 4806 | if chkudtf and (vl^.name = nil) and (vp <> nil) then begin |
| 4807 | { tagfield is unnamed and checking is on, force tagfield |
| 4808 | assignment } |
| 4809 | gattrs := gattr; |
| 4810 | with gattr, vl^ do begin |
| 4811 | typtr := idtype; |
| 4812 | case access of |
| 4813 | drct: dplmt := dplmt + fldaddr; |
| 4814 | indrct: begin |
| 4815 | idplmt := idplmt + fldaddr; |
| 4816 | gen0t(76(*dup*),nilptr) |
| 4817 | end; |
| 4818 | inxd: error(406) |
| 4819 | end; |
| 4820 | loadaddress; |
| 4821 | gen2(51(*ldc*),1,vp^.varval.ival); |
| 4822 | if chkvbk then |
| 4823 | genctaivtcvb(95(*cvb*),vl^.varsaddr-fldaddr,vl^.varssize, |
| 4824 | vl^.vartl,vl^.idtype); |
| 4825 | if debug then |
| 4826 | genctaivtcvb(82(*ivt*),vl^.varsaddr-fldaddr,vl^.varssize, |
| 4827 | vl^.vartl,vl^.idtype); |
| 4828 | gen0t(26(*sto*),basetype(idtype)); |
| 4829 | end; |
| 4830 | gattr := gattrs |
| 4831 | end; |
| 4832 | gattrs := gattr; |
| 4833 | with gattr, vl^ do begin |
| 4834 | typtr := idtype; |
| 4835 | case access of |
| 4836 | drct: dplmt := dplmt + fldaddr; |
| 4837 | indrct: begin |
| 4838 | idplmt := idplmt + fldaddr; |
| 4839 | gen0t(76(*dup*),nilptr) |
| 4840 | end; |
| 4841 | inxd: error(406) |
| 4842 | end; |
| 4843 | load; |
| 4844 | gen0(78(*cks*)); |
| 4845 | while vp <> nil do begin |
| 4846 | gen1t(75(*ckv*),vp^.varval.ival, basetype(idtype)); |
| 4847 | vp := vp^.caslst |
| 4848 | end; |
| 4849 | gen0(77(*cke*)); |
| 4850 | end; |
| 4851 | gattr := gattrs |
| 4852 | end |
| 4853 | end |
| 4854 | end |
| 4855 | end; |
| 4856 | begin { selector } |
| 4857 | lastptr := false; { set last index op not ptr } |
| 4858 | with fcp^, gattr do |
| 4859 | begin symptr := nil; typtr := idtype; spv := false; kind := varbl; |
| 4860 | packing := false; packcom := false; tagfield := false; ptrref := false; |
| 4861 | vartl := -1; pickup := true; dblptr := false; |
| 4862 | case klass of |
| 4863 | vars: begin symptr := fcp; |
| 4864 | if typtr <> nil then |
| 4865 | begin packing := typtr^.packing; dblptr := fcp^.dblptr end; |
| 4866 | if vkind = actual then |
| 4867 | begin access := drct; vlevel := vlev; |
| 4868 | { don't offset far } |
| 4869 | if chkext(fcp) then dplmt := 0 else dplmt := vaddr |
| 4870 | end |
| 4871 | else |
| 4872 | begin |
| 4873 | { if container, just load the address of it, the complex |
| 4874 | pointer is loaded when the address is loaded } |
| 4875 | ct := false; if typtr <> nil then ct := typtr^.form = arrayc; |
| 4876 | if ct then gen2(50(*lda*),level-(level-vlev),vaddr) |
| 4877 | else gen2t(54(*lod*),level-(level-vlev),vaddr,nilptr); |
| 4878 | access := indrct; idplmt := 0 |
| 4879 | end; |
| 4880 | end; |
| 4881 | fixedt: begin symptr := fcp; |
| 4882 | if typtr <> nil then packing := typtr^.packing; |
| 4883 | access := drct; vlevel := 0; dplmt := 0 |
| 4884 | end; |
| 4885 | field: |
| 4886 | with display[disx] do begin |
| 4887 | gattr.packcom := display[disx].packing; |
| 4888 | if typtr <> nil then |
| 4889 | gattr.packing := display[disx].packing or typtr^.packing; |
| 4890 | gattr.ptrref := display[disx].ptrref; |
| 4891 | gattr.tagfield := fcp^.tagfield; |
| 4892 | gattr.taglvl := fcp^.taglvl; |
| 4893 | gattr.varnt := fcp^.varnt; |
| 4894 | if gattr.tagfield then |
| 4895 | gattr.vartagoff := fcp^.varsaddr-fldaddr; |
| 4896 | gattr.varssize := fcp^.varssize; |
| 4897 | gattr.vartl := fcp^.vartl; |
| 4898 | if occur = crec then |
| 4899 | begin access := drct; vlevel := clev; |
| 4900 | dplmt := cdspl + fldaddr |
| 4901 | end |
| 4902 | else if occur = vrec then |
| 4903 | begin |
| 4904 | { override to local for with statement } |
| 4905 | gen2t(54(*lod*),level,vdspl,nilptr); |
| 4906 | access := indrct; idplmt := fldaddr |
| 4907 | end |
| 4908 | else |
| 4909 | begin |
| 4910 | if level = 1 then gen1t(39(*ldo*),vdspl,nilptr) |
| 4911 | else gen2t(54(*lod*),level,vdspl,nilptr); |
| 4912 | access := indrct; idplmt := fldaddr |
| 4913 | end |
| 4914 | end; |
| 4915 | func: |
| 4916 | if pfdeckind = standard then |
| 4917 | begin error(150); typtr := nil end |
| 4918 | else |
| 4919 | begin |
| 4920 | if pfkind = formal then error(151) |
| 4921 | else |
| 4922 | if not schblk(fcp) then error(192); |
| 4923 | begin access := drct; vlevel := pflev + 1; |
| 4924 | { determine size of FR. This is a bit of a hack |
| 4925 | against the fact that int/ptr results fit in |
| 4926 | the upper half of the FR. } |
| 4927 | id := basetype(fcp^.idtype); |
| 4928 | lsize := parmsize; if id <> nil then lsize := id^.size; |
| 4929 | dplmt := marksize+ptrsize+adrsize+locpar { addr of fr } |
| 4930 | end |
| 4931 | end; |
| 4932 | proc: { nothing, its an error case } |
| 4933 | end (*case*) |
| 4934 | end (*with*); |
| 4935 | if not (sy in selectsys + fsys) and not skp then |
| 4936 | begin error(59); skip(selectsys + fsys) end; |
| 4937 | while sy in selectsys do |
| 4938 | begin |
| 4939 | (*[*) if sy = lbrack then |
| 4940 | begin gattr.ptrref := false; |
| 4941 | repeat lattr := gattr; |
| 4942 | with lattr do |
| 4943 | if typtr <> nil then begin |
| 4944 | if not arrayt(typtr) then begin error(138); typtr := nil end |
| 4945 | end; |
| 4946 | loadaddress; |
| 4947 | insymbol; expression(fsys + [comma,rbrack], false); |
| 4948 | load; |
| 4949 | if gattr.typtr <> nil then |
| 4950 | if gattr.typtr^.form<>scalar then error(113) |
| 4951 | else if not comptypes(gattr.typtr,intptr) then |
| 4952 | gen0t(58(*ord*),gattr.typtr); |
| 4953 | if lattr.typtr <> nil then |
| 4954 | with lattr.typtr^ do |
| 4955 | begin |
| 4956 | if form = arrayc then begin |
| 4957 | { note containers merge index and bounds check } |
| 4958 | if gattr.typtr <> intptr then error(139) |
| 4959 | end else if comptypes(inxtype,gattr.typtr) then |
| 4960 | begin |
| 4961 | if inxtype <> nil then |
| 4962 | begin getbounds(inxtype,lmin,lmax); |
| 4963 | if debug then |
| 4964 | gen2t(45(*chk*),lmin,lmax,intptr); |
| 4965 | if lmin>0 then gen1t(31(*dec*),lmin,intptr) |
| 4966 | else if lmin<0 then |
| 4967 | gen1t(34(*inc*),-lmin,intptr); |
| 4968 | (*or simply gen1(31,lmin)*) |
| 4969 | end |
| 4970 | end |
| 4971 | else error(139); |
| 4972 | with gattr do |
| 4973 | begin |
| 4974 | if lattr.typtr^.form = arrays then typtr := aeltype |
| 4975 | else typtr := abstype; |
| 4976 | kind := varbl; |
| 4977 | access := indrct; idplmt := 0; packing := false; |
| 4978 | packcom := false; tagfield := false; ptrref := false; |
| 4979 | vartl := -1; pickup := false; dblptr := false; |
| 4980 | end; |
| 4981 | if gattr.typtr <> nil then |
| 4982 | begin |
| 4983 | gattr.packcom := lattr.packing; |
| 4984 | gattr.packing := |
| 4985 | lattr.packing or gattr.typtr^.packing; |
| 4986 | lsize := gattr.typtr^.size; { get base size } |
| 4987 | cc := containers(lattr.typtr); |
| 4988 | if lattr.typtr^.form = arrays then gen1(36(*ixa*),lsize) |
| 4989 | else if cc = 1 then |
| 4990 | gen1(103(*cxs*),lsize) { simple container index } |
| 4991 | else begin { complex container index } |
| 4992 | gen2(104(*cxc*),cc,containerbase(gattr.typtr)); |
| 4993 | { if level is at bottom, simplify the template } |
| 4994 | if cc = 2 then gen0(108(*spc*)) |
| 4995 | end |
| 4996 | end |
| 4997 | end |
| 4998 | else gattr.typtr := nil |
| 4999 | until sy <> comma; |
| 5000 | if sy = rbrack then insymbol else error(12); |
| 5001 | lastptr := false { set not pointer op } |
| 5002 | end (*if sy = lbrack*) |
| 5003 | else |
| 5004 | (*.*) if sy = period then |
| 5005 | begin |
| 5006 | with gattr do |
| 5007 | begin |
| 5008 | if typtr <> nil then begin |
| 5009 | if typtr^.form <> records then |
| 5010 | begin error(140); typtr := nil end |
| 5011 | end; |
| 5012 | insymbol; |
| 5013 | if sy = ident then |
| 5014 | begin |
| 5015 | if typtr <> nil then |
| 5016 | begin searchsection(typtr^.fstfld,lcp); |
| 5017 | if lcp = nil then |
| 5018 | begin error(152); typtr := nil end |
| 5019 | else |
| 5020 | with lcp^ do |
| 5021 | begin checkvrnt(lcp); |
| 5022 | typtr := idtype; |
| 5023 | gattr.packcom := gattr.packing; |
| 5024 | if typtr <> nil then |
| 5025 | gattr.packing := |
| 5026 | gattr.packing or typtr^.packing; |
| 5027 | gattr.tagfield := lcp^.tagfield; |
| 5028 | gattr.taglvl := lcp^.taglvl; |
| 5029 | gattr.varnt := lcp^.varnt; |
| 5030 | if gattr.tagfield then |
| 5031 | gattr.vartagoff := lcp^.varsaddr-fldaddr; |
| 5032 | gattr.varssize := lcp^.varssize; |
| 5033 | { only set ptr offset ref if last was ptr } |
| 5034 | gattr.ptrref := lastptr; |
| 5035 | gattr.vartl := lcp^.vartl; |
| 5036 | gattr.pickup := false; |
| 5037 | gattr.dblptr := false; |
| 5038 | case access of |
| 5039 | drct: dplmt := dplmt + fldaddr; |
| 5040 | indrct: idplmt := idplmt + fldaddr; |
| 5041 | inxd: error(407) |
| 5042 | end |
| 5043 | end |
| 5044 | end; |
| 5045 | insymbol |
| 5046 | end (*sy = ident*) |
| 5047 | else error(2) |
| 5048 | end; (*with gattr*) |
| 5049 | lastptr := false { set last not ptr op } |
| 5050 | end (*if sy = period*) |
| 5051 | else |
| 5052 | (*^*) begin |
| 5053 | if gattr.typtr <> nil then |
| 5054 | with gattr,typtr^ do |
| 5055 | if form = pointer then |
| 5056 | begin load; |
| 5057 | typtr := eltype; |
| 5058 | if debug then begin |
| 5059 | if taggedrec(eltype) then |
| 5060 | gen2t(80(*ckl*),1,maxaddr,nilptr) |
| 5061 | else gen2t(45(*chk*),1,maxaddr,nilptr); |
| 5062 | end; |
| 5063 | if eltype <> nil then |
| 5064 | if eltype^.form = arrayc then begin |
| 5065 | { it's a container, load a complex pointer based on |
| 5066 | that } |
| 5067 | gen1(130(*mdc*),containers(eltype)*intsize); |
| 5068 | { if level is at bottom, simplify the template } |
| 5069 | if containers(eltype) = 1 then gen0(108(*spc*)) |
| 5070 | end; |
| 5071 | with gattr do |
| 5072 | begin kind := varbl; access := indrct; idplmt := 0; |
| 5073 | packing := false; packcom := false; |
| 5074 | tagfield := false; ptrref := true; vartl := -1; |
| 5075 | pickup := false; dblptr := false; |
| 5076 | end |
| 5077 | end |
| 5078 | else |
| 5079 | if form = files then begin loadaddress; |
| 5080 | { generate buffer validate for file } |
| 5081 | if typtr = textptr then |
| 5082 | gen1(30(*csp*), 46(*fbv*)) |
| 5083 | else begin |
| 5084 | gen2(51(*ldc*),1,filtype^.size); |
| 5085 | gen1(30(*csp*),47(*fvb*)) |
| 5086 | end; |
| 5087 | { index buffer } |
| 5088 | gen1t(34(*inc*),fileidsize,gattr.typtr); |
| 5089 | typtr := filtype; |
| 5090 | end else error(141); |
| 5091 | insymbol; |
| 5092 | lastptr := true { set last was ptr op } |
| 5093 | end; |
| 5094 | if not (sy in fsys + selectsys) then |
| 5095 | begin error(6); skip(fsys + selectsys) end |
| 5096 | end (*while*) |
| 5097 | end (*selector*) ; |
| 5098 | |
| 5099 | procedure fixpar(fsp,asp: stp); |
| 5100 | var cc: integer; |
| 5101 | begin |
| 5102 | if fsp <> nil then begin |
| 5103 | if (asp^.form = arrays) and (fsp^.form = arrayc) then begin |
| 5104 | { fixed into container } |
| 5105 | cc := containers(fsp); |
| 5106 | if cc = 1 then begin |
| 5107 | { load simple template } |
| 5108 | gen2(51(*ldc*),1,spana(asp)); |
| 5109 | gen1(72(*swp*),stackelsize); |
| 5110 | gen2(124(*mpc*),0,0) |
| 5111 | end else |
| 5112 | { load complex fixed template } |
| 5113 | gen1(105(*lft*),asp^.tmpl) |
| 5114 | end else if (asp^.form = arrayc) and |
| 5115 | (fsp^.form = arrays) then begin |
| 5116 | { container into fixed, load template for fixed side } |
| 5117 | cc := containers(asp); |
| 5118 | if cc = 1 then begin |
| 5119 | { load simple template } |
| 5120 | gen2(51(*ldc*),1,span(fsp)); |
| 5121 | gen2(51(*ldc*),4,0) { load dummy address } |
| 5122 | end else begin |
| 5123 | { load complex fixed template } |
| 5124 | gen2(51(*ldc*),4,0); { load dummy address } |
| 5125 | gen1(105(*lft*),fsp^.tmpl); |
| 5126 | end; |
| 5127 | { compare templates } |
| 5128 | if cc = 1 then gen0(99(*cps*)) { simple compare } |
| 5129 | else gen1(100(*cpc*),cc); { complex compare } |
| 5130 | { discard the templates } |
| 5131 | gen1(71(*dmp*),ptrsize*2); |
| 5132 | gen1(72(*swp*),ptrsize); |
| 5133 | gen1(71(*dmp*),ptrsize) |
| 5134 | end |
| 5135 | end |
| 5136 | end; |
| 5137 | |
| 5138 | procedure call(fsys: setofsys; fcp: ctp; inherit: boolean; isfunc: boolean); |
| 5139 | var lkey: keyrng; |
| 5140 | |
| 5141 | procedure variable(fsys: setofsys; threaten: boolean); |
| 5142 | var lcp: ctp; |
| 5143 | begin |
| 5144 | if sy = ident then |
| 5145 | begin searchid([vars,fixedt,field],lcp); insymbol end |
| 5146 | else begin error(2); lcp := uvarptr end; |
| 5147 | if threaten and (lcp^.klass = vars) then with lcp^ do begin |
| 5148 | if vlev < level then threat := true; |
| 5149 | if forcnt > 0 then error(195); |
| 5150 | if part = ptview then error(290) |
| 5151 | end; |
| 5152 | selector(fsys,lcp, false); |
| 5153 | if gattr.kind = expr then error(287) |
| 5154 | end (*variable*) ; |
| 5155 | |
| 5156 | procedure chkhdr; |
| 5157 | var lcp: ctp; dummy: boolean; |
| 5158 | begin |
| 5159 | if sy = ident then begin { test for file } |
| 5160 | searchidnenm([vars],lcp,dummy); |
| 5161 | if (lcp = inputptr) and not inputptr^.hdr then error(175) |
| 5162 | else if (lcp = outputptr) and not outputptr^.hdr then error(176) |
| 5163 | else if (lcp = prdptr) and not prdptr^.hdr then error(217) |
| 5164 | else if (lcp = prrptr) and not prrptr^.hdr then error(218) |
| 5165 | else if (lcp = errorptr) and not errorptr^.hdr then error(219) |
| 5166 | else if (lcp = listptr) and not listptr^.hdr then error(220) |
| 5167 | else if (lcp = commandptr) and not commandptr^.hdr then error(221) |
| 5168 | end |
| 5169 | end; |
| 5170 | |
| 5171 | procedure getputresetrewriteprocedure; |
| 5172 | begin chkhdr; variable(fsys + [rparent], false); loadaddress; |
| 5173 | if gattr.typtr <> nil then |
| 5174 | if gattr.typtr^.form <> files then error(116); |
| 5175 | if lkey <= 2 then begin |
| 5176 | if gattr.typtr = textptr then gen1(30(*csp*),lkey(*get,put*)) |
| 5177 | else begin |
| 5178 | if gattr.typtr <> nil then |
| 5179 | gen2(51(*ldc*),1,gattr.typtr^.filtype^.size); |
| 5180 | if lkey = 1 then gen1(30(*csp*),38(*gbf*)) |
| 5181 | else gen1(30(*csp*),39(*pbf*)) |
| 5182 | end |
| 5183 | end else |
| 5184 | if gattr.typtr = textptr then begin |
| 5185 | if lkey = 3 then gen1(30(*csp*),25(*reset*)) |
| 5186 | else gen1(30(*csp*),26(*rewrite*)) |
| 5187 | end else begin |
| 5188 | if lkey = 3 then gen1(30(*csp*),36(*reset*)) |
| 5189 | else gen1(30(*csp*),37(*rewrite*)) |
| 5190 | end |
| 5191 | end (*getputresetrewrite*) ; |
| 5192 | |
| 5193 | procedure pageprocedure; |
| 5194 | begin |
| 5195 | if sy = lparent then |
| 5196 | begin insymbol; chkhdr; |
| 5197 | variable(fsys + [rparent], false); loadaddress; |
| 5198 | if gattr.typtr <> nil then |
| 5199 | if gattr.typtr <> textptr then error(116); |
| 5200 | if sy = rparent then insymbol else error(4) |
| 5201 | end else begin |
| 5202 | if not outputptr^.hdr then error(176); |
| 5203 | gen1(37(*lao*),outputptr^.vaddr); |
| 5204 | end; |
| 5205 | gen1(30(*csp*),24(*page*)) |
| 5206 | end (*page*) ; |
| 5207 | |
| 5208 | procedure readprocedure; |
| 5209 | var lsp : stp; |
| 5210 | txt: boolean; { is a text file } |
| 5211 | deffil: boolean; { default file was loaded } |
| 5212 | test: boolean; |
| 5213 | lmin,lmax: integer; |
| 5214 | len:addrrange; |
| 5215 | fld, spad: boolean; |
| 5216 | cp: boolean; |
| 5217 | cststr: boolean; |
| 5218 | r: integer; { radix of read } |
| 5219 | begin |
| 5220 | txt := true; deffil := true; cp := false; |
| 5221 | if sy = lparent then |
| 5222 | begin insymbol; chkhdr; cststr := false; |
| 5223 | if sy = stringconst then begin chkstd; cststr := true; |
| 5224 | expression(fsys + [comma,colon,rparent,hexsy,octsy,binsy], false) |
| 5225 | end else |
| 5226 | variable(fsys + [comma,colon,rparent,hexsy,octsy,binsy], true); |
| 5227 | if gattr.typtr <> nil then cp := gattr.typtr^.form = arrayc; |
| 5228 | lsp := gattr.typtr; test := false; |
| 5229 | if lsp <> nil then |
| 5230 | if lsp^.form = files then |
| 5231 | with gattr, lsp^ do |
| 5232 | begin |
| 5233 | txt := lsp = textptr; |
| 5234 | if not txt and (lkey = 11) then error(116); |
| 5235 | loadaddress; deffil := false; |
| 5236 | if sy = rparent then |
| 5237 | begin if lkey = 5 then error(116); |
| 5238 | test := true |
| 5239 | end |
| 5240 | else |
| 5241 | if sy <> comma then |
| 5242 | begin error(116); |
| 5243 | skip(fsys + [comma,colon,rparent]) |
| 5244 | end; |
| 5245 | if sy = comma then |
| 5246 | begin insymbol; cststr := false; |
| 5247 | if sy = stringconst then begin chkstd; cststr := true; |
| 5248 | expression(fsys + [comma,colon,rparent,hexsy,octsy,binsy], false) |
| 5249 | end else |
| 5250 | variable(fsys + [comma,colon,rparent,hexsy,octsy,binsy], true); |
| 5251 | if gattr.typtr <> nil then |
| 5252 | cp := gattr.typtr^.form = arrayc |
| 5253 | end |
| 5254 | else test := true |
| 5255 | end |
| 5256 | else if not inputptr^.hdr then error(175); |
| 5257 | if not test then |
| 5258 | repeat loadaddress; |
| 5259 | if stringt(gattr.typtr) and not complext(gattr.typtr) then begin |
| 5260 | { make common string pointer into complex } |
| 5261 | len := gattr.typtr^.size div charmax; |
| 5262 | gen2(51(*ldc*),1,len); gen1(72(*swp*),intsize); |
| 5263 | gen2(124(*mpc*),0,0) |
| 5264 | end; |
| 5265 | if deffil then begin |
| 5266 | { file was not loaded, we load and swap so that it ends up |
| 5267 | on the bottom.} |
| 5268 | gen1(37(*lao*),inputptr^.vaddr); |
| 5269 | { note 2nd is always pointer } |
| 5270 | if cp then gen1(72(*swp*),ptrsize+intsize) |
| 5271 | else gen1(72(*swp*),ptrsize); |
| 5272 | deffil := false |
| 5273 | end; |
| 5274 | if txt then begin |
| 5275 | { check radix markers } |
| 5276 | r := 10; |
| 5277 | if sy = hexsy then begin r := 16; insymbol end |
| 5278 | else if sy = octsy then begin r := 8; insymbol end |
| 5279 | else if sy = binsy then begin r := 2; insymbol end; |
| 5280 | lsp := gattr.typtr; fld := false; spad := false; |
| 5281 | if sy = colon then begin { field } |
| 5282 | chkstd; if cststr then error(296); insymbol; |
| 5283 | if (sy = mulop) and (op = mul) then begin |
| 5284 | spad := true; insymbol; |
| 5285 | if not stringt(lsp) then error(215); |
| 5286 | end else begin |
| 5287 | expression(fsys + [comma,rparent], false); |
| 5288 | if gattr.typtr <> nil then |
| 5289 | if basetype(gattr.typtr) <> intptr then error(116); |
| 5290 | load; fld := true |
| 5291 | end |
| 5292 | end; |
| 5293 | if lsp <> nil then |
| 5294 | if (lsp^.form <= subrange) or |
| 5295 | (stringt(lsp) and not iso7185) then |
| 5296 | if comptypes(intptr,lsp) then begin |
| 5297 | if debug then begin |
| 5298 | getbounds(lsp, lmin, lmax); |
| 5299 | gen1t(51(*ldc*),lmin,basetype(lsp)); |
| 5300 | gen1t(51(*ldc*),lmax,basetype(lsp)); |
| 5301 | if fld then begin |
| 5302 | if isbyte(lsp) then begin |
| 5303 | if r = 10 then gen1(30(*csp*),90(*rxbf*)) |
| 5304 | else if r = 16 then gen1(30(*csp*),112(*rbxh*)) |
| 5305 | else if r = 8 then gen1(30(*csp*),113(*rbxo*)) |
| 5306 | else if r = 2 then gen1(30(*csp*),114(*rbxb*)) |
| 5307 | end else begin |
| 5308 | if r = 10 then gen1(30(*csp*),74(*ribf*)) |
| 5309 | else if r = 16 then gen1(30(*csp*),100(*rdih*)) |
| 5310 | else if r = 8 then gen1(30(*csp*),101(*rdio*)) |
| 5311 | else if r = 2 then gen1(30(*csp*),102(*rdib*)) |
| 5312 | end |
| 5313 | end else begin |
| 5314 | if isbyte(lsp) then begin |
| 5315 | if r = 10 then gen1(30(*csp*),89(*rxb*)) |
| 5316 | else if r = 16 then gen1(30(*csp*),109(*rxbh*)) |
| 5317 | else if r = 8 then gen1(30(*csp*),110(*rxbo*)) |
| 5318 | else if r = 2 then gen1(30(*csp*),111(*rxbb*)) |
| 5319 | end else begin |
| 5320 | if r = 10 then gen1(30(*csp*),40(*rib*)) |
| 5321 | else if r = 16 then gen1(30(*csp*),97(*ribh*)) |
| 5322 | else if r = 8 then gen1(30(*csp*),98(*ribo*)) |
| 5323 | else if r = 2 then gen1(30(*csp*),99(*ribb*)) |
| 5324 | end |
| 5325 | end |
| 5326 | end else if fld then begin |
| 5327 | if isbyte(lsp) then begin |
| 5328 | if r = 10 then gen1(30(*csp*),88(*rdxf*)) |
| 5329 | else if r = 16 then gen1(30(*csp*),106(*rxfh*)) |
| 5330 | else if r = 8 then gen1(30(*csp*),107(*rxfo*)) |
| 5331 | else if r = 2 then gen1(30(*csp*),108(*rxfb*)) |
| 5332 | end else begin |
| 5333 | if r = 10 then gen1(30(*csp*),75(*rdif*)) |
| 5334 | else if r = 16 then gen1(30(*csp*),94(*rifh*)) |
| 5335 | else if r = 8 then gen1(30(*csp*),95(*rifo*)) |
| 5336 | else if r = 2 then gen1(30(*csp*),96(*rifb*)) |
| 5337 | end |
| 5338 | end else begin |
| 5339 | if isbyte(lsp) then begin |
| 5340 | if r = 10 then gen1(30(*csp*),87(*rdx*)) |
| 5341 | else if r = 16 then gen1(30(*csp*),103(*rdxh*)) |
| 5342 | else if r = 8 then gen1(30(*csp*),104(*rdxo*)) |
| 5343 | else if r = 2 then gen1(30(*csp*),105(*rdxb*)) |
| 5344 | end else begin |
| 5345 | if r = 10 then gen1(30(*csp*),3(*rdi*)) |
| 5346 | else if r = 16 then gen1(30(*csp*),91(*rdih*)) |
| 5347 | else if r = 8 then gen1(30(*csp*),92(*rdio*)) |
| 5348 | else if r = 2 then gen1(30(*csp*),93(*rdib*)) |
| 5349 | end |
| 5350 | end |
| 5351 | end else |
| 5352 | if comptypes(realptr,lsp) then |
| 5353 | if fld then gen1(30(*csp*),76(*rdrf*)) |
| 5354 | else gen1(30(*csp*),4(*rdr*)) |
| 5355 | else |
| 5356 | if comptypes(charptr,lsp) then begin |
| 5357 | if debug then begin |
| 5358 | getbounds(lsp, lmin, lmax); |
| 5359 | gen2(51(*ldc*),6,lmin); |
| 5360 | gen2(51(*ldc*),6,lmax); |
| 5361 | if fld then gen1(30(*csp*),77(*rcbf*)) |
| 5362 | else gen1(30(*csp*),41(*rcb*)) |
| 5363 | end else if fld then gen1(30(*csp*),78(*rdcf*)) |
| 5364 | else gen1(30(*csp*),5(*rdc*)) |
| 5365 | end else if stringt(lsp) then begin |
| 5366 | if fld then gen1(30(*csp*),79(*rdsf*)) |
| 5367 | else if spad then gen1(30(*csp*),80(*rdsp*)) |
| 5368 | else begin |
| 5369 | if cststr then gen1(30(*csp*),86(*rdsc*)) |
| 5370 | else gen1(30(*csp*),73(*rds*)) |
| 5371 | end |
| 5372 | end else error(153) |
| 5373 | else error(116); |
| 5374 | end else begin { binary file } |
| 5375 | if not comptypes(gattr.typtr,lsp^.filtype) then error(129); |
| 5376 | gen2(51(*ldc*),1,lsp^.filtype^.size); |
| 5377 | gen1(30(*csp*),35(*rbf*)) |
| 5378 | end; |
| 5379 | test := sy <> comma; |
| 5380 | if not test then |
| 5381 | begin insymbol; cststr := false; |
| 5382 | if sy = stringconst then begin chkstd; cststr := true; |
| 5383 | expression(fsys + [comma,colon,rparent,hexsy,octsy,binsy], false) |
| 5384 | end else |
| 5385 | variable(fsys + [comma,colon,rparent,hexsy,octsy,binsy], true); |
| 5386 | if gattr.typtr <> nil then cp := gattr.typtr^.form = arrayc |
| 5387 | end |
| 5388 | until test; |
| 5389 | if sy = rparent then insymbol else error(4) |
| 5390 | end |
| 5391 | else begin |
| 5392 | if not inputptr^.hdr then error(175); |
| 5393 | if lkey = 5 then error(116); |
| 5394 | gen1(37(*lao*),inputptr^.vaddr); |
| 5395 | end; |
| 5396 | if lkey = 11 then gen1(30(*csp*),21(*rln*)); |
| 5397 | { remove the file pointer from stack } |
| 5398 | gen1(71(*dmp*),ptrsize); |
| 5399 | end (*read*) ; |
| 5400 | |
| 5401 | procedure writeprocedure; |
| 5402 | var lsp,lsp1: stp; default, default1: boolean; llkey: 1..15; |
| 5403 | len:addrrange; |
| 5404 | txt: boolean; { is a text file } |
| 5405 | byt: boolean; { is a byte file } |
| 5406 | deffil: boolean; { default file was loaded } |
| 5407 | test: boolean; |
| 5408 | r: integer; { radix of print } |
| 5409 | spad: boolean; { write space padded string } |
| 5410 | ledz: boolean; { use leading zeros } |
| 5411 | onstk: boolean; { expression result on stack } |
| 5412 | lsize: addrrange; |
| 5413 | begin llkey := lkey; txt := true; deffil := true; byt := false; |
| 5414 | if sy = lparent then |
| 5415 | begin insymbol; chkhdr; |
| 5416 | expression(fsys + [comma,colon,rparent,hexsy,octsy,binsy], false); |
| 5417 | onstk := gattr.kind = expr; |
| 5418 | lsp := gattr.typtr; test := false; |
| 5419 | if lsp <> nil then |
| 5420 | if lsp^.form = files then |
| 5421 | with gattr, lsp^ do |
| 5422 | begin lsp1 := lsp; |
| 5423 | txt := lsp = textptr; |
| 5424 | if not txt then begin |
| 5425 | if lkey = 12 then error(116); |
| 5426 | byt := isbyte(lsp^.filtype) |
| 5427 | end; |
| 5428 | loadaddress; deffil := false; |
| 5429 | if sy = rparent then |
| 5430 | begin if llkey = 6 then error(116); |
| 5431 | test := true |
| 5432 | end |
| 5433 | else |
| 5434 | if sy <> comma then |
| 5435 | begin error(116); skip(fsys+[comma,rparent]) end; |
| 5436 | if sy = comma then |
| 5437 | begin insymbol; |
| 5438 | expression(fsys+[comma,colon,rparent,hexsy,octsy,binsy], |
| 5439 | false); |
| 5440 | onstk := gattr.kind = expr |
| 5441 | end |
| 5442 | else test := true |
| 5443 | end |
| 5444 | else if not outputptr^.hdr then error(176); |
| 5445 | if not test then |
| 5446 | repeat |
| 5447 | lsp := gattr.typtr; |
| 5448 | if lsp <> nil then |
| 5449 | if lsp^.form <= subrange then load else loadaddress; |
| 5450 | lsp := basetype(lsp); { remove any subrange } |
| 5451 | if stringt(lsp) and not complext(lsp) then begin |
| 5452 | len := lsp^.size div charmax; |
| 5453 | gen2(51(*ldc*),1,len); |
| 5454 | gen1(72(*swp*),stackelsize); { swap ptr and len } |
| 5455 | gen2(124(*mpc*),0,0) |
| 5456 | end; |
| 5457 | if deffil then begin |
| 5458 | { file was not loaded, we load and swap so that it ends up |
| 5459 | on the bottom.} |
| 5460 | gen1(37(*lao*),outputptr^.vaddr); |
| 5461 | if lsp <> nil then begin |
| 5462 | lsize := lsp^.size; alignau(stackal, lsize); |
| 5463 | if lsp^.form <= subrange then gen1(72(*swp*),lsize) |
| 5464 | else |
| 5465 | { 2nd is pointer, either simple or complex } |
| 5466 | if (lsp^.form = arrayc) or stringt(lsp) then |
| 5467 | gen1(72(*swp*),ptrsize*2) |
| 5468 | else gen1(72(*swp*),ptrsize); |
| 5469 | end; |
| 5470 | deffil := false |
| 5471 | end; |
| 5472 | if txt then begin |
| 5473 | { check radix markers } |
| 5474 | r := 10; |
| 5475 | if sy = hexsy then begin r := 16; insymbol end |
| 5476 | else if sy = octsy then begin r := 8; insymbol end |
| 5477 | else if sy = binsy then begin r := 2; insymbol end; |
| 5478 | if (r <> 10) and (lsp <> intptr) then error(214); |
| 5479 | spad := false; { set no padded string } |
| 5480 | ledz := false; { set no leading zero } |
| 5481 | if sy = colon then |
| 5482 | begin insymbol; |
| 5483 | if (sy = mulop) and (op = mul) then begin |
| 5484 | spad := true; insymbol; |
| 5485 | if not stringt(lsp) then error(215) |
| 5486 | end else begin |
| 5487 | if sy = numsy then |
| 5488 | begin chkstd; ledz := true; insymbol end; |
| 5489 | expression(fsys + [comma,colon,rparent], false); |
| 5490 | if gattr.typtr <> nil then |
| 5491 | if basetype(gattr.typtr) <> intptr then error(116); |
| 5492 | load; |
| 5493 | end; |
| 5494 | default := false |
| 5495 | end |
| 5496 | else default := true; |
| 5497 | if sy = colon then |
| 5498 | begin insymbol; |
| 5499 | expression(fsys + [comma,rparent], false); |
| 5500 | if gattr.typtr <> nil then |
| 5501 | if basetype(gattr.typtr) <> intptr then error(116); |
| 5502 | if lsp <> realptr then error(124); |
| 5503 | load; default1 := false |
| 5504 | end else default1 := true; |
| 5505 | if lsp = intptr then |
| 5506 | begin if default then gen2(51(*ldc*),1,intdeff); |
| 5507 | if ledz then begin { leading zeros } |
| 5508 | if r = 10 then gen1(30(*csp*),69(*wiz*)) |
| 5509 | else if r = 16 then gen1(30(*csp*),70(*wizh*)) |
| 5510 | else if r = 8 then gen1(30(*csp*),71(*wizo*)) |
| 5511 | else if r = 2 then gen1(30(*csp*),72(*wizb*)) |
| 5512 | end else begin |
| 5513 | if r = 10 then gen1(30(*csp*),6(*wri*)) |
| 5514 | else if r = 16 then gen1(30(*csp*),65(*wrih*)) |
| 5515 | else if r = 8 then gen1(30(*csp*),66(*wrio*)) |
| 5516 | else if r = 2 then gen1(30(*csp*),67(*wrib*)) |
| 5517 | end |
| 5518 | end |
| 5519 | else |
| 5520 | if lsp = realptr then |
| 5521 | begin |
| 5522 | if default1 then begin |
| 5523 | if default then gen2(51(*ldc*),1,reldeff); |
| 5524 | gen1(30(*csp*),8(*wrr*)) |
| 5525 | end else begin |
| 5526 | if default then gen2(51(*ldc*),1,reldeff); |
| 5527 | gen1(30(*csp*),28(*wrf*)) |
| 5528 | end |
| 5529 | end |
| 5530 | else |
| 5531 | if lsp = charptr then |
| 5532 | begin if default then gen2(51(*ldc*),1,chrdeff); |
| 5533 | gen1(30(*csp*),9(*wrc*)) |
| 5534 | end |
| 5535 | else |
| 5536 | if lsp = boolptr then |
| 5537 | begin if default then gen2(51(*ldc*),1,boldeff); |
| 5538 | gen1(30(*csp*),27(*wrb*)) |
| 5539 | end |
| 5540 | else |
| 5541 | if lsp <> nil then |
| 5542 | begin |
| 5543 | if lsp^.form = scalar then error(236) |
| 5544 | else |
| 5545 | if stringt(lsp) then begin |
| 5546 | if default and not spad then |
| 5547 | { no field, need to duplicate len to make the |
| 5548 | field } |
| 5549 | gen0(127(*cpl*)); { copy length } |
| 5550 | if spad then gen1(30(*csp*),68(*wrsp*)) |
| 5551 | else gen1(30(*csp*),10(*wrs*)); |
| 5552 | end else error(116) |
| 5553 | end |
| 5554 | end else begin { binary file } |
| 5555 | if not comptypes(lsp1^.filtype,lsp) then error(129); |
| 5556 | if lsp <> nil then |
| 5557 | if (lsp = intptr) and not byt then gen1(30(*csp*),31(*wbi*)) |
| 5558 | else |
| 5559 | if lsp = realptr then gen1(30(*csp*),32(*wbr*)) |
| 5560 | else |
| 5561 | if lsp = charptr then gen1(30(*csp*),33(*wbc*)) |
| 5562 | else |
| 5563 | if lsp = boolptr then gen1(30(*csp*),34(*wbb*)) |
| 5564 | else |
| 5565 | if lsp^.form <= subrange then begin |
| 5566 | if byt then gen1(30(*csp*),48(*wbx*)) |
| 5567 | else gen1(30(*csp*),31(*wbi*)) |
| 5568 | end else begin |
| 5569 | gen2(51(*ldc*),1,lsp1^.filtype^.size); |
| 5570 | gen1(30(*csp*),30(*wbf*)) |
| 5571 | end |
| 5572 | end; |
| 5573 | test := sy <> comma; |
| 5574 | if not test then |
| 5575 | begin insymbol; |
| 5576 | expression(fsys + [comma,colon,rparent,hexsy,octsy,binsy], |
| 5577 | false); |
| 5578 | onstk := gattr.kind = expr |
| 5579 | end |
| 5580 | until test; |
| 5581 | if sy = rparent then insymbol else error(4) |
| 5582 | end else begin |
| 5583 | if not outputptr^.hdr then error(176); |
| 5584 | if lkey = 6 then error(116); |
| 5585 | gen1(37(*lao*),outputptr^.vaddr); |
| 5586 | end; |
| 5587 | if llkey = 12 then (*writeln*) |
| 5588 | gen1(30(*csp*),22(*wln*)); |
| 5589 | { remove the file pointer from stack } |
| 5590 | gen1(71(*dmp*),ptrsize) |
| 5591 | end (*write*) ; |
| 5592 | |
| 5593 | procedure packprocedure; |
| 5594 | var lsp,lsp1: stp; lb, bs: integer; lattr: attr; |
| 5595 | begin variable(fsys + [comma,rparent], false); loadaddress; |
| 5596 | lsp := nil; lsp1 := nil; lb := 1; bs := 1; |
| 5597 | lattr := gattr; |
| 5598 | if gattr.typtr <> nil then |
| 5599 | with gattr.typtr^ do |
| 5600 | if form = arrays then |
| 5601 | begin lsp := inxtype; lsp1 := aeltype; |
| 5602 | if (inxtype = charptr) or (inxtype = boolptr) then lb := 0 |
| 5603 | else if inxtype^.form = subrange then lb := inxtype^.min.ival; |
| 5604 | bs := aeltype^.size |
| 5605 | end |
| 5606 | else error(116); |
| 5607 | if sy = comma then insymbol else error(20); |
| 5608 | expression(fsys + [comma,rparent], false); load; |
| 5609 | if gattr.typtr <> nil then |
| 5610 | if gattr.typtr^.form <> scalar then error(116) |
| 5611 | else |
| 5612 | if not comptypes(lsp,gattr.typtr) then error(116); |
| 5613 | gen2(51(*ldc*),1,lb); |
| 5614 | gen0(21(*sbi*)); |
| 5615 | gen2(51(*ldc*),1,bs); |
| 5616 | gen0(15(*mpi*)); |
| 5617 | if sy = comma then insymbol else error(20); |
| 5618 | variable(fsys + [rparent], false); loadaddress; |
| 5619 | if gattr.typtr <> nil then |
| 5620 | with gattr.typtr^ do |
| 5621 | if form = arrays then |
| 5622 | begin |
| 5623 | if not comptypes(aeltype,lsp1) then error(116) |
| 5624 | end |
| 5625 | else error(116); |
| 5626 | if (gattr.typtr <> nil) and (lattr.typtr <> nil) then |
| 5627 | gen2(62(*pck*),gattr.typtr^.size,lattr.typtr^.size) |
| 5628 | end (*pack*) ; |
| 5629 | |
| 5630 | procedure unpackprocedure; |
| 5631 | var lsp,lsp1: stp; lattr,lattr1: attr; lb, bs: integer; |
| 5632 | begin variable(fsys + [comma,rparent], false); loadaddress; |
| 5633 | lattr := gattr; |
| 5634 | lsp := nil; lsp1 := nil; lb := 1; bs := 1; |
| 5635 | if gattr.typtr <> nil then |
| 5636 | with gattr.typtr^ do |
| 5637 | if form = arrays then lsp1 := aeltype |
| 5638 | else error(116); |
| 5639 | if sy = comma then insymbol else error(20); |
| 5640 | variable(fsys + [comma,rparent], false); loadaddress; |
| 5641 | lattr1 := gattr; |
| 5642 | if gattr.typtr <> nil then |
| 5643 | with gattr.typtr^ do |
| 5644 | if form = arrays then |
| 5645 | begin |
| 5646 | if not comptypes(aeltype,lsp1) then error(116); |
| 5647 | if (inxtype = charptr) or (inxtype = boolptr) then lb := 0 |
| 5648 | else if inxtype^.form = subrange then lb := inxtype^.min.ival; |
| 5649 | bs := aeltype^.size; |
| 5650 | lsp := inxtype; |
| 5651 | end |
| 5652 | else error(116); |
| 5653 | if sy = comma then insymbol else error(20); |
| 5654 | expression(fsys + [rparent], false); load; |
| 5655 | if gattr.typtr <> nil then |
| 5656 | if gattr.typtr^.form <> scalar then error(116) |
| 5657 | else |
| 5658 | if not comptypes(lsp,gattr.typtr) then error(116); |
| 5659 | gen2(51(*ldc*),1,lb); |
| 5660 | gen0(21(*sbi*)); |
| 5661 | gen2(51(*ldc*),1,bs); |
| 5662 | gen0(15(*mpi*)); |
| 5663 | if (lattr.typtr <> nil) and (lattr1.typtr <> nil) then |
| 5664 | gen2(63(*upk*),lattr.typtr^.size,lattr1.typtr^.size) |
| 5665 | end (*unpack*) ; |
| 5666 | |
| 5667 | procedure newdisposeprocedure(disp: boolean); |
| 5668 | label 1; |
| 5669 | var lsp,lsp1,lsp2,lsp3: stp; varts: integer; |
| 5670 | lsize: addrrange; lval: valu; tagc: integer; tagrec: boolean; |
| 5671 | ct: boolean; cc,pc: integer; |
| 5672 | begin |
| 5673 | if disp then begin |
| 5674 | expression(fsys + [comma, rparent], false); |
| 5675 | load |
| 5676 | end else begin |
| 5677 | variable(fsys + [comma,rparent], false); |
| 5678 | loadaddress |
| 5679 | end; |
| 5680 | ct := false; |
| 5681 | if gattr.typtr <> nil then |
| 5682 | if gattr.typtr^.form = pointer then |
| 5683 | if gattr.typtr^.eltype <> nil then |
| 5684 | ct := gattr.typtr^.eltype^.form = arrayc; |
| 5685 | if ct then begin { container array } |
| 5686 | if disp then gen0(113(*vdd*)) |
| 5687 | else begin lsp := gattr.typtr^.eltype; |
| 5688 | cc := containers(lsp); { find no. containers } |
| 5689 | pc := 0; |
| 5690 | while sy = comma do begin insymbol; |
| 5691 | expression(fsys+[comma,rparent], false); load; |
| 5692 | if gattr.typtr <> nil then |
| 5693 | if basetype(gattr.typtr) <> intptr then error(243); |
| 5694 | pc := pc+1; |
| 5695 | gen1(72(*swp*),ptrsize) { keep the var address on top } |
| 5696 | end; |
| 5697 | if pc <> cc then error(269); |
| 5698 | { issue vector init dynamic instruction } |
| 5699 | gen2(112(*vin*),pc,containerbase(lsp)); |
| 5700 | { remove initializers, var addr } |
| 5701 | mesl(pc*intsize+adrsize) |
| 5702 | end |
| 5703 | end else begin |
| 5704 | lsp := nil; varts := 0; lsize := 0; tagc := 0; tagrec := false; |
| 5705 | if gattr.typtr <> nil then |
| 5706 | with gattr.typtr^ do |
| 5707 | if form = pointer then |
| 5708 | begin |
| 5709 | if eltype <> nil then |
| 5710 | begin lsize := eltype^.size; |
| 5711 | if eltype^.form = records then lsp := eltype^.recvar |
| 5712 | end |
| 5713 | end |
| 5714 | else error(116); |
| 5715 | tagrec := taggedrec(lsp); |
| 5716 | while sy = comma do |
| 5717 | begin insymbol;constexpr(fsys + [comma,rparent],lsp1,lval); |
| 5718 | if not lval.intval then |
| 5719 | begin lval.intval := true; lval.ival := 1 end; |
| 5720 | varts := varts + 1; lsp2 := lsp1; |
| 5721 | (*check to insert here: is constant in tagfieldtype range*) |
| 5722 | if lsp = nil then error(158) |
| 5723 | else |
| 5724 | if lsp^.form <> tagfld then error(162) |
| 5725 | else |
| 5726 | if lsp^.tagfieldp <> nil then |
| 5727 | if stringt(lsp1) or (lsp1 = realptr) then error(159) |
| 5728 | else |
| 5729 | if comptypes(lsp^.tagfieldp^.idtype,lsp1) then |
| 5730 | begin |
| 5731 | lsp3 := lsp; lsp1 := lsp^.fstvar; |
| 5732 | while lsp1 <> nil do |
| 5733 | with lsp1^ do |
| 5734 | if varval.ival = lval.ival then |
| 5735 | begin lsize := size; lsp := subvar; |
| 5736 | if debug then begin |
| 5737 | if lsp3^.vart = nil then error(510); |
| 5738 | if lsp2=charptr then |
| 5739 | gen2(51(*ldc*),6,lsp3^.vart^[varval.ival]) |
| 5740 | else |
| 5741 | gen2(51(*ldc*),1,lsp3^.vart^[varval.ival]) |
| 5742 | end; |
| 5743 | tagc := tagc+1; |
| 5744 | goto 1 |
| 5745 | end |
| 5746 | else lsp1 := nxtvar; |
| 5747 | lsize := lsp^.size; lsp := nil; |
| 5748 | end |
| 5749 | else error(116); |
| 5750 | 1: end (*while*) ; |
| 5751 | if debug and tagrec then gen2(51(*ldc*),1,tagc); |
| 5752 | gen2(51(*ldc*),1,lsize); |
| 5753 | if debug and tagrec then begin |
| 5754 | if lkey = 9 then gen1(30(*csp*),42(*nwl*)) |
| 5755 | else gen1(30(*csp*),43(*dsl*)); |
| 5756 | mesl(tagc*intsize) |
| 5757 | end else begin |
| 5758 | if lkey = 9 then gen1(30(*csp*),12(*new*)) |
| 5759 | else gen1(30(*csp*),29(*dsp*)) |
| 5760 | end |
| 5761 | end |
| 5762 | end (*newdisposeprocedure*) ; |
| 5763 | |
| 5764 | procedure absfunction; |
| 5765 | begin |
| 5766 | if gattr.typtr <> nil then |
| 5767 | if gattr.typtr = intptr then gen0(0(*abi*)) |
| 5768 | else |
| 5769 | if gattr.typtr = realptr then gen0(1(*abr*)) |
| 5770 | else begin error(125); gattr.typtr := intptr end |
| 5771 | end (*abs*) ; |
| 5772 | |
| 5773 | procedure sqrfunction; |
| 5774 | begin |
| 5775 | if gattr.typtr <> nil then |
| 5776 | if gattr.typtr = intptr then gen0(24(*sqi*)) |
| 5777 | else |
| 5778 | if gattr.typtr = realptr then gen0(25(*sqr*)) |
| 5779 | else begin error(125); gattr.typtr := intptr end |
| 5780 | end (*sqr*) ; |
| 5781 | |
| 5782 | procedure truncfunction; |
| 5783 | begin |
| 5784 | if gattr.typtr <> nil then |
| 5785 | if gattr.typtr <> realptr then error(125); |
| 5786 | gen0(27(*trc*)); |
| 5787 | gattr.typtr := intptr |
| 5788 | end (*trunc*) ; |
| 5789 | |
| 5790 | procedure roundfunction; |
| 5791 | begin |
| 5792 | if gattr.typtr <> nil then |
| 5793 | if gattr.typtr <> realptr then error(125); |
| 5794 | gen0(61(*rnd*)); |
| 5795 | gattr.typtr := intptr |
| 5796 | end (*round*) ; |
| 5797 | |
| 5798 | procedure oddfunction; |
| 5799 | begin |
| 5800 | if gattr.typtr <> nil then |
| 5801 | if gattr.typtr <> intptr then error(125); |
| 5802 | gen0(20(*odd*)); |
| 5803 | gattr.typtr := boolptr |
| 5804 | end (*odd*) ; |
| 5805 | |
| 5806 | procedure ordfunction; |
| 5807 | begin |
| 5808 | if gattr.typtr <> nil then |
| 5809 | if gattr.typtr^.form >= pointer then error(125); |
| 5810 | gen0t(58(*ord*),gattr.typtr); |
| 5811 | gattr.typtr := intptr |
| 5812 | end (*ord*) ; |
| 5813 | |
| 5814 | procedure chrfunction; |
| 5815 | begin |
| 5816 | if gattr.typtr <> nil then |
| 5817 | if gattr.typtr <> intptr then error(125); |
| 5818 | gen0(59(*chr*)); |
| 5819 | gattr.typtr := charptr |
| 5820 | end (*chr*) ; |
| 5821 | |
| 5822 | procedure predsuccfunction; |
| 5823 | begin |
| 5824 | if gattr.typtr <> nil then |
| 5825 | if gattr.typtr^.form <> scalar then error(125); |
| 5826 | if lkey = 7 then gen1t(31(*dec*),1,gattr.typtr) |
| 5827 | else gen1t(34(*inc*),1,gattr.typtr) |
| 5828 | end (*predsucc*) ; |
| 5829 | |
| 5830 | procedure eofeolnfunction; |
| 5831 | begin |
| 5832 | if sy = lparent then |
| 5833 | begin insymbol; variable(fsys + [rparent], false); |
| 5834 | if sy = rparent then insymbol else error(4); |
| 5835 | loadaddress |
| 5836 | end |
| 5837 | else begin |
| 5838 | if not inputptr^.hdr then error(175); |
| 5839 | gen1(37(*lao*),inputptr^.vaddr); |
| 5840 | gattr.typtr := textptr |
| 5841 | end; |
| 5842 | if gattr.typtr <> nil then |
| 5843 | if gattr.typtr^.form <> files then error(125) |
| 5844 | else if (lkey = 10) and (gattr.typtr <> textptr) then error(116); |
| 5845 | if lkey = 9 then begin |
| 5846 | if gattr.typtr = textptr then gen1(30(*csp*),44(*eof*)) |
| 5847 | else gen1(30(*csp*),45(*efb*)) |
| 5848 | end else gen1(30(*csp*),14(*eln*)); |
| 5849 | gattr.typtr := boolptr |
| 5850 | end (*eof*) ; |
| 5851 | |
| 5852 | procedure assignprocedure; |
| 5853 | var len: addrrange; lattr: attr; |
| 5854 | begin chkstd; chkhdr; |
| 5855 | variable(fsys+[comma,rparent], false); loadaddress; |
| 5856 | if gattr.typtr <> nil then |
| 5857 | if gattr.typtr^.form <> files then error(125); |
| 5858 | if sy = comma then insymbol else error(20); |
| 5859 | lattr := gattr; |
| 5860 | expression(fsys + [rparent], false); loadaddress; |
| 5861 | if not stringt(gattr.typtr) then error(208); |
| 5862 | if gattr.typtr <> nil then begin |
| 5863 | len := gattr.typtr^.size div charmax; |
| 5864 | if not complext(gattr.typtr) then gen2(51(*ldc*),1,len); |
| 5865 | if lattr.typtr = textptr then { text } |
| 5866 | gen1(30(*csp*),49(*asst*)) |
| 5867 | else { binary } |
| 5868 | gen1(30(*csp*),59(*assb*)) |
| 5869 | end |
| 5870 | end; |
| 5871 | |
| 5872 | procedure closeupdateappendprocedure; |
| 5873 | begin chkstd; chkhdr; |
| 5874 | variable(fsys+[rparent], false); loadaddress; |
| 5875 | if gattr.typtr <> nil then |
| 5876 | if gattr.typtr^.form <> files then error(125); |
| 5877 | if lkey = 20 then begin |
| 5878 | if gattr.typtr = textptr then { text } |
| 5879 | gen1(30(*csp*),50(*clst*)) |
| 5880 | else { binary } |
| 5881 | gen1(30(*csp*),60(*clst*)) |
| 5882 | end else if lkey = 24 then begin |
| 5883 | if gattr.typtr = textptr then error(262); |
| 5884 | gen1(30(*csp*),52(*upd*)) |
| 5885 | end else begin |
| 5886 | if gattr.typtr = textptr then { text } |
| 5887 | gen1(30(*csp*),53(*appt*)) |
| 5888 | else { binary } |
| 5889 | gen1(30(*csp*),61(*appb*)) |
| 5890 | end |
| 5891 | end; |
| 5892 | |
| 5893 | procedure positionprocedure; |
| 5894 | begin chkstd; chkhdr; |
| 5895 | variable(fsys+[comma,rparent], false); loadaddress; |
| 5896 | if gattr.typtr <> nil then begin |
| 5897 | if gattr.typtr^.form <> files then error(125); |
| 5898 | if gattr.typtr = textptr then error(262); |
| 5899 | end; |
| 5900 | if sy = comma then insymbol else error(20); |
| 5901 | expression(fsys + [rparent], false); load; |
| 5902 | if gattr.typtr <> nil then |
| 5903 | if gattr.typtr <> intptr then error(125); |
| 5904 | gen1(30(*csp*),51(*pos*)); |
| 5905 | end; |
| 5906 | |
| 5907 | procedure deleteprocedure; |
| 5908 | var len: addrrange; |
| 5909 | begin chkstd; |
| 5910 | expression(fsys + [rparent], false); loadaddress; |
| 5911 | if not stringt(gattr.typtr) then error(208); |
| 5912 | if gattr.typtr <> nil then begin |
| 5913 | if not complext(gattr.typtr) then begin |
| 5914 | len := gattr.typtr^.size div charmax; |
| 5915 | gen2(51(*ldc*),1,len) |
| 5916 | end; |
| 5917 | gen1(30(*csp*),54(*del*)); |
| 5918 | end |
| 5919 | end; |
| 5920 | |
| 5921 | procedure changeprocedure; |
| 5922 | var len: addrrange; |
| 5923 | begin chkstd; |
| 5924 | expression(fsys + [comma,rparent], false); loadaddress; |
| 5925 | if not stringt(gattr.typtr) then error(208); |
| 5926 | if gattr.typtr <> nil then |
| 5927 | if not complext(gattr.typtr) then begin |
| 5928 | len := gattr.typtr^.size div charmax; |
| 5929 | gen2(51(*ldc*),1,len) |
| 5930 | end; |
| 5931 | if sy = comma then insymbol else error(20); |
| 5932 | expression(fsys + [rparent], false); loadaddress; |
| 5933 | if not stringt(gattr.typtr) then error(208); |
| 5934 | if gattr.typtr <> nil then |
| 5935 | if not complext(gattr.typtr) then begin |
| 5936 | len := gattr.typtr^.size div charmax; |
| 5937 | gen2(51(*ldc*),1,len) |
| 5938 | end; |
| 5939 | gen1(30(*csp*),55(*del*)); |
| 5940 | end; |
| 5941 | |
| 5942 | procedure lengthlocationfunction; |
| 5943 | begin chkstd; chkhdr; |
| 5944 | if sy = lparent then insymbol else error(9); |
| 5945 | variable(fsys+[rparent], false); loadaddress; |
| 5946 | if gattr.typtr <> nil then begin |
| 5947 | if gattr.typtr^.form <> files then error(125); |
| 5948 | if gattr.typtr = textptr then error(262); |
| 5949 | end; |
| 5950 | if lkey = 21 then gen1(30(*csp*),56(*len*)) |
| 5951 | else gen1(30(*csp*),57(*loc*)); |
| 5952 | if sy = rparent then insymbol else error(4); |
| 5953 | gattr.typtr := intptr |
| 5954 | end; |
| 5955 | |
| 5956 | procedure existsfunction; |
| 5957 | var len: addrrange; |
| 5958 | begin chkstd; |
| 5959 | if sy = lparent then insymbol else error(9); |
| 5960 | expression(fsys + [rparent], false); loadaddress; |
| 5961 | if not stringt(gattr.typtr) then error(208); |
| 5962 | if gattr.typtr <> nil then begin |
| 5963 | if not complext(gattr.typtr) then begin |
| 5964 | len := gattr.typtr^.size div charmax; |
| 5965 | gen2(51(*ldc*),1,len) |
| 5966 | end; |
| 5967 | gen1(30(*csp*),58(*exs*)) |
| 5968 | end; |
| 5969 | if sy = rparent then insymbol else error(4); |
| 5970 | gattr.typtr := boolptr |
| 5971 | end; |
| 5972 | |
| 5973 | procedure haltprocedure; |
| 5974 | begin chkstd; |
| 5975 | gen1(30(*csp*),62(*hlt*)) |
| 5976 | end; |
| 5977 | |
| 5978 | procedure assertprocedure; |
| 5979 | var len: addrrange; |
| 5980 | begin chkstd; |
| 5981 | expression(fsys+[comma,rparent], false); load; |
| 5982 | if gattr.typtr <> nil then |
| 5983 | if gattr.typtr <> boolptr then error(135); |
| 5984 | if sy = comma then begin insymbol; |
| 5985 | expression(fsys + [rparent], false); loadaddress; |
| 5986 | if not stringt(gattr.typtr) then error(208); |
| 5987 | if gattr.typtr <> nil then begin |
| 5988 | if not complext(gattr.typtr) then begin |
| 5989 | len := gattr.typtr^.size div charmax; |
| 5990 | gen2(51(*ldc*),1,len) |
| 5991 | end; |
| 5992 | gen1(30(*csp*),64(*asts*)) |
| 5993 | end |
| 5994 | end else |
| 5995 | gen1(30(*csp*),63(*ast*)) |
| 5996 | end; |
| 5997 | |
| 5998 | procedure throwprocedure; |
| 5999 | begin chkstd; |
| 6000 | variable(fsys+[rparent], false); loadaddress; |
| 6001 | if gattr.typtr <> nil then begin |
| 6002 | if gattr.typtr^.form <> exceptf then error(226); |
| 6003 | end; |
| 6004 | gen1(30(*csp*),85(*thw*)) |
| 6005 | end; |
| 6006 | |
| 6007 | procedure referprocedure; |
| 6008 | var lcp: ctp; |
| 6009 | begin chkstd; |
| 6010 | if sy <> ident then begin |
| 6011 | error(2); skip(fsys + [comma,rparent]) |
| 6012 | end else begin |
| 6013 | searchid([types,konst,vars,fixedt,field,func,proc],lcp); |
| 6014 | lcp^.refer := true; |
| 6015 | insymbol |
| 6016 | end |
| 6017 | end; |
| 6018 | |
| 6019 | procedure seterrprocedure; |
| 6020 | begin chkstd; |
| 6021 | expression(fsys + [rparent], false); load; |
| 6022 | if gattr.typtr <> nil then |
| 6023 | if gattr.typtr <> intptr then error(125); |
| 6024 | gen1(30(*csp*),115(*sete*)); |
| 6025 | end; |
| 6026 | |
| 6027 | procedure maxfunction; |
| 6028 | var lattr: attr; |
| 6029 | begin chkstd; |
| 6030 | if sy = lparent then insymbol else error(9); |
| 6031 | variable(fsys+[rparent,comma], false); loadaddress; |
| 6032 | if gattr.typtr <> nil then |
| 6033 | if gattr.typtr^.form <> arrayc then error(273); |
| 6034 | lattr := gattr; |
| 6035 | if sy = comma then begin insymbol; |
| 6036 | expression(fsys + [rparent], false); load; |
| 6037 | if gattr.typtr <> nil then if gattr.typtr <> intptr then error(125) |
| 6038 | end else gen2(51(*ldc*),1,1); { default level 1 } |
| 6039 | gen1(106(*max*),containers(lattr.typtr)); |
| 6040 | if sy = rparent then insymbol else error(4); |
| 6041 | gattr.typtr := intptr |
| 6042 | end; |
| 6043 | |
| 6044 | procedure callnonstandard(fcp: ctp; inherit: boolean); |
| 6045 | var nxt,lcp,fcpe,fcps,nxts: ctp; lsp: stp; lkind: idkind; lb: boolean; |
| 6046 | locpar, llc, soff: addrrange; varp: boolean; lsize: addrrange; |
| 6047 | frlab: integer; prcnt: integer; ovrl: boolean; |
| 6048 | test: boolean; match: boolean; e: boolean; mm: boolean; |
| 6049 | { This overload does not match, sequence to the next, same parameter. |
| 6050 | Set sets fcp -> new proc/func, nxt -> next parameter in new list. |
| 6051 | fcp = nil, nxt = nil for no next found. } |
| 6052 | procedure nxtprc; |
| 6053 | var pc: integer; fcpn, fcpf: ctp; |
| 6054 | { compare parameter lists until current } |
| 6055 | function cmplst(pl1, pl2: ctp): boolean; |
| 6056 | var pc: integer; |
| 6057 | begin cmplst := false; pc := 1; |
| 6058 | while (pc < prcnt) and (pl1 <> nil) and (pl2 <> nil) and cmppar(pl1, pl2) do begin |
| 6059 | pl1 := pl1^.next; |
| 6060 | pl2 := pl2^.next; |
| 6061 | pc := pc+1 |
| 6062 | end; |
| 6063 | { compared all list left } |
| 6064 | cmplst := pc = prcnt |
| 6065 | end; |
| 6066 | begin pc := 1; |
| 6067 | fcpn := fcp^.grpnxt; { go next proc/func, which may not exist } |
| 6068 | fcpf := nil; { set none found } |
| 6069 | while fcpn <> nil do begin { search next for match } |
| 6070 | if (isfunc and (fcpn^.klass = func)) or (not isfunc and (fcpn^.klass = proc)) then |
| 6071 | if cmplst(fcp^.pflist, fcpn^.pflist) then |
| 6072 | begin fcpf := fcpn; fcpn := nil end |
| 6073 | else fcpn := fcpn^.grpnxt { next group proc/func } |
| 6074 | else fcpn := fcpn^.grpnxt |
| 6075 | end; |
| 6076 | fcp := fcpf; nxt := nil; { set found/not found } |
| 6077 | if fcp <> nil then begin { recover parameter position in new list } |
| 6078 | nxt := fcp^.pflist; |
| 6079 | while pc < prcnt do begin if nxt <> nil then nxt := nxt^.next; pc := pc+1 end |
| 6080 | end |
| 6081 | end; |
| 6082 | begin { callnonstandard } |
| 6083 | soff := abs(topnew); { save stack net offset } |
| 6084 | fcpe := fcp; fcp := fcp^.grppar; locpar := 0; genlabel(frlab); |
| 6085 | while ((isfunc and (fcp^.klass <> func)) or |
| 6086 | (not isfunc and (fcp^.klass <> proc))) and (fcp^.grpnxt <> nil) do |
| 6087 | fcp := fcp^.grpnxt; |
| 6088 | if isfunc and (fcp^.klass <> func) then error(292) |
| 6089 | else if not isfunc and (fcp^.klass <> proc) then error(293); |
| 6090 | prcnt := 1; ovrl := fcp^.grpnxt <> nil; |
| 6091 | with fcp^ do |
| 6092 | begin nxt := pflist; lkind := pfkind; |
| 6093 | { I don't know why these are dups, guess is a badly formed far call } |
| 6094 | if pfkind = actual then begin { it's a system call } |
| 6095 | if not sysrot then gensfr(frlab) |
| 6096 | end else gensfr(frlab) { its an indirect } |
| 6097 | end; |
| 6098 | if sy = lparent then |
| 6099 | begin llc := lc; insymbol; |
| 6100 | repeat lb := false; (*decide whether proc/func must be passed*) |
| 6101 | if nxt = nil then begin |
| 6102 | { out of parameters, try to find another overload } |
| 6103 | nxtprc; |
| 6104 | if fcp = nil then begin |
| 6105 | { dispatch error according to overload status } |
| 6106 | if ovrl then error(275) else error(126); |
| 6107 | fcp := fcpe |
| 6108 | end |
| 6109 | end; |
| 6110 | e := false; |
| 6111 | if (sy = ident) and (fcp^.grpnxt <> nil) then begin |
| 6112 | { next is id, and proc/func is overload, try proc/func parameter } |
| 6113 | match := false; |
| 6114 | searchidnenm([proc,func],lcp,mm); |
| 6115 | fcps := fcp; nxts := nxt; |
| 6116 | if (lcp <> nil) and (nxt <> nil) then |
| 6117 | if lcp^.klass in [proc,func] then begin |
| 6118 | { Search matching overload. For proc/func parameters, we allow |
| 6119 | all features of the target to match, including function |
| 6120 | result. } |
| 6121 | repeat |
| 6122 | if nxt^.klass = proc then begin |
| 6123 | if cmpparlst(nxt^.pflist, lcp^.pflist) then match := true |
| 6124 | end else if nxt^.klass = func then begin |
| 6125 | if cmpparlst(nxt^.pflist, lcp^.pflist) then |
| 6126 | if comptypes(lcp^.idtype,nxt^.idtype) then match := true |
| 6127 | end; |
| 6128 | if not match then nxtprc { no match get next overload } |
| 6129 | until match or (fcp = nil); |
| 6130 | { proc/func param not found, reset to previous place } |
| 6131 | if fcp = nil then begin fcp := fcps; nxt := nxts end |
| 6132 | end |
| 6133 | end; |
| 6134 | { match same thing for all procs/funcs } |
| 6135 | if nxt <> nil then lb := nxt^.klass in [proc,func]; |
| 6136 | if lb then (*pass function or procedure*) |
| 6137 | begin |
| 6138 | if sy <> ident then |
| 6139 | begin error(2); skip(fsys + [comma,rparent]) end |
| 6140 | else if nxt <> nil then |
| 6141 | begin |
| 6142 | if nxt^.klass = proc then searchid([proc],lcp) |
| 6143 | else |
| 6144 | begin searchid([func],lcp); |
| 6145 | { compare result types } |
| 6146 | if not comptypes(lcp^.idtype,nxt^.idtype) then |
| 6147 | if not e then error(128) |
| 6148 | end; |
| 6149 | { compare parameter lists } |
| 6150 | if (nxt^.klass in [proc,func]) and |
| 6151 | (lcp^.klass in [proc,func]) then |
| 6152 | if not cmpparlst(nxt^.pflist, lcp^.pflist) then |
| 6153 | if not e then error(189); |
| 6154 | if lcp^.pfkind = actual then |
| 6155 | genlpa(lcp^.pfname,level-(level-lcp^.pflev)) |
| 6156 | else gen2(74(*lip*),level-(level-lcp^.pflev),lcp^.pfaddr); |
| 6157 | locpar := locpar+ptrsize*2; |
| 6158 | insymbol; |
| 6159 | if not (sy in fsys + [comma,rparent]) then |
| 6160 | begin error(6); skip(fsys + [comma,rparent]) end |
| 6161 | end |
| 6162 | end (*if lb*) |
| 6163 | else |
| 6164 | begin varp := false; |
| 6165 | if nxt <> nil then varp := (nxt^.vkind = formal) and (nxt^.part <> ptview); |
| 6166 | expression(fsys + [comma,rparent], varp); |
| 6167 | { find the appropriate overload } |
| 6168 | match := false; |
| 6169 | repeat |
| 6170 | if (nxt <> nil) and (gattr.typtr <> nil) then |
| 6171 | if nxt^.idtype <> nil then begin |
| 6172 | if comptypes(nxt^.idtype, gattr.typtr) or |
| 6173 | { special rule: const char matches container } |
| 6174 | ((nxt^.idtype^.form = arrayc) and |
| 6175 | chart(gattr.typtr) and (gattr.kind = cst)) then |
| 6176 | match := true |
| 6177 | else if comptypes(realptr,nxt^.idtype) and |
| 6178 | (gattr.typtr = intptr) then match := true |
| 6179 | end; |
| 6180 | if not match then nxtprc { no match get next overload } |
| 6181 | until match or (fcp = nil); |
| 6182 | if fcp = nil then begin if ovrl then error(277) else error(189); |
| 6183 | e := true; fcp := fcpe end; |
| 6184 | { override variable status for view parameter } |
| 6185 | if nxt <> nil then varp := (nxt^.vkind = formal) and not (nxt^.part = ptview); |
| 6186 | if varp and (gattr.kind <> varbl) then error(278); |
| 6187 | if gattr.typtr <> nil then |
| 6188 | begin |
| 6189 | if nxt <> nil then |
| 6190 | begin lsp := nxt^.idtype; |
| 6191 | if lsp <> nil then |
| 6192 | begin |
| 6193 | if (nxt^.vkind = actual) or (nxt^.part = ptview) then begin |
| 6194 | if not comptypes(lsp,gattr.typtr) and not |
| 6195 | { special rule: const char matches container } |
| 6196 | ((nxt^.idtype^.form = arrayc) and |
| 6197 | chart(gattr.typtr) and (gattr.kind = cst)) and not |
| 6198 | (comptypes(realptr,lsp) and |
| 6199 | (gattr.typtr = intptr)) then |
| 6200 | if not e then error(142); |
| 6201 | if lsp^.form <= power then |
| 6202 | begin load; |
| 6203 | if debug then checkbnds(lsp); |
| 6204 | if comptypes(realptr,lsp) |
| 6205 | and (gattr.typtr = intptr) then |
| 6206 | begin gen0(10(*flt*)); |
| 6207 | gattr.typtr := realptr |
| 6208 | end; |
| 6209 | locpar := locpar+lsp^.size; |
| 6210 | alignu(parmptr,locpar); |
| 6211 | end |
| 6212 | else if stringt(lsp) and ischrcst(gattr) then |
| 6213 | begin { is char to string } |
| 6214 | gen2(51(*ldc*),1,1); |
| 6215 | gensca(chr(gattr.cval.ival)); |
| 6216 | gen2(124(*mpc*),0,0); |
| 6217 | locpar := locpar+ptrsize*2; |
| 6218 | alignu(parmptr,locpar) |
| 6219 | end else begin |
| 6220 | loadaddress; |
| 6221 | fixpar(lsp,gattr.typtr); |
| 6222 | if lsp^.form = arrayc then |
| 6223 | locpar := locpar+ptrsize*2 |
| 6224 | else locpar := locpar+ptrsize; |
| 6225 | alignu(parmptr,locpar) |
| 6226 | end |
| 6227 | end else begin |
| 6228 | if gattr.kind = varbl then |
| 6229 | begin if gattr.packcom then error(197); |
| 6230 | if gattr.tagfield then error(198); |
| 6231 | loadaddress; |
| 6232 | fixpar(lsp,gattr.typtr); |
| 6233 | if lsp^.form = arrayc then |
| 6234 | locpar := locpar+ptrsize*2 |
| 6235 | else locpar := locpar+ptrsize; |
| 6236 | alignu(parmptr,locpar); |
| 6237 | end |
| 6238 | else error(154); |
| 6239 | if (lsp^.form = arrayc) and not iso7185 then begin |
| 6240 | if not comptypes(lsp, gattr.typtr) |
| 6241 | and not e then error(289) |
| 6242 | end else if lsp <> gattr.typtr then |
| 6243 | if not e then error(199) |
| 6244 | end |
| 6245 | end |
| 6246 | end |
| 6247 | end |
| 6248 | end; |
| 6249 | if nxt <> nil then nxt := nxt^.next; |
| 6250 | prcnt := prcnt+1; |
| 6251 | test := sy <> comma; |
| 6252 | if sy = comma then insymbol; |
| 6253 | until test; |
| 6254 | lc := llc; |
| 6255 | if sy = rparent then insymbol else error(4) |
| 6256 | end (*if lparent*); |
| 6257 | { not out of proto parameters, sequence until we are or there are no |
| 6258 | candidate overloads } |
| 6259 | if nxt <> nil then begin |
| 6260 | while (fcp <> nil) and (nxt <> nil) do begin |
| 6261 | nxtprc; |
| 6262 | if fcp = nil then if ovrl then error(277) else error(189) |
| 6263 | end |
| 6264 | end; |
| 6265 | if fcp = nil then begin if ovrl then error(277) else error(189); |
| 6266 | fcp := fcpe end; |
| 6267 | { find function result size } |
| 6268 | lsize := 0; |
| 6269 | if (fcp^.klass = func) and (fcp^.idtype <> nil) then begin |
| 6270 | lsize := fcp^.idtype^.size; |
| 6271 | alignu(parmptr,lsize); |
| 6272 | end; |
| 6273 | if prcode then begin prtlabel(frlab); writeln(prr,'=',lsize:1) end; |
| 6274 | if lkind = actual then |
| 6275 | begin if fcp = nil then if ovrl then error(275) else error(126); |
| 6276 | with fcp^ do |
| 6277 | begin |
| 6278 | if sysrot then gen1(30(*csp*),pfname) |
| 6279 | else begin |
| 6280 | if (pfattr = fpavirtual) or (pfattr = fpaoverride) then begin |
| 6281 | if inherit then begin |
| 6282 | fcp := ovrpf(fcp); if fcp = nil then error(516); |
| 6283 | if fcp^.pfattr <> fpaoverride then error(507); |
| 6284 | { inherited calls will never be far } |
| 6285 | if fcp^.klass = func then |
| 6286 | gencuvcvf(125(*cvf*), locpar, fcp^.pfvaddr,fcp,nil) |
| 6287 | else |
| 6288 | gencuvcvf(91(*cuv*), locpar, fcp^.pfvaddr,fcp,nil) |
| 6289 | end else begin |
| 6290 | lcp := fcp^.grppar; |
| 6291 | if lcp^.pfvid <> nil then begin |
| 6292 | if fcp^.klass = func then |
| 6293 | gencuvcvf(125(*cvf*), locpar, lcp^.pfvid^.vaddr,fcp, lcp^.pfvid) |
| 6294 | else |
| 6295 | gencuvcvf(91(*cuv*), locpar, lcp^.pfvid^.vaddr,fcp, lcp^.pfvid) |
| 6296 | end |
| 6297 | end |
| 6298 | end else begin |
| 6299 | if inherit then error(234); |
| 6300 | if fcp^.klass = func then |
| 6301 | gencupcuf(122(*cuf*),locpar,pfname,fcp) |
| 6302 | else |
| 6303 | gencupcuf(46(*cup*),locpar,pfname,fcp) |
| 6304 | end; |
| 6305 | mesl(-lsize) |
| 6306 | end |
| 6307 | end |
| 6308 | end |
| 6309 | else begin { call procedure or function parameter } |
| 6310 | gen2(50(*lda*),level-(level-fcp^.pflev),fcp^.pfaddr); |
| 6311 | if fcp^.klass = func then gencipcif(123(*cif*), fcp) |
| 6312 | else gencipcif(67(*cip*), fcp); |
| 6313 | gen1(32(*rip*),lcs+lsize+soff); |
| 6314 | mesl(locpar); { remove stack parameters } |
| 6315 | mesl(-lsize) |
| 6316 | end; |
| 6317 | gattr.typtr := fcp^.idtype |
| 6318 | end (*callnonstandard*) ; |
| 6319 | |
| 6320 | begin (*call*) |
| 6321 | if fcp^.pfdeckind = standard then |
| 6322 | begin lkey := fcp^.key; if inherit then error(233); |
| 6323 | if fcp^.klass = proc then |
| 6324 | begin |
| 6325 | if not(lkey in [5,6,11,12,17,29]) then |
| 6326 | if sy = lparent then insymbol else error(9); |
| 6327 | case lkey of |
| 6328 | 1,2, |
| 6329 | 3,4: getputresetrewriteprocedure; |
| 6330 | 17: pageprocedure; |
| 6331 | 5,11: readprocedure; |
| 6332 | 6,12: writeprocedure; |
| 6333 | 7: packprocedure; |
| 6334 | 8: unpackprocedure; |
| 6335 | 9,18: newdisposeprocedure(lkey = 18); |
| 6336 | 19: assignprocedure; |
| 6337 | 20, 24, |
| 6338 | 25: closeupdateappendprocedure; |
| 6339 | 23: positionprocedure; |
| 6340 | 27: deleteprocedure; |
| 6341 | 28: changeprocedure; |
| 6342 | 29: haltprocedure; |
| 6343 | 30: assertprocedure; |
| 6344 | 31: throwprocedure; |
| 6345 | 32: referprocedure; |
| 6346 | 33: seterrprocedure; |
| 6347 | |
| 6348 | 10,13: error(508) |
| 6349 | end; |
| 6350 | if not(lkey in [5,6,11,12,17,29]) then |
| 6351 | if sy = rparent then insymbol else error(4) |
| 6352 | end |
| 6353 | else |
| 6354 | begin |
| 6355 | if (lkey <= 8) or (lkey = 16) then |
| 6356 | begin |
| 6357 | if sy = lparent then insymbol else error(9); |
| 6358 | expression(fsys+[rparent], false); load |
| 6359 | end; |
| 6360 | case lkey of |
| 6361 | 1: absfunction; |
| 6362 | 2: sqrfunction; |
| 6363 | 3: truncfunction; |
| 6364 | 16: roundfunction; |
| 6365 | 4: oddfunction; |
| 6366 | 5: ordfunction; |
| 6367 | 6: chrfunction; |
| 6368 | 7,8: predsuccfunction; |
| 6369 | 9,10: eofeolnfunction; |
| 6370 | 21,22: lengthlocationfunction; |
| 6371 | 26: existsfunction; |
| 6372 | 32: maxfunction; |
| 6373 | end; |
| 6374 | if (lkey <= 8) or (lkey = 16) then |
| 6375 | if sy = rparent then insymbol else error(4) |
| 6376 | end; |
| 6377 | end (*standard procedures and functions*) |
| 6378 | else begin callnonstandard(fcp,inherit); markline end |
| 6379 | end (*call*) ; |
| 6380 | |
| 6381 | function psize(sp: stp): addrrange; |
| 6382 | var ps: addrrange; |
| 6383 | begin ps := 0; |
| 6384 | if sp <> nil then begin |
| 6385 | if sp^.form = arrayc then ps := ptrsize*2 |
| 6386 | else if sp^.form <= power then ps := sp^.size |
| 6387 | else ps := ptrsize; |
| 6388 | alignu(parmptr, ps) |
| 6389 | end; |
| 6390 | psize := ps |
| 6391 | end; |
| 6392 | |
| 6393 | { call operator type with 1 parameter } |
| 6394 | procedure callop1(fcp: ctp); |
| 6395 | var frlab: integer; lsize: addrrange; locpar, locpars: addrrange; |
| 6396 | sp: stp; |
| 6397 | begin |
| 6398 | sp := partype(fcp, 1); |
| 6399 | genlabel(frlab); gensfr(frlab); |
| 6400 | { find uncoerced parameters size } |
| 6401 | locpars := psize(gattr.typtr); |
| 6402 | { find final parameters size } |
| 6403 | locpar := psize(sp); |
| 6404 | { find function result size } |
| 6405 | lsize := fcp^.idtype^.size; |
| 6406 | alignu(parmptr,lsize); |
| 6407 | { generate a stack hoist of parameters. Basically the common math on stack |
| 6408 | not formatted the same way as function calls, so we hoist the parameters |
| 6409 | over the mark, call and then drop the function result downwards. } |
| 6410 | if gattr.typtr <> nil then |
| 6411 | if (gattr.kind = expr) and (gattr.typtr^.form > power) then |
| 6412 | gen1(118(*lsa*),lsize) |
| 6413 | else gen2(116(*cpp*),lsize,locpars); |
| 6414 | { do coercions } |
| 6415 | if realt(sp) and intt(gattr.typtr) then |
| 6416 | begin gen0(10(*flt*)); gattr.typtr := realptr end; |
| 6417 | fixpar(sp,gattr.typtr); |
| 6418 | if prcode then begin prtlabel(frlab); writeln(prr,'=',lsize:1) end; |
| 6419 | gencupcuf(122(*cuf*),locpar,fcp^.pfname,fcp); |
| 6420 | gen2(117(*cpr*),lsize,locpars); |
| 6421 | gattr.typtr := fcp^.idtype |
| 6422 | end; |
| 6423 | |
| 6424 | { call operator type with 2 parameters } |
| 6425 | procedure callop2(fcp: ctp; var lattr: attr); |
| 6426 | var frlab: integer; lsize: addrrange; |
| 6427 | locpar, locpars, lpl, lpr, lpls, lprs: addrrange; |
| 6428 | lsp, rsp: stp; |
| 6429 | { check actual type can be coerced into formal } |
| 6430 | function fungible(fsp,asp: stp): boolean; |
| 6431 | begin fungible := false; |
| 6432 | if (fsp <> nil) and (asp <> nil) then begin |
| 6433 | if realt(fsp) and intt(asp) then fungible := true |
| 6434 | else if ((fsp^.form = arrayc) and (asp^.form = arrays)) or |
| 6435 | ((fsp^.form = arrays) and (asp^.form = arrayc)) then |
| 6436 | fungible := true |
| 6437 | end |
| 6438 | end; |
| 6439 | begin |
| 6440 | lsp := partype(fcp, 1); rsp := partype(fcp, 2); |
| 6441 | genlabel(frlab); gensfr(frlab); |
| 6442 | { find uncoerced parameters size } |
| 6443 | lpls := psize(lattr.typtr); lprs := psize(gattr.typtr); |
| 6444 | locpars := lpls+lprs; |
| 6445 | { find final parameters size } |
| 6446 | lpl := psize(lsp); lpr := psize(rsp); locpar := lpl+lpr; |
| 6447 | { find function result size } |
| 6448 | lsize := 0; |
| 6449 | if fcp^.klass = func then begin |
| 6450 | lsize := fcp^.idtype^.size; |
| 6451 | alignu(parmptr,lsize) |
| 6452 | end; |
| 6453 | { generate a stack hoist of parameters. Basically the common math on stack |
| 6454 | not formatted the same way as function calls, so we hoist the parameters |
| 6455 | over the mark, call and then drop the function result downwards. } |
| 6456 | if fungible(lsp, lattr.typtr) or (lattr.kind = expr) or |
| 6457 | fungible(rsp, gattr.typtr) or (gattr.kind = expr) then begin |
| 6458 | { bring the parameters up and convert them one by one } |
| 6459 | if lattr.typtr <> nil then |
| 6460 | if (lattr.kind = expr) and (lattr.typtr^.form > power) then |
| 6461 | gen1(118(*lsa*),lsize+lprs) |
| 6462 | else gen2(116(*cpp*),lsize+lprs,lpls); |
| 6463 | { do coercions } |
| 6464 | if realt(lsp) and intt(lattr.typtr) then |
| 6465 | begin gen0(10(*flt*)); lattr.typtr := realptr end; |
| 6466 | fixpar(lsp,lattr.typtr); |
| 6467 | if gattr.typtr <> nil then |
| 6468 | if (gattr.kind = expr) and (gattr.typtr^.form > power) then |
| 6469 | gen1(118(*lsa*),lsize+lpl) |
| 6470 | else gen2(116(*cpp*),lsize+lpl,lprs); |
| 6471 | { do coercions } |
| 6472 | if realt(rsp) and intt(gattr.typtr) then |
| 6473 | begin gen0(10(*flt*)); gattr.typtr := realptr end; |
| 6474 | fixpar(rsp,gattr.typtr); |
| 6475 | end else gen2(116(*cpp*),lsize,locpar); { get both params } |
| 6476 | if prcode then begin prtlabel(frlab); writeln(prr,'=',lsize:1) end; |
| 6477 | gencupcuf(122(*cuf*),locpar,fcp^.pfname,fcp); |
| 6478 | gen2(117(*cpr*),lsize,locpars); |
| 6479 | gattr.typtr := fcp^.idtype |
| 6480 | end; |
| 6481 | |
| 6482 | procedure expression(fsys: setofsys; threaten: boolean); |
| 6483 | var lattr: attr; lop: operatort; typind: char; lsize, lsizspc: addrrange; |
| 6484 | fcp: ctp; lschrcst, rschrcst, revcmp: boolean; |
| 6485 | lc, rc: char; |
| 6486 | |
| 6487 | procedure simpleexpression(fsys: setofsys; threaten: boolean); |
| 6488 | var lattr: attr; lop: operatort; fsy: symbol; fop: operatort; fcp: ctp; |
| 6489 | |
| 6490 | procedure term(fsys: setofsys; threaten: boolean); |
| 6491 | var lattr: attr; lop: operatort; fcp: ctp; |
| 6492 | |
| 6493 | procedure factor(fsys: setofsys; threaten: boolean); |
| 6494 | var lcp,fcp: ctp; lvp: csp; varpart: boolean; inherit: boolean; |
| 6495 | cstpart: setty; lsp: stp; tattr, rattr: attr; test: boolean; |
| 6496 | begin |
| 6497 | if not (sy in facbegsys) then |
| 6498 | begin error(58); skip(fsys + facbegsys); |
| 6499 | gattr.typtr := nil |
| 6500 | end; |
| 6501 | while sy in facbegsys do |
| 6502 | begin inherit := false; |
| 6503 | if sy = inheritedsy then begin insymbol; inherit := true; |
| 6504 | if not (sy in facbegsys) then |
| 6505 | begin error(58); skip(fsys + facbegsys); |
| 6506 | gattr.typtr := nil end; |
| 6507 | if sy <> ident then error(233); |
| 6508 | end; |
| 6509 | if sy in facbegsys then case sy of |
| 6510 | (*id*) ident: |
| 6511 | begin searchid([types,konst,vars,fixedt,field,func,proc],lcp); |
| 6512 | insymbol; |
| 6513 | if hasfunc(lcp) then |
| 6514 | begin call(fsys,lcp, inherit, true); |
| 6515 | with gattr do |
| 6516 | begin kind := expr; |
| 6517 | if typtr <> nil then |
| 6518 | if typtr^.form=subrange then |
| 6519 | typtr := typtr^.rangetype |
| 6520 | end |
| 6521 | end |
| 6522 | else begin if inherit then error(233); |
| 6523 | if lcp^.klass = konst then |
| 6524 | with gattr, lcp^ do |
| 6525 | begin typtr := idtype; kind := cst; |
| 6526 | cval := values |
| 6527 | end |
| 6528 | else |
| 6529 | if lcp^.klass = types then begin |
| 6530 | { type convert/restrict } |
| 6531 | chkstd; |
| 6532 | if lcp^.idtype <> nil then |
| 6533 | if (lcp^.idtype^.form <> scalar) and |
| 6534 | (lcp^.idtype^.form <> subrange) then |
| 6535 | error(223); |
| 6536 | { if simple underfined error and no () trailer, |
| 6537 | then assume it is just an undefined id } |
| 6538 | if (lcp <> utypptr) or (sy = lparent) then begin |
| 6539 | if sy <> lparent then error(9); |
| 6540 | insymbol; expression(fsys + [rparent], false); |
| 6541 | load; |
| 6542 | if sy = rparent then insymbol else error(4); |
| 6543 | if gattr.typtr <> nil then |
| 6544 | if (gattr.typtr^.form <> scalar) and |
| 6545 | (gattr.typtr^.form <> subrange) then |
| 6546 | error(224); |
| 6547 | { bounds check to target type } |
| 6548 | checkbnds(lcp^.idtype); |
| 6549 | gattr.typtr := lcp^.idtype { retype } |
| 6550 | end |
| 6551 | end else |
| 6552 | begin selector(fsys,lcp,false); |
| 6553 | if threaten and (lcp^.klass = vars) then with lcp^ do begin |
| 6554 | if vlev < level then threat := true; |
| 6555 | if forcnt > 0 then error(195); |
| 6556 | if part = ptview then error(290) |
| 6557 | end; |
| 6558 | if gattr.typtr<>nil then(*elim.subr.types to*) |
| 6559 | with gattr,typtr^ do(*simplify later tests*) |
| 6560 | end |
| 6561 | end |
| 6562 | end; |
| 6563 | (*cst*) intconst: |
| 6564 | begin |
| 6565 | with gattr do |
| 6566 | begin typtr := intptr; kind := cst; |
| 6567 | cval := val |
| 6568 | end; |
| 6569 | insymbol |
| 6570 | end; |
| 6571 | realconst: |
| 6572 | begin |
| 6573 | with gattr do |
| 6574 | begin typtr := realptr; kind := cst; |
| 6575 | cval := val |
| 6576 | end; |
| 6577 | insymbol |
| 6578 | end; |
| 6579 | stringconst: |
| 6580 | begin |
| 6581 | with gattr do |
| 6582 | begin |
| 6583 | if lgth = 1 then typtr := charptr |
| 6584 | else |
| 6585 | begin new(lsp,arrays); pshstc(lsp); |
| 6586 | with lsp^ do |
| 6587 | begin form:=arrays; aeltype := charptr; |
| 6588 | packing := true; inxtype := nil; tmpl := -1; |
| 6589 | size := lgth*charsize |
| 6590 | end; |
| 6591 | arrtmp(lsp); { output fixed template } |
| 6592 | typtr := lsp |
| 6593 | end; |
| 6594 | kind := cst; cval := val |
| 6595 | end; |
| 6596 | insymbol |
| 6597 | end; |
| 6598 | (* ( *) lparent: |
| 6599 | begin insymbol; expression(fsys + [rparent], false); |
| 6600 | if sy = rparent then insymbol else error(4) |
| 6601 | end; |
| 6602 | (*not*) notsy: |
| 6603 | begin insymbol; factor(fsys, false); |
| 6604 | if gattr.kind <> expr then |
| 6605 | if gattr.typtr <> nil then |
| 6606 | if gattr.typtr^.form <= power then load else loadaddress; |
| 6607 | fndopr1(notop, fcp); |
| 6608 | if fcp <> nil then callop1(fcp) else begin |
| 6609 | if (gattr.typtr = boolptr) or |
| 6610 | ((gattr.typtr = intptr) and not iso7185) then |
| 6611 | gen0t(19(*not*),gattr.typtr) |
| 6612 | else begin error(135); gattr.typtr := nil end |
| 6613 | end |
| 6614 | end; |
| 6615 | (*[*) lbrack: |
| 6616 | begin insymbol; cstpart := [ ]; varpart := false; |
| 6617 | new(lsp,power); pshstc(lsp); |
| 6618 | with lsp^ do |
| 6619 | begin form:=power; elset:=nil;size:=setsize; |
| 6620 | packing := false; matchpack := false end; |
| 6621 | if sy = rbrack then |
| 6622 | begin |
| 6623 | with gattr do |
| 6624 | begin typtr := lsp; kind := cst end; |
| 6625 | insymbol |
| 6626 | end |
| 6627 | else |
| 6628 | begin |
| 6629 | repeat |
| 6630 | expression(fsys + [comma,range,rbrack], false); |
| 6631 | rattr.typtr := nil; |
| 6632 | if sy = range then begin insymbol; |
| 6633 | { if the left side is not constant, load it |
| 6634 | and coerce it to integer now } |
| 6635 | if gattr.kind <> cst then begin |
| 6636 | load; |
| 6637 | if not comptypes(gattr.typtr,intptr) |
| 6638 | then gen0t(58(*ord*),gattr.typtr); |
| 6639 | end; |
| 6640 | tattr := gattr; |
| 6641 | expression(fsys + [comma,rbrack], false); |
| 6642 | rattr := gattr; gattr := tattr; |
| 6643 | end; |
| 6644 | if gattr.typtr <> nil then |
| 6645 | if (gattr.typtr^.form <> scalar) and |
| 6646 | (gattr.typtr^.form <> subrange) then |
| 6647 | begin error(136); gattr.typtr := nil end |
| 6648 | else if comptypes(gattr.typtr,realptr) then |
| 6649 | begin error(109); gattr.typtr := nil end |
| 6650 | else |
| 6651 | if comptypes(lsp^.elset,gattr.typtr) then |
| 6652 | begin |
| 6653 | if rattr.typtr <> nil then begin { x..y form } |
| 6654 | if (rattr.typtr^.form <> scalar) and |
| 6655 | (rattr.typtr^.form <> subrange) then |
| 6656 | begin error(136); rattr.typtr := nil end |
| 6657 | else if comptypes(rattr.typtr,realptr) then |
| 6658 | begin error(109); rattr.typtr := nil end |
| 6659 | else |
| 6660 | if comptypes(lsp^.elset,rattr.typtr) then |
| 6661 | begin |
| 6662 | if (gattr.kind = cst) and |
| 6663 | (rattr.kind = cst) then |
| 6664 | if (rattr.cval.ival < setlow) or |
| 6665 | (rattr.cval.ival > sethigh) or |
| 6666 | (gattr.cval.ival < setlow) or |
| 6667 | (gattr.cval.ival > sethigh) then |
| 6668 | error(304) |
| 6669 | else |
| 6670 | cstpart := cstpart+ |
| 6671 | [gattr.cval.ival..rattr.cval.ival] |
| 6672 | else |
| 6673 | begin |
| 6674 | if gattr.kind = cst then begin |
| 6675 | load; |
| 6676 | if not comptypes(gattr.typtr,intptr) |
| 6677 | then gen0t(58(*ord*),gattr.typtr) |
| 6678 | end; |
| 6679 | tattr := gattr; gattr := rattr; |
| 6680 | load; |
| 6681 | gattr := tattr; |
| 6682 | if not comptypes(rattr.typtr,intptr) |
| 6683 | then gen0t(58(*ord*),rattr.typtr); |
| 6684 | gen0(64(*rgs*)); |
| 6685 | if varpart then gen0(28(*uni*)) |
| 6686 | else varpart := true |
| 6687 | end |
| 6688 | end |
| 6689 | else error(137) |
| 6690 | end else begin |
| 6691 | if gattr.kind = cst then |
| 6692 | if (gattr.cval.ival < setlow) or |
| 6693 | (gattr.cval.ival > sethigh) then |
| 6694 | error(304) |
| 6695 | else |
| 6696 | cstpart := cstpart+[gattr.cval.ival] |
| 6697 | else |
| 6698 | begin load; |
| 6699 | if not comptypes(gattr.typtr,intptr) |
| 6700 | then gen0t(58(*ord*),gattr.typtr); |
| 6701 | gen0(23(*sgs*)); |
| 6702 | if varpart then gen0(28(*uni*)) |
| 6703 | else varpart := true |
| 6704 | end |
| 6705 | end; |
| 6706 | lsp^.elset := gattr.typtr; |
| 6707 | gattr.typtr := lsp |
| 6708 | end |
| 6709 | else begin error(137); gattr.typtr := nil end; |
| 6710 | test := sy <> comma; |
| 6711 | if not test then insymbol |
| 6712 | until test; |
| 6713 | if sy = rbrack then insymbol else error(12) |
| 6714 | end; |
| 6715 | if varpart then |
| 6716 | begin |
| 6717 | if cstpart <> [ ] then |
| 6718 | begin new(lvp,pset); pshcst(lvp); |
| 6719 | lvp^.pval := cstpart; |
| 6720 | lvp^.cclass := pset; |
| 6721 | if cstptrix = cstoccmax then error(254) |
| 6722 | else |
| 6723 | begin cstptrix := cstptrix + 1; |
| 6724 | cstptr[cstptrix] := lvp; |
| 6725 | gen2(51(*ldc*),5,cstptrix); |
| 6726 | gen0(28(*uni*)); gattr.kind := expr |
| 6727 | end |
| 6728 | end |
| 6729 | end |
| 6730 | else |
| 6731 | begin new(lvp,pset); pshcst(lvp); |
| 6732 | lvp^.cclass := pset; |
| 6733 | lvp^.pval := cstpart; |
| 6734 | gattr.kind := cst; |
| 6735 | gattr.cval.intval := false; |
| 6736 | gattr.cval.valp := lvp |
| 6737 | end |
| 6738 | end; |
| 6739 | (*nil*) nilsy: with gattr do |
| 6740 | begin typtr := nilptr; kind := cst; |
| 6741 | cval.intval := true; |
| 6742 | cval.ival := nilval; |
| 6743 | insymbol |
| 6744 | end |
| 6745 | end (*case*) ; |
| 6746 | if not (sy in fsys) then |
| 6747 | begin error(6); skip(fsys + facbegsys) end |
| 6748 | end (*while*) |
| 6749 | end (*factor*) ; |
| 6750 | |
| 6751 | begin (*term*) |
| 6752 | factor(fsys + [mulop], threaten); |
| 6753 | while sy = mulop do |
| 6754 | begin |
| 6755 | if gattr.kind <> expr then |
| 6756 | if gattr.typtr <> nil then |
| 6757 | if gattr.typtr^.form <= power then load else loadaddress; |
| 6758 | lattr := gattr; lop := op; |
| 6759 | insymbol; factor(fsys + [mulop], threaten); |
| 6760 | if gattr.kind <> expr then |
| 6761 | if gattr.typtr <> nil then |
| 6762 | if gattr.typtr^.form <= power then load else loadaddress; |
| 6763 | if (lattr.typtr <> nil) and (gattr.typtr <> nil) then |
| 6764 | case lop of |
| 6765 | (***) mul: begin fndopr2(lop, lattr, fcp); |
| 6766 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6767 | if (lattr.typtr=intptr) and (gattr.typtr=intptr) |
| 6768 | then gen0(15(*mpi*)) |
| 6769 | else |
| 6770 | begin |
| 6771 | { convert either integer to real } |
| 6772 | if lattr.typtr = intptr then |
| 6773 | begin gen0(9(*flo*)); |
| 6774 | lattr.typtr := realptr |
| 6775 | end |
| 6776 | else |
| 6777 | if gattr.typtr = intptr then |
| 6778 | begin gen0(10(*flt*)); |
| 6779 | gattr.typtr := realptr |
| 6780 | end; |
| 6781 | if (lattr.typtr = realptr) and |
| 6782 | (gattr.typtr=realptr) then gen0(16(*mpr*)) |
| 6783 | else if (lattr.typtr^.form=power) and |
| 6784 | comptypes(lattr.typtr,gattr.typtr) then |
| 6785 | gen0(12(*int*)) |
| 6786 | else begin error(134); gattr.typtr:=nil end |
| 6787 | end |
| 6788 | end |
| 6789 | end; |
| 6790 | (* / *) rdiv: begin fndopr2(lop, lattr, fcp); |
| 6791 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6792 | { convert either integer to real } |
| 6793 | if gattr.typtr = intptr then |
| 6794 | begin gen0(10(*flt*)); gattr.typtr := realptr end; |
| 6795 | if lattr.typtr = intptr then |
| 6796 | begin gen0(9(*flo*)); lattr.typtr := realptr end; |
| 6797 | if (lattr.typtr = realptr) and |
| 6798 | (gattr.typtr=realptr) then gen0(7(*dvr*)) |
| 6799 | else begin error(134); gattr.typtr := nil end |
| 6800 | end |
| 6801 | end; |
| 6802 | (*div*) idiv: begin fndopr2(lop, lattr, fcp); |
| 6803 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6804 | if (lattr.typtr = intptr) and (gattr.typtr = intptr) then |
| 6805 | gen0(6(*dvi*)) |
| 6806 | else begin error(134); gattr.typtr := nil end |
| 6807 | end |
| 6808 | end; |
| 6809 | (*mod*) imod: begin fndopr2(lop, lattr, fcp); |
| 6810 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6811 | if (lattr.typtr = intptr) and (gattr.typtr = intptr) then |
| 6812 | gen0(14(*mod*)) |
| 6813 | else begin error(134); gattr.typtr := nil end |
| 6814 | end |
| 6815 | end; |
| 6816 | (*and*) andop: begin fndopr2(lop, lattr, fcp); |
| 6817 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6818 | if ((lattr.typtr = boolptr) and (gattr.typtr = boolptr)) or |
| 6819 | ((lattr.typtr=intptr) and (gattr.typtr=intptr) and |
| 6820 | not iso7185) then gen0(4(*and*)) |
| 6821 | else begin error(134); gattr.typtr := nil end |
| 6822 | end |
| 6823 | end |
| 6824 | end (*case*) |
| 6825 | else gattr.typtr := nil |
| 6826 | end (*while*) |
| 6827 | end (*term*) ; |
| 6828 | |
| 6829 | begin (*simpleexpression*) |
| 6830 | fsy := sy; fop := op; |
| 6831 | if (sy = addop) and (op in [plus,minus]) then insymbol; |
| 6832 | term(fsys + [addop], threaten); |
| 6833 | if (fsy = addop) and (fop in [plus, minus]) then begin |
| 6834 | if gattr.kind <> expr then |
| 6835 | if gattr.typtr <> nil then |
| 6836 | if gattr.typtr^.form <= power then load else loadaddress; |
| 6837 | fndopr1(fop, fcp); |
| 6838 | if fcp <> nil then callop1(fcp) else begin |
| 6839 | if fop = minus then begin |
| 6840 | if gattr.typtr = intptr then gen0(17(*ngi*)) |
| 6841 | else |
| 6842 | if gattr.typtr = realptr then gen0(18(*ngr*)) |
| 6843 | else begin error(134); gattr.typtr := nil end |
| 6844 | end else begin |
| 6845 | if (gattr.typtr <> intptr) and |
| 6846 | (gattr.typtr <> realptr) then |
| 6847 | begin error(134); gattr.typtr := nil end |
| 6848 | end |
| 6849 | end |
| 6850 | end; |
| 6851 | while sy = addop do |
| 6852 | begin |
| 6853 | if gattr.kind <> expr then |
| 6854 | if gattr.typtr <> nil then |
| 6855 | if gattr.typtr^.form <= power then load else loadaddress; |
| 6856 | lattr := gattr; lop := op; |
| 6857 | insymbol; term(fsys + [addop], threaten); |
| 6858 | if gattr.kind <> expr then |
| 6859 | if gattr.typtr <> nil then |
| 6860 | if gattr.typtr^.form <= power then load else loadaddress; |
| 6861 | if (lattr.typtr <> nil) and (gattr.typtr <> nil) then |
| 6862 | case lop of |
| 6863 | (*+,-*) plus,minus: begin fndopr2(lop, lattr, fcp); |
| 6864 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6865 | if (lattr.typtr = intptr) and (gattr.typtr = intptr) then begin |
| 6866 | if lop = plus then gen0(2(*adi*)) else gen0(21(*sbi*)) |
| 6867 | end else begin |
| 6868 | { convert either integer to real } |
| 6869 | if lattr.typtr = intptr then |
| 6870 | begin gen0(9(*flo*)); |
| 6871 | lattr.typtr := realptr |
| 6872 | end |
| 6873 | else |
| 6874 | if gattr.typtr = intptr then |
| 6875 | begin gen0(10(*flt*)); |
| 6876 | gattr.typtr := realptr |
| 6877 | end; |
| 6878 | if (lattr.typtr = realptr) and |
| 6879 | (gattr.typtr = realptr) then begin |
| 6880 | if lop = plus then gen0(3(*adr*)) else gen0(22(*sbr*)) |
| 6881 | end else if (lattr.typtr^.form=power) and |
| 6882 | comptypes(lattr.typtr,gattr.typtr) then begin |
| 6883 | if lop = plus then gen0(28(*uni*)) else gen0(5(*dif*)) |
| 6884 | end else begin error(134); gattr.typtr:=nil end |
| 6885 | end |
| 6886 | end |
| 6887 | end; |
| 6888 | (*or,xor*) orop, xorop: begin fndopr2(lop, lattr, fcp); |
| 6889 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6890 | if ((lattr.typtr=boolptr) and (gattr.typtr=boolptr)) or |
| 6891 | ((lattr.typtr=intptr) and (gattr.typtr=intptr) and |
| 6892 | not iso7185) then begin |
| 6893 | if lop = orop then gen0(13(*ior*)) else gen0(83(*ixor*)) |
| 6894 | end else begin error(134); gattr.typtr := nil end |
| 6895 | end |
| 6896 | end |
| 6897 | end (*case*) |
| 6898 | else gattr.typtr := nil |
| 6899 | end (*while*) |
| 6900 | end (*simpleexpression*) ; |
| 6901 | |
| 6902 | begin (*expression*) |
| 6903 | revcmp := false; |
| 6904 | simpleexpression(fsys + [relop], threaten); |
| 6905 | lschrcst := ischrcst(gattr); |
| 6906 | if lschrcst then lc := chr(gattr.cval.ival); |
| 6907 | if sy = relop then begin |
| 6908 | if gattr.typtr <> nil then |
| 6909 | if gattr.typtr^.form <= power then load |
| 6910 | else loadaddress; |
| 6911 | lattr := gattr; lop := op; |
| 6912 | if (lop = inop) and (gattr.typtr <> nil) then |
| 6913 | if not comptypes(gattr.typtr,intptr) and |
| 6914 | (gattr.typtr^.form <= subrange) then |
| 6915 | gen0t(58(*ord*),gattr.typtr); |
| 6916 | insymbol; simpleexpression(fsys, threaten); |
| 6917 | rschrcst := ischrcst(gattr); |
| 6918 | if rschrcst then rc := chr(gattr.cval.ival); |
| 6919 | if gattr.typtr <> nil then |
| 6920 | if gattr.typtr^.form <= power then load |
| 6921 | else loadaddress; |
| 6922 | if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin |
| 6923 | fndopr2(lop, lattr, fcp); |
| 6924 | if fcp <> nil then callop2(fcp, lattr) else begin |
| 6925 | if lop = inop then |
| 6926 | if gattr.typtr^.form = power then |
| 6927 | if comptypes(lattr.typtr,gattr.typtr^.elset) then |
| 6928 | gen0(11(*inn*)) |
| 6929 | else begin error(129); gattr.typtr := nil end |
| 6930 | else begin error(130); gattr.typtr := nil end |
| 6931 | else |
| 6932 | begin |
| 6933 | { convert either integer to real } |
| 6934 | if lattr.typtr <> gattr.typtr then |
| 6935 | if lattr.typtr = intptr then |
| 6936 | begin gen0(9(*flo*)); |
| 6937 | lattr.typtr := realptr |
| 6938 | end |
| 6939 | else |
| 6940 | if gattr.typtr = intptr then |
| 6941 | begin gen0(10(*flt*)); |
| 6942 | gattr.typtr := realptr |
| 6943 | end; |
| 6944 | if comptypes(lattr.typtr,gattr.typtr) or |
| 6945 | (lschrcst and (gattr.typtr^.form = arrayc)) or |
| 6946 | ((lattr.typtr^.form = arrayc) and rschrcst) then |
| 6947 | begin lsize := lattr.typtr^.size; |
| 6948 | typind := ' '; |
| 6949 | case lattr.typtr^.form of |
| 6950 | scalar: |
| 6951 | if lschrcst and (gattr.typtr^.form = arrayc) then |
| 6952 | begin |
| 6953 | { load char ptr under } |
| 6954 | gen2(51(*ldc*),1,1); |
| 6955 | gensca(lc); |
| 6956 | gen2(124(*mpc*),0,0); |
| 6957 | typind := 'v'; |
| 6958 | revcmp := true |
| 6959 | end |
| 6960 | else if lattr.typtr = realptr then typind := 'r' |
| 6961 | else |
| 6962 | if lattr.typtr = boolptr then typind := 'b' |
| 6963 | else |
| 6964 | if lattr.typtr = charptr then typind := 'c' |
| 6965 | else typind := 'i'; |
| 6966 | pointer: |
| 6967 | begin |
| 6968 | if lop in [ltop,leop,gtop,geop] then error(131); |
| 6969 | typind := 'a' |
| 6970 | end; |
| 6971 | power: |
| 6972 | begin if lop in [ltop,gtop] then error(132); |
| 6973 | typind := 's' |
| 6974 | end; |
| 6975 | arrays, arrayc: |
| 6976 | begin |
| 6977 | if not stringt(lattr.typtr) then error(134); |
| 6978 | if rschrcst and (lattr.typtr^.form = arrayc) then begin |
| 6979 | gen1(71(*dmp*),intsize); { discard char } |
| 6980 | { rationalize character } |
| 6981 | gen2(51(*ldc*),1,1); |
| 6982 | gensca(rc); |
| 6983 | gen2(124(*mpc*),0,0); |
| 6984 | typind := 'v' |
| 6985 | end else begin |
| 6986 | lsizspc := lsize; alignu(parmptr,lsizspc); |
| 6987 | if (lattr.typtr^.form = arrayc) or |
| 6988 | (gattr.typtr^.form = arrayc) then typind := 'v' |
| 6989 | else typind := 'm'; |
| 6990 | containerop(lattr); { rationalize binary container } |
| 6991 | end |
| 6992 | end; |
| 6993 | records: |
| 6994 | begin |
| 6995 | error(134); |
| 6996 | typind := 'm' |
| 6997 | end; |
| 6998 | files: |
| 6999 | begin error(133); typind := 'f' end |
| 7000 | end; |
| 7001 | if typind <> ' ' then if revcmp then begin |
| 7002 | case lop of |
| 7003 | { reverse flipped operands } |
| 7004 | ltop: gen2(49(*grt*),ord(typind),lsize); |
| 7005 | leop: gen2(48(*geq*),ord(typind),lsize); |
| 7006 | gtop: gen2(53(*les*),ord(typind),lsize); |
| 7007 | geop: gen2(52(*leq*),ord(typind),lsize); |
| 7008 | neop: gen2(55(*neq*),ord(typind),lsize); |
| 7009 | eqop: gen2(47(*equ*),ord(typind),lsize) |
| 7010 | end; |
| 7011 | gen1(72(*swp*),intsize); { swap for previous const } |
| 7012 | gen1(71(*dmp*),ptrsize) { dump it } |
| 7013 | end else case lop of |
| 7014 | ltop: gen2(53(*les*),ord(typind),lsize); |
| 7015 | leop: gen2(52(*leq*),ord(typind),lsize); |
| 7016 | gtop: gen2(49(*grt*),ord(typind),lsize); |
| 7017 | geop: gen2(48(*geq*),ord(typind),lsize); |
| 7018 | neop: gen2(55(*neq*),ord(typind),lsize); |
| 7019 | eqop: gen2(47(*equ*),ord(typind),lsize) |
| 7020 | end |
| 7021 | end |
| 7022 | else error(129) |
| 7023 | end; |
| 7024 | gattr.typtr := boolptr; gattr.kind := expr |
| 7025 | end |
| 7026 | end |
| 7027 | end (*sy = relop*) |
| 7028 | end (*expression*) ; |
| 7029 | |
| 7030 | procedure body(fsys: setofsys; fprocp: ctp); forward; |
| 7031 | |
| 7032 | procedure declare(fsys: setofsys); |
| 7033 | var lsy: symbol; |
| 7034 | |
| 7035 | { resolve all pointer references in the forward list } |
| 7036 | procedure resolvep; |
| 7037 | var ids: idstr; lcp1, lcp2: ctp; mm, fe: boolean; |
| 7038 | begin |
| 7039 | ids := id; |
| 7040 | fe := true; |
| 7041 | while fwptr <> nil do begin |
| 7042 | lcp1 := fwptr; |
| 7043 | fwptr := lcp1^.next; |
| 7044 | strassfv(id, lcp1^.name); |
| 7045 | searchidnenm([types], lcp2, mm); |
| 7046 | if lcp2 <> nil then begin |
| 7047 | lcp1^.idtype^.eltype := lcp2^.idtype; |
| 7048 | lcp2^.refer := true; |
| 7049 | end else begin |
| 7050 | if fe then begin error(117); writeln(output) end; |
| 7051 | write('*** undefined type-id forward reference: '); |
| 7052 | writev(output, lcp1^.name, prtlln); writeln; |
| 7053 | fe := false |
| 7054 | end; |
| 7055 | putnam(lcp1) |
| 7056 | end; |
| 7057 | id := ids |
| 7058 | end; |
| 7059 | |
| 7060 | procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange); |
| 7061 | var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp; |
| 7062 | lsize,displ: addrrange; lmin,lmax, span: integer; |
| 7063 | test: boolean; ispacked: boolean; lvalu: valu; |
| 7064 | |
| 7065 | procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange); |
| 7066 | var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange; |
| 7067 | lcnt: integer; lvalu: valu; t: integer; |
| 7068 | begin fsize := 1; |
| 7069 | if not (sy in simptypebegsys) then |
| 7070 | begin error(1); skip(fsys + simptypebegsys) end; |
| 7071 | if sy in simptypebegsys then |
| 7072 | begin |
| 7073 | if sy = lparent then |
| 7074 | begin ttop := top; (*decl. consts local to innermost block*) |
| 7075 | while display[top].occur <> blck do top := top - 1; |
| 7076 | new(lsp,scalar,declared); pshstc(lsp); |
| 7077 | with lsp^ do |
| 7078 | begin form := scalar; size := intsize; scalkind := declared; |
| 7079 | packing := false |
| 7080 | end; |
| 7081 | lcp1 := nil; lcnt := 0; |
| 7082 | repeat insymbol; |
| 7083 | if sy = ident then |
| 7084 | begin new(lcp,konst); ininam(lcp); |
| 7085 | with lcp^ do |
| 7086 | begin klass := konst; strassvf(name, id); idtype := lsp; |
| 7087 | next := lcp1; values.intval := true; |
| 7088 | values.ival := lcnt; |
| 7089 | end; |
| 7090 | enterid(lcp); |
| 7091 | lcnt := lcnt + 1; |
| 7092 | lcp1 := lcp; insymbol |
| 7093 | end |
| 7094 | else error(2); |
| 7095 | if not (sy in fsys + [comma,rparent]) then |
| 7096 | begin error(6); skip(fsys + [comma,rparent]) end |
| 7097 | until sy <> comma; |
| 7098 | lsp^.fconst := lcp1; top := ttop; |
| 7099 | if sy = rparent then insymbol else error(4); |
| 7100 | { resize for byte if needed } |
| 7101 | if isbyte(lsp) then lsp^.size := 1; |
| 7102 | fsize := lsp^.size |
| 7103 | end |
| 7104 | else |
| 7105 | begin |
| 7106 | if sy = ident then |
| 7107 | begin searchid([types,konst],lcp); |
| 7108 | insymbol; |
| 7109 | if lcp^.klass = konst then |
| 7110 | begin new(lsp,subrange); pshstc(lsp); |
| 7111 | with lsp^, lcp^ do |
| 7112 | begin form := subrange; rangetype := idtype; |
| 7113 | if stringt(rangetype) then |
| 7114 | begin error(148); rangetype := nil end; |
| 7115 | if rangetype = realptr then |
| 7116 | begin error(109); rangetype := nil end; |
| 7117 | if not values.intval then |
| 7118 | begin min.intval := true; min.ival := 1 end |
| 7119 | else min := values; |
| 7120 | size := intsize; packing := false |
| 7121 | end; |
| 7122 | if sy = range then insymbol else error(30); |
| 7123 | constexpr(fsys,lsp1,lvalu); |
| 7124 | if not lvalu.intval then |
| 7125 | begin lsp^.max.intval := true; lsp^.max.ival := 1 end |
| 7126 | else lsp^.max := lvalu; |
| 7127 | if lsp^.rangetype <> lsp1 then error(107); |
| 7128 | if isbyte(lsp) then lsp^.size := 1 |
| 7129 | end |
| 7130 | else |
| 7131 | begin lsp := lcp^.idtype; |
| 7132 | if lsp <> nil then fsize := lsp^.size |
| 7133 | end |
| 7134 | end (*sy = ident*) |
| 7135 | else |
| 7136 | begin new(lsp,subrange); pshstc(lsp); |
| 7137 | lsp^.form := subrange; lsp^.packing := false; |
| 7138 | constexpr(fsys + [range],lsp1,lvalu); |
| 7139 | if stringt(lsp1) then |
| 7140 | begin error(148); lsp1 := nil end; |
| 7141 | if lsp1 = realptr then begin error(109); lsp1 := nil end; |
| 7142 | with lsp^ do begin |
| 7143 | rangetype:=lsp1; |
| 7144 | if lvalu.intval then min:=lvalu else |
| 7145 | begin min.intval := true; min.ival := 1 end; |
| 7146 | size:=intsize |
| 7147 | end; |
| 7148 | if sy = range then insymbol else error(30); |
| 7149 | constexpr(fsys,lsp1,lvalu); |
| 7150 | if lvalu.intval then lsp^.max := lvalu |
| 7151 | else begin lsp^.max.intval := true; lsp^.max.ival := 1 end; |
| 7152 | if lsp^.rangetype <> lsp1 then error(107); |
| 7153 | if isbyte(lsp) then lsp^.size := 1; |
| 7154 | fsize := lsp^.size |
| 7155 | end; |
| 7156 | if lsp <> nil then |
| 7157 | with lsp^ do |
| 7158 | if form = subrange then begin |
| 7159 | if rangetype <> nil then |
| 7160 | if rangetype = realptr then |
| 7161 | begin error(109); rangetype := intptr end; |
| 7162 | if min.ival > max.ival then |
| 7163 | begin error(102); |
| 7164 | { swap to fix and suppress further errors } |
| 7165 | t := min.ival; min.ival := max.ival; max.ival := t |
| 7166 | end |
| 7167 | end |
| 7168 | end; |
| 7169 | fsp := lsp; |
| 7170 | if not (sy in fsys) then |
| 7171 | begin error(6); skip(fsys) end |
| 7172 | end |
| 7173 | else fsp := nil |
| 7174 | end (*simpletype*) ; |
| 7175 | |
| 7176 | procedure fieldlist(fsys: setofsys; var frecvar: stp; vartyp: stp; |
| 7177 | varlab: ctp; lvl: integer; var fstlab: ctp); |
| 7178 | var lcp,lcp1,lcp2,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp; |
| 7179 | minsize,maxsize,lsize: addrrange; lvalu,rvalu: valu; |
| 7180 | test: boolean; mm: boolean; varlnm, varcn, varcmx: varinx; |
| 7181 | varcof: boolean; tagp,tagl: ttp; mint, maxt: integer; ferr: boolean; |
| 7182 | procedure ordertag(var tp: ttp); |
| 7183 | var lp, p, p2, p3: ttp; |
| 7184 | begin |
| 7185 | if tp <> nil then begin |
| 7186 | lp := tp; tp := tp^.next; lp^.next := nil; |
| 7187 | while tp <> nil do begin |
| 7188 | p := tp; tp := tp^.next; p^.next := nil; p2 := lp; p3 := nil; |
| 7189 | while (p^.ival > p2^.ival) and (p2^.next <> nil) do |
| 7190 | begin p3 := p2; p2 := p2^.next end; |
| 7191 | if p^.ival > p2^.ival then p2^.next := p |
| 7192 | else if p3 = nil then begin p^.next := lp; lp := p end |
| 7193 | else begin p^.next := p3^.next; p3^.next := p end |
| 7194 | end |
| 7195 | end; |
| 7196 | tp := lp |
| 7197 | end; |
| 7198 | begin nxt1 := nil; lsp := nil; fstlab := nil; |
| 7199 | if not (sy in (fsys+[ident,casesy])) then |
| 7200 | begin error(19); skip(fsys + [ident,casesy]) end; |
| 7201 | while sy = ident do |
| 7202 | begin nxt := nxt1; |
| 7203 | repeat |
| 7204 | if sy = ident then |
| 7205 | begin new(lcp,field); ininam(lcp); |
| 7206 | if fstlab = nil then fstlab := lcp; |
| 7207 | with lcp^ do |
| 7208 | begin klass := field; strassvf(name, id); idtype := nil; |
| 7209 | next := nxt; fldaddr := 0; varnt := vartyp; |
| 7210 | varlb := varlab; tagfield := false; taglvl := lvl; |
| 7211 | varsaddr := 0; varssize := 0; vartl := -1 |
| 7212 | end; |
| 7213 | nxt := lcp; |
| 7214 | enterid(lcp); |
| 7215 | insymbol |
| 7216 | end |
| 7217 | else error(2); |
| 7218 | if not (sy in [comma,colon]) then |
| 7219 | begin error(6); skip(fsys + [comma,colon,semicolon,casesy]) |
| 7220 | end; |
| 7221 | test := sy <> comma; |
| 7222 | if not test then insymbol |
| 7223 | until test; |
| 7224 | if sy = colon then insymbol else error(5); |
| 7225 | typ(fsys + [casesy,semicolon],lsp,lsize); |
| 7226 | if lsp <> nil then |
| 7227 | if lsp^.form = arrayc then error(272); |
| 7228 | while nxt <> nxt1 do |
| 7229 | with nxt^ do |
| 7230 | begin alignu(lsp,displ); |
| 7231 | idtype := lsp; fldaddr := displ; |
| 7232 | nxt := next; displ := displ + lsize |
| 7233 | end; |
| 7234 | nxt1 := lcp; |
| 7235 | while sy = semicolon do |
| 7236 | begin insymbol; |
| 7237 | if not (sy in fsys + [ident,casesy,semicolon]) then |
| 7238 | begin error(19); skip(fsys + [ident,casesy]) end |
| 7239 | end |
| 7240 | end (*while*); |
| 7241 | nxt := nil; |
| 7242 | while nxt1 <> nil do |
| 7243 | with nxt1^ do |
| 7244 | begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end; |
| 7245 | if sy = casesy then |
| 7246 | begin new(lsp,tagfld); pshstc(lsp); |
| 7247 | with lsp^ do |
| 7248 | begin form := tagfld; tagfieldp := nil; fstvar := nil; |
| 7249 | packing := false; new(vart); |
| 7250 | for varcn := 0 to varmax do vart^[varcn] := 0 |
| 7251 | end; |
| 7252 | varlnm := 1; varcof := false; varcmx := 0; |
| 7253 | frecvar := lsp; |
| 7254 | insymbol; |
| 7255 | if sy = ident then |
| 7256 | begin |
| 7257 | { find possible type first } |
| 7258 | searchidnenm([types],lcp1,mm); |
| 7259 | { now set up as field id } |
| 7260 | new(lcp,field); ininam(lcp); |
| 7261 | with lcp^ do |
| 7262 | begin klass:=field; strassvf(name, id); idtype := nil; |
| 7263 | next := nil; fldaddr := displ; varnt := vartyp; |
| 7264 | varlb := varlab; tagfield := true; taglvl := lvl; |
| 7265 | varsaddr := 0; varssize := 0; vartl := -1 |
| 7266 | end; |
| 7267 | lsp^.tagfieldp := lcp; |
| 7268 | insymbol; |
| 7269 | if sy = colon then begin |
| 7270 | enterid(lcp); insymbol; |
| 7271 | if sy = ident then begin searchid([types],lcp1); insymbol end |
| 7272 | else begin error(2); skip(fsys + [ofsy,lparent]); lcp1 := nil end |
| 7273 | end else begin |
| 7274 | if lcp1 = nil then begin error(104); lcp1 := usclrptr end; |
| 7275 | { If type only (undiscriminated variant), kill the id. } |
| 7276 | if mm then error(103); |
| 7277 | putstrs(lcp^.name); { release name string } |
| 7278 | lcp^.name := nil { set no tagfield } |
| 7279 | end; |
| 7280 | if lcp1 <> nil then begin |
| 7281 | lsp1 := lcp1^.idtype; |
| 7282 | if lsp1 <> nil then |
| 7283 | begin alignu(lsp1,displ); |
| 7284 | lcp^.fldaddr := displ; |
| 7285 | { only allocate field if named or if undiscriminated |
| 7286 | tagfield checks are on } |
| 7287 | if (lcp^.name <> nil) or chkudtf then |
| 7288 | displ := displ+lsp1^.size; |
| 7289 | if (lsp1^.form <= subrange) or stringt(lsp1) then |
| 7290 | begin if comptypes(realptr,lsp1) then error(159) |
| 7291 | else if stringt(lsp1) then error(159); |
| 7292 | lcp^.idtype := lsp1 |
| 7293 | end |
| 7294 | else error(110); |
| 7295 | end |
| 7296 | end |
| 7297 | end |
| 7298 | else begin error(2); skip(fsys + [ofsy,lparent]) end; |
| 7299 | lsp^.size := displ; |
| 7300 | if sy = ofsy then insymbol else error(8); |
| 7301 | lsp1 := nil; minsize := displ; maxsize := displ; |
| 7302 | tagl := nil; |
| 7303 | mint := -maxint; maxt := maxint; |
| 7304 | if lsp^.tagfieldp <> nil then |
| 7305 | if lsp^.tagfieldp^.idtype <> nil then begin |
| 7306 | getbounds(lsp^.tagfieldp^.idtype, mint, maxt); |
| 7307 | if maxt-mint+1 > varmax then error(239) |
| 7308 | end; |
| 7309 | repeat lsp2 := nil; |
| 7310 | if not (sy in fsys + [semicolon]) then |
| 7311 | begin |
| 7312 | repeat constexpr(fsys + [comma,colon,lparent,range],lsp3,lvalu); |
| 7313 | rvalu := lvalu; lsp4 := lsp3; if sy = range then begin chkstd; |
| 7314 | insymbol; constexpr(fsys + [comma,colon,lparent],lsp4,rvalu) |
| 7315 | end; |
| 7316 | if lsp^.tagfieldp <> nil then begin |
| 7317 | if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111); |
| 7318 | if not comptypes(lsp^.tagfieldp^.idtype,lsp4)then error(111); |
| 7319 | end; |
| 7320 | { fix up for error processing } |
| 7321 | if not lvalu.intval then |
| 7322 | begin lvalu.intval := true; lvalu.ival := 1 end; |
| 7323 | if not rvalu.intval then |
| 7324 | begin rvalu.intval := true; rvalu.ival := 1 end; |
| 7325 | if lvalu.ival > rvalu.ival then error(225); |
| 7326 | repeat { case range } |
| 7327 | gettag(tagp); tagp^.ival := lvalu.ival; tagp^.next := tagl; |
| 7328 | tagl := tagp; |
| 7329 | new(lsp3,variant); pshstc(lsp3); |
| 7330 | with lsp3^ do |
| 7331 | begin form := variant; varln := varlnm; |
| 7332 | nxtvar := lsp1; subvar := lsp2; varval := lvalu; |
| 7333 | caslst := lsp2; packing := false |
| 7334 | end; |
| 7335 | if (lvalu.ival >= 0) and (lvalu.ival <= varmax) then |
| 7336 | lsp^.vart^[lvalu.ival] := varlnm; { set case to logical } |
| 7337 | lsp4 := lsp1; |
| 7338 | while lsp4 <> nil do |
| 7339 | with lsp4^ do |
| 7340 | begin |
| 7341 | if varval.ival = lvalu.ival then error(178); |
| 7342 | lsp4 := nxtvar |
| 7343 | end; |
| 7344 | lsp1 := lsp3; lsp2 := lsp3; |
| 7345 | lvalu.ival := lvalu.ival+1 { next range value } |
| 7346 | until lvalu.ival > rvalu.ival; { range is complete } |
| 7347 | if lvalu.ival-1 > varcmx then varcmx := lvalu.ival-1; |
| 7348 | if lvalu.ival > varmax then |
| 7349 | { errors supressed for multiple overflows in list } |
| 7350 | begin if not varcof then error(239); varcof := true end; |
| 7351 | test := sy <> comma; |
| 7352 | if not test then insymbol |
| 7353 | until test; |
| 7354 | if sy = colon then insymbol else error(5); |
| 7355 | if sy = lparent then insymbol else error(9); |
| 7356 | alignu(nilptr, displ); { max align all variants } |
| 7357 | if lcp <> nil then lcp^.varsaddr := displ; |
| 7358 | fieldlist(fsys + [rparent,semicolon],lsp2,lsp3,lcp, lvl+1,lcp2); |
| 7359 | if displ > maxsize then maxsize := displ; |
| 7360 | if lcp <> nil then lcp^.varssize := maxsize-lcp^.varsaddr; |
| 7361 | while lsp3 <> nil do |
| 7362 | begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2; |
| 7363 | lsp3^.varfld := lcp2; |
| 7364 | lsp3^.size := displ; |
| 7365 | lsp3 := lsp4 |
| 7366 | end; |
| 7367 | if sy = rparent then |
| 7368 | begin insymbol; |
| 7369 | if not (sy in fsys + [semicolon]) then |
| 7370 | begin error(6); skip(fsys + [semicolon]) end |
| 7371 | end |
| 7372 | else error(4); |
| 7373 | end; |
| 7374 | varlnm := varlnm+1; |
| 7375 | test := sy <> semicolon; |
| 7376 | if not test then |
| 7377 | begin displ := minsize; |
| 7378 | insymbol |
| 7379 | end |
| 7380 | until test; |
| 7381 | displ := maxsize; |
| 7382 | lsp^.fstvar := lsp1; |
| 7383 | lsp^.varts := 0; |
| 7384 | if lcp <> nil then begin |
| 7385 | if varcmx >= 0 then lsp^.varts := varcmx+1; |
| 7386 | { output LVN table. note each file gets a copy of this, near or |
| 7387 | far. } |
| 7388 | write(prr, 'v',' ':7); |
| 7389 | genlabel(lcp^.vartl); prtlabelu(lcp^.vartl); |
| 7390 | write(prr, ' ', lsp^.varts:1); |
| 7391 | for varcn := 0 to lsp^.varts-1 do |
| 7392 | write(prr, ' ', lsp^.vart^[varcn]:1); |
| 7393 | writeln(prr) |
| 7394 | end; |
| 7395 | if lsp^.tagfieldp <> nil then begin |
| 7396 | ordertag(tagl); |
| 7397 | tagp := tagl; ferr := false; |
| 7398 | while (tagp <> nil) and (mint <= maxt) and not ferr do begin |
| 7399 | if tagp^.ival <> mint then begin error(200); ferr := true end |
| 7400 | else begin mint := mint+1; tagp := tagp^.next end |
| 7401 | end; |
| 7402 | if (mint <= maxt) and not ferr then error(200) |
| 7403 | end; |
| 7404 | while tagl <> nil do |
| 7405 | begin tagp := tagl; tagl := tagl^.next; puttag(tagp) end |
| 7406 | end |
| 7407 | else frecvar := nil |
| 7408 | end (*fieldlist*) ; |
| 7409 | |
| 7410 | begin (*typ*) |
| 7411 | lsp := nil; |
| 7412 | if not (sy in typebegsys) then |
| 7413 | begin error(10); skip(fsys + typebegsys) end; |
| 7414 | if sy in typebegsys then |
| 7415 | begin |
| 7416 | if sy in simptypebegsys then simpletype(fsys,fsp,fsize) |
| 7417 | else |
| 7418 | (*^*) if sy = arrow then |
| 7419 | begin new(lsp,pointer); pshstc(lsp); fsp := lsp; |
| 7420 | with lsp^ do |
| 7421 | begin form:=pointer; eltype := nil; size := ptrsize; |
| 7422 | packing := false end; |
| 7423 | insymbol; |
| 7424 | if sy = ident then |
| 7425 | begin { forward reference everything } |
| 7426 | new(lcp,types); ininam(lcp); |
| 7427 | with lcp^ do |
| 7428 | begin klass := types; strassvf(name,id); idtype := lsp; |
| 7429 | next := fwptr; |
| 7430 | end; |
| 7431 | fwptr := lcp; |
| 7432 | insymbol; |
| 7433 | end |
| 7434 | else error(2); |
| 7435 | end |
| 7436 | else |
| 7437 | begin |
| 7438 | ispacked := false; { set not packed by default } |
| 7439 | if sy = packedsy then |
| 7440 | begin insymbol; ispacked := true; { packed } |
| 7441 | if not (sy in typedels) then |
| 7442 | begin |
| 7443 | error(10); skip(fsys + typedels) |
| 7444 | end |
| 7445 | end; |
| 7446 | (*array*) if sy = arraysy then |
| 7447 | begin insymbol; |
| 7448 | if (sy <> lbrack) and iso7185 then error(11); |
| 7449 | if (sy = ofsy) and not iso7185 then begin |
| 7450 | lsp1 := nil; |
| 7451 | { process container array } |
| 7452 | new(lsp,arrayc); pshstc(lsp); |
| 7453 | with lsp^ do |
| 7454 | begin form:=arrayc; abstype := lsp1; |
| 7455 | packing := ispacked end; |
| 7456 | lsp1 := lsp |
| 7457 | end else if (sy <> lbrack) and not iso7185 then begin |
| 7458 | { process Pascaline array } |
| 7459 | lsp1 := nil; |
| 7460 | repeat new(lsp,arrays); pshstc(lsp); |
| 7461 | with lsp^ do |
| 7462 | begin form:=arrays; aeltype := lsp1; inxtype := nil; |
| 7463 | tmpl := -1; packing := ispacked end; |
| 7464 | lsp1 := lsp; |
| 7465 | constexpr(fsys+[comma,ofsy],lsp2,lvalu); |
| 7466 | if lsp2 <> nil then if lsp2 <> intptr then error(15); |
| 7467 | if not lvalu.intval then |
| 7468 | begin lvalu.intval := true; lvalu.ival := 1 end; |
| 7469 | if lvalu.ival <= 0 then |
| 7470 | begin error(238); lvalu.ival := 1 end; |
| 7471 | lsp1^.size := 0; |
| 7472 | { build subrange type based on 1..n } |
| 7473 | new(lsp2,subrange); pshstc(lsp2); |
| 7474 | with lsp2^ do |
| 7475 | begin form := subrange; rangetype := intptr; |
| 7476 | min.intval := true; min.ival := 1; |
| 7477 | max.intval := true; max := lvalu end; |
| 7478 | lsp^.inxtype := lsp2; |
| 7479 | test := sy <> comma; |
| 7480 | if not test then insymbol |
| 7481 | until test |
| 7482 | end else begin if sy = lbrack then insymbol; |
| 7483 | { process ISO 7185 array } |
| 7484 | lsp1 := nil; |
| 7485 | repeat new(lsp,arrays); pshstc(lsp); |
| 7486 | with lsp^ do |
| 7487 | begin form:=arrays; aeltype := lsp1; inxtype := nil; |
| 7488 | tmpl := -1; packing := ispacked end; |
| 7489 | lsp1 := lsp; |
| 7490 | simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize); |
| 7491 | lsp1^.size := lsize; |
| 7492 | if lsp2 <> nil then |
| 7493 | if lsp2^.form <= subrange then |
| 7494 | begin |
| 7495 | if lsp2 = realptr then |
| 7496 | begin error(109); lsp2 := nil end |
| 7497 | else |
| 7498 | if lsp2 = intptr then |
| 7499 | begin error(149); lsp2 := nil end; |
| 7500 | lsp^.inxtype := lsp2 |
| 7501 | end |
| 7502 | else begin error(113); lsp2 := nil end; |
| 7503 | test := sy <> comma; |
| 7504 | if not test then insymbol |
| 7505 | until test; |
| 7506 | if sy = rbrack then insymbol else error(12) |
| 7507 | end; |
| 7508 | if sy = ofsy then insymbol else error(8); |
| 7509 | typ(fsys,lsp,lsize); |
| 7510 | repeat |
| 7511 | with lsp1^ do begin |
| 7512 | if lsp1^.form = arrays then begin |
| 7513 | if lsp <> nil then |
| 7514 | if lsp^.form = arrayc then error(272); |
| 7515 | lsp2 := aeltype; aeltype := lsp; |
| 7516 | if inxtype <> nil then begin |
| 7517 | getbounds(inxtype,lmin,lmax); |
| 7518 | span := lmax-lmin+1; |
| 7519 | if span < 1 then error(509); |
| 7520 | if lsize > pmmaxint div span then |
| 7521 | begin error(237); lsize := 1 end |
| 7522 | else lsize := lsize*span; |
| 7523 | size := lsize |
| 7524 | end; |
| 7525 | arrtmp(lsp1) { output fixed template } |
| 7526 | end else |
| 7527 | { note containers are only one deep, and have no size } |
| 7528 | begin lsp2 := abstype; abstype := lsp; size := 0 end |
| 7529 | end; |
| 7530 | lsp := lsp1; lsp1 := lsp2 |
| 7531 | until lsp1 = nil |
| 7532 | end |
| 7533 | else |
| 7534 | (*record*) if sy = recordsy then |
| 7535 | begin insymbol; |
| 7536 | oldtop := top; |
| 7537 | if top < displimit then |
| 7538 | begin top := top + 1; inidsp(display[top]); |
| 7539 | display[top].occur := rec |
| 7540 | end |
| 7541 | else error(250); |
| 7542 | displ := 0; |
| 7543 | fieldlist(fsys-[semicolon]+[endsy],lsp1,nil,nil,1,lcp); |
| 7544 | new(lsp,records); |
| 7545 | with lsp^ do |
| 7546 | begin form := records; fstfld := display[top].fname; |
| 7547 | display[top].fname := nil; |
| 7548 | recvar := lsp1; size := displ; |
| 7549 | packing := ispacked; |
| 7550 | recyc := display[top].fstruct; |
| 7551 | display[top].fstruct := nil |
| 7552 | end; |
| 7553 | putdsps(oldtop); top := oldtop; |
| 7554 | { register the record late because of the purge above } |
| 7555 | pshstc(lsp); |
| 7556 | if sy = endsy then insymbol else error(13) |
| 7557 | end |
| 7558 | else |
| 7559 | (*set*) if sy = setsy then |
| 7560 | begin insymbol; |
| 7561 | if sy = ofsy then insymbol else error(8); |
| 7562 | simpletype(fsys,lsp1,lsize); |
| 7563 | if lsp1 <> nil then |
| 7564 | if lsp1^.form > subrange then |
| 7565 | begin error(115); lsp1 := nil end |
| 7566 | else |
| 7567 | if lsp1 = realptr then |
| 7568 | begin error(114); lsp1 := nil end |
| 7569 | else if lsp1 = intptr then |
| 7570 | begin error(169); lsp1 := nil end |
| 7571 | else |
| 7572 | begin getbounds(lsp1,lmin,lmax); |
| 7573 | if (lmin < setlow) or (lmax > sethigh) |
| 7574 | then error(169); |
| 7575 | end; |
| 7576 | new(lsp,power); pshstc(lsp); |
| 7577 | with lsp^ do |
| 7578 | begin form:=power; elset:=lsp1; size:=setsize; |
| 7579 | packing := ispacked; matchpack := true end; |
| 7580 | end |
| 7581 | else |
| 7582 | (*file*) if sy = filesy then |
| 7583 | begin insymbol; |
| 7584 | if sy = ofsy then insymbol else error(8); |
| 7585 | typ(fsys,lsp1,lsize); |
| 7586 | if filecomponent(lsp1) then error(190); |
| 7587 | new(lsp,files); pshstc(lsp); |
| 7588 | with lsp^ do |
| 7589 | begin form := files; filtype := lsp1; |
| 7590 | size := filesize+lsize; packing := ispacked |
| 7591 | end |
| 7592 | end |
| 7593 | else fsp := nil; |
| 7594 | fsp := lsp |
| 7595 | end; |
| 7596 | if not (sy in fsys) then |
| 7597 | begin error(6); skip(fsys) end |
| 7598 | end |
| 7599 | else fsp := nil; |
| 7600 | if fsp = nil then fsize := 1 else fsize := fsp^.size |
| 7601 | end (*typ*) ; |
| 7602 | |
| 7603 | procedure labeldeclaration; |
| 7604 | var llp: lbp; |
| 7605 | test: boolean; |
| 7606 | begin |
| 7607 | repeat |
| 7608 | if (sy = intconst) or (sy = ident) then begin |
| 7609 | if sy = ident then chkstd; |
| 7610 | searchlabel(llp, top, sy = ident); { search preexisting label } |
| 7611 | if llp <> nil then error(166) { multideclared label } |
| 7612 | else newlabel(llp, sy = ident); |
| 7613 | insymbol |
| 7614 | end else if iso7185 then error(15) else error(22); |
| 7615 | if not ( sy in fsys + [comma, semicolon] ) then |
| 7616 | begin error(6); skip(fsys+[comma,semicolon]) end; |
| 7617 | test := sy <> comma; |
| 7618 | if not test then insymbol |
| 7619 | until test; |
| 7620 | if sy = semicolon then insymbol else error(14) |
| 7621 | end (* labeldeclaration *) ; |
| 7622 | |
| 7623 | procedure constdeclaration; |
| 7624 | var lcp: ctp; lsp: stp; lvalu: valu; |
| 7625 | begin |
| 7626 | if sy <> ident then |
| 7627 | begin error(2); skip(fsys + [ident]) end; |
| 7628 | while sy = ident do |
| 7629 | begin new(lcp,konst); ininam(lcp); |
| 7630 | with lcp^ do |
| 7631 | begin klass:=konst; strassvf(name, id); idtype := nil; next := nil; |
| 7632 | refer := false |
| 7633 | end; |
| 7634 | insymbol; |
| 7635 | if (sy = relop) and (op = eqop) then insymbol else error(16); |
| 7636 | constexpr(fsys + [semicolon],lsp,lvalu); |
| 7637 | enterid(lcp); |
| 7638 | lcp^.idtype := lsp; lcp^.values := lvalu; |
| 7639 | if sy = semicolon then |
| 7640 | begin insymbol; |
| 7641 | if not (sy in fsys + [ident]) then |
| 7642 | begin error(6); skip(fsys + [ident]) end |
| 7643 | end |
| 7644 | else error(14) |
| 7645 | end |
| 7646 | end (*constdeclaration*) ; |
| 7647 | |
| 7648 | procedure typedeclaration; |
| 7649 | var lcp: ctp; lsp: stp; lsize: addrrange; |
| 7650 | begin |
| 7651 | if sy <> ident then |
| 7652 | begin error(2); skip(fsys + [ident]) end; |
| 7653 | while sy = ident do |
| 7654 | begin new(lcp,types); ininam(lcp); |
| 7655 | with lcp^ do |
| 7656 | begin klass := types; strassvf(name, id); idtype := nil; |
| 7657 | refer := false |
| 7658 | end; |
| 7659 | insymbol; |
| 7660 | if (sy = relop) and (op = eqop) then insymbol else error(16); |
| 7661 | typ(fsys + [semicolon],lsp,lsize); |
| 7662 | enterid(lcp); |
| 7663 | lcp^.idtype := lsp; |
| 7664 | if sy = semicolon then |
| 7665 | begin insymbol; |
| 7666 | if not (sy in fsys + [ident]) then |
| 7667 | begin error(6); skip(fsys + [ident]) end |
| 7668 | end |
| 7669 | else error(14) |
| 7670 | end; |
| 7671 | resolvep |
| 7672 | end (*typedeclaration*) ; |
| 7673 | |
| 7674 | procedure wrtsym(lcp: ctp; typ: char); |
| 7675 | begin |
| 7676 | if prcode then begin |
| 7677 | with lcp^ do begin |
| 7678 | write(prr, 's',' ':7); |
| 7679 | writev(prr, name, lenpv(name)); write(prr, ' ', typ); |
| 7680 | if klass in [proc, func] then begin |
| 7681 | write(prr, ' ', pfaddr:1, ' '); |
| 7682 | write(prr, 'q('); prtpartyp(lcp); write(prr, ')'); |
| 7683 | if klass = func then begin |
| 7684 | write(prr, ':'); wrttyp(prr, idtype) |
| 7685 | end |
| 7686 | end else if klass = vars then begin |
| 7687 | write(prr, ' ', vaddr:1, ' '); |
| 7688 | wrttyp(prr, idtype) |
| 7689 | end else if klass = fixedt then begin |
| 7690 | { fixed address is determined at gentime } |
| 7691 | write(prr, ' 0 '); |
| 7692 | wrttyp(prr, idtype) |
| 7693 | end else error(517); |
| 7694 | writeln(prr) |
| 7695 | end |
| 7696 | end |
| 7697 | end; |
| 7698 | |
| 7699 | procedure vardeclaration; |
| 7700 | var lcp,nxt: ctp; lsp: stp; lsize: addrrange; |
| 7701 | test: boolean; maxpar, curpar: integer; cc: integer; |
| 7702 | begin nxt := nil; |
| 7703 | repeat { id:type group } |
| 7704 | maxpar := 0; |
| 7705 | repeat {ids } |
| 7706 | lcp := nil; |
| 7707 | if sy = ident then |
| 7708 | begin new(lcp,vars); ininam(lcp); curpar := 0; |
| 7709 | with lcp^ do |
| 7710 | begin klass := vars; strassvf(name, id); next := nxt; |
| 7711 | idtype := nil; vkind := actual; vlev := level; |
| 7712 | refer := false; isloc := false; threat := false; forcnt := 0; |
| 7713 | part := ptval; hdr := false; vext := incact; |
| 7714 | vmod := incstk; inilab := -1; ininxt := nil; dblptr := false; |
| 7715 | end; |
| 7716 | enterid(lcp); |
| 7717 | nxt := lcp; |
| 7718 | insymbol; |
| 7719 | end |
| 7720 | else error(2); |
| 7721 | if (sy = lparent) and not iso7185 then begin |
| 7722 | { parameterized type specification } |
| 7723 | if (nxt <> nil) and (lcp <>nil) then begin { gen code strip label } |
| 7724 | lcp^.ininxt := display[top].inilst; display[top].inilst := lcp; |
| 7725 | genlabel(lcp^.inilab); prtlabel(lcp^.inilab); |
| 7726 | if prcode then writeln(prr); |
| 7727 | genlabel(lcp^.skplab) |
| 7728 | end; |
| 7729 | insymbol; |
| 7730 | repeat |
| 7731 | expression(fsys+[comma,rparent], false); load; curpar := curpar+1; |
| 7732 | if gattr.typtr <> nil then |
| 7733 | if basetype(gattr.typtr) <> intptr then error(243); |
| 7734 | if not (sy in [comma,rparent]) then |
| 7735 | begin error(27); |
| 7736 | skip(fsys+[comma,rparent,colon,semicolon]+typedels) end; |
| 7737 | test := sy <> comma; |
| 7738 | if not test then insymbol |
| 7739 | until test; |
| 7740 | if lcp <> nil then genujpxjpcal(57(*ujp*),lcp^.skplab); |
| 7741 | if sy = rparent then insymbol else error(4) |
| 7742 | end; |
| 7743 | if (maxpar <> 0) and (curpar <> maxpar) then error(269); |
| 7744 | if curpar > maxpar then maxpar := curpar; |
| 7745 | if not (sy in fsys + [comma,colon] + typedels) then |
| 7746 | begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end; |
| 7747 | test := sy <> comma; |
| 7748 | if not test then insymbol |
| 7749 | until test; |
| 7750 | { At this point, initializers, if they exist, are on stack in groups |
| 7751 | according to the id they belong to, and maxpar indicates how many per |
| 7752 | id. This must be so because we don't know the type or location of the |
| 7753 | assocated variable yet. } |
| 7754 | if sy = colon then insymbol else error(5); |
| 7755 | typ(fsys + [semicolon] + typedels,lsp,lsize); |
| 7756 | cc := containers(lsp); { find # containers } |
| 7757 | if cc > 0 then |
| 7758 | { change variable from size of base to pointer+template for containers } |
| 7759 | lsize := ptrsize+cc*intsize; |
| 7760 | resolvep; { resolve pointer defs before symbol generate } |
| 7761 | if lsp <> nil then |
| 7762 | if (lsp^.form = arrayc) and (maxpar = 0) then error(270) |
| 7763 | else if maxpar <> containers(lsp) then error(271); |
| 7764 | while nxt <> nil do |
| 7765 | with nxt^ do |
| 7766 | begin |
| 7767 | idtype := lsp; |
| 7768 | { globals are alloc/increment, locals are decrement/alloc } |
| 7769 | if level <= 1 then |
| 7770 | begin alignu(lsp,gc); vaddr := gc; gc := gc + lsize end |
| 7771 | else |
| 7772 | begin lc := lc - lsize; alignd(lsp,lc); vaddr := lc end; |
| 7773 | { mark symbol } |
| 7774 | if prcode then |
| 7775 | if level <= 1 then wrtsym(nxt, 'g') else wrtsym(nxt, 'l'); |
| 7776 | if maxpar > 0 then begin |
| 7777 | prtlabel(nxt^.skplab); if prcode then writeln(prr); |
| 7778 | { load variable address } |
| 7779 | if level <= 1 then gen1(37(*lao*),vaddr) |
| 7780 | else gen2(50(*lda*),level-(level-vlev),vaddr); |
| 7781 | if level <= 1 then |
| 7782 | { issue vector init ptr instruction } |
| 7783 | gen2(97(*vip*),maxpar,containerbase(lsp)) |
| 7784 | else |
| 7785 | { issue vector init stack instruction } |
| 7786 | gen2(96(*vis*),maxpar,containerbase(lsp)); |
| 7787 | gen0(90(*ret*)); { issue code strip return } |
| 7788 | { remove initializers, var addr } |
| 7789 | mesl(maxpar*intsize+adrsize) |
| 7790 | end; |
| 7791 | nxt := next |
| 7792 | end; |
| 7793 | if sy = semicolon then |
| 7794 | begin insymbol; |
| 7795 | if not (sy in fsys + [ident]) then |
| 7796 | begin error(6); skip(fsys + [ident]) end |
| 7797 | end |
| 7798 | else error(14) |
| 7799 | until (sy <> ident) and not (sy in typedels); |
| 7800 | resolvep |
| 7801 | end (*vardeclaration*) ; |
| 7802 | |
| 7803 | procedure fixeddeclaration; |
| 7804 | var lcp: ctp; lsp: stp; lsize: addrrange; |
| 7805 | v: integer; d: boolean; dummy: stp; |
| 7806 | procedure fixeditem(fsys: setofsys; lsp: stp; size: integer; var v: integer; var d: boolean); |
| 7807 | var fvalu: valu; lsp1: stp; lcp: ctp; i, min, max: integer; |
| 7808 | test: boolean; |
| 7809 | begin v := 0; d := false; |
| 7810 | if lsp <> nil then begin |
| 7811 | case lsp^.form of |
| 7812 | scalar: if lsp^.scalkind = declared then begin |
| 7813 | { enumerated type } |
| 7814 | if sy = ident then begin |
| 7815 | searchid([konst],lcp); |
| 7816 | if not comptypes(lsp, lcp^.idtype) then error(245); |
| 7817 | if lcp^.values.intval then begin |
| 7818 | if prcode then begin |
| 7819 | if lsp = boolptr then |
| 7820 | writeln(prr, 'c b ', lcp^.values.ival:1) |
| 7821 | else if size = 1 then |
| 7822 | writeln(prr, 'c x ', lcp^.values.ival:1) |
| 7823 | else writeln(prr, 'c i ', lcp^.values.ival:1); |
| 7824 | end; |
| 7825 | v := lcp^.values.ival; d := true |
| 7826 | end else error(513); |
| 7827 | insymbol |
| 7828 | end else error(2) |
| 7829 | end else begin |
| 7830 | { get value to satisfy entry } |
| 7831 | constexpr(fsys,lsp1,fvalu); |
| 7832 | if lsp1 <> nil then |
| 7833 | if (lsp = realptr) and (lsp1 = intptr) then begin |
| 7834 | { integer to real, convert } |
| 7835 | if not fvalu.intval then error(515) |
| 7836 | else if prcode then writeln(prr, 'c r ', fvalu.ival:1) |
| 7837 | end else if comptypes(lsp, lsp1) then begin |
| 7838 | { constants possible are i: integer, r: real, |
| 7839 | p: (power) set, s: string (including set), c: char, |
| 7840 | b: boolean, x: byte integer } |
| 7841 | if lsp = charptr then begin |
| 7842 | if fvalu.intval then begin |
| 7843 | if prcode then write(prr, 'c c ', fvalu.ival:1); |
| 7844 | v := fvalu.ival; d := true |
| 7845 | end |
| 7846 | end else if fvalu.intval then begin |
| 7847 | if prcode then begin |
| 7848 | if size = 1 then |
| 7849 | write(prr, 'c x ', fvalu.ival:1) |
| 7850 | else write(prr, 'c i ', fvalu.ival:1) |
| 7851 | end; |
| 7852 | v := fvalu.ival; d := true |
| 7853 | end else if (fvalu.valp^.cclass = reel) and prcode then |
| 7854 | write(prr, 'c r ', fvalu.valp^.rval:23); |
| 7855 | if prcode then writeln(prr) |
| 7856 | end else error(245) |
| 7857 | end; |
| 7858 | subrange: begin fixeditem(fsys,lsp^.rangetype,lsp^.size,v,d); |
| 7859 | if d then |
| 7860 | if (v < lsp^.min.ival) or (v > lsp^.max.ival) then |
| 7861 | error(246) |
| 7862 | end; |
| 7863 | power: begin { get value to satisfy entry } |
| 7864 | constexpr(fsys,lsp1,fvalu); |
| 7865 | if comptypes(lsp, lsp1) then begin |
| 7866 | if prcode then begin |
| 7867 | write(prr, 'c p ('); |
| 7868 | for i := setlow to sethigh do |
| 7869 | if i in fvalu.valp^.pval then write(prr,' ',i:1); |
| 7870 | writeln(prr, ')') |
| 7871 | end |
| 7872 | end else error(245) |
| 7873 | end; |
| 7874 | arrays: begin getbounds(lsp^.inxtype, min, max); |
| 7875 | if (sy = stringconst) and stringt(lsp) then begin |
| 7876 | constexpr(fsys,lsp1,fvalu); |
| 7877 | if comptypes(lsp, lsp1) then begin |
| 7878 | { string constant matches array } |
| 7879 | if fvalu.valp^.slgth <> max then error(245); |
| 7880 | if prcode then begin |
| 7881 | write(prr, 'c '); |
| 7882 | write(prr, 's '''); |
| 7883 | writev(prr, fvalu.valp^.sval, fvalu.valp^.slgth); |
| 7884 | writeln(prr, '''') |
| 7885 | end |
| 7886 | end else error(245) |
| 7887 | end else begin |
| 7888 | { iterate array elements } |
| 7889 | i := min; if sy = arraysy then insymbol else error(28); |
| 7890 | repeat |
| 7891 | if prcode then writeln(prr, 'r'); {reset alignment } |
| 7892 | fixeditem(fsys+[comma,endsy],lsp^.aeltype, lsp^.aeltype^.size, v, d); |
| 7893 | i := i+1; |
| 7894 | if not (sy in [comma,endsy]) then |
| 7895 | begin error(29); skip(fsys+[comma,endsy]+typedels) end; |
| 7896 | test := sy <> comma; |
| 7897 | if not test then insymbol |
| 7898 | until test; |
| 7899 | if i-1 <> max then error(247); |
| 7900 | if sy = endsy then insymbol else error(13) |
| 7901 | end |
| 7902 | end; |
| 7903 | records: begin lcp := lsp^.fstfld; |
| 7904 | if lsp^.recvar <> nil then error(248); |
| 7905 | if sy = recordsy then insymbol else error(28); |
| 7906 | i := 1; max := 1; |
| 7907 | repeat |
| 7908 | if lcp = nil then |
| 7909 | { ran out of data items, dummy parse a constant } |
| 7910 | constexpr(fsys+[comma,endsy],dummy,fvalu) |
| 7911 | else fixeditem(fsys+[comma,endsy],lcp^.idtype, |
| 7912 | lcp^.idtype^.size, v, d); |
| 7913 | max := max+1; |
| 7914 | if lcp <> nil then begin lcp := lcp^.next; i := i+1 end; |
| 7915 | if not (sy in [comma,endsy]) then |
| 7916 | begin error(29); skip(fsys+[comma,endsy]+typedels) end; |
| 7917 | test := sy <> comma; |
| 7918 | if not test then insymbol |
| 7919 | until test; |
| 7920 | if i <> max then error(247); |
| 7921 | if sy = endsy then insymbol else error(13) |
| 7922 | end; |
| 7923 | pointer, arrayc, files, tagfld, variant,exceptf: error(244); |
| 7924 | end |
| 7925 | end |
| 7926 | end; |
| 7927 | begin |
| 7928 | repeat { id:type group } |
| 7929 | lcp := nil; |
| 7930 | if sy = ident then |
| 7931 | begin new(lcp,fixedt); ininam(lcp); |
| 7932 | with lcp^ do |
| 7933 | begin klass := fixedt; strassvf(name, id); |
| 7934 | idtype := nil; floc := -1; fext := incact; fmod := incstk |
| 7935 | end; |
| 7936 | enterid(lcp); |
| 7937 | insymbol; |
| 7938 | end |
| 7939 | else error(2); |
| 7940 | if not (sy in fsys + [colon] + typedels) then |
| 7941 | begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end; |
| 7942 | if sy = colon then insymbol else error(5); |
| 7943 | typ(fsys + [semicolon,relop] + typedels,lsp,lsize); |
| 7944 | if lcp <> nil then lcp^.idtype := lsp; |
| 7945 | { mark symbol } |
| 7946 | if prcode then |
| 7947 | if level <= 1 then wrtsym(lcp, 'f') else wrtsym(lcp, 'c'); |
| 7948 | if (sy = relop) and (op = eqop) then begin |
| 7949 | insymbol; |
| 7950 | { start fixed constants } |
| 7951 | if prcode then write(prr, 'n '); |
| 7952 | if level > 1 then genlabel(lcp^.floc); |
| 7953 | prtfxlabel(lcp); |
| 7954 | if prcode then writeln(prr, ' ', lsize:1); |
| 7955 | fixeditem(fsys+[semicolon], lsp, lsp^.size, v, d); |
| 7956 | if prcode then writeln(prr, 'x') |
| 7957 | end else error(16); |
| 7958 | if sy = semicolon then |
| 7959 | begin insymbol; |
| 7960 | if not (sy in fsys + [ident]) then |
| 7961 | begin error(6); skip(fsys + [ident]) end |
| 7962 | end |
| 7963 | else error(14) |
| 7964 | until (sy <> ident) and not (sy in typedels) |
| 7965 | end (*fixeddeclaration*) ; |
| 7966 | |
| 7967 | procedure procdeclaration(fsy: symbol); |
| 7968 | var oldlev: 0..maxlevel; lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; |
| 7969 | forw,forwn,extn,opr,isvirt, form: boolean; |
| 7970 | oldtop: disprange; llc: stkoff; lbname: integer; plst: boolean; |
| 7971 | fpat: fpattr; ops: restr; opt: operatort; ids: idstr; |
| 7972 | |
| 7973 | procedure pushlvl(lcp: ctp); |
| 7974 | begin |
| 7975 | if level < maxlevel then level := level + 1 else error(251); |
| 7976 | if top < displimit then |
| 7977 | begin top := top + 1; |
| 7978 | with display[top] do |
| 7979 | begin inidsp(display[top]); |
| 7980 | { use the defining point status of the parent block } |
| 7981 | define := display[top-1].define; |
| 7982 | occur := blck; bname := lcp |
| 7983 | end |
| 7984 | end |
| 7985 | else error(250); |
| 7986 | end; |
| 7987 | |
| 7988 | procedure parameterlist(fsy: setofsys; var fpar: ctp; var plst: boolean; |
| 7989 | opr: boolean; opt: operatort); |
| 7990 | var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind; |
| 7991 | llc,lsize: addrrange; count: integer; pt: partyp; |
| 7992 | oldlev: 0..maxlevel; oldtop: disprange; |
| 7993 | lcs: addrrange; test: boolean; dummy: boolean; first: boolean; |
| 7994 | procedure joinlists; |
| 7995 | var lcp, lcp3: ctp; |
| 7996 | begin |
| 7997 | { we missed the type for this id list, meaning the types are nil. Add |
| 7998 | the new list as is for error recovery } |
| 7999 | if lcp2 <> nil then begin |
| 8000 | lcp3 := lcp2; { save sublist head } |
| 8001 | { find sublist end } |
| 8002 | lcp := nil; |
| 8003 | while lcp2 <> nil do begin lcp := lcp2; lcp2 := lcp2^.next end; |
| 8004 | { join lists } |
| 8005 | lcp^.next := lcp1; |
| 8006 | lcp1 := lcp3 |
| 8007 | end |
| 8008 | end; |
| 8009 | begin { parameterlist } |
| 8010 | plst := false; first := true; |
| 8011 | lcp1 := nil; |
| 8012 | if not (sy in fsy + [lparent]) then |
| 8013 | begin error(7); skip(fsys + fsy + [lparent]) end; |
| 8014 | if sy = lparent then |
| 8015 | begin plst := true; |
| 8016 | insymbol; |
| 8017 | if not (sy in [ident,varsy,procsy,funcsy,viewsy,outsy]) then |
| 8018 | begin error(7); skip(fsys + [ident,rparent]) end; |
| 8019 | while sy in [ident,varsy,procsy,funcsy,viewsy,outsy] do |
| 8020 | begin |
| 8021 | if sy = procsy then |
| 8022 | begin |
| 8023 | insymbol; lcp := nil; if opr then error(285); |
| 8024 | if sy = ident then |
| 8025 | begin new(lcp,proc,declared,formal); ininam(lcp); |
| 8026 | lc := lc-ptrsize*2; { mp and addr } |
| 8027 | alignd(parmptr,lc); |
| 8028 | with lcp^ do |
| 8029 | begin klass:=proc; strassvf(name, id); idtype := nil; |
| 8030 | next := lcp1; |
| 8031 | pflev := level (*beware of parameter procedures*); |
| 8032 | pfdeckind:=declared; pflist := nil; |
| 8033 | pfkind:=formal; pfaddr := lc; pext := false; |
| 8034 | pmod := nil; keep := true; pfattr := fpanone; |
| 8035 | grpnxt := nil; grppar := lcp; pfvid := nil |
| 8036 | end; |
| 8037 | enterid(lcp); |
| 8038 | lcp1 := lcp; |
| 8039 | insymbol |
| 8040 | end |
| 8041 | else error(2); |
| 8042 | oldlev := level; oldtop := top; pushlvl(lcp); |
| 8043 | lcs := lc; parameterlist([semicolon,rparent],lcp2,dummy, false, noop); |
| 8044 | lc := lcs; |
| 8045 | if lcp <> nil then |
| 8046 | begin lcp^.pflist := lcp2; lcp^.pfnum := parnum(lcp) end; |
| 8047 | if not (sy in fsys+[semicolon,rparent]) then |
| 8048 | begin error(7);skip(fsys+[semicolon,rparent]) end; |
| 8049 | level := oldlev; putdsps(oldtop); top := oldtop |
| 8050 | end |
| 8051 | else |
| 8052 | begin |
| 8053 | if sy = funcsy then |
| 8054 | begin lcp2 := nil; if opr then error(285); |
| 8055 | insymbol; |
| 8056 | if sy = ident then |
| 8057 | begin new(lcp,func,declared,formal); ininam(lcp); |
| 8058 | lc := lc-ptrsize*2; { mp and addr } |
| 8059 | alignd(parmptr,lc); |
| 8060 | with lcp^ do |
| 8061 | begin klass:=func; strassvf(name, id); |
| 8062 | idtype := nil; next := lcp1; |
| 8063 | pflev := level (*beware param funcs*); |
| 8064 | pfdeckind:=declared; pflist := nil; |
| 8065 | pfkind:=formal; pfaddr:=lc; pext := false; |
| 8066 | pmod := nil; keep := true; pfattr := fpanone; |
| 8067 | grpnxt := nil; grppar := lcp; pfvid := nil |
| 8068 | end; |
| 8069 | enterid(lcp); |
| 8070 | lcp1 := lcp; |
| 8071 | insymbol; |
| 8072 | end |
| 8073 | else error(2); |
| 8074 | oldlev := level; oldtop := top; pushlvl(lcp); |
| 8075 | lcs := lc; |
| 8076 | parameterlist([colon,semicolon,rparent],lcp2,dummy, false, noop); |
| 8077 | lc := lcs; |
| 8078 | if lcp <> nil then |
| 8079 | begin lcp^.pflist := lcp2; lcp^.pfnum := parnum(lcp) end; |
| 8080 | if not (sy in fsys+[colon]) then |
| 8081 | begin error(7);skip(fsys+[comma,semicolon,rparent]) end; |
| 8082 | if sy = colon then |
| 8083 | begin insymbol; |
| 8084 | if sy = ident then |
| 8085 | begin searchid([types],lcp2); |
| 8086 | lsp := lcp2^.idtype; |
| 8087 | lcp^.idtype := lsp; |
| 8088 | if lsp <> nil then |
| 8089 | if not(lsp^.form in[scalar,subrange,pointer]) |
| 8090 | then begin error(120); lsp := nil end; |
| 8091 | insymbol |
| 8092 | end |
| 8093 | else error(2); |
| 8094 | if not (sy in fsys + [semicolon,rparent]) then |
| 8095 | begin error(7);skip(fsys+[semicolon,rparent])end |
| 8096 | end |
| 8097 | else error(5); |
| 8098 | level := oldlev; putdsps(oldtop); top := oldtop |
| 8099 | end |
| 8100 | else |
| 8101 | begin |
| 8102 | pt := ptval; |
| 8103 | if sy = varsy then pt := ptvar |
| 8104 | else if sy = viewsy then pt := ptview |
| 8105 | else if sy = outsy then pt := ptout; |
| 8106 | if opr then begin |
| 8107 | if first and (opt = bcmop) then begin |
| 8108 | if pt <> ptout then error(288) |
| 8109 | end else if opr and (pt <> ptval) and (pt <> ptview) then |
| 8110 | error(286) |
| 8111 | end; |
| 8112 | if (sy = varsy) or (sy = outsy) then |
| 8113 | begin lkind := formal; insymbol end |
| 8114 | else begin lkind := actual; |
| 8115 | if sy = viewsy then insymbol |
| 8116 | end; |
| 8117 | lcp2 := nil; |
| 8118 | count := 0; |
| 8119 | repeat |
| 8120 | if sy = ident then |
| 8121 | begin new(lcp,vars); ininam(lcp); |
| 8122 | with lcp^ do |
| 8123 | begin klass:=vars; strassvf(name,id); |
| 8124 | idtype:=nil; vkind := lkind; next := lcp2; |
| 8125 | vlev := level; keep := true; refer := false; |
| 8126 | isloc := false; threat := false; forcnt := 0; |
| 8127 | part := pt; hdr := false; vext := false; |
| 8128 | vmod := nil; vaddr := 0; inilab := -1; |
| 8129 | ininxt := nil; dblptr := true |
| 8130 | end; |
| 8131 | enterid(lcp); |
| 8132 | lcp2 := lcp; count := count+1; |
| 8133 | insymbol; |
| 8134 | end |
| 8135 | else error(2); |
| 8136 | if not (sy in [comma,colon] + fsys) then |
| 8137 | begin error(7);skip(fsys+[comma,semicolon,rparent]) |
| 8138 | end; |
| 8139 | test := sy <> comma; |
| 8140 | if not test then insymbol |
| 8141 | until test; |
| 8142 | if sy = colon then |
| 8143 | begin insymbol; |
| 8144 | if sy = ident then |
| 8145 | begin searchid([types],lcp); |
| 8146 | lsp := lcp^.idtype; |
| 8147 | lsize := ptrsize; |
| 8148 | if lsp <> nil then begin |
| 8149 | if lsp^.form = arrayc then lsize := ptrsize*2; |
| 8150 | if lkind=actual then begin |
| 8151 | if lsp^.form<=power then lsize := lsp^.size |
| 8152 | else if lsp^.form=files then error(121); |
| 8153 | { type containing file not allowed either } |
| 8154 | if filecomponent(lsp) then error(121) |
| 8155 | end |
| 8156 | end; |
| 8157 | alignu(parmptr,lsize); |
| 8158 | lcp3 := lcp2; |
| 8159 | lc := lc-count*lsize; |
| 8160 | alignd(parmptr,lc); |
| 8161 | llc := lc; |
| 8162 | while lcp2 <> nil do |
| 8163 | begin lcp := lcp2; |
| 8164 | with lcp2^ do |
| 8165 | begin idtype := lsp; |
| 8166 | vaddr := llc; |
| 8167 | llc := llc+lsize; |
| 8168 | { if the type is structured, and is |
| 8169 | a view parameter, promote to formal } |
| 8170 | if lsp <> nil then |
| 8171 | if (lsp^.form > power) and |
| 8172 | (part = ptview) then |
| 8173 | vkind := formal |
| 8174 | end; |
| 8175 | lcp2 := lcp2^.next |
| 8176 | end; |
| 8177 | lcp^.next := lcp1; lcp1 := lcp3; |
| 8178 | insymbol |
| 8179 | end |
| 8180 | else begin error(2); joinlists end; |
| 8181 | if not (sy in fsys + [semicolon,rparent]) then |
| 8182 | begin error(7);skip(fsys+[semicolon,rparent])end |
| 8183 | end |
| 8184 | else begin error(5); joinlists end |
| 8185 | end; |
| 8186 | end; |
| 8187 | first := false; |
| 8188 | if sy = semicolon then |
| 8189 | begin insymbol; |
| 8190 | if not (sy in fsys + [ident,varsy,procsy,funcsy,viewsy,outsy]) then |
| 8191 | begin error(7); skip(fsys + [ident,rparent]) end |
| 8192 | end |
| 8193 | end (*while*) ; |
| 8194 | if sy = rparent then |
| 8195 | begin insymbol; |
| 8196 | if not (sy in fsy + fsys) then |
| 8197 | begin error(6); skip(fsy + fsys) end |
| 8198 | end |
| 8199 | else error(4); |
| 8200 | lcp3 := nil; |
| 8201 | (*reverse pointers and reserve local cells for copies of multiple |
| 8202 | values*) |
| 8203 | lc := -level*ptrsize; { set locals top } |
| 8204 | while lcp1 <> nil do |
| 8205 | with lcp1^ do |
| 8206 | begin lcp2 := next; next := lcp3; |
| 8207 | if klass = vars then |
| 8208 | if idtype <> nil then |
| 8209 | { if value variable, and structured, we make a copy to |
| 8210 | play with. However, structured is treated as var if |
| 8211 | it is view, since that is protected } |
| 8212 | if (vkind=actual) and (idtype^.form>power) and |
| 8213 | (idtype^.form <> arrayc) then |
| 8214 | begin |
| 8215 | lc := lc-idtype^.size; |
| 8216 | alignd(parmptr,lc); |
| 8217 | vaddr := lc; |
| 8218 | isloc := true { flag is a local now } |
| 8219 | end; |
| 8220 | lcp3 := lcp1; lcp1 := lcp2 |
| 8221 | end; |
| 8222 | fpar := lcp3 |
| 8223 | end else begin fpar := nil; lc := -level*ptrsize end |
| 8224 | end (*parameterlist*) ; |
| 8225 | |
| 8226 | { for overloading, same as strict cmpparlst(), but includes read = integer |
| 8227 | and string = char } |
| 8228 | function compparamovl(pla, plb: ctp): boolean; |
| 8229 | var f: boolean; t1, t2: stp; |
| 8230 | begin f := true; |
| 8231 | while (pla <> nil) and (plb <> nil) do begin |
| 8232 | if not cmppar(pla,plb) then begin |
| 8233 | { incompatible, but check special cases } |
| 8234 | t1 := basetype(pla^.idtype); |
| 8235 | t2 := basetype(plb^.idtype); |
| 8236 | if not ((intt(t1) and realt(t2)) or |
| 8237 | (realt(t1) and intt(t2)) or |
| 8238 | (chart(t1) and chart(t2))) then f := false |
| 8239 | end; |
| 8240 | pla := pla^.next; plb := plb^.next |
| 8241 | end; |
| 8242 | if (pla <> nil) or (plb <> nil) then f := false; |
| 8243 | compparamovl := f |
| 8244 | end; |
| 8245 | |
| 8246 | { check parameter lists converge with different modes } |
| 8247 | function conpar(pla, plb: ctp): boolean; |
| 8248 | var f: boolean; |
| 8249 | { find bidirectionally assignment compatible } |
| 8250 | function comp(t1, t2: stp): boolean; |
| 8251 | begin comp := false; |
| 8252 | if comptypes(t1, t2) then comp := true |
| 8253 | else if (intt(t1) and realt(t2)) or (realt(t1) and intt(t2)) or |
| 8254 | (chart(t1) and chart(t2)) then comp := true |
| 8255 | end; |
| 8256 | begin f := false; |
| 8257 | while (pla <> nil) and (plb <> nil) do begin |
| 8258 | if comp(pla^.idtype,plb^.idtype) then |
| 8259 | if pla^.part <> plb^.part then begin f := true; pla := nil end |
| 8260 | else begin pla := pla^.next; plb := plb^.next end |
| 8261 | else pla := nil |
| 8262 | end; |
| 8263 | conpar := f |
| 8264 | end; |
| 8265 | |
| 8266 | { check overload proc/funcs against each other, first list is group } |
| 8267 | procedure chkovlpar(lcp, lp, hp: ctp); |
| 8268 | var e: boolean; |
| 8269 | begin |
| 8270 | e := false; |
| 8271 | while lcp <> nil do begin |
| 8272 | if (lcp <> hp) and (lcp^.klass = hp^.klass) then begin |
| 8273 | if compparamovl(lp, lcp^.pflist) then begin |
| 8274 | if not e then if fsy = operatorsy then error(283) |
| 8275 | else error(249); |
| 8276 | e := true |
| 8277 | end; |
| 8278 | if conpar(lp, lcp^.pflist) then begin |
| 8279 | if not e then if fsy = operatorsy then error(284) |
| 8280 | else error(276); |
| 8281 | e := true |
| 8282 | end; |
| 8283 | end; |
| 8284 | lcp := lcp^.grpnxt |
| 8285 | end |
| 8286 | end; |
| 8287 | |
| 8288 | { find congruent overload group } |
| 8289 | function fndovlgrp(lcp, lp, hp: ctp): ctp; |
| 8290 | var lcp1: ctp; |
| 8291 | begin |
| 8292 | lcp1 := nil; |
| 8293 | lcp := lcp^.grppar; { index top of overload group } |
| 8294 | while lcp <> nil do begin |
| 8295 | if cmpparlst(lcp^.pflist, lp) and (lcp <> hp) and |
| 8296 | (lcp^.klass = hp^.klass) then begin |
| 8297 | lcp1 := lcp; lcp := nil { found congruent group } |
| 8298 | end else lcp := lcp^.grpnxt |
| 8299 | end; |
| 8300 | fndovlgrp := lcp1 |
| 8301 | end; |
| 8302 | |
| 8303 | { find space occupied by parameter list } |
| 8304 | function parmspc(plst: ctp): addrrange; |
| 8305 | var locpar: addrrange; |
| 8306 | begin |
| 8307 | locpar := 0; |
| 8308 | while plst <> nil do begin |
| 8309 | if (plst^.idtype <> nil) and (plst^.klass = vars) then begin |
| 8310 | if (plst^.part = ptval) or (plst^.part = ptview) then begin |
| 8311 | if plst^.idtype^.form <= power then |
| 8312 | locpar := locpar+plst^.idtype^.size |
| 8313 | else if plst^.idtype^.form = arrayc then |
| 8314 | locpar := locpar+ptrsize*2 |
| 8315 | else locpar := locpar+ptrsize |
| 8316 | end else begin |
| 8317 | if plst^.idtype^.form = arrayc then locpar := locpar+ptrsize*2 |
| 8318 | else locpar := locpar+ptrsize |
| 8319 | end |
| 8320 | end else if (plst^.klass = proc) or (plst^.klass = func) then |
| 8321 | locpar := locpar+ptrsize*2; |
| 8322 | alignu(parmptr,locpar); |
| 8323 | plst := plst^.next |
| 8324 | end; |
| 8325 | parmspc := locpar |
| 8326 | end; |
| 8327 | |
| 8328 | { offset addresses in parameter list } |
| 8329 | procedure parmoff(plst: ctp; off: addrrange); |
| 8330 | begin |
| 8331 | while plst <> nil do begin |
| 8332 | if plst^.klass = vars then begin |
| 8333 | if not plst^.isloc then plst^.vaddr := plst^.vaddr+off |
| 8334 | end else if (plst^.klass = proc) or (plst^.klass = func) then |
| 8335 | plst^.pfaddr := plst^.pfaddr+off; |
| 8336 | plst := plst^.next |
| 8337 | end |
| 8338 | end; |
| 8339 | |
| 8340 | { merge names in parameter list with current display } |
| 8341 | procedure parmrg(plst: ctp); |
| 8342 | begin |
| 8343 | while plst <> nil do begin |
| 8344 | enterid(plst); |
| 8345 | plst := plst^.next |
| 8346 | end |
| 8347 | end; |
| 8348 | |
| 8349 | begin (*procdeclaration*) |
| 8350 | { parse and skip any attribute } |
| 8351 | fpat := fpanone; |
| 8352 | opt := bcmop; { avoid undefined error } |
| 8353 | if fsy in [overloadsy,staticsy,virtualsy,overridesy] then begin |
| 8354 | chkstd; |
| 8355 | case fsy of { attribute } |
| 8356 | overloadsy: fpat := fpaoverload; |
| 8357 | staticsy: fpat := fpastatic; |
| 8358 | virtualsy: begin fpat := fpavirtual; if top > 1 then error(228) end; |
| 8359 | overridesy: begin fpat := fpaoverride; if top > 1 then error(229) end; |
| 8360 | end; |
| 8361 | if (sy <> procsy) and (sy <> funcsy) and (sy <> operatorsy) then |
| 8362 | if iso7185 then error(209) else error(279) |
| 8363 | else fsy := sy; insymbol |
| 8364 | end; |
| 8365 | { set parameter address start to zero, offset later } |
| 8366 | llc := lc; lc := 0; ids := id; opr := false; lcp1 := nil; |
| 8367 | { lcp = current proc/func, lcp1 = previous proc/func, lcp2 = parm list } |
| 8368 | if (sy = ident) or (fsy = operatorsy) then begin |
| 8369 | if fsy = operatorsy then begin { process operator definition } |
| 8370 | opr := true; |
| 8371 | if not (sy in [mulop,addop,relop,notsy,becomes]) then |
| 8372 | begin error(281); lcp1 := nil; |
| 8373 | skip(fsys+[mulop,addop,relop,notsy,arrow,lparent,semicolon]) |
| 8374 | end |
| 8375 | else begin |
| 8376 | if sy = notsy then op := notop |
| 8377 | else if sy = becomes then op := bcmop; |
| 8378 | lcp1 := display[top].oprprc[op] { pick up an operator leader } |
| 8379 | end; |
| 8380 | if fpat <> fpanone then error(280); |
| 8381 | opt := op { save operator for later } |
| 8382 | end else begin |
| 8383 | searchsection(display[top].fname,lcp1); { find previous definition } |
| 8384 | if lcp1 <> nil then |
| 8385 | if not (lcp1^.klass in [proc, func]) then begin |
| 8386 | error(101); lcp1 := nil |
| 8387 | end |
| 8388 | end; |
| 8389 | { create proc/func entry } |
| 8390 | if (fsy = procsy) or ((fsy = operatorsy) and (opt = bcmop)) then |
| 8391 | new(lcp,proc,declared,actual) |
| 8392 | else { func/opr } new(lcp,func,declared,actual); |
| 8393 | ininam(lcp); |
| 8394 | with lcp^ do begin |
| 8395 | if (fsy = procsy) or |
| 8396 | ((fsy = operatorsy) and (opt = bcmop)) then |
| 8397 | klass := proc else klass := func; |
| 8398 | if fsy = operatorsy then begin |
| 8399 | { Synth a label based on the operator. This is done for |
| 8400 | downstream diagnostics. } |
| 8401 | case op of { operator } |
| 8402 | mul: ops := '* '; rdiv: ops := '/ '; |
| 8403 | andop: ops := 'and '; idiv: ops := 'div '; |
| 8404 | imod: ops := 'mod '; plus: ops := '+ '; |
| 8405 | minus: ops := '- '; orop: ops := 'or '; |
| 8406 | ltop: ops := '< '; leop: ops := '<= '; |
| 8407 | geop: ops := '> '; gtop: ops := '>= '; |
| 8408 | neop: ops := '<> '; eqop: ops := '= '; |
| 8409 | inop: ops := 'in '; xorop: ops := 'xor '; |
| 8410 | notop: ops := 'not '; bcmop: ops := ':= '; |
| 8411 | end; |
| 8412 | strassvr(name, ops) |
| 8413 | end else strassvf(name, ids); |
| 8414 | idtype := nil; next := nil; |
| 8415 | sysrot := false; extern := false; pflev := level; |
| 8416 | genlabel(lbname); pfdeckind := declared; pfkind := actual; |
| 8417 | pfname := lbname; pflist := nil; asgn := false; |
| 8418 | pext := incact; pmod := incstk; refer := false; |
| 8419 | pfattr := fpat; grpnxt := nil; grppar := lcp; |
| 8420 | if lcp1 <> nil then grppar := lcp1^.grppar; |
| 8421 | if pfattr in [fpavirtual, fpaoverride] then begin { alloc vector } |
| 8422 | if pfattr = fpavirtual then begin |
| 8423 | { check previously created the vector } |
| 8424 | isvirt := false; |
| 8425 | if lcp1 <> nil then isvirt := lcp1^.pfattr = fpavirtual; |
| 8426 | if not isvirt then begin |
| 8427 | { have to create a label for far references to virtual } |
| 8428 | new(lcp3,vars); ininam(lcp3); |
| 8429 | with lcp3^ do begin klass := vars; |
| 8430 | strassvf(name, ids); strcatvr(name, '__virtvec'); |
| 8431 | idtype := nilptr; vkind := actual; next := nil; |
| 8432 | vlev := 0; vaddr := gc; isloc := false; threat := false; |
| 8433 | forcnt := 0; part := ptval; hdr := false; |
| 8434 | vext := incact; vmod := incstk; inilab := -1; |
| 8435 | ininxt := nil; dblptr := false; pfvid := nil |
| 8436 | end; |
| 8437 | enterid(lcp3); lcp^.pfvid := lcp3; |
| 8438 | wrtsym(lcp3, 'g') |
| 8439 | end |
| 8440 | end; |
| 8441 | pfvaddr := gc; gc := gc+adrsize |
| 8442 | end; |
| 8443 | if opr then begin |
| 8444 | if display[top].oprprc[op] = nil then display[top].oprprc[op] := lcp |
| 8445 | end else if lcp1 = nil then enterid(lcp) |
| 8446 | end; |
| 8447 | insymbol |
| 8448 | end else begin |
| 8449 | error(2); |
| 8450 | if (fsy = procsy) or ((fsy = operatorsy) and (opt = bcmop)) then |
| 8451 | lcp := uprcptr else lcp := ufctptr |
| 8452 | end; |
| 8453 | { procedure/functions have an odd defining status. The parameter list does |
| 8454 | not have defining points, but the rest of the routine definition does. } |
| 8455 | oldlev := level; oldtop := top; pushlvl(lcp); |
| 8456 | display[top].define := false; |
| 8457 | { push another level to isolate the parameter list for forward declarations } |
| 8458 | pushlvl(nil); level := level-1; |
| 8459 | if (fsy = procsy) or ((fsy = operatorsy) and (opt = bcmop)) then |
| 8460 | parameterlist([semicolon],lcp2,plst, fsy = operatorsy, opt) |
| 8461 | else parameterlist([semicolon,colon],lcp2,plst, fsy = operatorsy, opt); |
| 8462 | putdsps(top-1); top := top-1; { dump display } |
| 8463 | if (fsy = funcsy) or ((fsy = operatorsy) and not (opt = bcmop)) then |
| 8464 | { function } |
| 8465 | if sy = colon then |
| 8466 | begin insymbol; |
| 8467 | if sy = ident then |
| 8468 | begin |
| 8469 | searchid([types],lcp3); |
| 8470 | lcp^.idtype := lcp3^.idtype; |
| 8471 | lsp := lcp^.idtype; |
| 8472 | if lcp^.idtype <> nil then |
| 8473 | if iso7185 then begin |
| 8474 | if not (lsp^.form in [scalar,subrange,pointer]) then |
| 8475 | begin error(120); lcp^.idtype := nil end |
| 8476 | end else begin |
| 8477 | if not (lsp^.form in [scalar,subrange,pointer,power, |
| 8478 | arrays,records]) then |
| 8479 | begin error(274); lcp^.idtype := nil end |
| 8480 | end; |
| 8481 | insymbol |
| 8482 | end |
| 8483 | else begin error(2); skip(fsys + [semicolon]) end |
| 8484 | end; |
| 8485 | if sy = semicolon then insymbol else error(14); |
| 8486 | forwn := false; extn := false; |
| 8487 | if ((sy = ident) and strequri('forward ', id)) or (sy = forwardsy) or |
| 8488 | (sy = externalsy) then begin |
| 8489 | if sy = externalsy then |
| 8490 | begin chkstd; lcp^.extern := true; extn := true end |
| 8491 | else begin lcp^.forwdecl := true; forwn := true end; |
| 8492 | insymbol; |
| 8493 | if sy = semicolon then insymbol else error(14); |
| 8494 | if not (sy in fsys) then |
| 8495 | begin error(6); skip(fsys) end |
| 8496 | end; |
| 8497 | { now the proc/func is completely defined } |
| 8498 | forw := false; { set not forwarded } |
| 8499 | form := false; { set no matching entry } |
| 8500 | if lcp1 <> nil then begin { previous func/proc exists, reconcile } |
| 8501 | if (lcp^.pfattr = fpaoverride) and not (lcp1^.pfattr = fpavirtual) then |
| 8502 | error(231); |
| 8503 | if (lcp^.pfattr = fpaoverride) and not chkext(lcp1) then error(230); |
| 8504 | if lcp^.pfattr = fpaoverload then begin { check for existing overload forward } |
| 8505 | lcp3 := fndovlgrp(lcp1, lcp2, lcp); |
| 8506 | if lcp3 <> nil then begin |
| 8507 | if not lcp3^.forwdecl then error(298); |
| 8508 | lcp1 := lcp3; form := true |
| 8509 | end |
| 8510 | end; |
| 8511 | if lcp^.pfattr = fpaoverride then |
| 8512 | if lcp1^.grpnxt <> nil then lcp1 := lcp1^.grpnxt; |
| 8513 | forw := lcp1^.forwdecl; { set forwarded status } |
| 8514 | if forw and iso7185 and (lcp2 <> nil) then error(119); |
| 8515 | if (lcp^.pfattr <> fpaoverload) and (lcp^.pfattr <> fpaoverride) and |
| 8516 | (fsy <> operatorsy) and not forw then error(101); |
| 8517 | if (lcp^.pfattr = fpaoverload) and (lcp1^.pfattr = fpavirtual) then |
| 8518 | error(232); |
| 8519 | if lcp^.forwdecl and (lcp^.pfattr <> fpaoverload) and forw then |
| 8520 | error(161); |
| 8521 | if (lcp^.pfattr = fpaoverload) and lcp1^.pext then error(294); |
| 8522 | if lcp^.extern <> lcp1^.extern then error(295); |
| 8523 | if ((lcp^.pfattr = fpaoverload) or (fsy = operatorsy)) and |
| 8524 | not lcp1^.forwdecl then { compare against overload group } |
| 8525 | chkovlpar(lcp^.grppar, lcp2, lcp); |
| 8526 | if lcp1^.forwdecl and iso7185 and (lcp^.idtype <> nil) then error(122); |
| 8527 | if lcp1^.forwdecl and not lcp^.forwdecl then |
| 8528 | if not comptypes(lcp^.idtype, lcp1^.idtype) then error(216); |
| 8529 | if ((lcp^.pfattr = fpaoverload) or opr) and not |
| 8530 | (lcp1^.forwdecl and form) then begin |
| 8531 | { just insert to group list for this proc/func } |
| 8532 | lcp^.grpnxt := lcp1^.grpnxt; lcp1^.grpnxt := lcp; lcp^.grppar := lcp1 |
| 8533 | end; |
| 8534 | if (lcp^.pfattr = fpaoverride) and not lcp1^.forwdecl then begin |
| 8535 | { just insert to group list for this proc/func } |
| 8536 | lcp^.grpnxt := lcp1^.grpnxt; lcp1^.grpnxt := lcp; lcp^.grppar := lcp1 |
| 8537 | end |
| 8538 | end else begin { no previous func/proc } |
| 8539 | if lcp^.pfattr = fpaoverload then error(297) |
| 8540 | else if lcp^.pfattr = fpaoverride then error(231); |
| 8541 | if (lcp^.klass = func) and (lcp^.idtype = nil) then error(123) |
| 8542 | end; |
| 8543 | { account for locals space in parameters } |
| 8544 | lcp3 := lcp^.pflist; |
| 8545 | while lcp3 <> nil do begin |
| 8546 | with lcp3^ do |
| 8547 | if klass = vars then |
| 8548 | if idtype <> nil then |
| 8549 | if vaddr < lc then lc := vaddr; |
| 8550 | lcp3 := lcp3^.next |
| 8551 | end; |
| 8552 | if not forw or ((lcp^.pfattr = fpaoverload) and not form) then begin |
| 8553 | parmrg(lcp2); { merge back the current parameter list } |
| 8554 | lcp^.pflist := lcp2; lcp^.pfnum := parnum(lcp); |
| 8555 | lcp^.locpar := parmspc(lcp^.pflist); |
| 8556 | parmoff(lcp^.pflist, marksize+ptrsize+adrsize+lcp^.locpar); |
| 8557 | lcp^.locstr := lc { save locals counter } |
| 8558 | end else begin |
| 8559 | parmrg(lcp1^.pflist); { merge back the forwarded parameter list } |
| 8560 | if plst and not (lcp^.pfattr = fpaoverload) then |
| 8561 | if not cmpparlst(lcp1^.pflist, lcp2) then error(216); |
| 8562 | putparlst(lcp2); { redeclare, dispose of copy } |
| 8563 | lc := lcp1^.locstr { reset locals counter } |
| 8564 | end; |
| 8565 | if (forw and (lcp^.pfattr <> fpaoverload)) or form then begin |
| 8566 | { forward, toss current entry and keep original } |
| 8567 | putnam(lcp); lcp := lcp1; lcp1 := nil; lcp^.forwdecl := false |
| 8568 | end; |
| 8569 | if not forwn and not extn then { process actual block} |
| 8570 | begin |
| 8571 | display[top].bname := lcp; |
| 8572 | { output block begin marker } |
| 8573 | if prcode then begin |
| 8574 | if lcp^.klass = proc then write(prr, 'b r ') else write(prr, 'b f '); |
| 8575 | writev(prr, lcp^.name, lenpv(lcp^.name)); |
| 8576 | write(prr, '@'); { this keeps the user from aliasing it } |
| 8577 | if lcp^.klass = proc then write(prr, 'p') else write(prr, 'f'); |
| 8578 | if lcp^.pflist <> nil then begin |
| 8579 | write(prr, '_'); |
| 8580 | prtpartyp(lcp) |
| 8581 | end; |
| 8582 | writeln(prr); |
| 8583 | end; |
| 8584 | { output parameter symbols } |
| 8585 | lcp3 := lcp^.pflist; |
| 8586 | while lcp3 <> nil do begin wrtsym(lcp3, 'p'); lcp3 := lcp3^.next end; |
| 8587 | { now we change to a block with defining points } |
| 8588 | display[top].define := true; |
| 8589 | declare(fsys); |
| 8590 | lcp^.locspc := lcp^.locstr-lc; |
| 8591 | lcs := lcp^.locspc; |
| 8592 | body(fsys + [semicolon],lcp); |
| 8593 | if sy = semicolon then |
| 8594 | begin if prtables then printtables(false); insymbol; |
| 8595 | if iso7185 then begin { handle according to standard } |
| 8596 | if not (sy in [beginsy]+pfbegsys) then |
| 8597 | begin error(6); skip(fsys) end |
| 8598 | end else begin |
| 8599 | if not (sy in |
| 8600 | [labelsy,constsy,typesy,varsy,beginsy]+pfbegsys) then |
| 8601 | begin error(6); skip(fsys) end |
| 8602 | end |
| 8603 | end |
| 8604 | else begin error(14); skip([semicolon]) end; |
| 8605 | { output block end marker } |
| 8606 | if prcode then |
| 8607 | if lcp^.klass = proc then writeln(prr, 'e r') |
| 8608 | else writeln(prr, 'e f'); |
| 8609 | if lcp^.klass = func then |
| 8610 | if lcp <> ufctptr then |
| 8611 | if not lcp^.asgn and not incact then |
| 8612 | error(193) { no function result assign } |
| 8613 | end; |
| 8614 | level := oldlev; putdsps(oldtop); top := oldtop; lc := llc; |
| 8615 | puttmps { free all local temps } |
| 8616 | end (*procdeclaration*) ; |
| 8617 | |
| 8618 | begin (*declare*) |
| 8619 | dp := true; |
| 8620 | repeat |
| 8621 | repeat |
| 8622 | if sy = privatesy then begin insymbol; |
| 8623 | if level > 2 then error(266); |
| 8624 | if incact and (level <= 2) then |
| 8625 | incstk^.priv := true { flag private encountered } |
| 8626 | end; |
| 8627 | if not inpriv then begin { if private, get us out quickly } |
| 8628 | if sy = labelsy then |
| 8629 | begin insymbol; labeldeclaration end; |
| 8630 | if sy = constsy then |
| 8631 | begin insymbol; constdeclaration end; |
| 8632 | if sy = typesy then |
| 8633 | begin insymbol; typedeclaration end; |
| 8634 | if sy = fixedsy then |
| 8635 | begin insymbol; fixeddeclaration end; |
| 8636 | if sy = varsy then |
| 8637 | begin insymbol; vardeclaration end; |
| 8638 | while sy in pfbegsys do |
| 8639 | begin lsy := sy; insymbol; procdeclaration(lsy) end |
| 8640 | end |
| 8641 | until inpriv or iso7185 or (sy = beginsy) or eofinp or |
| 8642 | not (sy in [privatesy,labelsy,constsy,typesy,fixedsy,varsy]+ |
| 8643 | pfbegsys); |
| 8644 | if (sy <> beginsy) and not inpriv then |
| 8645 | begin error(18); skip(fsys) end |
| 8646 | until (sy in statbegsys) or eofinp or inpriv; |
| 8647 | dp := false |
| 8648 | end (*declare*) ; |
| 8649 | |
| 8650 | procedure body(fsys: setofsys; fprocp: ctp); |
| 8651 | var |
| 8652 | segsize, gblsize, stackbot: integer; |
| 8653 | llc1: stkoff; lcp: ctp; |
| 8654 | llp: lbp; |
| 8655 | fp: extfilep; |
| 8656 | test: boolean; |
| 8657 | printed: boolean; |
| 8658 | stalvl: integer; { statement nesting level } |
| 8659 | ilp: ctp; |
| 8660 | |
| 8661 | { add statement level } |
| 8662 | procedure addlvl; |
| 8663 | begin |
| 8664 | stalvl := stalvl+1 |
| 8665 | end; |
| 8666 | |
| 8667 | { remove statement level } |
| 8668 | procedure sublvl; |
| 8669 | var llp: lbp; |
| 8670 | begin |
| 8671 | stalvl := stalvl-1; |
| 8672 | { traverse label list for current block and remove any label from |
| 8673 | active status whose statement block has closed } |
| 8674 | llp := display[top].flabel; |
| 8675 | while llp <> nil do with llp^ do begin |
| 8676 | if slevel > stalvl then bact := false; |
| 8677 | if refer and (minlvl > stalvl) then |
| 8678 | minlvl := stalvl; |
| 8679 | llp := nextlab { link next } |
| 8680 | end |
| 8681 | end; |
| 8682 | |
| 8683 | procedure genfjp(faddr: integer); |
| 8684 | begin load; |
| 8685 | if gattr.typtr <> nil then |
| 8686 | if gattr.typtr <> boolptr then error(144); |
| 8687 | if prcode then |
| 8688 | begin write(prr,' ':8,mn[33]:4,' '); prtlabel(faddr); writeln(prr) end; |
| 8689 | ic := ic + 1; mes(33) |
| 8690 | end (*genfjp*) ; |
| 8691 | |
| 8692 | { find active overload for name entry } |
| 8693 | function fndactovl(lcp: ctp): ctp; |
| 8694 | var fcp: ctp; i: disprange; |
| 8695 | begin fcp := nil; |
| 8696 | for i := top downto 2 do |
| 8697 | if display[i].occur = blck then |
| 8698 | if display[i].bname <> nil then |
| 8699 | if display[i].bname^.grppar = lcp then fcp := display[i].bname; |
| 8700 | fndactovl := fcp |
| 8701 | end; |
| 8702 | |
| 8703 | procedure statement(fsys: setofsys); |
| 8704 | var lcp, lcp2: ctp; llp: lbp; inherit: boolean; |
| 8705 | |
| 8706 | procedure assignment(fcp: ctp; skp: boolean); |
| 8707 | var lattr, lattr2: attr; tagasc, schrcst: boolean; fcp2: ctp; |
| 8708 | len: addrrange; |
| 8709 | begin |
| 8710 | tagasc := false; selector(fsys + [becomes],fcp,skp); |
| 8711 | if (sy = becomes) or skp then |
| 8712 | begin |
| 8713 | if gattr.kind = expr then error(287); |
| 8714 | { if function result, set assigned } |
| 8715 | if fcp^.klass = func then fcp^.asgn := true |
| 8716 | else if fcp^.klass = vars then with fcp^ do begin |
| 8717 | if vlev < level then threat := true; |
| 8718 | if forcnt > 0 then error(195); |
| 8719 | if part = ptview then error(290) |
| 8720 | end; |
| 8721 | tagasc := false; |
| 8722 | if gattr.kind = varbl then |
| 8723 | tagasc := gattr.tagfield and (debug or chkvbk); |
| 8724 | lattr2 := gattr; { save access before load } |
| 8725 | if gattr.typtr <> nil then |
| 8726 | if (gattr.access<>drct) or (gattr.typtr^.form>power) or |
| 8727 | tagasc then { if tag checking, force address load } |
| 8728 | if gattr.kind <> expr then loadaddress; |
| 8729 | lattr := gattr; |
| 8730 | insymbol; expression(fsys, false); schrcst := ischrcst(gattr); |
| 8731 | if (lattr.typtr <> nil) and (gattr.typtr <> nil) then |
| 8732 | { process expression rights as load } |
| 8733 | if (gattr.typtr^.form <= power) or (gattr.kind = expr) then begin |
| 8734 | if (lattr.typtr^.form = arrayc) and schrcst then begin |
| 8735 | { load as string pointer } |
| 8736 | gen2(51(*ldc*),1,1); |
| 8737 | gensca(chr(gattr.cval.ival)); |
| 8738 | gen2(124(*mpc*),0,0) |
| 8739 | end else load |
| 8740 | end else loadaddress; |
| 8741 | if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin |
| 8742 | fndopr2(bcmop, lattr, fcp2); |
| 8743 | if fcp2 <> nil then callop2(fcp2, lattr) else begin |
| 8744 | if comptypes(realptr,lattr.typtr)and(gattr.typtr=intptr)then |
| 8745 | begin gen0(10(*flt*)); |
| 8746 | gattr.typtr := realptr |
| 8747 | end; |
| 8748 | if comptypes(lattr.typtr,gattr.typtr) or |
| 8749 | ((lattr.typtr^.form = arrayc) and schrcst) then begin |
| 8750 | if filecomponent(gattr.typtr) then error(191); |
| 8751 | with lattr2 do |
| 8752 | if kind = varbl then begin |
| 8753 | if access = indrct then |
| 8754 | if debug and tagfield and ptrref then |
| 8755 | { check tag assignment to pointer record } |
| 8756 | genctaivtcvb(81(*cta*),idplmt,taglvl,vartl, |
| 8757 | lattr2.typtr); |
| 8758 | if chkvbk and tagfield then |
| 8759 | genctaivtcvb(95(*cvb*),vartagoff,varssize,vartl, |
| 8760 | lattr2.typtr); |
| 8761 | if debug and tagfield then |
| 8762 | genctaivtcvb(82(*ivt*),vartagoff,varssize,vartl, |
| 8763 | lattr2.typtr) |
| 8764 | end; |
| 8765 | { if tag checking, bypass normal store } |
| 8766 | if tagasc then |
| 8767 | gen0t(26(*sto*),lattr.typtr) |
| 8768 | else case lattr.typtr^.form of |
| 8769 | scalar, |
| 8770 | subrange, |
| 8771 | power: begin |
| 8772 | if debug then checkbnds(lattr.typtr); |
| 8773 | store(lattr) |
| 8774 | end; |
| 8775 | pointer: begin |
| 8776 | if debug then begin |
| 8777 | if taggedrec(lattr.typtr^.eltype) then |
| 8778 | gen2t(80(*ckl*),0,maxaddr,nilptr) |
| 8779 | else gen2t(45(*chk*),0,maxaddr,nilptr); |
| 8780 | end; |
| 8781 | store(lattr) |
| 8782 | end; |
| 8783 | arrays, arrayc: begin |
| 8784 | containerop(lattr); { rationalize binary container op } |
| 8785 | if (lattr.typtr^.form = arrayc) or |
| 8786 | (gattr.typtr^.form = arrayc) then begin |
| 8787 | { assign complex pointer } |
| 8788 | if (containers(lattr.typtr) = 1) or |
| 8789 | (containers(gattr.typtr) = 1) then |
| 8790 | gen1(101(*aps*),containerbase(gattr.typtr)) |
| 8791 | else gen2(102(*apc*),containers(lattr.typtr), |
| 8792 | containerbase(gattr.typtr)); |
| 8793 | if gattr.kind = expr then begin |
| 8794 | len := gattr.typtr^.size; alignu(parmptr,len); |
| 8795 | gen1(71(*dmp*),len+ptrsize*2) |
| 8796 | end |
| 8797 | end else begin { standard array assign } |
| 8798 | { onstack from expr } |
| 8799 | if gattr.kind = expr then store(lattr) |
| 8800 | { addressed } |
| 8801 | else gen1(40(*mov*),lattr.typtr^.size) |
| 8802 | end |
| 8803 | end; |
| 8804 | records: begin |
| 8805 | { onstack from expr } |
| 8806 | if gattr.kind = expr then store(lattr) |
| 8807 | { addressed } |
| 8808 | else gen1(40(*mov*),lattr.typtr^.size); |
| 8809 | end; |
| 8810 | files: error(146) |
| 8811 | end; |
| 8812 | end else error(129) |
| 8813 | end |
| 8814 | end |
| 8815 | end (*sy = becomes*) |
| 8816 | else error(51) |
| 8817 | end (*assignment*) ; |
| 8818 | |
| 8819 | procedure gotostatement; |
| 8820 | var llp: lbp; ttop,ttop1: disprange; |
| 8821 | wp: wtp; |
| 8822 | begin |
| 8823 | if (sy = intconst) or (sy = ident) then |
| 8824 | begin |
| 8825 | if sy = ident then chkstd; |
| 8826 | ttop := top; |
| 8827 | while display[ttop].occur <> blck do ttop := ttop - 1; |
| 8828 | ttop1 := ttop; |
| 8829 | repeat |
| 8830 | searchlabel(llp, ttop, sy = ident); { find label } |
| 8831 | if llp <> nil then with llp^ do begin |
| 8832 | refer := true; |
| 8833 | if defined then |
| 8834 | if slevel > stalvl then { defining point level greater than |
| 8835 | present statement level } |
| 8836 | error(185) { goto references deeper nested statement } |
| 8837 | else if (slevel > 1) and not bact then |
| 8838 | error(187); { Goto references label in different nested |
| 8839 | statement } |
| 8840 | { establish the minimum statement level a goto appeared at } |
| 8841 | if minlvl > stalvl then minlvl := stalvl; |
| 8842 | { remove any with statement levels to target } |
| 8843 | wp := wthstk; |
| 8844 | while wp <> nil do begin |
| 8845 | if wp^.sl <> slevel then gen0(120(*wbe*)); |
| 8846 | wp := wp^.next |
| 8847 | end; |
| 8848 | if ttop = ttop1 then |
| 8849 | genujpxjpcal(57(*ujp*),labname) |
| 8850 | else begin { interprocedural goto } |
| 8851 | genipj(66(*ipj*),level-(level-vlevel),labname); |
| 8852 | ipcref := true |
| 8853 | end |
| 8854 | end; |
| 8855 | ttop := ttop - 1 |
| 8856 | until (llp <> nil) or (ttop = 0); |
| 8857 | if llp = nil then begin |
| 8858 | error(167); { undeclared label } |
| 8859 | newlabel(llp, sy = ident); { create dummy label in current context } |
| 8860 | llp^.refer := true |
| 8861 | end; |
| 8862 | insymbol |
| 8863 | end |
| 8864 | else if iso7185 then error(15) else error(22); |
| 8865 | end (*gotostatement*) ; |
| 8866 | |
| 8867 | procedure compoundstatement; |
| 8868 | var test: boolean; |
| 8869 | begin |
| 8870 | addlvl; |
| 8871 | repeat |
| 8872 | repeat statement(fsys + [semicolon,endsy]) |
| 8873 | until not (sy in statbegsys); |
| 8874 | test := sy <> semicolon; |
| 8875 | if not test then insymbol |
| 8876 | until test; |
| 8877 | if sy = endsy then insymbol else error(13); |
| 8878 | sublvl |
| 8879 | end (*compoundstatemenet*) ; |
| 8880 | |
| 8881 | procedure ifstatement; |
| 8882 | var lcix1,lcix2: integer; |
| 8883 | begin expression(fsys + [thensy], false); |
| 8884 | genlabel(lcix1); genfjp(lcix1); |
| 8885 | if sy = thensy then insymbol else error(52); |
| 8886 | addlvl; |
| 8887 | statement(fsys + [elsesy]); |
| 8888 | sublvl; |
| 8889 | if sy = elsesy then |
| 8890 | begin genlabel(lcix2); genujpxjpcal(57(*ujp*),lcix2); |
| 8891 | prtlabel(lcix1); if prcode then writeln(prr); |
| 8892 | markline; |
| 8893 | insymbol; |
| 8894 | addlvl; |
| 8895 | statement(fsys); |
| 8896 | sublvl; |
| 8897 | prtlabel(lcix2); if prcode then writeln(prr); |
| 8898 | markline |
| 8899 | end |
| 8900 | else begin |
| 8901 | prtlabel(lcix1); |
| 8902 | if prcode then writeln(prr); |
| 8903 | markline |
| 8904 | end |
| 8905 | end (*ifstatement*) ; |
| 8906 | |
| 8907 | procedure casestatement; |
| 8908 | label 1; |
| 8909 | var lsp,lsp1,lsp2: stp; fstptr,lpt1,lpt2,lpt3: cip; lvals,lvale: valu; |
| 8910 | laddr, lcix, lcix1, lelse, lelse2, lmin, lmax: integer; |
| 8911 | test: boolean; i,occ: integer; |
| 8912 | csladr: stkoff; { case selector temp } |
| 8913 | function casecount(cp: cip): integer; |
| 8914 | var c: integer; |
| 8915 | begin c := 0; |
| 8916 | while cp <> nil do |
| 8917 | begin c := c+cp^.cslabe-cp^.cslabs+1; cp := cp^.next end; |
| 8918 | casecount := c |
| 8919 | end; |
| 8920 | begin gettmp(csladr, intsize, false); |
| 8921 | expression(fsys + [ofsy,comma,colon], false); load; |
| 8922 | genlabel(lcix); lelse := 0; |
| 8923 | lsp := gattr.typtr; |
| 8924 | if lsp <> nil then |
| 8925 | if (lsp^.form <> scalar) or (lsp = realptr) then |
| 8926 | begin error(144); lsp := nil end |
| 8927 | else if not comptypes(lsp,intptr) then gen0t(58(*ord*),lsp); |
| 8928 | { store start to temp } |
| 8929 | gen2t(56(*str*),level,csladr,intptr); |
| 8930 | genujpxjpcal(57(*ujp*),lcix); |
| 8931 | if sy = ofsy then insymbol else error(8); |
| 8932 | fstptr := nil; genlabel(laddr); |
| 8933 | repeat |
| 8934 | lpt3 := nil; genlabel(lcix1); |
| 8935 | if not(sy in [semicolon,endsy,elsesy]) then |
| 8936 | begin |
| 8937 | repeat constexpr(fsys + [comma,colon,range],lsp1,lvals); |
| 8938 | if not lvals.intval then |
| 8939 | begin lvals.intval := true; lvals.ival := 1 end; |
| 8940 | lvale := lvals; |
| 8941 | if sy = range then begin |
| 8942 | chkstd; insymbol; |
| 8943 | constexpr(fsys + [comma,colon],lsp2,lvale); |
| 8944 | if not lvale.intval then |
| 8945 | begin lvale.intval := true; lvale.ival := 1 end; |
| 8946 | if lvale.ival < lvals.ival then error(225) |
| 8947 | end; |
| 8948 | if lsp <> nil then |
| 8949 | if comptypes(lsp,lsp1) then |
| 8950 | begin lpt1 := fstptr; lpt2 := nil; |
| 8951 | while lpt1 <> nil do |
| 8952 | with lpt1^ do |
| 8953 | begin |
| 8954 | if (cslabs <= lvale.ival) and |
| 8955 | (cslabe >= lvals.ival) then error(156); |
| 8956 | if cslabs <= lvals.ival then goto 1; |
| 8957 | lpt2 := lpt1; lpt1 := next |
| 8958 | end; |
| 8959 | 1: getcas(lpt3); |
| 8960 | with lpt3^ do |
| 8961 | begin next := lpt1; cslabs := lvals.ival; |
| 8962 | cslabe := lvale.ival; csstart := lcix1 |
| 8963 | end; |
| 8964 | if lpt2 = nil then fstptr := lpt3 |
| 8965 | else lpt2^.next := lpt3 |
| 8966 | end |
| 8967 | else error(147); |
| 8968 | test := sy <> comma; |
| 8969 | if not test then insymbol |
| 8970 | until test; |
| 8971 | if sy = colon then insymbol else error(5); |
| 8972 | prtlabel(lcix1); |
| 8973 | markline; |
| 8974 | repeat |
| 8975 | addlvl; |
| 8976 | statement(fsys + [semicolon]); |
| 8977 | sublvl |
| 8978 | until not (sy in statbegsys); |
| 8979 | if lpt3 <> nil then genujpxjpcal(57(*ujp*),laddr); |
| 8980 | end; |
| 8981 | test := sy <> semicolon; |
| 8982 | if not test then insymbol |
| 8983 | until test; |
| 8984 | if sy = elsesy then begin chkstd; insymbol; genlabel(lelse); |
| 8985 | genlabel(lelse2); prtlabel(lelse2); if prcode then writeln(prr); |
| 8986 | mesl(-intsize); { put selector on stack } |
| 8987 | gen1(71(*dmp*),intsize); |
| 8988 | prtlabel(lelse); if prcode then writeln(prr); |
| 8989 | markline; |
| 8990 | addlvl; |
| 8991 | statement(fsys + [semicolon]); |
| 8992 | sublvl; |
| 8993 | genujpxjpcal(57(*ujp*),laddr); |
| 8994 | if sy = semicolon then insymbol |
| 8995 | end; |
| 8996 | prtlabel(lcix); if prcode then writeln(prr); |
| 8997 | markline; |
| 8998 | if fstptr <> nil then |
| 8999 | begin lmax := fstptr^.cslabe; |
| 9000 | (*reverse pointers*) |
| 9001 | lpt1 := fstptr; fstptr := nil; |
| 9002 | repeat lpt2 := lpt1^.next; lpt1^.next := fstptr; |
| 9003 | fstptr := lpt1; lpt1 := lpt2 |
| 9004 | until lpt1 = nil; |
| 9005 | lmin := fstptr^.cslabs; |
| 9006 | { find occupancy } |
| 9007 | occ := casecount(fstptr)*100 div (lmax-lmin+1); |
| 9008 | if lmax - lmin < cixmax then |
| 9009 | begin |
| 9010 | { put selector back on stack } |
| 9011 | gen2t(54(*lod*),level,csladr,intptr); |
| 9012 | if occ >= minocc then begin { build straight vector table } |
| 9013 | if lelse > 0 then begin |
| 9014 | gen2t(54(*lod*),level,csladr,intptr); |
| 9015 | gen2(51(*ldc*),1,lmin); |
| 9016 | gen2(53(*les*),ord('i'),0); |
| 9017 | genujpxjpcal(73(*tjp*),lelse2); |
| 9018 | gen2t(54(*lod*),level,csladr,intptr); |
| 9019 | gen2(51(*ldc*),1,lmax); |
| 9020 | gen2(49(*grt*),ord('i'),0); |
| 9021 | genujpxjpcal(73(*tjp*),lelse2); |
| 9022 | end else gen2t(45(*chk*),lmin,lmax,intptr); |
| 9023 | gen2(51(*ldc*),1,lmin); gen0(21(*sbi*)); genlabel(lcix); |
| 9024 | genujpxjpcal(44(*xjp*),lcix); prtlabel(lcix); |
| 9025 | if prcode then writeln(prr); |
| 9026 | repeat |
| 9027 | with fstptr^ do |
| 9028 | begin |
| 9029 | while cslabs > lmin do begin |
| 9030 | if lelse > 0 then genujpxjpcal(57(*ujp*),lelse) |
| 9031 | else gen0(60(*ujc error*)); |
| 9032 | lmin := lmin+1 |
| 9033 | end; |
| 9034 | for i := cslabs to cslabe do |
| 9035 | genujpxjpcal(57(*ujp*),csstart); |
| 9036 | lpt1 := fstptr; fstptr := next; lmin := cslabe+1 |
| 9037 | end; |
| 9038 | putcas(lpt1) |
| 9039 | until fstptr = nil; |
| 9040 | end else begin |
| 9041 | { devolve to comp/jmp seq } |
| 9042 | repeat |
| 9043 | with fstptr^ do begin |
| 9044 | gencjp(87(*cjp*),cslabs,cslabe,csstart); |
| 9045 | lpt1 := fstptr; fstptr := next; lmin := cslabe+1 |
| 9046 | end; |
| 9047 | putcas(lpt1) |
| 9048 | until fstptr = nil; |
| 9049 | if lelse > 0 then genujpxjpcal(57(*ujp*),lelse2); |
| 9050 | gen1(71(*dmp*),intsize); |
| 9051 | gen0(60(*ujc error*)) |
| 9052 | end; |
| 9053 | prtlabel(laddr); if prcode then writeln(prr); |
| 9054 | markline |
| 9055 | end |
| 9056 | else begin |
| 9057 | error(157); |
| 9058 | repeat |
| 9059 | with fstptr^ do |
| 9060 | begin lpt1 := fstptr; fstptr := next end; |
| 9061 | putcas(lpt1); |
| 9062 | until fstptr = nil |
| 9063 | end |
| 9064 | end; |
| 9065 | if sy = endsy then insymbol else error(13); |
| 9066 | puttmp(csladr) |
| 9067 | end (*casestatement*) ; |
| 9068 | |
| 9069 | procedure repeatstatement; |
| 9070 | var laddr: integer; |
| 9071 | begin genlabel(laddr); prtlabel(laddr); |
| 9072 | if prcode then writeln(prr); |
| 9073 | markline; |
| 9074 | addlvl; |
| 9075 | repeat |
| 9076 | statement(fsys + [semicolon,untilsy]); |
| 9077 | if sy in statbegsys then error(14) |
| 9078 | until not(sy in statbegsys); |
| 9079 | while sy = semicolon do |
| 9080 | begin insymbol; |
| 9081 | repeat |
| 9082 | statement(fsys + [semicolon,untilsy]); |
| 9083 | if sy in statbegsys then error(14); |
| 9084 | until not (sy in statbegsys); |
| 9085 | end; |
| 9086 | if sy = untilsy then |
| 9087 | begin insymbol; expression(fsys, false); genfjp(laddr) |
| 9088 | end |
| 9089 | else error(53); |
| 9090 | sublvl |
| 9091 | end (*repeatstatement*) ; |
| 9092 | |
| 9093 | procedure whilestatement; |
| 9094 | var laddr, lcix: integer; |
| 9095 | begin genlabel(laddr); prtlabel(laddr); |
| 9096 | if prcode then writeln(prr); |
| 9097 | markline; |
| 9098 | expression(fsys + [dosy], false); genlabel(lcix); genfjp(lcix); |
| 9099 | if sy = dosy then insymbol else error(54); |
| 9100 | addlvl; |
| 9101 | statement(fsys); |
| 9102 | sublvl; |
| 9103 | genujpxjpcal(57(*ujp*),laddr); prtlabel(lcix); |
| 9104 | if prcode then writeln(prr); |
| 9105 | markline |
| 9106 | end (*whilestatement*) ; |
| 9107 | |
| 9108 | procedure forstatement; |
| 9109 | var lattr: attr; lsy: symbol; |
| 9110 | lcix, laddr: integer; |
| 9111 | typind: char; (* added for typing [sam] *) |
| 9112 | typ: stp; |
| 9113 | stradr: stkoff; { start value temp } |
| 9114 | endadr: stkoff; { end value temp } |
| 9115 | begin lcp := nil; |
| 9116 | gettmp(stradr, intsize, false); gettmp(endadr, intsize, false); |
| 9117 | with lattr do |
| 9118 | begin symptr := nil; typtr := nil; kind := varbl; |
| 9119 | access := drct; vlevel := level; dplmt := 0; packing := false |
| 9120 | end; |
| 9121 | typind := 'i'; (* default to integer [sam] *) |
| 9122 | if sy = ident then |
| 9123 | begin searchid([vars],lcp); |
| 9124 | with lcp^, lattr do |
| 9125 | begin symptr := lcp; typtr := idtype; kind := varbl; |
| 9126 | packing := false; |
| 9127 | if threat or (forcnt > 0) then error(195); forcnt := forcnt+1; |
| 9128 | if part = ptview then error(290); |
| 9129 | if vkind = actual then |
| 9130 | begin access := drct; vlevel := vlev; |
| 9131 | if vlev <> level then error(183); |
| 9132 | { don't offset far } |
| 9133 | if chkext(lcp) then dplmt := 0 else dplmt := vaddr |
| 9134 | end |
| 9135 | else begin error(155); typtr := nil end |
| 9136 | end; |
| 9137 | (* determine type of control variable [sam] *) |
| 9138 | if lattr.typtr = boolptr then typind := 'b' |
| 9139 | else if lattr.typtr = charptr then typind := 'c'; |
| 9140 | if lattr.typtr <> nil then |
| 9141 | if (lattr.typtr^.form > subrange) |
| 9142 | or comptypes(realptr,lattr.typtr) then |
| 9143 | begin error(143); lattr.typtr := nil end; |
| 9144 | insymbol |
| 9145 | end |
| 9146 | else |
| 9147 | begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end; |
| 9148 | if sy = becomes then |
| 9149 | begin insymbol; expression(fsys + [tosy,downtosy,dosy], false); |
| 9150 | typ := basetype(gattr.typtr); { get base type } |
| 9151 | if typ <> nil then |
| 9152 | if typ^.form <> scalar then error(144) |
| 9153 | else |
| 9154 | if comptypes(lattr.typtr,gattr.typtr) then begin |
| 9155 | load; alignd(intptr,lc); |
| 9156 | { store start to temp } |
| 9157 | gen2t(56(*str*),level,stradr,intptr); |
| 9158 | end else error(145) |
| 9159 | end |
| 9160 | else |
| 9161 | begin error(51); skip(fsys + [tosy,downtosy,dosy]) end; |
| 9162 | if sy in [tosy,downtosy] then |
| 9163 | begin lsy := sy; insymbol; expression(fsys + [dosy], false); |
| 9164 | typ := basetype(gattr.typtr); { get base type } |
| 9165 | if typ <> nil then |
| 9166 | if typ^.form <> scalar then error(144) |
| 9167 | else |
| 9168 | if comptypes(lattr.typtr,gattr.typtr) then |
| 9169 | begin |
| 9170 | load; alignd(intptr,lc); |
| 9171 | if not comptypes(lattr.typtr,intptr) then |
| 9172 | gen0t(58(*ord*),gattr.typtr); |
| 9173 | gen2t(56(*str*),level,endadr,intptr); |
| 9174 | { set initial value of index } |
| 9175 | gen2t(54(*lod*),level,stradr,intptr); |
| 9176 | if debug and (lattr.typtr <> nil) then |
| 9177 | checkbnds(lattr.typtr); |
| 9178 | store(lattr); |
| 9179 | genlabel(laddr); prtlabel(laddr); |
| 9180 | if prcode then writeln(prr); |
| 9181 | markline; |
| 9182 | gattr := lattr; load; |
| 9183 | if not comptypes(gattr.typtr,intptr) then |
| 9184 | gen0t(58(*ord*),gattr.typtr); |
| 9185 | gen2t(54(*lod*),level,endadr,intptr); |
| 9186 | if lsy = tosy then gen2(52(*leq*),ord(typind),1) |
| 9187 | else gen2(48(*geq*),ord(typind),1); |
| 9188 | end |
| 9189 | else error(145) |
| 9190 | end |
| 9191 | else begin error(55); skip(fsys + [dosy]) end; |
| 9192 | genlabel(lcix); genujpxjpcal(33(*fjp*),lcix); |
| 9193 | if sy = dosy then insymbol else error(54); |
| 9194 | addlvl; |
| 9195 | statement(fsys); |
| 9196 | sublvl; |
| 9197 | gattr := lattr; load; |
| 9198 | if not comptypes(gattr.typtr,intptr) then |
| 9199 | gen0t(58(*ord*),gattr.typtr); |
| 9200 | gen2t(54(*lod*),level,endadr,intptr); |
| 9201 | gen2(47(*equ*),ord(typind),1); |
| 9202 | genujpxjpcal(73(*tjp*),lcix); |
| 9203 | gattr := lattr; load; |
| 9204 | if lsy=tosy then gen1t(34(*inc*),1,gattr.typtr) |
| 9205 | else gen1t(31(*dec*),1,gattr.typtr); |
| 9206 | if debug and (lattr.typtr <> nil) then |
| 9207 | checkbnds(lattr.typtr); |
| 9208 | store(lattr); |
| 9209 | genujpxjpcal(57(*ujp*),laddr); prtlabel(lcix); |
| 9210 | if prcode then writeln(prr); |
| 9211 | markline; |
| 9212 | gattr := lattr; loadaddress; gen0(79(*inv*)); |
| 9213 | if lcp <> nil then lcp^.forcnt := lcp^.forcnt-1; |
| 9214 | puttmp(stradr); puttmp(endadr) |
| 9215 | end (*forstatement*) ; |
| 9216 | |
| 9217 | procedure withstatement; |
| 9218 | var lcp: ctp; lcnt1: disprange; |
| 9219 | test: boolean; |
| 9220 | wbscnt: integer; |
| 9221 | wthadr: stkoff; { with variable value temp } |
| 9222 | begin lcnt1 := 0; wbscnt := 0; |
| 9223 | repeat |
| 9224 | if sy = ident then |
| 9225 | begin searchid([vars,field],lcp); insymbol end |
| 9226 | else begin error(2); lcp := uvarptr end; |
| 9227 | selector(fsys + [comma,dosy],lcp,false); |
| 9228 | if gattr.kind = expr then error(287); |
| 9229 | if gattr.typtr <> nil then |
| 9230 | if gattr.typtr^.form = records then |
| 9231 | if top < displimit then |
| 9232 | begin top := top + 1; lcnt1 := lcnt1 + 1; |
| 9233 | with display[top] do |
| 9234 | begin inidsp(display[top]); fname := gattr.typtr^.fstfld; |
| 9235 | packing := gattr.packing; |
| 9236 | packcom := gattr.packcom; |
| 9237 | ptrref := gattr.ptrref |
| 9238 | end; |
| 9239 | if gattr.access = drct then |
| 9240 | with display[top] do |
| 9241 | begin occur := crec; clev := gattr.vlevel; |
| 9242 | cdspl := gattr.dplmt |
| 9243 | end |
| 9244 | else |
| 9245 | begin loadaddress; |
| 9246 | if debug and gattr.ptrref then |
| 9247 | begin gen0(119(*wbs*)); wbscnt := wbscnt+1; pshwth(stalvl) end; |
| 9248 | gettmp(wthadr, intsize, false); |
| 9249 | gen2t(56(*str*),level,wthadr,nilptr); |
| 9250 | with display[top] do |
| 9251 | begin occur := vrec; vdspl := wthadr end |
| 9252 | end |
| 9253 | end |
| 9254 | else error(250) |
| 9255 | else error(140); |
| 9256 | test := sy <> comma; |
| 9257 | if not test then insymbol |
| 9258 | until test; |
| 9259 | if sy = dosy then insymbol else error(54); |
| 9260 | addlvl; |
| 9261 | statement(fsys); |
| 9262 | sublvl; |
| 9263 | while wbscnt > 0 do begin gen0(120(*wbe*)); wbscnt := wbscnt-1; popwth end; |
| 9264 | { purge display levels } |
| 9265 | while lcnt1 > 0 do begin |
| 9266 | if display[top].occur = vrec then puttmp(display[top].vdspl); |
| 9267 | { don't recycle the record context } |
| 9268 | display[top].fname := nil; |
| 9269 | putdsp(display[top]); { purge } |
| 9270 | top := top-1; lcnt1 := lcnt1-1; { count off } |
| 9271 | end |
| 9272 | end (*withstatement*) ; |
| 9273 | |
| 9274 | procedure trystatement; |
| 9275 | var test: boolean; lcp: ctp; lattr: attr; |
| 9276 | endlbl, noexplbl, bgnexplbl, onendlbl,onstalbl: integer; |
| 9277 | vecadr: stkoff; |
| 9278 | begin genlabel(endlbl); genlabel(noexplbl); genlabel(bgnexplbl); |
| 9279 | gettmp(vecadr, intsize, false); |
| 9280 | genujpxjpcal(84(*bge*),bgnexplbl); |
| 9281 | addlvl; |
| 9282 | repeat |
| 9283 | statement(fsys + [semicolon,onsy,exceptsy,elsesy]); |
| 9284 | if sy in statbegsys then error(14) |
| 9285 | until not(sy in statbegsys); |
| 9286 | while sy = semicolon do |
| 9287 | begin insymbol; |
| 9288 | repeat |
| 9289 | statement(fsys + [semicolon,onsy,exceptsy,elsesy]); |
| 9290 | if sy in statbegsys then error(14); |
| 9291 | until not (sy in statbegsys); |
| 9292 | end; |
| 9293 | sublvl; |
| 9294 | genujpxjpcal(57(*ujp*),noexplbl); |
| 9295 | prtlabel(bgnexplbl); |
| 9296 | if prcode then writeln(prr); |
| 9297 | markline; |
| 9298 | gen2(129(*sev*),level,vecadr); |
| 9299 | if (sy <> onsy) and (sy <> exceptsy) then error(24); |
| 9300 | while sy = onsy do begin insymbol; genlabel(onstalbl); |
| 9301 | genlabel(onendlbl); |
| 9302 | repeat |
| 9303 | if sy = ident then begin |
| 9304 | searchid([vars],lcp); |
| 9305 | with lcp^, lattr do |
| 9306 | begin typtr := idtype; kind := varbl; packing := false; |
| 9307 | if threat or (forcnt > 0) then error(195); forcnt := forcnt+1; |
| 9308 | if part = ptview then error(290); |
| 9309 | if vkind = actual then |
| 9310 | begin access := drct; vlevel := vlev; |
| 9311 | if vlev <> level then error(183); |
| 9312 | dplmt := vaddr |
| 9313 | end |
| 9314 | else begin error(155); typtr := nil end |
| 9315 | end; |
| 9316 | if lcp^.idtype <> nil then |
| 9317 | if lcp^.idtype^.form <> exceptf then error(226); |
| 9318 | insymbol; |
| 9319 | gen2t(54(*lod*),level,vecadr,intptr); |
| 9320 | gattr := lattr; loadaddress; { load compare vector } |
| 9321 | gen2(47(*equ*),ord('a'),0); |
| 9322 | genujpxjpcal(73(*tjp*),onstalbl); |
| 9323 | end else begin error(2); skip(fsys+[onsy,exceptsy,elsesy]) end; |
| 9324 | test := sy <> comma; |
| 9325 | if not test then insymbol |
| 9326 | until test; |
| 9327 | genujpxjpcal(57(*ujp*),onendlbl); |
| 9328 | if sy = exceptsy then insymbol else |
| 9329 | begin error(23); skip(fsys+[onsy,exceptsy,elsesy]) end; |
| 9330 | prtlabel(onstalbl); |
| 9331 | if prcode then writeln(prr); |
| 9332 | markline; |
| 9333 | addlvl; |
| 9334 | statement(fsys+[exceptsy]); |
| 9335 | sublvl; |
| 9336 | genujpxjpcal(57(*ujp*),endlbl); |
| 9337 | prtlabel(onendlbl); |
| 9338 | if prcode then writeln(prr); |
| 9339 | markline |
| 9340 | end; |
| 9341 | if sy = exceptsy then begin addlvl; |
| 9342 | insymbol; statement(fsys+[elsesy]); sublvl; |
| 9343 | genujpxjpcal(57(*ujp*),endlbl) |
| 9344 | end; |
| 9345 | gen0(86(*mse*)); |
| 9346 | prtlabel(noexplbl); |
| 9347 | if prcode then writeln(prr); |
| 9348 | markline; |
| 9349 | if sy = elsesy then begin addlvl; |
| 9350 | insymbol; statement(fsys); sublvl |
| 9351 | end; |
| 9352 | sublvl; |
| 9353 | prtlabel(endlbl); |
| 9354 | if prcode then writeln(prr); |
| 9355 | markline; |
| 9356 | gen0(85(*ede*)); |
| 9357 | puttmp(vecadr) |
| 9358 | end (*trystatement*) ; |
| 9359 | |
| 9360 | begin (*statement*) |
| 9361 | if (sy = intconst) or (sy = ident) then begin (*label*) |
| 9362 | { and here is why Wirth didn't include symbolic labels in Pascal. |
| 9363 | We are ambiguous with assigns and calls, so must look ahead for |
| 9364 | the ':' } |
| 9365 | searchlabel(llp, level, sy = ident); { search label } |
| 9366 | insymbol; { look ahead } |
| 9367 | if sy = colon then begin { process as label } |
| 9368 | insymbol; { skip ':' } |
| 9369 | if llp <> nil then with llp^ do begin { found } |
| 9370 | if defined then error(165); { multidefined label } |
| 9371 | bact := true; { set in active block now } |
| 9372 | slevel := stalvl; { establish statement level } |
| 9373 | defined := true; { set defined } |
| 9374 | if ipcref and (stalvl > 1) then |
| 9375 | error(184) { intraprocedure goto does not reference outter block } |
| 9376 | else if minlvl < stalvl then |
| 9377 | { Label referenced by goto at lesser statement level or |
| 9378 | differently nested statement } |
| 9379 | error(186); |
| 9380 | { output label to intermediate } |
| 9381 | prtlabel(labname); |
| 9382 | if prcode then writeln(prr); |
| 9383 | markline |
| 9384 | end else begin { not found } |
| 9385 | error(167); { undeclared label } |
| 9386 | newlabel(llp, false) { create a dummy level } |
| 9387 | end |
| 9388 | end else pushback { back to ident } |
| 9389 | end; |
| 9390 | if not (sy in fsys + statbegsys + [ident,resultsy,inheritedsy]) then |
| 9391 | begin error(6); skip(fsys) end; |
| 9392 | inherit := false; |
| 9393 | if sy in statbegsys + [ident,resultsy,inheritedsy] then |
| 9394 | begin |
| 9395 | case sy of |
| 9396 | inheritedsy, |
| 9397 | ident: begin |
| 9398 | if sy = inheritedsy then |
| 9399 | begin insymbol; inherit := true end; |
| 9400 | searchid([vars,field,func,proc],lcp); insymbol; |
| 9401 | if hasproc(lcp) or hasfunc(lcp) then begin |
| 9402 | if hasfunc(lcp) then begin |
| 9403 | { could be proc or func, need disambiguate } |
| 9404 | if sy = becomes then begin |
| 9405 | if inherit then error(233); |
| 9406 | lcp2 := fndactovl(lcp); { see if overload } |
| 9407 | { if not, error and back to original } |
| 9408 | if lcp2 = nil then |
| 9409 | begin error(192); lcp2 := lcp end; |
| 9410 | assignment(lcp2, false) |
| 9411 | end else call(fsys,lcp,inherit,false) |
| 9412 | end else call(fsys,lcp,inherit,false) |
| 9413 | end else begin if inherit then error(233); |
| 9414 | assignment(lcp, false) |
| 9415 | end |
| 9416 | end; |
| 9417 | beginsy: begin insymbol; compoundstatement end; |
| 9418 | gotosy: begin insymbol; gotostatement end; |
| 9419 | ifsy: begin insymbol; ifstatement end; |
| 9420 | casesy: begin insymbol; casestatement end; |
| 9421 | whilesy: begin insymbol; whilestatement end; |
| 9422 | repeatsy: begin insymbol; repeatstatement end; |
| 9423 | forsy: begin insymbol; forstatement end; |
| 9424 | withsy: begin insymbol; withstatement end; |
| 9425 | trysy: begin insymbol; trystatement end; |
| 9426 | { process result as a pseudostatement } |
| 9427 | resultsy: begin |
| 9428 | if fprocp <> nil then |
| 9429 | if fprocp^.klass <> func then error(210) |
| 9430 | else begin |
| 9431 | if fprocp^.asgn then error(212); |
| 9432 | fprocp^.asgn := true |
| 9433 | end; |
| 9434 | assignment(fprocp, true); |
| 9435 | if not (sy = endsy) or (stalvl > 1) then error(211) |
| 9436 | end |
| 9437 | end; |
| 9438 | if not (sy in [semicolon,endsy,elsesy,untilsy,exceptsy,onsy]) then |
| 9439 | begin error(6); skip(fsys) end; |
| 9440 | clrtmp { free temps in this function/procedure } |
| 9441 | end |
| 9442 | end (*statement*) ; |
| 9443 | |
| 9444 | { validate and start external header files } |
| 9445 | procedure externalheader; |
| 9446 | var valp: csp; saveid: idstr; llcp:ctp; |
| 9447 | begin |
| 9448 | saveid := id; |
| 9449 | while fextfilep <> nil do begin |
| 9450 | with fextfilep^ do begin |
| 9451 | id := filename; |
| 9452 | searchidne([vars],llcp); |
| 9453 | if llcp = nil then begin |
| 9454 | { a header file was never defined in a var statement } |
| 9455 | writeln(output); |
| 9456 | writeln('*** Error: Undeclared external file ''', |
| 9457 | fextfilep^.filename:8, ''''); |
| 9458 | toterr := toterr+1; |
| 9459 | llcp := uvarptr |
| 9460 | end; |
| 9461 | if llcp^.idtype<>nil then |
| 9462 | if (llcp^.idtype^.form<>files) and (llcp^.idtype <> intptr) and |
| 9463 | (llcp^.idtype <> realptr) then |
| 9464 | begin writeln(output); |
| 9465 | writeln('*** Error: Undeclared external file ''', |
| 9466 | fextfilep^.filename:8, ''''); |
| 9467 | toterr := toterr+1 |
| 9468 | end |
| 9469 | else begin { process header file } |
| 9470 | llcp^.hdr := true; { appears in header } |
| 9471 | { check is a standard header file } |
| 9472 | if not (strequri('input ', filename) or |
| 9473 | strequri('output ', filename) or |
| 9474 | strequri('error ', filename) or |
| 9475 | strequri('list ', filename) or |
| 9476 | strequri('command ', filename)) then begin |
| 9477 | gen1(37(*lao*),llcp^.vaddr); { load file/variable address } |
| 9478 | { put name in constants table } |
| 9479 | new(valp,strg); valp^.cclass := strg; |
| 9480 | valp^.slgth := lenpv(llcp^.name); |
| 9481 | valp^.sval := llcp^.name; |
| 9482 | if cstptrix >= cstoccmax then error(254) |
| 9483 | else begin cstptrix := cstptrix + 1; |
| 9484 | cstptr[cstptrix] := valp; |
| 9485 | gen1(38(*lca*),cstptrix) |
| 9486 | end; |
| 9487 | cstptrix := cstptrix - 1; |
| 9488 | { load length of name } |
| 9489 | gen2(51(*ldc*),1,valp^.slgth); |
| 9490 | if llcp^.idtype = intptr then { integer } |
| 9491 | gen1(30(*csp*),83(*rdie*)) |
| 9492 | else if llcp^.idtype = realptr then { real } |
| 9493 | gen1(30(*csp*),84(*rdir*)) |
| 9494 | else if llcp^.idtype = textptr then { text } |
| 9495 | gen1(30(*csp*),81(*aeft*)) |
| 9496 | else { binary } |
| 9497 | gen1(30(*csp*),82(*aefb*)); |
| 9498 | dispose(valp,strg) |
| 9499 | end |
| 9500 | end |
| 9501 | end; |
| 9502 | fp := fextfilep; fextfilep := fextfilep^.nextfile; putfil(fp) |
| 9503 | end; |
| 9504 | id := saveid |
| 9505 | end; |
| 9506 | |
| 9507 | procedure initvirt; |
| 9508 | procedure schvirt(lcp: ctp); |
| 9509 | var lcp1,lcp2: ctp; |
| 9510 | begin |
| 9511 | if lcp <> nil then begin |
| 9512 | if lcp^.klass in [proc,func] then begin |
| 9513 | if not chkext(lcp) then begin |
| 9514 | if (lcp^.pfattr = fpavirtual) then |
| 9515 | gensuv(lcp^.pfname,lcp^.pfvaddr,lcp) |
| 9516 | else if lcp^.pfattr = fpaoverride then begin |
| 9517 | lcp1 := lcp^.grppar; { link parent } |
| 9518 | if lcp1 <> nil then begin |
| 9519 | lcp2 := lcp1^.pfvid; { get vector symbol } |
| 9520 | if lcp2 <> nil then begin |
| 9521 | { copy old vector to store } |
| 9522 | gen1ts(39(*ldo*),lcp2^.vaddr,lcp2^.idtype,lcp2); |
| 9523 | gen1t(43(*sro*),lcp^.pfvaddr,nilptr); |
| 9524 | { place new vector } |
| 9525 | gensuv(lcp^.pfname,lcp2^.vaddr,lcp2); |
| 9526 | end |
| 9527 | end |
| 9528 | end |
| 9529 | end; |
| 9530 | schvirt(lcp^.grpnxt); |
| 9531 | end; |
| 9532 | schvirt(lcp^.llink); schvirt(lcp^.rlink) |
| 9533 | end |
| 9534 | end; |
| 9535 | begin |
| 9536 | schvirt(display[top].fname) |
| 9537 | end; |
| 9538 | |
| 9539 | begin (*body*) |
| 9540 | stalvl := 0; { clear statement nesting level } |
| 9541 | cstptrix := 0; topnew := 0; topmin := 0; |
| 9542 | { if processing procedure/function, use that entry label, otherwise set |
| 9543 | at program } |
| 9544 | if fprocp <> nil then prtlabel(fprocp^.pfname) else prtlabel(entname); |
| 9545 | if prcode then writeln(prr); |
| 9546 | markline; |
| 9547 | genlabel(segsize); genlabel(stackbot); |
| 9548 | genlabel(gblsize); |
| 9549 | genmst(level-1,segsize,stackbot); |
| 9550 | if fprocp <> nil then (*copy multiple values into local cells*) |
| 9551 | begin llc1 := marksize+ptrsize+adrsize+fprocp^.locpar; { index params } |
| 9552 | lcp := fprocp^.pflist; |
| 9553 | while lcp <> nil do |
| 9554 | with lcp^ do |
| 9555 | begin |
| 9556 | if klass = vars then |
| 9557 | if idtype <> nil then begin |
| 9558 | if idtype^.form > power then |
| 9559 | begin |
| 9560 | if idtype^.form = arrayc then llc1 := llc1 - ptrsize*2 |
| 9561 | else llc1 := llc1-ptrsize; |
| 9562 | alignd(parmptr,llc1); |
| 9563 | if vkind = actual then |
| 9564 | if idtype^.form = arrayc then begin |
| 9565 | { Container array. These are not preallocated, so we |
| 9566 | have to create a copy on stack. } |
| 9567 | gen2(50(*lda*),level,llc1); { index the pointer } |
| 9568 | gen0(111(*ldp*)); { load complex pointer } |
| 9569 | { copy complex to stack } |
| 9570 | gen2(109(*ccs*),containers(idtype),containerbase(idtype)); |
| 9571 | gen2(50(*lda*),level,vaddr); { load dest addr } |
| 9572 | gen1(72(*swp*),stackelsize*2); { swap that under cp } |
| 9573 | gen0(110(*scp*)) { store complex pointer } |
| 9574 | end else begin |
| 9575 | gen2(50(*lda*),level,vaddr); |
| 9576 | gen2t(54(*lod*),level,llc1,nilptr); |
| 9577 | gen1(40(*mov*),idtype^.size); |
| 9578 | end |
| 9579 | end |
| 9580 | else |
| 9581 | begin |
| 9582 | if vkind = formal then llc1 := llc1-ptrsize |
| 9583 | else llc1 := llc1-idtype^.size; |
| 9584 | alignd(parmptr,llc1); |
| 9585 | end; |
| 9586 | if chkvbk and (vkind = formal) then begin |
| 9587 | { establish var block } |
| 9588 | gen2t(54(*lod*),level,llc1,nilptr); |
| 9589 | gen1(93(*vbs*),idtype^.size) |
| 9590 | end |
| 9591 | end; |
| 9592 | lcp := lcp^.next; |
| 9593 | end; |
| 9594 | end; |
| 9595 | addlvl; |
| 9596 | if (level = 1) and not incact then begin { perform module setup tasks } |
| 9597 | externalheader; { process external header files } |
| 9598 | initvirt { process virtual procedure/function sets } |
| 9599 | end; |
| 9600 | { call initializer code strips } |
| 9601 | ilp := display[top].inilst; |
| 9602 | while ilp <> nil do |
| 9603 | begin genujpxjpcal(89(*cal*),ilp^.inilab); ilp := ilp^.ininxt end; |
| 9604 | if sy = beginsy then insymbol else error(17); |
| 9605 | repeat |
| 9606 | repeat statement(fsys + [semicolon,endsy]) |
| 9607 | until not (sy in statbegsys); |
| 9608 | test := sy <> semicolon; |
| 9609 | if not test then insymbol |
| 9610 | until test; |
| 9611 | { deinitialize containers } |
| 9612 | if level = 1 then begin |
| 9613 | ilp := display[top].inilst; |
| 9614 | while ilp <> nil do begin |
| 9615 | gen1t(39(*ldo*),ilp^.vaddr,nilptr); |
| 9616 | gen0(107(*vdp*)); |
| 9617 | ilp := ilp^.ininxt end |
| 9618 | end; |
| 9619 | sublvl; |
| 9620 | if sy = endsy then insymbol else error(13); |
| 9621 | llp := display[top].flabel; (*test for undefined and unreferenced labels*) |
| 9622 | while llp <> nil do |
| 9623 | with llp^ do |
| 9624 | begin |
| 9625 | if not defined or not refer then |
| 9626 | begin if not defined then error(168); |
| 9627 | writeln(output); write('label ',labval:11); |
| 9628 | if not refer and not incact then write(' unreferenced'); |
| 9629 | writeln; |
| 9630 | write(' ':chcnt+16) |
| 9631 | end; |
| 9632 | llp := nextlab |
| 9633 | end; |
| 9634 | printed := false; |
| 9635 | if (fprocp <> nil) or iso7185 then |
| 9636 | chkrefs(fprocp, display[top].fname, printed); |
| 9637 | if toterr = 0 then |
| 9638 | if (topnew <> 0) and prcode then |
| 9639 | error(504); { stack should have wound to zero } |
| 9640 | { in an external module, we could have unbalanced, so zero it. } |
| 9641 | topnew := 0; |
| 9642 | if fprocp <> nil then |
| 9643 | begin |
| 9644 | { output var block ends for each var parameter } |
| 9645 | lcp := fprocp^.pflist; |
| 9646 | while lcp <> nil do |
| 9647 | with lcp^ do begin |
| 9648 | if klass = vars then |
| 9649 | if chkvbk and (vkind = formal) then gen0(94(*vbe*)); |
| 9650 | lcp := next |
| 9651 | end; |
| 9652 | if fprocp^.idtype = nil then gen2(42(*ret*),ord('p'),fprocp^.locpar) |
| 9653 | else if fprocp^.idtype^.form in [records, arrays] then |
| 9654 | gen2t(42(*ret*),fprocp^.locpar,fprocp^.idtype^.size,basetype(fprocp^.idtype)) |
| 9655 | else gen1t(42(*ret*),fprocp^.locpar,fprocp^.idtype); |
| 9656 | alignd(parmptr,lc); |
| 9657 | if prcode then |
| 9658 | begin prtlabel(segsize); writeln(prr,'=',-level*ptrsize-lc:1); |
| 9659 | prtlabel(stackbot); writeln(prr,'=',-topmin:1) |
| 9660 | end |
| 9661 | end |
| 9662 | else |
| 9663 | begin gen2(42(*ret*),ord('p'),0); |
| 9664 | alignd(parmptr,lc); |
| 9665 | if prcode then |
| 9666 | begin |
| 9667 | prtlabel(segsize); writeln(prr,'=',-level*ptrsize-lc:1); |
| 9668 | prtlabel(stackbot); writeln(prr,'=',-topmin:1) |
| 9669 | end; |
| 9670 | ic := 0; |
| 9671 | if prtables then |
| 9672 | begin writeln(output); printtables(true) |
| 9673 | end |
| 9674 | end; |
| 9675 | end (*body*) ; |
| 9676 | |
| 9677 | procedure openinput(isuse: boolean; var ff: boolean); |
| 9678 | var fp: filptr; x: 1..4; es: packed array [1..4] of char; ii: lininx; |
| 9679 | fi,fi2,fi3: 1..fillen; me: boolean; |
| 9680 | { for any error, back out the include level } |
| 9681 | procedure err; |
| 9682 | begin |
| 9683 | incstk := incstk^.next; |
| 9684 | ff := false |
| 9685 | end; |
| 9686 | procedure nxtinc; |
| 9687 | var lchar: char; |
| 9688 | begin |
| 9689 | fi2 := 1; |
| 9690 | if incbuf[ii] <> ' ' then with fp^ do begin |
| 9691 | lchar := ' '; |
| 9692 | while (incbuf[ii] <> ' ') and (incbuf[ii] <> ':') and |
| 9693 | (ii <= maxlin) and (fi2 <= fillen) do begin |
| 9694 | fn[fi2] := incbuf[ii]; lchar := fn[fi2]; ii := ii+1; fi2 := fi2+1 |
| 9695 | end; |
| 9696 | if (incbuf[ii] = ':') and (ii < maxlin) then ii := ii+1; |
| 9697 | if (lchar <> '/') and (fi2 < fillen) and (ii > 1) then begin |
| 9698 | fn[fi2] := '/'; fi2 := fi2+1 |
| 9699 | end |
| 9700 | end |
| 9701 | end; |
| 9702 | { insert uses to joins/main level } |
| 9703 | procedure insertuse(fp: filptr); |
| 9704 | var lp: filptr; |
| 9705 | begin |
| 9706 | lp := incstk; |
| 9707 | while lp^.use do lp := lp^.next; |
| 9708 | fp^.uselist := lp^.uselist; lp^.uselist := fp |
| 9709 | end; |
| 9710 | begin ff := true; es := extsrc; ii := 1; |
| 9711 | { have not previously parsed this module } |
| 9712 | new(fp); |
| 9713 | with fp^ do begin |
| 9714 | next := incstk; incstk := fp; strassvf(mn, id); priv := false; |
| 9715 | si := 1; sl := 0; |
| 9716 | lo := false; fio := true; use := isuse; uselist := nil; |
| 9717 | if isuse then insertuse(fp); |
| 9718 | me := false; |
| 9719 | repeat |
| 9720 | me := incbuf[ii] = ' '; |
| 9721 | for fi := 1 to fillen do fn[fi] := ' '; |
| 9722 | nxtinc; fi3 := 1; |
| 9723 | while (fi2 < fillen) and (id[fi3] <> ' ') do begin |
| 9724 | fn[fi2] := id[fi3]; fi2 := fi2+1; fi3 := fi3+1 |
| 9725 | end; |
| 9726 | if fi2 > fillen-4-1 then begin err; error(265) end |
| 9727 | else begin |
| 9728 | for x := 1 to 4 do begin fn[fi2] := es[x]; fi2 := fi2+1 end; |
| 9729 | ff := exists(fn); |
| 9730 | end |
| 9731 | until ff or me; |
| 9732 | if not ff then begin err; error(264) end |
| 9733 | else begin assign(f, fn); reset(f) end; |
| 9734 | if not ff then putstrs(fp^.mn) |
| 9735 | end; |
| 9736 | if not ff then dispose(fp) |
| 9737 | end; |
| 9738 | |
| 9739 | procedure closeinput; |
| 9740 | var fp: filptr; |
| 9741 | begin |
| 9742 | if not incact then error(505); |
| 9743 | if incstk^.fio then begin { not at level 0 } |
| 9744 | close(incstk^.f); |
| 9745 | { remove top include entry } |
| 9746 | fp := incstk; incstk := incstk^.next; |
| 9747 | fp^.next := inclst; { put on discard list } |
| 9748 | inclst := fp |
| 9749 | end |
| 9750 | end; |
| 9751 | |
| 9752 | procedure putinp(var fl: filptr); |
| 9753 | var fp: filptr; |
| 9754 | begin |
| 9755 | while fl <> nil do begin |
| 9756 | fp := fl; fl := fl^.next; putstrs(fp^.mn); dispose(fp) |
| 9757 | end |
| 9758 | end; |
| 9759 | |
| 9760 | procedure cancelfwd(fcp: ctp); |
| 9761 | begin |
| 9762 | if fcp <> nil then begin |
| 9763 | if fcp^.klass in [proc, func] then fcp^.forwdecl := false; |
| 9764 | cancelfwd(fcp^.llink); cancelfwd(fcp^.rlink) |
| 9765 | end |
| 9766 | end; |
| 9767 | |
| 9768 | procedure modulep(fsys:setofsys); forward; |
| 9769 | |
| 9770 | procedure usesjoins; |
| 9771 | var sys: symbol; prcodes: boolean; ff: boolean; eols: boolean; |
| 9772 | lists: boolean; nammods, modnams, thismod: strvsp; gcs: addrrange; |
| 9773 | curmods: modtyp; entnames: integer; sym: symbol; dup: boolean; |
| 9774 | function schnam: boolean; |
| 9775 | var fn: filnam; i, nc, ec: 1..fillen; fp: filptr; |
| 9776 | begin schnam := false; fp := incstk; |
| 9777 | while fp^.use do fp := fp^.next; |
| 9778 | fp := fp^.uselist; |
| 9779 | while fp <> nil do begin |
| 9780 | nc := 1; |
| 9781 | for i := 1 to fillen do |
| 9782 | if (fp^.fn[i] = '/') or (fp^.fn[i] = '\\') then nc := i+1; |
| 9783 | ec := fillen; |
| 9784 | for i := 1 to fillen do if fp^.fn[i] = '.' then ec := i; |
| 9785 | for i := 1 to fillen do begin |
| 9786 | fn[i] := ' '; |
| 9787 | if (nc < fillen) and (nc < ec) then |
| 9788 | begin fn[i] := fp^.fn[nc]; nc := nc+1 end |
| 9789 | end; |
| 9790 | if fn = id then schnam := true; |
| 9791 | fp := fp^.uselist |
| 9792 | end |
| 9793 | end; |
| 9794 | begin |
| 9795 | sym := sy; insymbol; { skip uses/joins } |
| 9796 | repeat { modules } |
| 9797 | thismod := nil; |
| 9798 | if sy <> ident then error(2) else begin |
| 9799 | dup := schnam; |
| 9800 | if not dup then begin |
| 9801 | eols := eol; prcodes := prcode; lists := list; gcs := gc; |
| 9802 | nammods := nammod; curmods := curmod; entnames := entname; |
| 9803 | openinput(sym = usessy, ff); |
| 9804 | if ff then begin |
| 9805 | prcode := false; list := false; |
| 9806 | readline; insymbol; |
| 9807 | if sym = joinssy then |
| 9808 | { throw display for joined module } |
| 9809 | begin top := top+1; inidsp(display[top]); |
| 9810 | display[top].occur := blck; display[top].bname := nil end; |
| 9811 | modnams := display[top].modnam; |
| 9812 | display[top].modnam := nil; |
| 9813 | modulep(blockbegsys+statbegsys-[casesy]); |
| 9814 | thismod := display[top].modnam; display[top].modnam := modnams; |
| 9815 | cancelfwd(display[top].fname); closeinput |
| 9816 | end; |
| 9817 | prcode := prcodes; list := lists; gc := gcs; |
| 9818 | nammod := nammods; curmod := curmods; entname := entnames |
| 9819 | end; |
| 9820 | insymbol; { skip id } |
| 9821 | if (sym = joinssy) and not dup then begin { post process joins level } |
| 9822 | if ptop >= displimit then error(267) |
| 9823 | else begin |
| 9824 | pile[ptop] := display[top]; { copy out definitions from display } |
| 9825 | pile[ptop].modnam := thismod; { put back module name } |
| 9826 | ptop := ptop+1; top := top-1 |
| 9827 | end |
| 9828 | end else putstrs(thismod); |
| 9829 | end; |
| 9830 | sys := sy; |
| 9831 | if sy = comma then insymbol |
| 9832 | until sys <> comma; |
| 9833 | if sy = semicolon then insymbol else error(14) |
| 9834 | end; |
| 9835 | |
| 9836 | function searchext: boolean; |
| 9837 | var fp: extfilep; f: boolean; |
| 9838 | begin f := false; fp := fextfilep; |
| 9839 | while fp <> nil do |
| 9840 | begin if id = fp^.filename then f := true; fp := fp^.nextfile end; |
| 9841 | searchext := f |
| 9842 | end; |
| 9843 | |
| 9844 | procedure modulep(fsys:setofsys); |
| 9845 | var extfp,newfl:extfilep; segsize, stackbot: integer; |
| 9846 | nulllab: integer; extname,nxtname: integer; |
| 9847 | begin |
| 9848 | cstptrix := 0; topnew := 0; topmin := 0; nammod := nil; genlabel(entname); |
| 9849 | genlabel(extname); genlabel(nxtname); |
| 9850 | chkudtf := chkudtc; { finalize undefined tag checking flag } |
| 9851 | { set type of module parsing } |
| 9852 | curmod := mtprogram; |
| 9853 | if sy = modulesy then curmod := mtmodule; |
| 9854 | if (sy = progsy) or (sy = modulesy) then |
| 9855 | begin insymbol; |
| 9856 | if sy <> ident then error(2) else begin |
| 9857 | strassvf(nammod, id); { place module name } |
| 9858 | strassvf(display[top].modnam, id); |
| 9859 | if prcode then begin |
| 9860 | writeln(prr, '!'); |
| 9861 | if curmod = mtprogram then |
| 9862 | begin write(prr, '! Program '); writevp(prr, nammod); |
| 9863 | if prcode then writeln(prr) end |
| 9864 | else |
| 9865 | begin write(prr, '! Module '); writevp(prr, nammod); |
| 9866 | if prcode then writeln(prr) end; |
| 9867 | writeln(prr, '!'); |
| 9868 | if curmod = mtmodule then |
| 9869 | writeln(prr, 'b', ' ':7, 'm', ' ':7, id:kk) { mark module block start } |
| 9870 | else |
| 9871 | writeln(prr, 'b', ' ':7, 'p', ' ':7, id:kk) { mark program block start } |
| 9872 | end; |
| 9873 | insymbol; |
| 9874 | { mark stack, generate call to startup block } |
| 9875 | genlabel(nulllab); |
| 9876 | gensfr(nulllab); |
| 9877 | if prcode then begin prtlabel(nulllab); writeln(prr,'=0') end; |
| 9878 | gencupcuf(46(*cup*),0,entname,nil); |
| 9879 | if curmod = mtmodule then begin |
| 9880 | { for module we need call next in module stack, then call exit |
| 9881 | module } |
| 9882 | genujpxjpcal(89(*cal*),nxtname); |
| 9883 | gensfr(nulllab); gencupcuf(46(*cup*),0,extname,nil) |
| 9884 | end; |
| 9885 | gen0(90(*ret*)) { return last module stack } |
| 9886 | end; |
| 9887 | if not (sy in [lparent,semicolon]) then error(14); |
| 9888 | if sy = lparent then |
| 9889 | begin |
| 9890 | newfl := nil; |
| 9891 | repeat insymbol; |
| 9892 | if sy = ident then |
| 9893 | begin |
| 9894 | if not incact then begin |
| 9895 | getfil(extfp); if searchext then error(240); |
| 9896 | with extfp^ do |
| 9897 | begin filename := id; nextfile := fextfilep end; |
| 9898 | fextfilep := extfp |
| 9899 | end; |
| 9900 | { check 'input' or 'output' appears in header for defaults } |
| 9901 | if strequri('input ', id) then inputptr^.hdr := true |
| 9902 | else if strequri('output ', id) then outputptr^.hdr := true |
| 9903 | else if strequri('error ', id) then errorptr^.hdr := true |
| 9904 | else if strequri('list ', id) then listptr^.hdr := true |
| 9905 | else if strequri('command ', id) then commandptr^.hdr := true; |
| 9906 | insymbol; |
| 9907 | if not ( sy in [comma,rparent] ) then error(20) |
| 9908 | end |
| 9909 | else error(2) |
| 9910 | until sy <> comma; |
| 9911 | { reverse the header list into order } |
| 9912 | if not incact then begin |
| 9913 | newfl := nil; |
| 9914 | while fextfilep <> nil do |
| 9915 | begin extfp := fextfilep; fextfilep := fextfilep^.nextfile; |
| 9916 | extfp^.nextfile := newfl; newfl := extfp end; |
| 9917 | fextfilep := newfl |
| 9918 | end; |
| 9919 | if sy <> rparent then error(4); |
| 9920 | insymbol; |
| 9921 | if sy <> semicolon then error(14) |
| 9922 | end; |
| 9923 | if sy = semicolon then insymbol |
| 9924 | end else error(3); |
| 9925 | { must process joins first so that the module (1) display level is clean. |
| 9926 | Otherwise this could create a situation where joins rely on other |
| 9927 | modules } |
| 9928 | if sy = joinssy then usesjoins; { process joins } |
| 9929 | if sy = usessy then usesjoins; { process uses } |
| 9930 | declare(fsys); |
| 9931 | if not inpriv then body(fsys,nil); |
| 9932 | if curmod = mtmodule then begin |
| 9933 | if sy = semicolon then begin |
| 9934 | insymbol; |
| 9935 | if sy <> beginsy then error(17) |
| 9936 | end; |
| 9937 | if sy = beginsy then begin |
| 9938 | { gen exit block } |
| 9939 | entname := extname; body(fsys, nil); |
| 9940 | end else begin { generate dummy terminator block } |
| 9941 | genlabel(segsize); genlabel(stackbot); prtlabel(extname); |
| 9942 | if prcode then writeln(prr); |
| 9943 | genmst(level-1,segsize,stackbot); |
| 9944 | gen2(42(*ret*),ord('p'),0); |
| 9945 | if prcode then begin |
| 9946 | prtlabel(segsize); writeln(prr,'=',0:1); |
| 9947 | prtlabel(stackbot); writeln(prr,'=',0:1) |
| 9948 | end |
| 9949 | end; |
| 9950 | if prcode then begin |
| 9951 | { set skip module stack } |
| 9952 | prtlabel(nxtname); |
| 9953 | if prcode then writeln(prr); |
| 9954 | writeln(prr,'g ',gc:1); |
| 9955 | writeln(prr, 'e m') { mark module block end } |
| 9956 | end |
| 9957 | end else begin { program } |
| 9958 | if prcode then begin |
| 9959 | writeln(prr,'g', ' ':7,gc:1); |
| 9960 | writeln(prr, 'e', ' ':7, 'p') { mark program block end } |
| 9961 | end |
| 9962 | end; |
| 9963 | if (sy <> period) and not inpriv then begin error(21); skip([period]) end; |
| 9964 | if prcode then begin |
| 9965 | writeln(prr, 'f', ' ':7, toterr:1); |
| 9966 | { only terminate intermediate if we are a cap cell (program) } |
| 9967 | if curmod = mtprogram then writeln(prr,'q') |
| 9968 | end; |
| 9969 | if list then writeln; |
| 9970 | if errinx <> 0 then endofline; |
| 9971 | putstrs(nammod) { release module name } |
| 9972 | end (*modulep*) ; |
| 9973 | |
| 9974 | procedure stdnames; |
| 9975 | begin |
| 9976 | { 'mark' and 'release' were removed and replaced with placeholders } |
| 9977 | na[ 1] := 'false '; na[ 2] := 'true '; na[ 3] := 'input '; |
| 9978 | na[ 4] := 'output '; na[ 5] := 'get '; na[ 6] := 'put '; |
| 9979 | na[ 7] := 'reset '; na[ 8] := 'rewrite '; na[ 9] := 'read '; |
| 9980 | na[10] := 'write '; na[11] := 'pack '; na[12] := 'unpack '; |
| 9981 | na[13] := 'new '; na[14] := 'assign '; na[15] := 'readln '; |
| 9982 | na[16] := 'writeln '; na[17] := 'abs '; na[18] := 'sqr '; |
| 9983 | na[19] := 'trunc '; na[20] := 'odd '; na[21] := 'ord '; |
| 9984 | na[22] := 'chr '; na[23] := 'pred '; na[24] := 'succ '; |
| 9985 | na[25] := 'eof '; na[26] := 'eoln '; na[27] := 'sin '; |
| 9986 | na[28] := 'cos '; na[29] := 'exp '; na[30] := 'sqrt '; |
| 9987 | na[31] := 'ln '; na[32] := 'arctan '; na[33] := 'prd '; |
| 9988 | na[34] := 'prr '; na[35] := 'close '; na[36] := 'maxint '; |
| 9989 | na[37] := 'round '; na[38] := 'page '; na[39] := 'dispose '; |
| 9990 | na[40] := 'length '; na[41] := 'location '; na[42] := 'position '; |
| 9991 | na[43] := 'update '; na[44] := 'append '; na[45] := 'exists '; |
| 9992 | na[46] := 'delete '; na[47] := 'change '; na[48] := 'error '; |
| 9993 | na[49] := 'list '; na[50] := 'command '; na[51] := 'halt '; |
| 9994 | na[52] := 'linteger '; na[53] := 'maxlint '; na[54] := 'cardinal '; |
| 9995 | na[55] := 'maxcrd '; na[56] := 'lcardinal'; na[57] := 'maxlcrd '; |
| 9996 | na[58] := 'sreal '; na[59] := 'lreal '; na[60] := 'maxreal '; |
| 9997 | na[61] := 'maxsreal '; na[62] := 'maxlreal '; na[63] := 'integer '; |
| 9998 | na[64] := 'real '; na[65] := 'char '; na[66] := 'boolean '; |
| 9999 | na[67] := 'text '; na[68] := 'maxchr '; na[69] := 'assert '; |
| 10000 | na[70] := 'error '; na[71] := 'list '; na[72] := 'command '; |
| 10001 | na[73] := 'exception'; na[74] := 'throw '; na[75] := 'max '; |
| 10002 | na[76] := 'string '; na[77] := 'pstring '; na[78] := 'byte '; |
| 10003 | na[79] := 'vector '; na[80] := 'matrix '; na[81] := 'abyte '; |
| 10004 | na[82] := 'schar '; na[83] := 'refer '; na[84] := 'seterr '; |
| 10005 | |
| 10006 | end (*stdnames*) ; |
| 10007 | |
| 10008 | procedure enterstdtypes; |
| 10009 | begin (*type underlying:*) |
| 10010 | (******************) |
| 10011 | |
| 10012 | new(intptr,scalar,standard); pshstc(intptr); (*integer*) |
| 10013 | with intptr^ do |
| 10014 | begin form := scalar; size := intsize; scalkind := standard; |
| 10015 | packing := false end; |
| 10016 | new(crdptr,subrange); pshstc(crdptr); (*cardinal*) |
| 10017 | with crdptr^ do |
| 10018 | begin form := subrange; size := intsize; rangetype := intptr; |
| 10019 | min.intval := true; min.ival := 0; |
| 10020 | max.intval := true; max.ival := pmmaxint; packing := false end; |
| 10021 | new(realptr,scalar,standard); pshstc(realptr); (*real*) |
| 10022 | with realptr^ do |
| 10023 | begin form := scalar; size := realsize; scalkind := standard; |
| 10024 | packing := false end; |
| 10025 | new(charptr,scalar,standard); pshstc(charptr); (*char*) |
| 10026 | with charptr^ do |
| 10027 | begin form := scalar; size := charsize; scalkind := standard; |
| 10028 | packing := false end; |
| 10029 | new(boolptr,scalar,declared); pshstc(boolptr); (*boolean*) |
| 10030 | with boolptr^ do |
| 10031 | begin form := scalar; size := boolsize; scalkind := declared; |
| 10032 | packing := false end; |
| 10033 | new(nilptr,pointer); pshstc(nilptr); (*nil*) |
| 10034 | with nilptr^ do |
| 10035 | begin form := pointer; eltype := nil; size := ptrsize; |
| 10036 | packing := false end; |
| 10037 | (*for alignment of parameters*) |
| 10038 | new(parmptr,scalar,standard); pshstc(parmptr); |
| 10039 | with parmptr^ do |
| 10040 | begin form := scalar; size := parmsize; scalkind := standard; |
| 10041 | packing := false end ; |
| 10042 | new(textptr,files); pshstc(textptr); (*text*) |
| 10043 | with textptr^ do |
| 10044 | begin form := files; filtype := charptr; size := filesize+charsize; |
| 10045 | packing := false end; |
| 10046 | new(exceptptr,exceptf); pshstc(exceptptr); (*exception*) |
| 10047 | with exceptptr^ do |
| 10048 | begin form := exceptf; size := exceptsize; packing := false end; |
| 10049 | |
| 10050 | { common types } |
| 10051 | new(stringptr,arrayc); pshstc(stringptr); (*string*) |
| 10052 | with stringptr^ do |
| 10053 | begin form := arrayc; size := 0; packing := true; abstype := charptr end; |
| 10054 | new(pstringptr,pointer); pshstc(pstringptr); (*string pointer*) |
| 10055 | with pstringptr^ do |
| 10056 | begin form := pointer; size := ptrsize; packing := false; |
| 10057 | eltype := stringptr end; |
| 10058 | new(byteptr,subrange); pshstc(byteptr); |
| 10059 | with byteptr^ do |
| 10060 | begin form := subrange; size := 1; packing := false; rangetype := intptr; |
| 10061 | min.intval := true; min.ival := 0; max.intval := true; |
| 10062 | max.ival := 255 end; |
| 10063 | new(abyteptr,arrayc); pshstc(abyteptr); (*byte array*) |
| 10064 | with abyteptr^ do |
| 10065 | begin form := arrayc; size := 0; packing := false; abstype := byteptr end; |
| 10066 | new(vectorptr,arrayc); pshstc(vectorptr); (*vector*) |
| 10067 | with vectorptr^ do |
| 10068 | begin form := arrayc; size := 0; packing := false; abstype := intptr end; |
| 10069 | new(matrixptr,arrayc); pshstc(matrixptr); (*matrix*) |
| 10070 | with matrixptr^ do |
| 10071 | begin form := arrayc; size := 0; packing := false; |
| 10072 | abstype := vectorptr end; |
| 10073 | new(scharptr,power); pshstc(scharptr); (*set of char*) |
| 10074 | with scharptr^ do |
| 10075 | begin form := power; size := setsize; packing := false; elset := charptr; |
| 10076 | matchpack := true end; |
| 10077 | end (*enterstdtypes*) ; |
| 10078 | |
| 10079 | procedure entstdnames; |
| 10080 | var cp,cp1: ctp; i: integer; |
| 10081 | |
| 10082 | procedure entstdprocfunc(idc: idclass; sn: stdrng; kn: keyrng; idt: stp); |
| 10083 | begin |
| 10084 | if idc = proc then new(cp,proc,standard) |
| 10085 | else new(cp,func,standard); |
| 10086 | ininam(cp); |
| 10087 | with cp^ do |
| 10088 | begin klass := idc; strassvr(name, na[sn]); idtype := idt; |
| 10089 | pflist := nil; next := nil; key := kn; |
| 10090 | pfdeckind := standard; pfaddr := 0; pext := false; |
| 10091 | pmod := nil; pfattr := fpanone; grpnxt := nil; grppar := cp; |
| 10092 | pfvid := nil; pflist := nil |
| 10093 | end; enterid(cp) |
| 10094 | end; |
| 10095 | |
| 10096 | procedure entstdtyp(sn: stdrng; idt: stp); |
| 10097 | begin |
| 10098 | new(cp,types); ininam(cp); |
| 10099 | with cp^ do |
| 10100 | begin klass := types; strassvr(name, na[sn]); idtype := idt end; |
| 10101 | enterid(cp) |
| 10102 | end; |
| 10103 | |
| 10104 | procedure entstdintcst(sn: stdrng; idt: stp; i: integer); |
| 10105 | begin |
| 10106 | new(cp,konst); ininam(cp); |
| 10107 | with cp^ do |
| 10108 | begin klass := konst; strassvr(name, na[sn]); idtype := idt; next := nil; |
| 10109 | values.intval := true; values.ival := i end; |
| 10110 | enterid(cp) |
| 10111 | end; |
| 10112 | |
| 10113 | procedure entstdrlcst(sn: stdrng; idt: stp; r: real); |
| 10114 | var lvp: csp; |
| 10115 | begin |
| 10116 | new(cp,konst); ininam(cp); new(lvp,reel); pshcst(lvp); lvp^.cclass := reel; |
| 10117 | lvp^.rval := r; |
| 10118 | with cp^ do |
| 10119 | begin klass := konst; strassvr(name, na[sn]); idtype := idt; next := nil; |
| 10120 | values.intval := false; values.valp := lvp end; |
| 10121 | enterid(cp) |
| 10122 | end; |
| 10123 | |
| 10124 | procedure entstdhdr(sn: stdrng); |
| 10125 | begin |
| 10126 | new(cp,vars); ininam(cp); |
| 10127 | with cp^ do |
| 10128 | begin klass := vars; strassvr(name, na[sn]); idtype := textptr; |
| 10129 | vkind := actual; next := nil; vlev := 1; |
| 10130 | vaddr := gc; gc := gc+filesize+charsize; { files are global now } |
| 10131 | isloc := false; threat := false; forcnt := 0; part := ptval; hdr := false; |
| 10132 | vext := false; vmod := nil; inilab := -1; ininxt := nil; dblptr := false |
| 10133 | end; |
| 10134 | enterid(cp) |
| 10135 | end; |
| 10136 | |
| 10137 | procedure entstdexp(en: expstr); |
| 10138 | begin |
| 10139 | new(cp,vars); ininam(cp); |
| 10140 | with cp^ do |
| 10141 | begin klass := vars; strassve(name, en); idtype := exceptptr; |
| 10142 | vkind := actual; next := nil; vlev := 1; |
| 10143 | vaddr := gc; gc := gc+exceptsize; |
| 10144 | isloc := false; threat := false; forcnt := 0; part := ptval; hdr := false; |
| 10145 | vext := false; vmod := nil; inilab := -1; ininxt := nil; dblptr := false |
| 10146 | end; |
| 10147 | enterid(cp) |
| 10148 | end; |
| 10149 | |
| 10150 | begin (*name:*) |
| 10151 | (*******) |
| 10152 | |
| 10153 | entstdtyp(63, intptr); (*integer*) |
| 10154 | entstdtyp(52, intptr); (*linteger*) |
| 10155 | entstdtyp(54, crdptr); (*cardinal*) |
| 10156 | entstdtyp(56, crdptr); (*lcardinal*) |
| 10157 | entstdtyp(64, realptr); (*real*) |
| 10158 | entstdtyp(58, realptr); (*sreal*) |
| 10159 | entstdtyp(59, realptr); (*lreal*) |
| 10160 | entstdtyp(65, charptr); (*char*) |
| 10161 | entstdtyp(66, boolptr); (*boolean*) |
| 10162 | usclrptr := cp; { save to satisfy broken tags } |
| 10163 | entstdtyp(67, textptr); (*text*) |
| 10164 | entstdtyp(73, exceptptr); (*exception*) |
| 10165 | entstdtyp(76, stringptr); (*string*) |
| 10166 | entstdtyp(77, pstringptr); (*pointer to string*) |
| 10167 | entstdtyp(78, byteptr); (*byte*) |
| 10168 | entstdtyp(79, vectorptr); (*vector*) |
| 10169 | entstdtyp(80, matrixptr); (*matrix*) |
| 10170 | entstdtyp(81, abyteptr); (*array of bytes*) |
| 10171 | entstdtyp(82, scharptr); (*set of char*) |
| 10172 | |
| 10173 | cp1 := nil; |
| 10174 | for i := 1 to 2 do |
| 10175 | begin new(cp,konst); ininam(cp); (*false,true*) |
| 10176 | with cp^ do |
| 10177 | begin klass := konst; strassvr(name, na[i]); idtype := boolptr; |
| 10178 | next := cp1; values.intval := true; values.ival := i - 1; |
| 10179 | end; |
| 10180 | enterid(cp); cp1 := cp |
| 10181 | end; |
| 10182 | boolptr^.fconst := cp; |
| 10183 | |
| 10184 | entstdhdr(3); inputptr := cp; (*input*) |
| 10185 | entstdhdr(4); outputptr := cp; (*output*) |
| 10186 | entstdhdr(33); prdptr := cp; (*prd*) |
| 10187 | entstdhdr(34); prrptr := cp; (*prr*) |
| 10188 | entstdhdr(70); errorptr := cp; (*error*) |
| 10189 | entstdhdr(71); listptr := cp; (*list*) |
| 10190 | entstdhdr(72); commandptr := cp; (*command*) |
| 10191 | |
| 10192 | for i := 27 to 32 do |
| 10193 | begin |
| 10194 | new(cp,vars); ininam(cp); (*parameter of predeclared functions*) |
| 10195 | with cp^ do |
| 10196 | begin klass := vars; strassvr(name, ' '); idtype := realptr; |
| 10197 | vkind := actual; next := nil; vlev := 1; vaddr := 0; |
| 10198 | isloc := false; threat := false; forcnt := 0; part := ptval; |
| 10199 | hdr := false; vext := false; vmod := nil; inilab := -1; |
| 10200 | ininxt := nil; dblptr := false |
| 10201 | end; |
| 10202 | new(cp1,func,declared,actual); ininam(cp1); (*sin,cos,exp*) |
| 10203 | with cp1^ do (*sqrt,ln,arctan*) |
| 10204 | begin klass := func; strassvr(name, na[i]); idtype := realptr; |
| 10205 | pflist := cp; forwdecl := false; sysrot := true; extern := false; |
| 10206 | pflev := 0; pfname := i - 12; pfdeckind := declared; |
| 10207 | pfkind := actual; pfaddr := 0; pext := false; pmod := nil; |
| 10208 | pfattr := fpanone; grpnxt := nil; grppar := cp1; pfvid := nil |
| 10209 | end; |
| 10210 | enterid(cp1) |
| 10211 | end; |
| 10212 | |
| 10213 | entstdintcst(36, intptr, pmmaxint); (*maxint*) |
| 10214 | entstdintcst(53, intptr, pmmaxint); (*maxlint*) |
| 10215 | entstdintcst(55, crdptr, pmmaxint); (*maxcrd*) |
| 10216 | entstdintcst(57, crdptr, pmmaxint); (*maxlcrd*) |
| 10217 | entstdintcst(68, charptr, ordmaxchar); (*maxlcrd*) |
| 10218 | entstdrlcst(60, realptr, 1.79769313486231e308); (*maxreal*) |
| 10219 | entstdrlcst(61, realptr, 1.79769313486231e308); (*maxsreal*) |
| 10220 | entstdrlcst(62, realptr, 1.79769313486231e308); (*maxlreal*) |
| 10221 | |
| 10222 | entstdprocfunc(proc, 5, 1, nil); { get } |
| 10223 | entstdprocfunc(proc, 6, 2, nil); { put } |
| 10224 | entstdprocfunc(proc, 7, 3, nil); { reset } |
| 10225 | entstdprocfunc(proc, 8, 4, nil); { rewrite } |
| 10226 | entstdprocfunc(proc, 9, 5, nil); { read } |
| 10227 | entstdprocfunc(proc, 10, 6, nil); { write } |
| 10228 | entstdprocfunc(proc, 11, 7, nil); { pack } |
| 10229 | entstdprocfunc(proc, 12, 8, nil); { unpack } |
| 10230 | entstdprocfunc(proc, 13, 9, nil); { new } |
| 10231 | entstdprocfunc(proc, 15, 11, nil); { readln } |
| 10232 | entstdprocfunc(proc, 16, 12, nil); { writeln } |
| 10233 | entstdprocfunc(func, 17, 1, nil); { abs } |
| 10234 | entstdprocfunc(func, 18, 2, nil); { sqr } |
| 10235 | entstdprocfunc(func, 19, 3, nil); { trunc } |
| 10236 | entstdprocfunc(func, 20, 4, nil); { odd } |
| 10237 | entstdprocfunc(func, 21, 5, nil); { ord } |
| 10238 | entstdprocfunc(func, 22, 6, nil); { chr } |
| 10239 | entstdprocfunc(func, 23, 7, nil); { pred } |
| 10240 | entstdprocfunc(func, 24, 8, nil); { succ } |
| 10241 | entstdprocfunc(func, 25, 9, nil); { eof } |
| 10242 | entstdprocfunc(func, 26, 10, nil); { eoln } |
| 10243 | entstdprocfunc(func, 37, 16, nil); { round } |
| 10244 | entstdprocfunc(proc, 38, 17, nil); { page } |
| 10245 | entstdprocfunc(proc, 39, 18, nil); { dispose } |
| 10246 | { Note: I was to lazy to overload the keys on these } |
| 10247 | entstdprocfunc(proc, 14, 19, nil); { assign } |
| 10248 | entstdprocfunc(proc, 35, 20, nil); { close } |
| 10249 | entstdprocfunc(func, 40, 21, intptr); { length } |
| 10250 | entstdprocfunc(func, 41, 22, intptr); { location } |
| 10251 | entstdprocfunc(proc, 42, 23, nil); { position } |
| 10252 | entstdprocfunc(proc, 43, 24, nil); { update } |
| 10253 | entstdprocfunc(proc, 44, 25, nil); { append } |
| 10254 | entstdprocfunc(func, 45, 26, boolptr); { exists } |
| 10255 | entstdprocfunc(proc, 46, 27, nil); { delete } |
| 10256 | entstdprocfunc(proc, 47, 28, nil); { change } |
| 10257 | entstdprocfunc(proc, 51, 29, nil); { halt } |
| 10258 | entstdprocfunc(proc, 69, 30, nil); { assert } |
| 10259 | entstdprocfunc(proc, 74, 31, nil); { throw } |
| 10260 | entstdprocfunc(func, 75, 32, intptr); { max } |
| 10261 | entstdprocfunc(proc, 83, 32, nil); { refer } |
| 10262 | entstdprocfunc(proc, 84, 33, nil); { seterr } |
| 10263 | |
| 10264 | { standard exceptions } |
| 10265 | entstdexp('ValueOutOfRange '); |
| 10266 | entstdexp('ArrayLengthMatch '); |
| 10267 | entstdexp('CaseValueNotFound '); |
| 10268 | entstdexp('ZeroDivide '); |
| 10269 | entstdexp('InvalidOperand '); |
| 10270 | entstdexp('NilPointerDereference '); |
| 10271 | entstdexp('RealOverflow '); |
| 10272 | entstdexp('RealUnderflow '); |
| 10273 | entstdexp('RealProcessingFault '); |
| 10274 | entstdexp('TagValueNotActive '); |
| 10275 | entstdexp('TooManyFiles '); |
| 10276 | entstdexp('FileIsOpen '); |
| 10277 | entstdexp('FileAlreadyNamed '); |
| 10278 | entstdexp('FileNotOpen '); |
| 10279 | entstdexp('FileModeIncorrect '); |
| 10280 | entstdexp('InvalidFieldSpecification '); |
| 10281 | entstdexp('InvalidRealNumber '); |
| 10282 | entstdexp('InvalidFractionSpecification '); |
| 10283 | entstdexp('InvalidIntegerFormat '); |
| 10284 | entstdexp('IntegerValueOverflow '); |
| 10285 | entstdexp('InvalidRealFormat '); |
| 10286 | entstdexp('EndOfFile '); |
| 10287 | entstdexp('InvalidFilePosition '); |
| 10288 | entstdexp('FilenameTooLong '); |
| 10289 | entstdexp('FileOpenFail '); |
| 10290 | entstdexp('FileSIzeFail '); |
| 10291 | entstdexp('FileCloseFail '); |
| 10292 | entstdexp('FileReadFail '); |
| 10293 | entstdexp('FileWriteFail '); |
| 10294 | entstdexp('FilePositionFail '); |
| 10295 | entstdexp('FileDeleteFail '); |
| 10296 | entstdexp('FileNameChangeFail '); |
| 10297 | entstdexp('SpaceAllocateFail '); |
| 10298 | entstdexp('SpaceReleaseFail '); |
| 10299 | entstdexp('SpaceAllocateNegative '); |
| 10300 | entstdexp('CannotPerformSpecial '); |
| 10301 | entstdexp('CommandLineTooLong '); |
| 10302 | entstdexp('ReadPastEOF '); |
| 10303 | entstdexp('FileTransferLengthZero '); |
| 10304 | entstdexp('FileSizeTooLarge '); |
| 10305 | entstdexp('FilenameEmpty '); |
| 10306 | entstdexp('CannotOpenStandard '); |
| 10307 | entstdexp('TooManyTemporaryFiles '); |
| 10308 | entstdexp('InputBufferOverflow '); |
| 10309 | entstdexp('TooManyThreads '); |
| 10310 | entstdexp('CannotStartThread '); |
| 10311 | entstdexp('InvalidThreadHandle '); |
| 10312 | entstdexp('CannotStopThread '); |
| 10313 | entstdexp('TooManyIntertaskLocks '); |
| 10314 | entstdexp('InvalidLockHandle '); |
| 10315 | entstdexp('LockSequenceFail '); |
| 10316 | entstdexp('TooManySignals '); |
| 10317 | entstdexp('CannotCreateSignal '); |
| 10318 | entstdexp('InvalidSignalHandle '); |
| 10319 | entstdexp('CannotDeleteSignal '); |
| 10320 | entstdexp('CannotSendSignal '); |
| 10321 | entstdexp('WaitForSignalFail '); |
| 10322 | entstdexp('FieldNotBlank '); |
| 10323 | entstdexp('ReadOnWriteOnlyFile '); |
| 10324 | entstdexp('WriteOnReadOnlyFile '); |
| 10325 | entstdexp('FileBufferVariableUndefined '); |
| 10326 | entstdexp('NondecimalRadixOfNegative '); |
| 10327 | entstdexp('InvalidArgumentToLn '); |
| 10328 | entstdexp('InvalidArgumentToSqrt '); |
| 10329 | entstdexp('CannotResetOrRewriteStandardFile'); |
| 10330 | entstdexp('CannotResetWriteOnlyFile '); |
| 10331 | entstdexp('CannotRewriteReadOnlyFile '); |
| 10332 | entstdexp('SetElementOutOfRange '); |
| 10333 | entstdexp('RealArgumentTooLarge '); |
| 10334 | entstdexp('BooleanOperatorOfNegative '); |
| 10335 | entstdexp('InvalidDivisorToMod '); |
| 10336 | entstdexp('PackElementsOutOfBounds '); |
| 10337 | entstdexp('UnpackElementsOutOfBounds '); |
| 10338 | entstdexp('CannotResetClosedTempFile '); |
| 10339 | entstdexp('ReadCharacterMismatch '); |
| 10340 | end (*entstdnames*) ; |
| 10341 | |
| 10342 | procedure enterundecl; |
| 10343 | begin |
| 10344 | new(utypptr,types); ininam(utypptr); |
| 10345 | with utypptr^ do |
| 10346 | begin klass := types; strassvr(name, ' '); idtype := nil end; |
| 10347 | new(ucstptr,konst); ininam(ucstptr); |
| 10348 | with ucstptr^ do |
| 10349 | begin klass := konst; strassvr(name, ' '); idtype := nil; |
| 10350 | next := nil; values.intval := true; values.ival := 0 |
| 10351 | end; |
| 10352 | new(uvarptr,vars); ininam(uvarptr); |
| 10353 | with uvarptr^ do |
| 10354 | begin klass := vars; strassvr(name, ' '); idtype := nil; |
| 10355 | vkind := actual; next := nil; vlev := 0; vaddr := 0; |
| 10356 | isloc := false; threat := false; forcnt := 0; part := ptval; |
| 10357 | hdr := false; vext := false; vmod := nil; inilab := -1; ininxt := nil; |
| 10358 | dblptr := false |
| 10359 | end; |
| 10360 | new(ufldptr,field); ininam(ufldptr); |
| 10361 | with ufldptr^ do |
| 10362 | begin klass := field; strassvr(name, ' '); idtype := nil; |
| 10363 | next := nil; fldaddr := 0; varnt := nil; varlb := nil; |
| 10364 | tagfield := false; taglvl := 0; varsaddr := 0; |
| 10365 | varssize := 0; vartl := -1 |
| 10366 | end; |
| 10367 | new(uprcptr,proc,declared,actual); ininam(uprcptr); |
| 10368 | with uprcptr^ do |
| 10369 | begin klass := proc; strassvr(name, ' '); idtype := nil; |
| 10370 | forwdecl := false; next := nil; sysrot := false; extern := false; |
| 10371 | pflev := 0; genlabel(pfname); pflist := nil; pfdeckind := declared; |
| 10372 | pfkind := actual; pmod := nil; grpnxt := nil; grppar := uprcptr; |
| 10373 | pfvid := nil |
| 10374 | end; |
| 10375 | new(ufctptr,func,declared,actual); ininam(ufctptr); |
| 10376 | with ufctptr^ do |
| 10377 | begin klass := func; strassvr(name, ' '); idtype := nil; |
| 10378 | next := nil; forwdecl := false; sysrot := false; extern := false; |
| 10379 | pflev := 0; genlabel(pfname); pflist := nil; pfdeckind := declared; |
| 10380 | pfkind := actual; pmod := nil; grpnxt := nil; grppar := ufctptr; |
| 10381 | pfvid := nil |
| 10382 | end |
| 10383 | end (*enterundecl*) ; |
| 10384 | |
| 10385 | { tear down storage allocations from enterundecl } |
| 10386 | procedure exitundecl; |
| 10387 | begin |
| 10388 | putnam(utypptr); |
| 10389 | putnam(ucstptr); |
| 10390 | putnam(uvarptr); |
| 10391 | putnam(ufldptr); |
| 10392 | putnam(uprcptr); |
| 10393 | putnam(ufctptr); |
| 10394 | end (*exitundecl*) ; |
| 10395 | |
| 10396 | { parse command line options } |
| 10397 | procedure paropt; |
| 10398 | var w(fillen): string; { word holder } |
| 10399 | err: boolean; { error flag } |
| 10400 | optfnd: boolean; { option found } |
| 10401 | ii: lininx; { index for incbuf } |
| 10402 | setpos, setneg: boolean; { set flag positive or negative } |
| 10403 | |
| 10404 | { set true/false flag } |
| 10405 | procedure setflg(view a, n: string; var f, s: boolean); |
| 10406 | var ts: packed array [1..40] of char; |
| 10407 | begin |
| 10408 | if compp(w, n) or compp(w, a) then begin |
| 10409 | f := true; s := true; optfnd := true; |
| 10410 | if setpos then f := true; |
| 10411 | if setneg then f := false |
| 10412 | end else begin |
| 10413 | copy(ts, 'n'); cat(ts, n); |
| 10414 | if compp(w, ts) then begin |
| 10415 | f := false; s := true; optfnd := true; |
| 10416 | if setpos then f := true; |
| 10417 | if setneg then f := false |
| 10418 | end else if len(a) >= 1 then begin |
| 10419 | copy(ts, 'n'); cat(ts, a); |
| 10420 | if compp(w, ts) then begin |
| 10421 | f := false; s := true; optfnd := true; |
| 10422 | if setpos then f := true; |
| 10423 | if setneg then f := false |
| 10424 | end |
| 10425 | end |
| 10426 | end |
| 10427 | end; |
| 10428 | |
| 10429 | begin |
| 10430 | parse.skpspc(cmdhan); |
| 10431 | while parse.chkchr(cmdhan) = services.optchr do begin |
| 10432 | optfnd := false; setpos := false; setneg := false; |
| 10433 | parse.getchr(cmdhan); { skip option char } |
| 10434 | if parse.chkchr(cmdhan) = services.optchr then |
| 10435 | parse.getchr(cmdhan); { skip optional double dash } |
| 10436 | parse.parlab(cmdhan, w, err); |
| 10437 | if err then begin |
| 10438 | writeln('*** No valid option found'); goto 99 |
| 10439 | end; |
| 10440 | { allow +/- at end of option for compatibility } |
| 10441 | if (parse.chkchr(cmdhan) = '+') or (parse.chkchr(cmdhan) = '-') then begin |
| 10442 | if parse.chkchr(cmdhan) = '+' then setpos := true else setneg := true; |
| 10443 | parse.getchr(cmdhan) |
| 10444 | end; |
| 10445 | setflg('a', 'debugflt', option[1], options[1]); |
| 10446 | setflg('b', 'prtlab', option[2], options[2]); |
| 10447 | setflg('c', 'lstcod', option[3], options[3]); |
| 10448 | setflg('d', 'chk', option[4], options[4]); |
| 10449 | setflg('e', 'machdeck', option[5], options[5]); |
| 10450 | setflg('f', 'debugsrc', option[6], options[6]); |
| 10451 | setflg('g', 'prtlabdef', option[7], options[7]); |
| 10452 | setflg('h', 'sourceset', option[8], options[8]); |
| 10453 | setflg('i', 'varblk', option[9], options[9]); |
| 10454 | setflg('ee', 'experror', option[10], options[10]); |
| 10455 | setflg('', 'echoline', option[11], options[11]); |
| 10456 | setflg('l', 'list', option[12], options[12]); |
| 10457 | setflg('m', 'breakheap', option[13], options[13]); |
| 10458 | setflg('n', 'recycle', option[14], options[14]); |
| 10459 | setflg('o', 'chkoverflo', option[15], options[15]); |
| 10460 | setflg('p', 'chkreuse', option[16], options[16]); |
| 10461 | setflg('q', 'chkundef', option[17], options[17]); |
| 10462 | setflg('r', 'reference', option[18], options[18]); |
| 10463 | setflg('s', 'iso7185', option[19], options[19]); |
| 10464 | setflg('t', 'prttables', option[20], options[20]); |
| 10465 | setflg('u', 'undestag', option[21], options[21]); |
| 10466 | setflg('v', 'chkvar', option[22], options[22]); |
| 10467 | setflg('w', 'debug', option[23], options[23]); |
| 10468 | setflg('x', 'prtlex', option[24], options[24]); |
| 10469 | setflg('y', 'prtdisplay', option[25], options[25]); |
| 10470 | setflg('z', 'lineinfo', option[26], options[26]); |
| 10471 | { module path: -md=path or -modules=path or -mp=path } |
| 10472 | if compp(w, 'md') or compp(w, 'modules') or |
| 10473 | compp(w, 'modulepath') or compp(w, 'mp') then begin |
| 10474 | optfnd := true; |
| 10475 | parse.skpspc(cmdhan); |
| 10476 | if parse.chkchr(cmdhan) <> '=' then begin |
| 10477 | writeln('*** Missing "=" for module path'); goto 99 |
| 10478 | end; |
| 10479 | parse.getchr(cmdhan); { skip '=' } |
| 10480 | { append to incbuf with : separator } |
| 10481 | ii := maxlin; |
| 10482 | while (incbuf[ii] = ' ') and (ii > 1) do ii := ii-1; |
| 10483 | if incbuf[ii] <> ' ' then begin |
| 10484 | if ii < maxlin then ii := ii+1; |
| 10485 | if ii < maxlin-1 then begin incbuf[ii] := ':'; ii := ii+1 end |
| 10486 | end; |
| 10487 | while (parse.chkchr(cmdhan) <> ' ') and |
| 10488 | not parse.endlin(cmdhan) do begin |
| 10489 | if ii >= maxlin then begin |
| 10490 | writeln('*** Include path too long'); goto 99 |
| 10491 | end; |
| 10492 | incbuf[ii] := parse.chkchr(cmdhan); |
| 10493 | parse.getchr(cmdhan); |
| 10494 | ii := ii+1 |
| 10495 | end |
| 10496 | end; |
| 10497 | { error file: -errfile=file or -ef=file } |
| 10498 | if compp(w, 'errfile') or compp(w, 'ef') then begin |
| 10499 | optfnd := true; |
| 10500 | parse.skpspc(cmdhan); |
| 10501 | if parse.chkchr(cmdhan) <> '=' then begin |
| 10502 | writeln('*** Missing "=" for error file'); goto 99 |
| 10503 | end; |
| 10504 | parse.getchr(cmdhan); { skip '=' } |
| 10505 | if parse.chkchr(cmdhan) = '"' then |
| 10506 | parse.parstr(cmdhan, errfil, err) |
| 10507 | else |
| 10508 | parse.parfil(cmdhan, errfil, false, err); |
| 10509 | err := not err; |
| 10510 | if not err then begin |
| 10511 | writeln('*** Error: error filename not found'); goto 99 |
| 10512 | end; |
| 10513 | errfval := true |
| 10514 | end; |
| 10515 | setflg('mal', 'mrkasslin', option[28], options[28]); |
| 10516 | if not optfnd then begin |
| 10517 | writeln('*** Unknown option ', w:*); goto 99 |
| 10518 | end; |
| 10519 | parse.skpspc(cmdhan) |
| 10520 | end |
| 10521 | end; |
| 10522 | |
| 10523 | { place options in flags } |
| 10524 | procedure plcopt; |
| 10525 | var oi: 1..maxopt; |
| 10526 | begin |
| 10527 | for oi := 1 to maxopt do if options[oi] then |
| 10528 | case oi of |
| 10529 | 2: doprtlab := option[oi]; |
| 10530 | 3: prcode := option[oi]; |
| 10531 | 4: debug := option[oi]; |
| 10532 | 9: chkvbk := option[oi]; |
| 10533 | 10: experr := option[oi]; |
| 10534 | 12: list := option[oi]; |
| 10535 | 18: chkref := option[oi]; |
| 10536 | 19: iso7185 := option[oi]; |
| 10537 | |
| 10538 | 20: prtables := option[oi]; |
| 10539 | 21: chkudtc := option[oi]; |
| 10540 | 22: chkvar := option[oi]; |
| 10541 | 24: dodmplex := option[oi]; |
| 10542 | 25: dodmpdsp := option[oi]; |
| 10543 | 26: dolineinfo := option[oi]; |
| 10544 | { these are backend options } |
| 10545 | 1:; 5:; 6:; 7:; 8:; 11:; 13:; 14:; 15:; 16:; |
| 10546 | 17:; 23:; 27:; 28:; |
| 10547 | end |
| 10548 | end; |
| 10549 | |
| 10550 | procedure initscalars; |
| 10551 | var i: integer; oi: 1..maxopt; |
| 10552 | begin fwptr := nil; |
| 10553 | for oi := 1 to maxopt do |
| 10554 | begin option[oi] := false; options[oi] := false end; |
| 10555 | { initialize option name tables } |
| 10556 | opts[1] := 'a '; opts[2] := 'b '; |
| 10557 | opts[3] := 'c '; opts[4] := 'd '; |
| 10558 | opts[5] := 'e '; opts[6] := 'f '; |
| 10559 | opts[7] := 'g '; opts[8] := 'h '; |
| 10560 | opts[9] := 'i '; opts[10] := 'ee '; |
| 10561 | opts[11] := ' '; opts[12] := 'l '; |
| 10562 | opts[13] := 'm '; opts[14] := 'n '; |
| 10563 | opts[15] := 'o '; opts[16] := 'p '; |
| 10564 | opts[17] := 'q '; opts[18] := 'r '; |
| 10565 | opts[19] := 's '; opts[20] := 't '; |
| 10566 | opts[21] := 'u '; opts[22] := 'v '; |
| 10567 | opts[23] := 'w '; opts[24] := 'x '; |
| 10568 | opts[25] := 'y '; opts[26] := 'z '; |
| 10569 | opts[27] := 'md '; opts[28] := 'mal '; |
| 10570 | optsl[1] := 'debugflt '; optsl[2] := 'prtlab '; |
| 10571 | optsl[3] := 'lstcod '; optsl[4] := 'chk '; |
| 10572 | optsl[5] := 'machdeck '; optsl[6] := 'debugsrc '; |
| 10573 | optsl[7] := 'prtlabdef '; optsl[8] := 'sourceset '; |
| 10574 | optsl[9] := 'varblk '; optsl[10] := 'experror '; |
| 10575 | optsl[11] := 'echoline '; optsl[12] := 'list '; |
| 10576 | optsl[13] := 'breakheap '; optsl[14] := 'recycle '; |
| 10577 | optsl[15] := 'chkoverflo'; optsl[16] := 'chkreuse '; |
| 10578 | optsl[17] := 'chkundef '; optsl[18] := 'reference '; |
| 10579 | optsl[19] := 'iso7185 '; optsl[20] := 'prttables '; |
| 10580 | optsl[21] := 'undestag '; optsl[22] := 'chkvar '; |
| 10581 | optsl[23] := 'debug '; optsl[24] := 'prtlex '; |
| 10582 | optsl[25] := 'prtdisplay'; optsl[26] := 'lineinfo '; |
| 10583 | optsl[27] := 'modules '; optsl[28] := 'mrkasslin '; |
| 10584 | prtables := false; option[20] := false; list := false; option[12] := false; |
| 10585 | prcode := true; option[3] := true; debug := true; option[4] := true; |
| 10586 | chkvar := true; option[22] := true; chkref := true; option[18] := true; |
| 10587 | chkudtc := true; option[21] := true; option[19] := false; iso7185 := false; |
| 10588 | dodmplex := false; doprtryc := false; doprtlab := false; dodmpdsp := false; |
| 10589 | chkvbk := false; option[9] := false; experr := true; option[10] := true; |
| 10590 | dolineinfo := true; option[26] := true; |
| 10591 | dp := true; errinx := 0; |
| 10592 | intlabel := 0; kk := maxids; fextfilep := nil; wthstk := nil; |
| 10593 | { single display entry for top level } |
| 10594 | lc := -ptrsize; gc := 0; |
| 10595 | (* note in the above reservation of buffer store for 2 text files *) |
| 10596 | ic := 3; |
| 10597 | incstk := nil; inclst := nil; chcnt := 0; |
| 10598 | mxint10 := maxint div 10; |
| 10599 | maxpow10 := 1; while maxpow10 < mxint10 do maxpow10 := maxpow10*10; |
| 10600 | tmplst := nil; { clear temps list } |
| 10601 | tmpfre := nil; { clear temps free list } |
| 10602 | |
| 10603 | for i := 1 to maxftl do errtbl[i] := 0; { initialize error tracking } |
| 10604 | for i := 1 to maxftl do errltb[i] := nil; |
| 10605 | toterr := 0; { clear error count } |
| 10606 | { clear the recycling tracking counters } |
| 10607 | strcnt := 0; { strings } |
| 10608 | cspcnt := 0; { constants } |
| 10609 | stpcnt := 0; { structures } |
| 10610 | ctpcnt := 0; { identifiers } |
| 10611 | lbpcnt := 0; { label counts } |
| 10612 | filcnt := 0; { file tracking counts } |
| 10613 | cipcnt := 0; { case entry tracking counts } |
| 10614 | ttpcnt := 0; { tag tracking entry counts } |
| 10615 | wtpcnt := 0; { with tracking entry counts } |
| 10616 | |
| 10617 | { clear id counts } |
| 10618 | ctpsnm := 0; |
| 10619 | stpsnm := 0 |
| 10620 | end (*initscalars*) ; |
| 10621 | |
| 10622 | procedure initsets; |
| 10623 | begin |
| 10624 | constbegsys := [lparent,notsy,intconst,realconst,stringconst,ident,lbrack]; |
| 10625 | simptypebegsys := [lparent,addop,intconst,realconst,stringconst,ident]; |
| 10626 | typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys; |
| 10627 | typedels := [arraysy,recordsy,setsy,filesy]; |
| 10628 | pfbegsys := [procsy,funcsy,overloadsy,staticsy,virtualsy,overridesy, |
| 10629 | operatorsy]; |
| 10630 | blockbegsys := [privatesy,labelsy,constsy,typesy,fixedsy,varsy,beginsy]+pfbegsys; |
| 10631 | selectsys := [arrow,period,lbrack]; |
| 10632 | facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy,nilsy, |
| 10633 | inheritedsy]; |
| 10634 | statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy, |
| 10635 | trysy]; |
| 10636 | end (*initsets*) ; |
| 10637 | |
| 10638 | procedure inittables; |
| 10639 | procedure reswords; |
| 10640 | begin |
| 10641 | rw[ 1] := 'if '; rw[ 2] := 'do '; rw[ 3] := 'of '; |
| 10642 | rw[ 4] := 'to '; rw[ 5] := 'in '; rw[ 6] := 'or '; |
| 10643 | rw[ 7] := 'end '; rw[ 8] := 'for '; rw[ 9] := 'var '; |
| 10644 | rw[10] := 'div '; rw[11] := 'mod '; rw[12] := 'set '; |
| 10645 | rw[13] := 'and '; rw[14] := 'not '; rw[15] := 'nil '; |
| 10646 | rw[16] := 'then '; rw[17] := 'else '; rw[18] := 'with '; |
| 10647 | rw[19] := 'goto '; rw[20] := 'case '; rw[21] := 'type '; |
| 10648 | rw[22] := 'file '; rw[23] := 'begin '; rw[24] := 'until '; |
| 10649 | rw[25] := 'while '; rw[26] := 'array '; rw[27] := 'const '; |
| 10650 | rw[28] := 'label '; rw[29] := 'repeat '; rw[30] := 'record '; |
| 10651 | rw[31] := 'downto '; rw[32] := 'packed '; rw[33] := 'program '; |
| 10652 | rw[34] := 'function '; rw[35] := 'procedure'; rw[36] := 'forward '; |
| 10653 | rw[37] := 'module '; rw[38] := 'uses '; rw[39] := 'private '; |
| 10654 | rw[40] := 'external '; rw[41] := 'view '; rw[42] := 'fixed '; |
| 10655 | rw[43] := 'process '; rw[44] := 'monitor '; rw[45] := 'share '; |
| 10656 | rw[46] := 'class '; rw[47] := 'is '; rw[48] := 'overload '; |
| 10657 | rw[49] := 'override '; rw[50] := 'reference'; rw[51] := 'joins '; |
| 10658 | rw[52] := 'static '; rw[53] := 'inherited'; rw[54] := 'self '; |
| 10659 | rw[55] := 'virtual '; rw[56] := 'try '; rw[57] := 'except '; |
| 10660 | rw[58] := 'extends '; rw[59] := 'on '; rw[60] := 'result '; |
| 10661 | rw[61] := 'operator '; rw[62] := 'out '; rw[63] := 'property '; |
| 10662 | rw[64] := 'channel '; rw[65] := 'stream '; rw[66] := 'xor '; |
| 10663 | end (*reswords*) ; |
| 10664 | |
| 10665 | procedure symbols; |
| 10666 | var i: integer; |
| 10667 | begin |
| 10668 | rsy[ 1] := ifsy; rsy[ 2] := dosy; rsy[ 3] := ofsy; |
| 10669 | rsy[ 4] := tosy; rsy[ 5] := relop; rsy[ 6] := addop; |
| 10670 | rsy[ 7] := endsy; rsy[ 8] := forsy; rsy[ 9] := varsy; |
| 10671 | rsy[10] := mulop; rsy[11] := mulop; rsy[12] := setsy; |
| 10672 | rsy[13] := mulop; rsy[14] := notsy; rsy[15] := nilsy; |
| 10673 | rsy[16] := thensy; rsy[17] := elsesy; rsy[18] := withsy; |
| 10674 | rsy[19] := gotosy; rsy[20] := casesy; rsy[21] := typesy; |
| 10675 | rsy[22] := filesy; rsy[23] := beginsy; rsy[24] := untilsy; |
| 10676 | rsy[25] := whilesy; rsy[26] := arraysy; rsy[27] := constsy; |
| 10677 | rsy[28] := labelsy; rsy[29] := repeatsy; rsy[30] := recordsy; |
| 10678 | rsy[31] := downtosy; rsy[32] := packedsy; rsy[33] := progsy; |
| 10679 | rsy[34] := funcsy; rsy[35] := procsy; rsy[36] := forwardsy; |
| 10680 | rsy[37] := modulesy; rsy[38] := usessy; rsy[39] := privatesy; |
| 10681 | rsy[40] := externalsy; rsy[41] := viewsy; rsy[42] := fixedsy; |
| 10682 | rsy[43] := processsy; rsy[44] := monitorsy; rsy[45] := sharesy; |
| 10683 | rsy[46] := classsy; rsy[47] := issy; rsy[48] := overloadsy; |
| 10684 | rsy[49] := overridesy; rsy[50] := referencesy; rsy[51] := joinssy; |
| 10685 | rsy[52] := staticsy; rsy[53] := inheritedsy; rsy[54] := selfsy; |
| 10686 | rsy[55] := virtualsy; rsy[56] := trysy; rsy[57] := exceptsy; |
| 10687 | rsy[58] := extendssy; rsy[59] := onsy; rsy[60] := resultsy; |
| 10688 | rsy[61] := operatorsy; rsy[62] := outsy; rsy[63] := propertysy; |
| 10689 | rsy[64] := channelsy; rsy[65] := streamsy; rsy[66] := addop; |
| 10690 | |
| 10691 | for i := ordminchar to ordmaxchar do ssy[chr(i)] := othersy; |
| 10692 | ssy['+'] := addop ; ssy['-'] := addop; ssy['*'] := mulop; |
| 10693 | ssy['/'] := mulop ; ssy['('] := lparent; ssy[')'] := rparent; |
| 10694 | ssy['$'] := othersy ; ssy['='] := relop; ssy[' '] := othersy; |
| 10695 | ssy[','] := comma ; ssy['.'] := period; ssy['''']:= othersy; |
| 10696 | ssy['['] := lbrack ; ssy[']'] := rbrack; ssy[':'] := colon; |
| 10697 | ssy['^'] := arrow ; ssy['<'] := relop; ssy['>'] := relop; |
| 10698 | ssy[';'] := semicolon; ssy['@'] := arrow; ssy['#'] := numsy; |
| 10699 | ssy['}'] := othersy; |
| 10700 | end (*symbols*) ; |
| 10701 | |
| 10702 | procedure rators; |
| 10703 | var i: integer; |
| 10704 | begin |
| 10705 | for i := 1 to maxres (*nr of res words*) do rop[i] := noop; |
| 10706 | rop[5] := inop; rop[10] := idiv; rop[11] := imod; |
| 10707 | rop[6] := orop; rop[13] := andop; rop[66] := xorop; |
| 10708 | for i := ordminchar to ordmaxchar do sop[chr(i)] := noop; |
| 10709 | sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv; |
| 10710 | sop['='] := eqop; sop['<'] := ltop; sop['>'] := gtop; |
| 10711 | end (*rators*) ; |
| 10712 | |
| 10713 | procedure procmnemonics; |
| 10714 | begin |
| 10715 | { There are two mnemonics that have no counterpart in the |
| 10716 | assembler/interpreter: wro, pak. I didn't find a generator for them, and |
| 10717 | suspect they are abandoned. The mnemmonics rst and sav are for |
| 10718 | "mark" and "release", which are no longer used. } |
| 10719 | sna[ 1] :='get '; sna[ 2] :='put '; sna[ 3] :='rdi '; sna[ 4] :='rdr '; |
| 10720 | sna[ 5] :='rdc '; sna[ 6] :='wri '; sna[ 7] :='wro '; sna[ 8] :='wrr '; |
| 10721 | sna[ 9] :='wrc '; sna[10] :='wrs '; sna[11] :='pak '; sna[12] :='new '; |
| 10722 | sna[13] :='rst '; sna[14] :='eln '; sna[15] :='sin '; sna[16] :='cos '; |
| 10723 | sna[17] :='exp '; sna[18] :='sqt '; sna[19] :='log '; sna[20] :='atn '; |
| 10724 | sna[21] :='rln '; sna[22] :='wln '; sna[23] :='sav '; |
| 10725 | { new procedure/function memonics for p5/p6 } |
| 10726 | sna[24] :='pag '; sna[25] :='rsf '; sna[26] :='rwf '; sna[27] :='wrb '; |
| 10727 | sna[28] :='wrf '; sna[29] :='dsp '; sna[30] :='wbf '; sna[31] :='wbi '; |
| 10728 | sna[32] :='wbr '; sna[33] :='wbc '; sna[34] :='wbb '; sna[35] :='rbf '; |
| 10729 | sna[36] :='rsb '; sna[37] :='rwb '; sna[38] :='gbf '; sna[39] :='pbf '; |
| 10730 | sna[40] :='rib '; sna[41] :='rcb '; sna[42] :='nwl '; sna[43] :='dsl '; |
| 10731 | sna[44] :='eof '; sna[45] :='efb '; sna[46] :='fbv '; sna[47] :='fvb '; |
| 10732 | sna[48] :='wbx '; sna[49] :='asst'; sna[50] :='clst'; sna[51] :='pos '; |
| 10733 | sna[52] :='upd '; sna[53] :='appt'; sna[54] :='del '; sna[55] :='chg '; |
| 10734 | sna[56] :='len '; sna[57] :='loc '; sna[58] :='exs '; sna[59] :='assb'; |
| 10735 | sna[60] :='clsb'; sna[61] :='appb'; sna[62] :='hlt '; sna[63] :='ast '; |
| 10736 | sna[64] :='asts'; sna[65] :='wrih'; sna[66] :='wrio'; sna[67] :='wrib'; |
| 10737 | sna[68] :='wrsp'; sna[69] :='wiz '; sna[70] :='wizh'; sna[71] :='wizo'; |
| 10738 | sna[72] :='wizb'; sna[73] :='rds '; sna[74] :='ribf'; sna[75] :='rdif'; |
| 10739 | sna[76] :='rdrf'; sna[77] :='rcbf'; sna[78] :='rdcf'; sna[79] :='rdsf'; |
| 10740 | sna[80] :='rdsp'; sna[81] :='aeft'; sna[82] :='aefb'; sna[83] :='rdie'; |
| 10741 | sna[84] :='rdre'; sna[85] :='thw '; sna[86] :='rdsc'; sna[87] :='rdx '; |
| 10742 | sna[88] :='rdxf'; sna[89] :='rxb '; sna[90] :='rxbf'; sna[91] :='rdih'; |
| 10743 | sna[92] :='rdio'; sna[93] :='rdib'; sna[94] :='rifh'; sna[95] :='rifo'; |
| 10744 | sna[96] :='rifb'; sna[97] :='ribh'; sna[98] :='ribo'; sna[99] :='ribb'; |
| 10745 | sna[100] :='rbfh'; sna[101] :='rbfo'; sna[102] :='rbfb'; sna[103] :='rdxh'; |
| 10746 | sna[104] :='rdxo'; sna[105] :='rdxb'; sna[106] :='rxfh'; sna[107] :='rxfo'; |
| 10747 | sna[108] :='rxfb'; sna[109] :='rxbh'; sna[110] :='rxbo'; sna[111] :='rxbb'; |
| 10748 | sna[112] :='rbxh'; sna[113] :='rbxo'; sna[114] :='rbxb'; sna[115] :='sete'; |
| 10749 | |
| 10750 | end (*procmnemonics*) ; |
| 10751 | |
| 10752 | procedure instrmnemonics; |
| 10753 | begin { --- are unused codes } |
| 10754 | mn[ 0] :='abi'; mn[ 1] :='abr'; mn[ 2] :='adi'; mn[ 3] :='adr'; |
| 10755 | mn[ 4] :='and'; mn[ 5] :='dif'; mn[ 6] :='dvi'; mn[ 7] :='dvr'; |
| 10756 | mn[ 8] :='ltc'; mn[ 9] :='flo'; mn[ 10] :='flt'; mn[ 11] :='inn'; |
| 10757 | mn[ 12] :='int'; mn[ 13] :='ior'; mn[ 14] :='mod'; mn[ 15] :='mpi'; |
| 10758 | mn[ 16] :='mpr'; mn[ 17] :='ngi'; mn[ 18] :='ngr'; mn[ 19] :='not'; |
| 10759 | mn[ 20] :='odd'; mn[ 21] :='sbi'; mn[ 22] :='sbr'; mn[ 23] :='sgs'; |
| 10760 | mn[ 24] :='sqi'; mn[ 25] :='sqr'; mn[ 26] :='sto'; mn[ 27] :='trc'; |
| 10761 | mn[ 28] :='uni'; mn[ 29] :='stp'; mn[ 30] :='csp'; mn[ 31] :='dec'; |
| 10762 | mn[ 32] :='rip'; mn[ 33] :='fjp'; mn[ 34] :='inc'; mn[ 35] :='ind'; |
| 10763 | mn[ 36] :='ixa'; mn[ 37] :='lao'; mn[ 38] :='lca'; mn[ 39] :='ldo'; |
| 10764 | mn[ 40] :='mov'; mn[ 41] :='mst'; mn[ 42] :='ret'; mn[ 43] :='sro'; |
| 10765 | mn[ 44] :='xjp'; mn[ 45] :='chk'; mn[ 46] :='cup'; mn[ 47] :='equ'; |
| 10766 | mn[ 48] :='geq'; mn[ 49] :='grt'; mn[ 50] :='lda'; mn[ 51] :='ldc'; |
| 10767 | mn[ 52] :='leq'; mn[ 53] :='les'; mn[ 54] :='lod'; mn[ 55] :='neq'; |
| 10768 | mn[ 56] :='str'; mn[ 57] :='ujp'; mn[ 58] :='ord'; mn[ 59] :='chr'; |
| 10769 | mn[ 60] :='ujc'; mn[ 61] :='rnd'; mn[ 62] :='pck'; mn[ 63] :='upk'; |
| 10770 | mn[ 64] :='rgs'; mn[ 65] :='???'; mn[ 66] :='ipj'; mn[ 67] :='cip'; |
| 10771 | mn[ 68] :='lpa'; mn[ 69] :='???'; mn[ 70] :='???'; mn[ 71] :='dmp'; |
| 10772 | mn[ 72] :='swp'; mn[ 73] :='tjp'; mn[ 74] :='lip'; mn[ 75] :='ckv'; |
| 10773 | mn[ 76] :='dup'; mn[ 77] :='cke'; mn[ 78] :='cks'; mn[ 79] :='inv'; |
| 10774 | mn[ 80] :='ckl'; mn[ 81] :='cta'; mn[ 82] :='ivt'; mn[ 83] :='xor'; |
| 10775 | mn[ 84] :='bge'; mn[ 85] :='ede'; mn[ 86] :='mse'; mn[ 87] :='cjp'; |
| 10776 | mn[ 88] :='lnp'; mn[ 89] :='cal'; mn[ 90] :='ret'; mn[ 91] :='cuv'; |
| 10777 | mn[ 92] :='suv'; mn[ 93] :='vbs'; mn[ 94] :='vbe'; mn[ 95] :='cvb'; |
| 10778 | mn[ 96] :='vis'; mn[ 97] :='vip'; mn[ 98] :='lcp'; mn[ 99] :='cps'; |
| 10779 | mn[100] :='cpc'; mn[101] :='aps'; mn[102] :='apc'; mn[103] :='cxs'; |
| 10780 | mn[104] :='cxc'; mn[105] :='lft'; mn[106] :='max'; mn[107] :='vdp'; |
| 10781 | mn[108] :='spc'; mn[109] :='ccs'; mn[110] :='scp'; mn[111] :='ldp'; |
| 10782 | mn[112] :='vin'; mn[113] :='vdd'; mn[114] :='lto'; mn[115] :='ctb'; |
| 10783 | mn[116] :='cpp'; mn[117] :='cpr'; mn[118] :='lsa'; mn[119] :='wbs'; |
| 10784 | mn[120] :='wbe'; mn[121] :='sfr'; mn[122] :='cuf'; mn[123] :='cif'; |
| 10785 | mn[124] :='mpc'; mn[125] :='cvf'; mn[126] :='lsp'; mn[127] :='cpl'; |
| 10786 | mn[128] :='sfs'; mn[129] :='sev'; mn[130] :='mdc'; |
| 10787 | |
| 10788 | end (*instrmnemonics*) ; |
| 10789 | |
| 10790 | procedure chartypes; |
| 10791 | var i : integer; |
| 10792 | begin |
| 10793 | for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal; |
| 10794 | chartp['a'] := letter ; |
| 10795 | chartp['b'] := letter ; chartp['c'] := letter ; |
| 10796 | chartp['d'] := letter ; chartp['e'] := letter ; |
| 10797 | chartp['f'] := letter ; chartp['g'] := letter ; |
| 10798 | chartp['h'] := letter ; chartp['i'] := letter ; |
| 10799 | chartp['j'] := letter ; chartp['k'] := letter ; |
| 10800 | chartp['l'] := letter ; chartp['m'] := letter ; |
| 10801 | chartp['n'] := letter ; chartp['o'] := letter ; |
| 10802 | chartp['p'] := letter ; chartp['q'] := letter ; |
| 10803 | chartp['r'] := letter ; chartp['s'] := letter ; |
| 10804 | chartp['t'] := letter ; chartp['u'] := letter ; |
| 10805 | chartp['v'] := letter ; chartp['w'] := letter ; |
| 10806 | chartp['x'] := letter ; chartp['y'] := letter ; |
| 10807 | chartp['z'] := letter ; |
| 10808 | chartp['A'] := letter ; |
| 10809 | chartp['B'] := letter ; chartp['C'] := letter ; |
| 10810 | chartp['D'] := letter ; chartp['E'] := letter ; |
| 10811 | chartp['F'] := letter ; chartp['G'] := letter ; |
| 10812 | chartp['H'] := letter ; chartp['I'] := letter ; |
| 10813 | chartp['J'] := letter ; chartp['K'] := letter ; |
| 10814 | chartp['L'] := letter ; chartp['M'] := letter ; |
| 10815 | chartp['N'] := letter ; chartp['O'] := letter ; |
| 10816 | chartp['P'] := letter ; chartp['Q'] := letter ; |
| 10817 | chartp['R'] := letter ; chartp['S'] := letter ; |
| 10818 | chartp['T'] := letter ; chartp['U'] := letter ; |
| 10819 | chartp['V'] := letter ; chartp['W'] := letter ; |
| 10820 | chartp['X'] := letter ; chartp['Y'] := letter ; |
| 10821 | chartp['Z'] := letter ; |
| 10822 | chartp['_'] := letter ; |
| 10823 | chartp['0'] := number ; |
| 10824 | chartp['1'] := number ; chartp['2'] := number ; |
| 10825 | chartp['3'] := number ; chartp['4'] := number ; |
| 10826 | chartp['5'] := number ; chartp['6'] := number ; |
| 10827 | chartp['7'] := number ; chartp['8'] := number ; |
| 10828 | chartp['9'] := number ; chartp['+'] := special ; |
| 10829 | chartp['-'] := special ; chartp['*'] := special ; |
| 10830 | chartp['/'] := special ; chartp['('] := chlparen; |
| 10831 | chartp[')'] := special ; chartp['$'] := special ; |
| 10832 | chartp['='] := special ; chartp[' '] := chspace ; |
| 10833 | chartp[','] := special ; chartp['.'] := chperiod; |
| 10834 | chartp['''']:= chstrquo; chartp['['] := special ; |
| 10835 | chartp[']'] := special ; chartp[':'] := chcolon ; |
| 10836 | chartp['^'] := special ; chartp[';'] := special ; |
| 10837 | chartp['<'] := chlt ; chartp['>'] := chgt ; |
| 10838 | chartp['{'] := chlcmt ; chartp['}'] := special ; |
| 10839 | chartp['@'] := special ; chartp['!'] := chrem ; |
| 10840 | chartp['$'] := chhex ; chartp['&'] := choct ; |
| 10841 | chartp['%'] := chbin ; chartp['#'] := special ; |
| 10842 | |
| 10843 | for i := ordminchar to ordmaxchar do ordint[chr(i)] := 0; |
| 10844 | ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2; |
| 10845 | ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5; |
| 10846 | ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8; |
| 10847 | ordint['9'] := 9; ordint['a'] := 10; ordint['b'] := 11; |
| 10848 | ordint['c'] := 12; ordint['d'] := 13; ordint['e'] := 14; |
| 10849 | ordint['f'] := 15; ordint['A'] := 10; ordint['B'] := 11; |
| 10850 | ordint['C'] := 12; ordint['D'] := 13; ordint['E'] := 14; |
| 10851 | ordint['F'] := 15; |
| 10852 | end; |
| 10853 | |
| 10854 | procedure initdx; |
| 10855 | begin |
| 10856 | { [sam] if your sizes are not even multiples of |
| 10857 | stackelsize, you are going to need to compensate this. |
| 10858 | entries marked with * go to secondary table } |
| 10859 | cdx[ 0] := 0; cdx[ 1] := 0; |
| 10860 | cdx[ 2] := +intsize; cdx[ 3] := +realsize; |
| 10861 | cdx[ 4] := +intsize; cdx[ 5] := +setsize; |
| 10862 | cdx[ 6] := +intsize; cdx[ 7] := +realsize; |
| 10863 | cdx[ 8] := 4{*}; cdx[ 9] := +intsize-realsize; |
| 10864 | cdx[ 10] := -realsize+intsize; cdx[ 11] := +setsize; |
| 10865 | cdx[ 12] := +setsize; cdx[ 13] := +intsize; |
| 10866 | cdx[ 14] := +intsize; cdx[ 15] := +intsize; |
| 10867 | cdx[ 16] := +realsize; cdx[ 17] := 0; |
| 10868 | cdx[ 18] := 0; cdx[ 19] := 2{*}; |
| 10869 | cdx[ 20] := 0; cdx[ 21] := +intsize; |
| 10870 | cdx[ 22] := +realsize; cdx[ 23] := +intsize-setsize; |
| 10871 | cdx[ 24] := 0; cdx[ 25] := 0; |
| 10872 | cdx[ 26] := 1{*}; cdx[ 27] := +realsize-intsize; |
| 10873 | cdx[ 28] := +setsize; cdx[ 29] := 0; |
| 10874 | cdx[ 30] := 0; cdx[ 31] := 2{*}; |
| 10875 | cdx[ 32] := 0; cdx[ 33] := +intsize; |
| 10876 | cdx[ 34] := 2{*}; cdx[ 35] := 3{*}; |
| 10877 | cdx[ 36] := +intsize; cdx[ 37] := -adrsize; |
| 10878 | cdx[ 38] := -adrsize; cdx[ 39] := 4{*}; |
| 10879 | cdx[ 40] := +adrsize*2; cdx[ 41] := 0; |
| 10880 | cdx[ 42] := 2{*}; cdx[ 43] := 5{*}; |
| 10881 | cdx[ 44] := +intsize; cdx[ 45] := 2{*}; |
| 10882 | cdx[ 46] := 0; cdx[ 47] := 6{*}; |
| 10883 | cdx[ 48] := 6{*}; cdx[ 49] := 6{*}; |
| 10884 | cdx[ 50] := -adrsize; cdx[ 51] := 4{*}; |
| 10885 | cdx[ 52] := 6{*}; cdx[ 53] := 6{*}; |
| 10886 | cdx[ 54] := 4{*}; cdx[ 55] := 6{*}; |
| 10887 | cdx[ 56] := 5{*}; cdx[ 57] := 0; |
| 10888 | cdx[ 58] := 2{*}; cdx[ 59] := 0; |
| 10889 | cdx[ 60] := 0; cdx[ 61] := +realsize-intsize; |
| 10890 | cdx[ 62] := +adrsize*3; cdx[ 63] := +adrsize*3; |
| 10891 | cdx[ 64] := +intsize*2-setsize; cdx[ 65] := 0; |
| 10892 | cdx[ 66] := 0; cdx[ 67] := +ptrsize; |
| 10893 | cdx[ 68] := -adrsize*2; cdx[ 69] := 0; |
| 10894 | cdx[ 70] := 0; cdx[ 71] := +ptrsize; |
| 10895 | cdx[ 72] := 0; cdx[ 73] := +intsize; |
| 10896 | cdx[ 74] := -adrsize*2; cdx[ 75] := 2{*}; |
| 10897 | cdx[ 76] := 4{*}; cdx[ 77] := +intsize*2; |
| 10898 | cdx[ 78] := -intsize; cdx[ 79] := +adrsize; |
| 10899 | cdx[ 80] := 2{*}; cdx[ 81] := 0; |
| 10900 | cdx[ 82] := 0; cdx[ 83] := +intsize; |
| 10901 | cdx[ 84] := -(adrsize*3+intsize); cdx[ 85] := adrsize*3+intsize; |
| 10902 | cdx[ 86] := 0; cdx[ 87] := 0; |
| 10903 | cdx[ 88] := 0; cdx[ 89] := 0; |
| 10904 | cdx[ 90] := 0; cdx[ 91] := 0; |
| 10905 | cdx[ 92] := 0; cdx[ 93] := +intsize; |
| 10906 | cdx[ 94] := 0; cdx[ 95] := 0; |
| 10907 | cdx[ 96] := 0; cdx[ 97] := 0; |
| 10908 | cdx[ 98] := -adrsize; cdx[ 99] := 0; |
| 10909 | cdx[100] := 0; cdx[101] := +ptrsize*4; |
| 10910 | cdx[102] := +ptrsize*4; cdx[103] := +intsize+ptrsize; |
| 10911 | cdx[104] := +intsize; cdx[105] := -adrsize; |
| 10912 | cdx[106] := +ptrsize*2; cdx[107] := +ptrsize; |
| 10913 | cdx[108] := 0; cdx[109] := 0; |
| 10914 | cdx[110] := +ptrsize*3; cdx[111] := -adrsize; |
| 10915 | cdx[112] := 0; cdx[113] := +ptrsize; |
| 10916 | cdx[114] := -adrsize; cdx[115] := 0; |
| 10917 | cdx[116] := 0; cdx[117] := 0; |
| 10918 | cdx[118] := -adrsize; cdx[119] := 0; |
| 10919 | cdx[120] := 0; cdx[121] := 0; |
| 10920 | cdx[122] := 0; cdx[123] := +ptrsize; |
| 10921 | cdx[124] := 0; cdx[125] := 0; |
| 10922 | cdx[126] := -adrsize; cdx[127] := -intsize; |
| 10923 | cdx[128] := 0; cdx[129] := 0; |
| 10924 | cdx[130] := -adrsize; |
| 10925 | |
| 10926 | { secondary table order is i, r, b, c, a, s, m } |
| 10927 | cdxs[1][1] := +(adrsize+intsize); { stoi } |
| 10928 | cdxs[1][2] := +(adrsize+realsize); { stor } |
| 10929 | cdxs[1][3] := +(adrsize+intsize); { stob } |
| 10930 | cdxs[1][4] := +(adrsize+intsize); { stoc } |
| 10931 | cdxs[1][5] := +(adrsize+adrsize); { stoa } |
| 10932 | cdxs[1][6] := +(adrsize+setsize); { stos } |
| 10933 | cdxs[1][7] := 0; |
| 10934 | cdxs[1][8] := 0; |
| 10935 | |
| 10936 | cdxs[2][1] := 0; { deci/inci/ordi/chki/reti/noti } |
| 10937 | cdxs[2][2] := 0; { chkr/retr } |
| 10938 | cdxs[2][3] := 0; { decb/incb/ordb/chkb/retb/notb } |
| 10939 | cdxs[2][4] := 0; { decc/incc/ordc/chkc/retc } |
| 10940 | cdxs[2][5] := 0; { chka/reta/ckl } |
| 10941 | cdxs[2][6] := 0; { chks } |
| 10942 | cdxs[2][7] := 0; |
| 10943 | cdxs[2][8] := 0; |
| 10944 | |
| 10945 | cdxs[3][1] := +adrsize-intsize; { indi } |
| 10946 | cdxs[3][2] := +adrsize-realsize; { indr } |
| 10947 | cdxs[3][3] := +adrsize-intsize; { indb } |
| 10948 | cdxs[3][4] := +adrsize-intsize; { indc } |
| 10949 | cdxs[3][5] := +adrsize-adrsize; { inda } |
| 10950 | cdxs[3][6] := +adrsize-setsize; { inds } |
| 10951 | cdxs[3][7] := 0; |
| 10952 | cdxs[3][8] := 0; |
| 10953 | |
| 10954 | cdxs[4][1] := -intsize; { ldoi/ldc/lodi/dupi/ltc } |
| 10955 | cdxs[4][2] := -realsize; { ldor/ldc/lodr/dupr/ltc } |
| 10956 | cdxs[4][3] := -intsize; { ldob/ldc/lodb/dupb/ltc } |
| 10957 | cdxs[4][4] := -intsize; { ldoc/ldc/lodc/dupc/ltc } |
| 10958 | cdxs[4][5] := -adrsize; { ldoa/ldc/loda/dupa/ltc } |
| 10959 | cdxs[4][6] := -setsize; { ldos/ldc/lods/dups/ltc } |
| 10960 | cdxs[4][7] := 0; |
| 10961 | cdxs[4][8] := 0; |
| 10962 | |
| 10963 | cdxs[5][1] := +intsize; { sroi/stri } |
| 10964 | cdxs[5][2] := +realsize; { sror/strr } |
| 10965 | cdxs[5][3] := +intsize; { srob/strb } |
| 10966 | cdxs[5][4] := +intsize; { sroc/strc } |
| 10967 | cdxs[5][5] := +adrsize; { sroa/stra } |
| 10968 | cdxs[5][6] := +setsize; { sros/strs } |
| 10969 | cdxs[5][7] := 0; |
| 10970 | cdxs[5][8] := 0; |
| 10971 | |
| 10972 | { note that all of the comparisions share the same table } |
| 10973 | cdxs[6][1] := +(intsize+intsize)-intsize; { equi/neqi/geqi/grti/leqi/lesi } |
| 10974 | cdxs[6][2] := +(realsize+realsize)-intsize; { equr/neqr/geqr/grtr/leqr/lesr } |
| 10975 | cdxs[6][3] := +(intsize+intsize)-intsize; { equb/neqb/geqb/grtb/leqb/lesb } |
| 10976 | cdxs[6][4] := +(intsize+intsize)-intsize; { equc/neqc/geqc/grtc/leqc/lesc } |
| 10977 | cdxs[6][5] := +(adrsize+intsize)-adrsize; { equa/neqa/geqa/grta/leqa/lesa } |
| 10978 | cdxs[6][6] := +(setsize+setsize)-intsize; { equs/neqs/geqs/grts/leqs/less } |
| 10979 | cdxs[6][7] := +(adrsize+adrsize)-intsize; { equm/neqm/geqm/grtm/leqm/lesm } |
| 10980 | cdxs[6][8] := +(adrsize*2+adrsize*2)-intsize; { equv/neqv/geqv/grtv/leqv/lesv } |
| 10981 | |
| 10982 | pdx[ 1] := +adrsize; pdx[ 2] := +adrsize; |
| 10983 | pdx[ 3] := +adrsize; pdx[ 4] := +adrsize; |
| 10984 | pdx[ 5] := +adrsize; pdx[ 6] := +adrsize*2; |
| 10985 | pdx[ 7] := 0; pdx[ 8] := +(realsize+intsize); |
| 10986 | pdx[ 9] := +intsize*2; pdx[10] := +(intsize+adrsize+intsize); |
| 10987 | pdx[11] := 0; pdx[12] := +ptrsize*2; |
| 10988 | pdx[13] := 0; pdx[14] := +adrsize-intsize; |
| 10989 | pdx[15] := 0; pdx[16] := 0; |
| 10990 | pdx[17] := 0; pdx[18] := 0; |
| 10991 | pdx[19] := 0; pdx[20] := 0; |
| 10992 | pdx[21] := 0; pdx[22] := 0; |
| 10993 | pdx[23] := 0; pdx[24] := +adrsize; |
| 10994 | pdx[25] := +adrsize; pdx[26] := +adrsize; |
| 10995 | pdx[27] := +intsize*2; pdx[28] := +(realsize+intsize*2); |
| 10996 | pdx[29] := +adrsize*2; pdx[30] := +(adrsize+intsize); |
| 10997 | pdx[31] := +intsize; pdx[32] := +realsize; |
| 10998 | pdx[33] := +intsize; pdx[34] := +intsize; |
| 10999 | pdx[35] := +(intsize+adrsize); pdx[36] := +adrsize; |
| 11000 | pdx[37] := +adrsize; pdx[38] := +(intsize+adrsize); |
| 11001 | pdx[39] := +(intsize+adrsize); pdx[40] := +(adrsize+intsize*2); |
| 11002 | pdx[41] := +(adrsize+intsize*2); pdx[42] := +(adrsize+intsize*2); |
| 11003 | pdx[43] := +(adrsize+intsize*2); pdx[44] := +adrsize-intsize; |
| 11004 | pdx[45] := +adrsize-intsize; pdx[46] := 0; |
| 11005 | pdx[47] := +intsize; pdx[48] := +intsize; |
| 11006 | pdx[49] := +adrsize*2+intsize; pdx[50] := +adrsize; |
| 11007 | pdx[51] := +adrsize+intsize; pdx[52] := +adrsize; |
| 11008 | pdx[53] := +adrsize; pdx[54] := +adrsize+intsize; |
| 11009 | pdx[55] := +adrsize*2+intsize*2; pdx[56] := +adrsize-intsize; |
| 11010 | pdx[57] := +adrsize-intsize; pdx[58] := +adrsize+intsize-intsize; |
| 11011 | pdx[59] := +adrsize*2+intsize; pdx[60] := +adrsize; |
| 11012 | pdx[61] := +adrsize; pdx[62] := 0; |
| 11013 | pdx[63] := +intsize; pdx[64] := +adrsize+intsize+intsize; |
| 11014 | pdx[65] := +adrsize*2; pdx[66] := +adrsize*2; |
| 11015 | pdx[67] := +adrsize*2; pdx[68] := +(adrsize+intsize); |
| 11016 | pdx[69] := +adrsize*2; pdx[70] := +adrsize*2; |
| 11017 | pdx[71] := +adrsize*2; pdx[72] := +adrsize*2; |
| 11018 | pdx[73] := +adrsize+intsize; pdx[74] := +(adrsize+intsize*3); |
| 11019 | pdx[75] := +adrsize+intsize; pdx[76] := +adrsize+intsize; |
| 11020 | pdx[77] := +(adrsize+intsize*3); pdx[78] := +adrsize+intsize; |
| 11021 | pdx[79] := +adrsize+intsize*2; pdx[80] := +adrsize+intsize; |
| 11022 | pdx[81] := +adrsize*2+intsize; pdx[82] := +adrsize*2+intsize; |
| 11023 | pdx[83] := +adrsize*2+intsize; pdx[84] := +adrsize*2+intsize; |
| 11024 | pdx[85] := +adrsize; pdx[86] := +adrsize+intsize; |
| 11025 | pdx[87] := +adrsize; pdx[88] := +adrsize+intsize; |
| 11026 | pdx[89] := +(adrsize+intsize*2); pdx[90] := +(adrsize+intsize*3); |
| 11027 | pdx[91] := +adrsize; pdx[92] := +adrsize; |
| 11028 | pdx[93] := +adrsize; pdx[94] := +adrsize+intsize; |
| 11029 | pdx[95] := +adrsize+intsize; pdx[96] := +adrsize+intsize; |
| 11030 | pdx[97] := +(adrsize+intsize*2); pdx[98] := +(adrsize+intsize*2); |
| 11031 | pdx[99] := +(adrsize+intsize*2); pdx[100] := +(adrsize+intsize*3); |
| 11032 | pdx[101] := +(adrsize+intsize*3); pdx[102] := +(adrsize+intsize*3); |
| 11033 | pdx[103] := +adrsize; pdx[104] := +adrsize; |
| 11034 | pdx[105] := +adrsize; pdx[106] := +adrsize+intsize; |
| 11035 | pdx[107] := +adrsize+intsize; pdx[108] := +adrsize+intsize; |
| 11036 | pdx[109] := +(adrsize+intsize*2); pdx[110] := +(adrsize+intsize*2); |
| 11037 | pdx[111] := +(adrsize+intsize*2); pdx[112] := +(adrsize+intsize*3); |
| 11038 | pdx[113] := +(adrsize+intsize*3); pdx[114] := +(adrsize+intsize*3); |
| 11039 | pdx[115] := +intsize; |
| 11040 | end; |
| 11041 | |
| 11042 | begin (*inittables*) |
| 11043 | reswords; symbols; rators; |
| 11044 | instrmnemonics; procmnemonics; |
| 11045 | chartypes; initdx; |
| 11046 | end (*inittables*) ; |
| 11047 | |
| 11048 | begin |
| 11049 | |
| 11050 | { Suppress unreferenced errors. These are all MPB (machine parameter |
| 11051 | block) equations that need to stay the same between front end and backend. } |
| 11052 | if heapal = 0 then; |
| 11053 | if inthex = 0 then; |
| 11054 | if market = 0 then; |
| 11055 | if markep = 0 then; |
| 11056 | if marksb = 0 then; |
| 11057 | if maxsize = 0 then; |
| 11058 | |
| 11059 | { supress errors on breakflag, only used in extention packages } |
| 11060 | breakflag := false; |
| 11061 | if breakflag = true then; |
| 11062 | |
| 11063 | prdopn := false; { set input and output files not open } |
| 11064 | prropn := false; |
| 11065 | |
| 11066 | (*initialize*) |
| 11067 | (************) |
| 11068 | initscalars; initsets; inittables; |
| 11069 | |
| 11070 | write('P6 Pascal compiler vs. ', majorver:1, '.', minorver:1); |
| 11071 | if experiment then write('.x'); |
| 11072 | writeln; |
| 11073 | if iso7185 then begin |
| 11074 | writeln('Pascal-P6 complies with the requirements of level 0 of ISO/IEC 7185.'); |
| 11075 | writeln |
| 11076 | end else begin |
| 11077 | writeln('Pascal-P6 complies with the requirements of Pascaline version 0.4'); |
| 11078 | writeln('and the following annexes: A,B,C,E.'); |
| 11079 | writeln |
| 11080 | end; |
| 11081 | |
| 11082 | (*enter standard names and standard types:*) |
| 11083 | (******************************************) |
| 11084 | level := 0; top := 0; ptop := 0; |
| 11085 | with display[0] do |
| 11086 | begin inidsp(display[0]); define := true; occur := blck; bname := nil end; |
| 11087 | enterstdtypes; stdnames; entstdnames; enterundecl; |
| 11088 | top := 1; level := 1; |
| 11089 | with display[1] do |
| 11090 | begin inidsp(display[1]); define := true; occur := blck; bname := nil end; |
| 11091 | |
| 11092 | for ii := 1 to maxlin do incbuf[ii] := ' '; { clear include line } |
| 11093 | errfopn := false; errfval := false; |
| 11094 | |
| 11095 | { parse command line } |
| 11096 | parse.openpar(cmdhan); |
| 11097 | parse.opencommand(cmdhan, 2000); |
| 11098 | paropt; { parse command line options } |
| 11099 | { parse source filename } |
| 11100 | parse.skpspc(cmdhan); |
| 11101 | if parse.endlin(cmdhan) then begin |
| 11102 | writeln('*** Error: input filename not found'); |
| 11103 | goto 99 |
| 11104 | end; |
| 11105 | if parse.chkchr(cmdhan) = '"' then |
| 11106 | parse.parstr(cmdhan, srcfil, prdval) |
| 11107 | else |
| 11108 | parse.parfil(cmdhan, srcfil, false, prdval); |
| 11109 | prdval := not prdval; { parfil returns err=true on failure } |
| 11110 | if not prdval then begin |
| 11111 | writeln('*** Error: input filename not found'); |
| 11112 | goto 99 |
| 11113 | end; |
| 11114 | services.brknam(srcfil, p, n, e); { form full filename } |
| 11115 | services.maknam(srcfil, p, n, 'pas'); |
| 11116 | services.fulnam(srcfil); |
| 11117 | assign(prd, srcfil); |
| 11118 | paropt; { parse command line options } |
| 11119 | { parse destination filename } |
| 11120 | parse.skpspc(cmdhan); |
| 11121 | if not parse.endlin(cmdhan) then begin |
| 11122 | if parse.chkchr(cmdhan) = '"' then |
| 11123 | parse.parstr(cmdhan, desfil, prrval) |
| 11124 | else |
| 11125 | parse.parfil(cmdhan, desfil, false, prrval); |
| 11126 | prrval := not prrval { parfil returns err=true on failure } |
| 11127 | end else begin |
| 11128 | { no output file given, derive from source } |
| 11129 | services.brknam(srcfil, p, n, e); |
| 11130 | services.maknam(desfil, p, n, 'p6'); |
| 11131 | prrval := true |
| 11132 | end; |
| 11133 | if prrval then begin |
| 11134 | services.brknam(desfil, p, n, e); |
| 11135 | services.maknam(desfil, p, n, 'p6'); |
| 11136 | assign(prr, desfil) |
| 11137 | end; |
| 11138 | { if no output file exists, turn off output listing } |
| 11139 | if not prrval then prcode := false; |
| 11140 | paropt; { parse command line options } |
| 11141 | plcopt; { place options in flags } |
| 11142 | |
| 11143 | { open error file if specified } |
| 11144 | if errfval then begin |
| 11145 | services.brknam(errfil, p, n, e); |
| 11146 | services.maknam(errfil, p, n, 'err'); |
| 11147 | assign(errf, errfil); |
| 11148 | rewrite(errf); |
| 11149 | errfopn := true |
| 11150 | end; |
| 11151 | |
| 11152 | (*compile:*) |
| 11153 | (**********) |
| 11154 | reset(prd); prdopn := true; |
| 11155 | if prrval then begin rewrite(prr); prropn := true end; |
| 11156 | |
| 11157 | { write generator comment } |
| 11158 | if prcode then begin |
| 11159 | writeln(prr, '!'); |
| 11160 | writeln(prr, '! Pascal intermediate file Generated by P6 Pascal compiler vs. ', |
| 11161 | majorver:1, '.', minorver:1); |
| 11162 | writeln(prr, '!'); |
| 11163 | writeln(prr, 'p ', srcfil:*); |
| 11164 | |
| 11165 | { write initial option values } |
| 11166 | write(prr, 'o '); |
| 11167 | for oi := 1 to maxopt do |
| 11168 | { exclude pint options and unused } |
| 11169 | if not (oi in [7,8,14,15,16,13,17,19,23,1,6,5,18,11,26,27,28]) or |
| 11170 | options[oi] then begin |
| 11171 | for oni := 1 to optlen do |
| 11172 | if optsl[oi, oni] <> ' ' then write(prr, optsl[oi, oni]); |
| 11173 | if option[oi] then write(prr, '+') else write(prr, '-'); |
| 11174 | write(prr, ' ') |
| 11175 | end; |
| 11176 | if prcode then writeln(prr) |
| 11177 | end; |
| 11178 | |
| 11179 | nvalid := false; { set no lookahead } |
| 11180 | { init for lookahead } |
| 11181 | sy := ident; op := mul; lgth := 0; kk := 1; |
| 11182 | { open input file } |
| 11183 | new(fp); with fp^ do begin |
| 11184 | next := incstk; incstk := fp; priv := false; linecount := 0; lineout := 0; |
| 11185 | si := 1; sl := 0; lo := false; fio := false |
| 11186 | end; |
| 11187 | readline; |
| 11188 | insymbol; |
| 11189 | modulep(blockbegsys+statbegsys-[casesy]); |
| 11190 | { compile the program } |
| 11191 | outline; |
| 11192 | { release file tracking entries } |
| 11193 | putinp(incstk); putinp(inclst); |
| 11194 | |
| 11195 | { dispose of levels 0 and 1 } |
| 11196 | putdsp(display[1]); |
| 11197 | putdsp(display[0]); |
| 11198 | |
| 11199 | { dispose of the pile } |
| 11200 | putpile; |
| 11201 | |
| 11202 | { remove undeclared ids } |
| 11203 | exitundecl; |
| 11204 | |
| 11205 | if errfval then writeln(errf, 'Errors in program: ', toterr:1) |
| 11206 | else writeln('Errors in program: ', toterr:1); |
| 11207 | { output error report as required } |
| 11208 | f := true; |
| 11209 | for i := 1 to maxftl do if errtbl[i] > 0 then begin |
| 11210 | if f then begin |
| 11211 | if errfval then begin |
| 11212 | writeln(errf); |
| 11213 | writeln(errf, 'Error numbers in listing:'); |
| 11214 | writeln(errf, '-------------------------') |
| 11215 | end else begin |
| 11216 | writeln; |
| 11217 | writeln('Error numbers in listing:'); |
| 11218 | writeln('-------------------------') |
| 11219 | end; |
| 11220 | f := false |
| 11221 | end; |
| 11222 | if errfval then write(errf, i:3, ' ', errtbl[i]:3, ' ') |
| 11223 | else write(i:3, ' ', errtbl[i]:3, ' '); |
| 11224 | epl := nil; |
| 11225 | while errltb[i] <> nil do begin ep := errltb[i]; errltb[i] := ep^.next; |
| 11226 | ep^.next := epl; epl := ep |
| 11227 | end; |
| 11228 | ep := epl; |
| 11229 | while ep <> nil do begin |
| 11230 | if errfval then write(errf, ep^.errlin:1) |
| 11231 | else write(ep^.errlin:1); |
| 11232 | ep := ep^.next; |
| 11233 | if ep <> nil then begin |
| 11234 | if errfval then write(errf, ',') |
| 11235 | else write(',') |
| 11236 | end |
| 11237 | end; |
| 11238 | if errfval then begin |
| 11239 | write(errf, ' '); errmsg(errf, i); writeln(errf) |
| 11240 | end else begin |
| 11241 | write(' '); errmsg(output, i); writeln |
| 11242 | end |
| 11243 | end; |
| 11244 | if not f then begin |
| 11245 | if errfval then writeln(errf) |
| 11246 | else writeln |
| 11247 | end; |
| 11248 | |
| 11249 | if doprtryc then begin { print recyling tracking counts } |
| 11250 | |
| 11251 | writeln; |
| 11252 | writeln('Recycling tracking counts:'); |
| 11253 | writeln; |
| 11254 | writeln('string quants: ', strcnt:1); |
| 11255 | writeln('constants: ', cspcnt:1); |
| 11256 | writeln('structures: ', stpcnt:1); |
| 11257 | writeln('identifiers: ', ctpcnt:1); |
| 11258 | writeln('label counts: ', lbpcnt:1); |
| 11259 | writeln('file tracking counts: ', filcnt:1); |
| 11260 | writeln('case entry tracking counts: ', cipcnt:1); |
| 11261 | writeln('tag entry tracking counts: ', ttpcnt:1); |
| 11262 | writeln('with entry tracking counts: ', wtpcnt:1); |
| 11263 | writeln; |
| 11264 | |
| 11265 | end; |
| 11266 | |
| 11267 | if doprtlab then prtlabels; { dump labels} |
| 11268 | if dodmpdsp then prtdsp; { dump display } |
| 11269 | |
| 11270 | { perform errors for recycling balance } |
| 11271 | |
| 11272 | if strcnt <> 0 then |
| 11273 | writeln('*** Error: Compiler internal error: string recycle balance: ', |
| 11274 | strcnt:1); |
| 11275 | if cspcnt <> 0 then |
| 11276 | writeln('*** Error: Compiler internal error: constant recycle balance: ', |
| 11277 | cspcnt:1); |
| 11278 | if stpcnt <> 0 then |
| 11279 | writeln('*** Error: Compiler internal error: structure recycle balance: ', |
| 11280 | stpcnt:1); |
| 11281 | if ctpcnt <> 0 then |
| 11282 | writeln('*** Error: Compiler internal error: identifier recycle balance: ', |
| 11283 | ctpcnt:1); |
| 11284 | if lbpcnt <> 0 then |
| 11285 | writeln('*** Error: Compiler internal error: label recycle balance: ', |
| 11286 | lbpcnt:1); |
| 11287 | if filcnt <> 0 then |
| 11288 | writeln('*** Error: Compiler internal error: file recycle balance: ', |
| 11289 | filcnt:1); |
| 11290 | if cipcnt <> 0 then |
| 11291 | writeln('*** Error: Compiler internal error: case recycle balance: ', |
| 11292 | cipcnt:1); |
| 11293 | if ttpcnt <> 0 then |
| 11294 | writeln('*** Error: Compiler internal error: tag recycle balance: ', |
| 11295 | cipcnt:1); |
| 11296 | if wtpcnt <> 0 then |
| 11297 | writeln('*** Error: Compiler internal error: with recycle balance: ', |
| 11298 | wtpcnt:1); |
| 11299 | |
| 11300 | 99: |
| 11301 | if prdopn then close(prd); |
| 11302 | if prropn then begin |
| 11303 | close(prr); |
| 11304 | services.brknam(desfil, p, n, e); { place extension } |
| 11305 | services.maknam(desfil, p, n, 'p6'); |
| 11306 | if toterr > 0 then delete(desfil) |
| 11307 | end; |
| 11308 | if errfopn then close(errf); |
| 11309 | |
| 11310 | { Return number of errors as return code. This does not match any standard, |
| 11311 | because there is no standard, so it might as well be useful. } |
| 11312 | seterr(toterr); |
| 11313 | |
| 11314 | end. |
================================================================================
PASCAL-P6 COMPILER (PCOM) THEORY OF OPERATIONS
================================================================================
Overview
--------
The Pascal-P6 compiler (pcom.pas) is a single-pass, recursive descent compiler
that translates Pascal source code into P-code (pseudo-code), an intermediate
stack-based instruction set. The compiler is itself written in Pascal, making
it a self-compiling (bootstrappable) system.
The compiler descends from the original Pascal-P compilers developed at ETH
Zurich in the 1970s by Wirth, Ammann, Nori, and Jacobi. P6 extends the original
ISO 7185 Pascal with the Pascaline extensions including modules, exception
handling, dynamic arrays, operator overloading, and object-oriented features.
================================================================================
COMPILER PHASES
================================================================================
The compiler operates in a single pass through the source code, performing:
1. Lexical Analysis (Scanner)
2. Syntax Analysis (Parser)
3. Semantic Analysis (Type Checking)
4. Code Generation (P-code Output)
All phases are interleaved - as the parser recognizes constructs, it
simultaneously performs type checking and emits P-code.
================================================================================
1. LEXICAL ANALYSIS
================================================================================
The lexical analyzer is implemented in the `insymbol` procedure (line ~1777).
Key Components:
---------------
- Input buffering via `incstk` (include file stack) with pushback support
- Character classification via `chartp` array mapping chars to token classes
- Reserved word recognition using the `rw` array and binary search
- Support for multiple number bases (decimal, hex with $, octal with &, binary)
- String literal handling with escape sequences (\n, \t, etc.)
- Comment handling (both { } and (* *) styles)
- Compiler directive processing ($option)
Scanner Output:
---------------
The scanner sets global variables for each token:
- `sy`: Symbol type (symbol enumeration)
- `op`: Operator type (for operator symbols)
- `id`: Identifier string (for identifiers)
- `val`: Value (for numeric/string constants)
- `lgth`: String length (for string constants)
Lookahead:
----------
The scanner maintains one-token lookahead via:
- `lsy`, `lop`, `lval`, etc. - previous token
- `nsy`, `nop`, `nval`, etc. - next token (when prefetched)
- `nvalid` - flag indicating valid lookahead exists
================================================================================
2. SYNTAX ANALYSIS
================================================================================
The parser uses recursive descent with the following major procedures:
Program Structure:
------------------
modulep() - Top-level: parses program/module header and structure
declare() - Declaration section (labels, consts, types, vars, procs)
body() - Statement part (begin..end block)
Declaration Parsing:
--------------------
labeldeclaration() - Label declarations
constdeclaration() - Constant definitions
typedeclaration() - Type definitions
vardeclaration() - Variable declarations
procdeclaration() - Procedure/function declarations
Type Parsing:
-------------
typ() - General type parsing
simpletype() - Scalar, subrange, pointer types
fieldlist() - Record field lists including variants
Statement Parsing:
------------------
statement() - Main statement dispatcher
assignment() - Assignment statements
compoundstatement() - begin..end blocks
ifstatement() - if..then..else
casestatement() - case..of
whilestatement() - while..do
repeatstatement() - repeat..until
forstatement() - for loops
withstatement() - with statements
gotostatement() - goto statements
trystatement() - try..except (Pascaline extension)
Expression Parsing:
-------------------
expression() - Comparison operators (=, <>, <, >, <=, >=, in)
simpleexpression() - Additive operators (+, -, or, xor)
term() - Multiplicative operators (*, /, div, mod, and)
factor() - Primaries (literals, identifiers, function calls)
selector() - Array indexing, field access, pointer dereference
Error Recovery:
---------------
Uses the "follow set" technique - each parsing procedure receives `fsys`,
a set of symbols that can legally follow the construct. On error, the parser
skips input until a symbol in fsys is found.
================================================================================
3. SEMANTIC ANALYSIS
================================================================================
Symbol Table:
-------------
The symbol table uses a display-based scope mechanism:
- `display` array: Stack of scope levels (0..displimit)
- Each display entry contains:
- `fname`: Root of binary search tree of identifiers
- `flabel`: List of labels in this scope
- `occur`: Type of scope (blck, crec, vrec, rec)
- `inilst`: Initializer list for the block
- `oprprc`: Operator function table for overloading
Key symbol table procedures:
- `enterid(fcp)`: Insert identifier into current scope's BST
- `searchid(fidcls, fcp)`: Search all scopes for identifier
- `searchsection(fcp, fcp1)`: Search single scope (for record fields)
Identifier Records (ctp):
-------------------------
Each identifier is represented by a variant record with fields:
- `name`: Identifier string (variable length via strvsp)
- `idtype`: Pointer to type structure
- `klass`: Identifier class (types, konst, vars, field, proc, func, alias)
- Class-specific fields for addresses, parameters, etc.
Type Structures (stp):
----------------------
Types are represented by variant records:
- `form`: Type form (scalar, subrange, pointer, power, arrays, records, etc.)
- `size`: Size in addressable units
- `packing`: Whether type is packed
- Form-specific fields for element types, bounds, fields, etc.
Type Checking:
--------------
- `comptypes(fsp1, fsp2)`: Check type compatibility
- `assigncompat(fsp1, fsp2)`: Check assignment compatibility
- Type coercion for integer-to-real conversion
- Bounds checking via `checkbnds()`
Expression Attributes:
----------------------
The `gattr` global (type `attr`) tracks the current expression:
- `typtr`: Type of expression
- `kind`: Category (cst=constant, varbl=variable, expr=computed)
- For variables: access mode (drct=direct, indrct=indirect, inxd=indexed)
- For constants: the constant value
================================================================================
4. CODE GENERATION
================================================================================
P-Code Output:
--------------
The compiler generates P-code, a stack-based intermediate language.
Code is written to the `prr` (program result) file as text.
Code Generation Procedures:
---------------------------
gen0(fop) - Zero-operand instruction
gen1(fop, fp2) - One-operand instruction
gen2(fop, fp1, fp2) - Two-operand instruction
gen0t(fop, fsp) - Typed zero-operand (adds type indicator)
gen1t(fop, fp2, fsp) - Typed one-operand
gen2t(fop, fp1, fp2, fsp) - Typed two-operand
genujpxjpcal() - Jump instructions
gencupcuf() - Procedure/function calls
genlabel() - Generate unique label number
Major P-Code Instructions:
--------------------------
Stack Operations:
ldc - Load constant
ldo - Load global variable (level 0)
lod - Load local/intermediate variable
lda - Load address
lao - Load address of global
sto - Store to address on stack
str - Store to local/intermediate variable
sro - Store to global variable
ind - Indirect load through pointer
mov - Block move
Arithmetic/Logic:
adi, adr - Add integer/real
sbi, sbr - Subtract
mpi, mpr - Multiply
dvi, dvr - Divide
ngi, ngr - Negate
abi, abr - Absolute value
sqi, sqr - Square
and, ior, xor, not - Boolean/bitwise operations
odd - Test odd
Comparison:
equ, neq - Equal, not equal
les, leq - Less than, less or equal
grt, geq - Greater than, greater or equal
Control Flow:
ujp - Unconditional jump
fjp - False jump (conditional)
tjp - True jump
xjp - Indexed jump (case statement)
cup - Call user procedure
cuf - Call user function
ret - Return from procedure/function
mst - Mark stack (prepare for call)
csp - Call standard procedure
Set Operations:
uni - Set union
int - Set intersection
dif - Set difference
inn - Set membership test
sgs - Singleton set
Type Conversion:
flt - Integer to real
trc - Truncate real to integer
rnd - Round real to integer
ord - Ordinal value
chr - Integer to character
Address Calculation:
ixa - Index array (compute element address)
inc, dec - Increment/decrement
Runtime Checks:
chk - Range check
ckv - Variant check
cta - Check tag assignment
Label Generation:
-----------------
Labels are generated as integers and printed in the output.
The `genlabel` procedure maintains a counter for unique labels.
================================================================================
DATA STRUCTURES
================================================================================
Constant Table:
---------------
Constants are stored in a linked list of `constant` records:
- `cclass`: Constant class (reel, pset, strg)
- Type-specific value storage
Case Table:
-----------
Case statement labels stored in `caseinfo` records:
- Linked list sorted by case value
- Used to generate jump table or comparison chain
Label Table:
------------
Labels stored in `labl` records per scope:
- `defined`: Whether label definition seen
- `labval`: Numeric label value
- `vlevel`: Procedure nesting level
- `slevel`: Statement nesting level (for goto checking)
With Statement Stack:
--------------------
`wthstk` tracks active with statements for:
- Scope management
- Proper cleanup on goto
================================================================================
MEMORY MODEL
================================================================================
Stack Frame Layout:
------------------
Each procedure activation has:
- Mark area (return address, static/dynamic links, etc.)
- Parameters (formal parameter space)
- Local variables
- Temporaries (for expression evaluation)
Address Calculation:
--------------------
- Global variables: Absolute addresses from level 0
- Local variables: Offsets from frame pointer
- Intermediate variables: Display-based access using static link chain
Variable Addressing:
--------------------
- `vlev`: Variable's lexical level
- `vaddr`: Offset within that level's frame
- Access mode determined by `vlev` vs. current `level`
================================================================================
PASCALINE EXTENSIONS
================================================================================
The P6 compiler extends ISO 7185 Pascal with:
Modules:
--------
- `module` keyword for separate compilation units
- `uses` and `joins` for module dependencies
- Qualified name access (module.identifier)
Dynamic Arrays:
---------------
- Container arrays with runtime bounds
- Complex pointer management (mpc, aps, apc instructions)
Exception Handling:
-------------------
- `try`..`except`..`on` statements
- `throw` for raising exceptions
- Exception type hierarchy
Operator Overloading:
---------------------
- `operator` keyword for defining operators on types
- Operator lookup table in display records
- `fndopr1`, `fndopr2` for operator resolution
Object-Oriented Features:
-------------------------
- `virtual` and `override` procedure attributes
- `inherited` for calling parent methods
- Virtual method tables (VMT)
Extended Parameter Modes:
-------------------------
- `view`: Read-only reference parameters
- `out`: Write-only parameters (uninitialized on entry)
================================================================================
COMPILATION FLOW
================================================================================
1. Initialization (initscalars, initsets, inittables)
- Set up reserved word tables
- Initialize standard type pointers
- Enter standard identifiers (entstdnames)
2. Open source file and begin scanning
3. Parse program/module header (modulep)
- Process program/module name
- Handle file list in header
- Process uses/joins clauses
4. Parse declarations (declare)
- Labels, constants, types, variables
- Nested procedures/functions (recursive)
5. Parse body (body)
- Compound statement (begin..end)
- Generate procedure entry/exit code
6. Finalize
- Check for undefined labels/forward declarations
- Output global size information
- Close output file
================================================================================
ERROR HANDLING
================================================================================
Error Reporting:
----------------
- `error(n)`: Report error number n at current position
- `errmsg(n)`: Print error message text
- Errors accumulated in `errinx` array for line-end display
Error Classes:
--------------
1-99: Syntax errors
100-199: Semantic errors (type mismatches, undeclared identifiers)
200-299: Extended feature errors
300-399: Pascaline-specific errors
500+: Fatal/internal errors
Error Recovery:
---------------
- Skip to synchronization point (symbol in fsys)
- Substitute dummy entries for missing declarations
- Continue parsing to find additional errors
================================================================================
FILE ORGANIZATION
================================================================================
The source file is organized as:
Lines 1-100: Header comments, licensing
Lines 101-111: Program header, label
Lines 112-187: Constants
Lines 188-433: Type definitions
Lines 434-630: Variable declarations
Lines 631-1180: Utility procedures (string handling, memory management)
Lines 1181-1234: Bitwise operations (bnot, bor, band, bxor)
Lines 1235-1776: Error handling, input processing, scanner support
Lines 1777-2297: Scanner (insymbol)
Lines 2298-2888: Symbol table management
Lines 2889-3606: Label and constant pool management
Lines 3607-4010: Code generation primitives
Lines 4011-4743: Type utilities, compatibility checking
Lines 4744-5097: Selector (array indexing, field access)
Lines 5098-6440: Call processing (procedure/function calls)
Lines 6442-6989: Expression parsing
Lines 6990-8608: Declaration parsing
Lines 8610-9403: Body and statement parsing
Lines 9404-9636: External headers, virtual method initialization
Lines 9637-9803: Include file and module handling
Lines 9804-9932: Main program/module parsing (modulep)
Lines 9933-10356: Standard identifier initialization
Lines 10357-10700: Main program initialization and entry point
================================================================================
DEBUGGING AIDS
================================================================================
Compiler Options:
-----------------
- debug: Enable runtime checks
- list: Generate source listing
- prcode: Generate P-code output
- chkvbk: Check variant block consistency
- chkref: Check for unreferenced identifiers
- prtables: Print symbol tables
Diagnostic Output:
------------------
- Symbol table dumps (via prtables option)
- Display stack dumps (dodmpdsp option)
- Lexer token dumps (dodmplex option)
================================================================================
REFERENCES
================================================================================
1. "Pascal Implementation" by Steven Pemberton and Martin Daniels
(Ellis Horwood, ISBN 0-13-653-0311) - The definitive guide to Pascal-P
2. "Algorithms + Data Structures = Programs" by Niklaus Wirth
- Original recursive descent technique
3. ISO 7185:1990 - Pascal standard
4. Pascaline Language Reference - P6 extensions documentation
================================================================================
LICENSING:
Copyright (c) 2022, Scott A. Franco All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in thedocumentation and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
The views and conclusions contained in the software and documentation are those of the authors and should not be interpreted as representing official policies, either expressed or implied, of the Pascal-P6 project.
Portable Pascal assembler/interpreterPascal P6
ETH May 76
Authors:
Urs AmmannKesav Nori
Christian Jacobi
K. Jensen
N. Wirth
Address:
Institut Fuer Informatik
Eidg. Technische Hochschule
CH-8096 Zuerich
This code is fully documented in the book
"Pascal Implementation"
by Steven Pemberton and Martin Daniels
published by Ellis Horwood, Chichester, UK
ISBN: 0-13-653-0311(also available in Japanese)
Steven Pemberton, CWI/AA, Kruislaan 413, 1098 SJ Amsterdam, NL Steven.Pemberton@cwi.nl
Adaption from P5 to P6 by:
Scott A. Francosamiam@moorecad.com
The comments marked with brackets are mine [sam]
Please see accompanying documentation concerning this software.
LICENSEThis software is based on, and represents an enhanced version, of Pascal-P5, which is itself based on Pascal-P4, and was enhanced from that version substantially.
Pascal-P4 is unlicensed and exists in the public domain. It has:
1. Been acknowledged as public domain by the author, Niklaus Wirth at ETH
Zurich.2. Has been freely distributed since 1976 with only charges for printing and
shipping costs.3. Has been used as the basis for many projects, both paid and free, by
other authors.I, Scott Franco, have extensively expanded the original software. The the changes made by me are held in copyright by me and released under the BSD "2-clause" license, the least restrictive open source license available.