%COMPILER=YES %CHARCODE=EBCDIC %RANGECHECKS=NO %DIAGLINEMAP=NO %DIAGNAMETABLE=NO PROGRAM ICL9LPCOMPILE ; CONST VERSIONNO = 20 ; MARKNO = 10 ; MAXINT = 2147483647 ; GLOBALLEVEL = 1 ; DISPLIMIT = 20 ; NILVALUE = 0 ; THROWLINE = 1 ; THROWPAGE = 2 ; (* CONSTANT USED BY THE DIAGNOSTICS HANDLER *) NILSERIAL = 0; (* CONSTANTS USED BY THE SOURCE HANDLER *) PAGEWIDTH = 120; (* SUITS ALL ICL LINEPRINTERS *) LEFTSPACE = 20; (* FOR LINE NO, ETC *) ERRMAX = 9; RIGHTSPACE = 3; (* FOR ERROR NO *) MAXMARGIN = 96; (* = PAGEWIDTH-LEFTSPACE-RIGHTSPACE-1 *) EBCDICTABCHAR = 5; BAR = '!'; BLANK = ' '; BLANKALFA8 = ' '; BLANKALFA16 = ' '; BLANKALFA = ' '; MAXERRORNUMBER = 410 ; ERRSETMAX = 63 ; ERRSETSIZE = 7 ; (* MAXERRORNUMBER DIV (ERRSETMAX + 1) + 1 *) EMTLEN = 80 ; (* CONSTANTS USED BY THE LEXICAL ANALYSER *) NOWORDSYMBOLS = 34 ; MAXWORDSYMLEN = 9 ; UNDERSCORECHAR = '_' ; STRINGMAX = 50; INTSIGMAX = 10 ; SIGMAX = 16 ; (* CONSTANTS USED BY THE CODE GENERATOR *) CODEMAX = 1500 ; CODETOP = 3001 (* 2*CODEMAX + 1 *) ; CODETOPANDONE = 3002 (* CODETOP + 1 *) ; BITSINBYTE = 8 ; MAXINTFORBYTE = 255 ; BYTESINWORD = 4 ; BYTESINHALFWORD = 2 ; CHARSINWORD = 4 ; WORDLENGTH = 32 ; ONEFROMWORDLENGTH = 31 ; TWICEWORDLENGTH = 64 ; ONEFROMTWICEWORDLENGTH = 63 ; ALFALENGTH = 32 ; ALFA16LENGTH = 16; ALFA8LENGTH = 8 ; ORDSMALLESTCHAR = 0 ; ORDLARGESTCHAR = 255 (* FOR EBCDIC *) ; BYTESINSEGMENT = 262143 ; WORDSINSEGMENT = 65535 ; TWOTOTHE18 = 262144 ; MININTFORLONGLITERAL = -131072 ; MAXINTFORLONGLITERAL = 131071 ; SUPREMEELEMENTINSET = 63 ; XFFFF = 65535 ; XFFFFFF = 16777215 ; XFFFC0000 = -262144 ; BASESTART = 8 ; DIAGOBJPLTOFFSET = 26 ; DIAGTOKENPLTOFFSET = 28 ; DIAGMAPPLTOFFSET = 30 ; RTOPTIONSPLTOFFSETWD = 32 ; PLTSTART = 34 ; GLOBALADDRESS = 8 ; BYTEDESCRIPTOR = 402653184 (* X@18000000 *) ; NOBNDBYTEDESCRIPTOR = 402915328 (* X@19000000 *) ; TWOBYTEDESCRIPTOR = 1476395010 (* X@58000002 *) ; THREBYTEDESCRIPTOR = 1476395011 (* X@58000003 *) ; NOBNDCODEDESCRIPTOR = -520093696 (* X@E1000000 *) ; UNSCLONEWORD = 704643072 (* X@2A000000@ *) ; SCLONEWORD = 671088640 (* X@28000000@ *) ; UNSCLTWOWORD = 838860800 (* X@32000000@ *) ; SCLTWOWORD = 805306368 (* X@30000000@ *) ; UNSCLFOURWORD = 973078528 (* X@3A000000@ *) ; SCLFOURWORD = 939524096 (* X@38000000@ *) ; ADB = 32 ; LAND = 138 ; ASF = 110 ; CALL = 30 ; CPB = 38 ; CPIB = 46 ; CPS = 164 ; CPSR = 52 ; CYD = 18 ; DEBJ = 36 ; EXIT = 56 ; FIX = 184 ; FLT = 168 ; IAD = 224 ; ICP = 230 ; IDLE = 78 ; IDV = 170 ; IMDV = 174 ; IMY = 234 ; INCA = 20 ; INCT = 86 ; INS = 146 ; IRDV = 172 ; IRSB = 228 ; ISB = 226 ; ISH = 232 ; J = 26 ; JAF = 6 ; JAT = 4 ; JCC = 2 ; JLK = 28 ; L = 96 ; LB = 122 ; LD = 120 ; LDA = 114 ; LDB = 118 ; LDRL = 112 ; LDTB = 116 ; LLN = 124 ; LCT = 48 ; LSD = 100 ; LSQ = 102 ; LSS = 98 ; LUH = 106 ; LXN = 126 ; MODD = 22 ; MPSR = 50 ; MV = 178 ; MVL = 176 ; MYB = 42 ; NEQ = 142 ; NEQS = 134 ; LOR = 140 ; ORS = 132 ; OUT = 60 ; PK = 144 ; PRCL = 24 ; RAD = 240 ; RALN = 108 ; RCP = 246 ; RDV = 186 ; RDVD = 190 ; RMY = 250 ; RMYD = 252 ; ROT = 202 ; RRDV = 188 ; RRSB = 244 ; RRTC = 104 ; RSB = 242 ; RSC = 248 ; SBB = 34 ; SHS = 204 ; SHZ = 206 ; SIG = 40 ; SL = 64 ; SLB = 82 ; SLD = 80 ; SLSD = 68 ; SLSQ = 70 ; SLSS = 66 ; ST = 72 ; STB = 90 ; STD = 88 ; STLN = 92 ; STCT = 54 ; STSF = 94 ; STUH = 74 ; STXN = 76 ; SUPK = 148 ; SWEQ = 160 ; SWNE = 162 ; TCH = 128 ; TDEC = 84 ; TTR = 166 ; UAD = 192 ; UCP = 198 ; URSB = 196 ; USB = 194 ; USH = 200 ; VAL = 16 ; VMY = 44 ; JMP = 256 ; (* MASKS FOR JAT AND JAF INSTRUCTIONS *) (* FLOATING POINT ACCUMULATOR JUMPS *) REALACCEQUALTOZERO = 0 ; REALACCGREATERTHANZERO = 1 ; REALACCLESSTHANZERO = 2 ; (* FIXED POINT ACCUMULATOR JUMPS *) INTACCEQUALTOZERO = 4 ; INTACCGREATERTHANZERO = 5 ; INTACCLESSTHANZERO = 6 ; (* B REGISTER JUMPS *) BEQUALTOZERO = 12 ; BGREATERTHANZERO = 13 ; BLESSTHANZERO = 14 ; (* OVERFLOW INDICATOR SET JUMP *) OVINDICATORSET = 15 ; (* MASKS FOR JCC INSTRUCTION *) REGEQUALTOOPERAND = 8 ; REGLESSTHANOPERAND = 4 ; REGGREATERTHANOPERAND = 2 ; REGNOTEQUALTOOPERAND = 7 ; REGEQORGREATERTHANOPERAND = 11 ; REGEQORLESSTHANOPERAND = 13 ; NOBITSLOST = 8 ; POSSHIFT = 1 ; ALLCCCONDITIONSSET = 15 ; FILEBLOCKSIZE = 8 ; STARTOFGLOBALSPACE = 8 ; LOCATIONOFSTATICLINK = 5 ; STATICLINKSPACE = 2 ; ADMINSPACEFORCALL = 5 ; PLTOFFSET = 3 ; STACKMAX = 40 ; FVADD = 1 ; LINEEND = 7 ; FILECHAR = 0 ; EOLNOFFSET = 8 ; EOFOFFSET = 12 ; JLKPARAMETERAREA = 0 ; GLOBALLNBDESCOFFSET = 4 ; JLKSUPPORTLINKOFFSET = 6 ; EXITPARAMETER = -20 ; TYPE SEGMENTSIZE = 0..WORDSINSEGMENT ; BYTESEGMENTSIZE = 0..BYTESINSEGMENT ; BYTERANGE = 1..BYTESINWORD ; ALFARANGE = 1..ALFALENGTH ; ALFA16RANGE = 1..ALFA16LENGTH ; ALFA8RANGE = 1..ALFA8LENGTH ; ALFA = PACKED ARRAY[ALFARANGE] OF CHAR ; ALFA16 = PACKED ARRAY [ALFA16RANGE] OF CHAR ; ALFA8 = PACKED ARRAY [ALFA8RANGE] OF CHAR ; SETRANGE = 0..SUPREMEELEMENTINSET ; BASICSET = SET OF SETRANGE ; POSITIVEINTEGER = 0..MAXINT ; BYTE = 0..MAXINTFORBYTE ; WORD = INTEGER ; VADDRESS = WORD ; TEXTPT = @TEXT ; (* TYPES CORRESPONDING TO PROGRAMMER OPTIONS *) OPTIONTYPE = (CHECKS, COMPILER, LINEMAP, DUMP, ENTRY, SOURCELIST, OBJECTLIST, PROFILE, RETRO, TRACE, NOCODEGEN, CHARCODE, (* RETROMAX, TRACEMIN, TRACEMAX, *) MARGIN, GLOBALID, TITLE, NEWPAGE, NOSUCHOPTION) ; BOOLOPTIONTYPE = CHECKS..TRACE ; (* ) THESE DEFINITIONS APPLY ONLY TO *) INTOPTIONTYPE = CHARCODE..MARGIN ; (* ) OPTIONS FOR WHICH PASCAL-SPECIFIC *) STRINGOPTIONTYPE = GLOBALID..TITLE ; (* ) DIRECTIVES ARE AVAILABLE. *) ALIENBOOLOPTIONTYPE = NOCODEGEN..NOCODEGEN; SETOFOPTIONS = SET OF OPTIONTYPE ; OPTIONSCOPE = (LOCALLY, GLOBALLY) ; DELAYEDLISTINGOPTIONREC = RECORD CASE OPTION : OPTIONTYPE OF MARGIN : (NEWMARGIN : INTEGER); TITLE : (NEWTITLE : ALFA); NEWPAGE : () (* - NO OTHER OPTION VALUES ARE RELEVANT *) END; (* TYPES USED BY THE SOURCE & LISTING HANDLER *) CHARCODETYPE = (CCEBCDIC, CCISO, CCICL1900, CCINVALID) ; LINEPOSITION = 0..MAXMARGIN ; EXTERNSOURCESTATUS = (BUFOK, BUFTRUNCATED, BUFTOBEIGNORED, BUFTOBELISTEDONLY, BUFABSENTATEOF); SOURCESTATUS = (LINEISABSENT, LINEISTOBEIGNORED, LINEISTOBELISTEDONLY, LINEISBLANK, LINEISNORMAL, LINEISPASCALDIRECTIVE); SOURCELINEBUF = PACKED ARRAY [LINEPOSITION] OF CHAR ; SOURCELINE = RECORD LINENUMBER : INTEGER ; MODES : PACKED ARRAY [1..5] OF CHAR; LINE : SOURCELINEBUF ; ATHEADOFTEXT : BOOLEAN ; CHARNUMBER : LINEPOSITION; (*-USED IN ERROR HANDLER*) LINEOVERFLOW, MARGINOVERFLOW : BOOLEAN; OVERFLOWMAX : LINEPOSITION; (*-DEFINED ONLY IF "MARGINOVERFLOW" IS TRUE*) DONEPREMATURELISTING, NEWHEADINGPENDING, DELAYEDOPTIONPENDING : BOOLEAN; ERRINX : 0..ERRMAX ; ERROROVERFLOW : BOOLEAN ; ERRLIST : ARRAY [1..ERRMAX] OF RECORD ERRORPOSITION : LINEPOSITION ; ERRORCODE : INTEGER END; CASE STATUS : SOURCESTATUS OF LINEISABSENT, LINEISTOBEIGNORED, LINEISTOBELISTEDONLY, LINEISBLANK: (); LINEISNORMAL, LINEISPASCALDIRECTIVE: (FIRSTNONBLANK, LASTNONBLANK: LINEPOSITION) END ; LISTPAGEHEADINGKIND = (SOURCEHEADING, PROGOBJECTHEADING, PROCOBJECTHEADING,FUNCOBJECTHEADING); LISTINGSTATUS = (LISTINGYETTOSTART, SOURCELS, OBJECTLS, SUMMARYLS); LISTINGCONTROLREC = RECORD SOURCETITLE : ALFA; STATUS : LISTINGSTATUS END; ERRINXTYPE = 1..ERRMAX ; ERRCODE = 1..MAXERRORNUMBER ; EMTBUF = PACKED ARRAY [ 1..EMTLEN ] OF CHAR ; (* TYPES USED BY THE LEXICAL ANALYSER *) SYMBOLTYPE = (IDENT,INTCONST,REALCONST,CHARCONST,STRINGCONST,NOTSY, MULOP,ADDOP,RELOP,LEFTPARENT,RIGHTPARENT, LEFTBRACKET,RIGHTBRACKET, LEFTCURLYBRACKET,RIGHTCURLYBRACKET, COMMA,SEMICOLON,PERIOD,DOTDOTSY,ARROW,COLON,BECOMES, LABELSY,CONSTSY,TYPESY,VARSY,FUNCSY,PROCSY,SETSY, PACKEDSY,ARRAYSY,RECORDSY,FILESY, BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY, GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY, THENSY,PROGRAMSY,VALUESY,QUOTE,DIGIT,OTHERSY) ; OPTYPE = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP, LTOP,LEOP,GEOP,GTOP,NEOP,EQOP,INOP,NOTOP) ; VALUEKIND = (INTVALUE,BOOLVALUE,CHARVALUE,REALVALUE, SETVALUE,STRINGVALUE ) ; STRINGP = @STRINGREC ; ALFAWORD = PACKED ARRAY [1..CHARSINWORD] OF CHAR; STRINGREC = RECORD WORD : ALFAWORD ; NEXTWORD : STRINGP END ; CHARSETP = @CHARSET ; CHARSET = PACKED ARRAY [CHAR] OF 0..255 ; VALU = RECORD SIZE : SEGMENTSIZE ; CASE KIND : VALUEKIND OF INTVALUE : (IVAL1 : INTEGER ; IVAL2 : INTEGER) ; BOOLVALUE : (BVAL : BOOLEAN) ; CHARVALUE : (CVAL : BYTE) ; REALVALUE : (RVAL : REAL) ; SETVALUE : (SVAL : BASICSET) ; STRINGVALUE : (LENGTH : 1..BYTESINSEGMENT ; STRING : STRINGP) END ; (* TYPES USED BY THE SYNTAX ANALYSER *) SETOFSYMBOLS = SET OF SYMBOLTYPE ; STDPROCFUNCS = (GETP,PUTP,RESETP,REWRITEP, READP,WRITEP,READLNP,WRITELNP,PAGEP, DATEANDTIMEP,HALTP, NEWP,DISPOSEP, STOREBYTEATP,STOREWORDATP, PACKP,UNPACKP, ABSF,SQRF,ODDF,SUCCF,PREDF,ORDF,CHRF, TRUNCF,ROUNDF,SINF,COSF,EXPF,LNF,SQRTF,ARCTANF, ADDRESSF,CLOCKF, ORF,ANDF,NEQF,USHF,ROTF,ISHF, BYTEATF,WORDATF, BYTESIZEOFF, EOFF,EOLNF) ; TYPENTRY = @ TYPEREC ; IDENTRY = @ IDREC ; FORMALENTRY = @ FORMREC ; LABELENTRY = @ LABELREC ; SCOPECOPY = @ SCOPEREC ; FIXUPENTRY = @ FIXUPREC ; FRAMESIZEFIXUPENTRY = @ FRAMESIZEFIXUPREC ; CODEADDRESS = 0..131069 ; IDLIST = RECORD FIRSTENTRY,LASTENTRY : IDENTRY END ; TYPEFORM = (SCALARS,SUBRANGES,POINTERS,SETS,ARRAYS,RECORDS, FILES,VARIANTPART,VARIANT) ; DECLKIND = (STANDARD,DECLARED) ; DISPRANGE = 0..DISPLIMIT ; (* TYPE USED BY THE DIAGNOSTICS HANDLER AND BY THE ANALYSER *) SERIALRANGE = INTEGER; (* TYPES USED IN THE ANALYSER/GENERATOR INTERFACE *) CODERANGE = 0..CODETOP ; SUPPORTTASK = (GETTEXTFILE, PUTTEXTFILE, TRUNCATE, ASSIGNARRAY, PROGPRELUDE,PROGPOSTLUDE, SINFUNC,COSFUNC,EXPFUNC,SQRTFUNC, LNFUNC,ARCTANFUNC, OPENFILE,CLOSEFILE, RESETFILE,REWRITEFILE, GETRECFILE,PUTRECFILE, READINTEGER,READREAL, WRITEINTEGER,WRITEBOOL,WRITESPACEDCHAR, WRITEREAL,WRITSTRING,WRITEWORDSTRING, READCONTROL,WRITECONTROL,PAGECONTROL, GETSPACE,RETURNSPACE, HALTSYSTEM, SETDATEANDTIMEVARS,READCLOCK, SETCHARACTERSET, TRACEFLOW,RETROFLOW,COUNTFLOW, RANGEABORT,CASEABORT) ; FORMATOFDESCRIPTOR = ( ONEBYTE , TWOBYTE , THREEBYTE , ONEWORDUNSCALED , ONEWORDSCALED , TWOWORDUNSCALED , TWOWORDSCALED , FORWORDUNSCALED , FORWORDSCALED ) ; TYPEREPRESENTATION = PACKED RECORD ACCESSDESCRIPTOR : FORMATOFDESCRIPTOR ; CASE SIZE : SEGMENTSIZE OF 1 : ( BYTESIZE : 1..BYTESINWORD ; MIN,MAX : INTEGER ) END ; RUNTIMEADDRESS = PACKED RECORD BLOCKLEVEL : DISPRANGE ; RELATIVEADDRESS : SEGMENTSIZE END ; FIELDOFFSET = PACKED RECORD BYTEOFFSET,BYTESIZE : BYTESEGMENTSIZE END ; SEQUENCETYPE = ( SIMPLESEQUENCE , PROCSEQUENCE , ENTRYSEQUENCE , EXTERNALSEQUENCE ) ; CODESEQUENCE = RECORD CASE KIND : SEQUENCETYPE OF SIMPLESEQUENCE , PROCSEQUENCE : ( FRAMESIZEFIXUPLIST : FRAMESIZEFIXUPENTRY ; CASE EXPECTED : BOOLEAN OF TRUE : ( FIXUPLIST : FIXUPENTRY ; CASE INPLTADDRESS : BOOLEAN OF TRUE : ( PLTREF : SEGMENTSIZE )) ; FALSE : ( STARTADDRESS : CODEADDRESS )) ; ENTRYSEQUENCE , EXTERNALSEQUENCE : ( PLTENTRYREFERENCE , PLTEXTERNALREFERENCE : SEGMENTSIZE ) END ; STACKENTRY = @STACKREC ; STACKTOP = (TOPOFSTACK,NEXTTOTOP) ; READORWRITEFILE = (READFILE,WRITEFILE) ; OUTPUTKIND = ( INTKIND,REALKIND,CHARKIND,BOOLKIND, STRINGKIND,LAYOUTKIND,DEFAULTKIND) ; INPUTKIND = INTKIND..CHARKIND ; FORMATKIND = (DEFAULT,FLOATING,FIXED) ; TYPEREC = PACKED RECORD SERIAL : SERIALRANGE; NEXT : TYPENTRY ; REPRESENTATION : TYPEREPRESENTATION ; CASE FORM : TYPEFORM OF SCALARS : (CASE SCALARKIND : DECLKIND OF DECLARED : (FIRSTCONST : IDENTRY)) ; SUBRANGES : (RANGETYPE : TYPENTRY ; MIN,MAX : INTEGER) ; POINTERS : (DOMAINTYPE : TYPENTRY) ; SETS : (PACKEDSET : BOOLEAN ; BASETYPE : TYPENTRY ) ; ARRAYS : (AELTYPE,INXTYPE : TYPENTRY ; PACKEDARRAY : BOOLEAN) ; RECORDS : (PACKEDRECORD : BOOLEAN ; FIELDSCOPE : IDENTRY ; NONVARPART : IDENTRY ; VARPART : TYPENTRY) ; FILES : (PACKEDFILE,TEXTFILE : BOOLEAN ; FELTYPE : TYPENTRY) ; VARIANTPART : (TAGFIELD : IDENTRY ; TAGTYPE, FIRSTVARIANT : TYPENTRY) ; VARIANT : (FSTVARFIELD : IDENTRY ; NEXTVARIANT,SUBVARPART : TYPENTRY ; VARIANTVALUE : VALU) END ; IDCLASS = (TYPES,CONSTS,VARS,FIELD,PROC,FUNC,PROG) ; BLOCKIDCLASS = PROC..PROG ; SETOFIDCLASS = SET OF IDCLASS ; IDKIND = (ACTUAL,FORMAL) ; IDREC = RECORD SERIAL : SERIALRANGE; NAME : ALFA ; LEFTLINK,RIGHTLINK : IDENTRY ; IDTYPE : TYPENTRY ; NEXT : IDENTRY ; CASE KLASS : IDCLASS OF CONSTS: ( VALUES : VALU ) ; VARS: ( VARPARAM : BOOLEAN ; VARADDRESS : RUNTIMEADDRESS ) ; FIELD: ( OFFSET : FIELDOFFSET ) ; PROC, FUNC: ( CASE PFDECKIND : DECLKIND OF STANDARD: ( PFINDEX : STDPROCFUNCS ) ; DECLARED: ( CASE PFKIND : IDKIND OF ACTUAL: ( FORMALS : FORMALENTRY ; CODEBODY : CODESEQUENCE ; FORWARD : BOOLEAN ; RESULT : RUNTIMEADDRESS ; FORMALSCOPE : SCOPECOPY ) ; FORMAL: ( FADDRESS : RUNTIMEADDRESS))) END ; FORMREC = PACKED RECORD NEXT : FORMALENTRY ; FORMALTYPE : TYPENTRY ; CASE KLASS : IDCLASS OF VARS : ( FORMALISVAR : BOOLEAN ) END ; LABELREC = RECORD LABELVALUE : INTEGER ; NEXTLABEL : LABELENTRY ; DEFINED : BOOLEAN ; LABELLEDCODE : CODESEQUENCE END ; CASENTRY = @ CASEREC ; CASEREC = RECORD CASEVALUE : INTEGER ; CASELIMB : CODESEQUENCE ; NEXTCASE : CASENTRY END ; SCOPEKIND = ( BLOC,WITHST ) ; SCOPEREC = RECORD IDSCOPE : IDENTRY ; CASE SCOPE : SCOPEKIND OF BLOC : ( TYPECHAIN : TYPENTRY ; FIRSTLABEL : LABELENTRY ; LOCALADDRESS : SEGMENTSIZE ; LOCALSPACEREQUIRED : SEGMENTSIZE ) ; WITHST : ( FIELDSPACKED : BOOLEAN ; WITHBASE : STACKENTRY ) END ; (* TYPES USED BY THE DIAGNOSTICS HANDLER *) OBJADDRRANGE = SEGMENTSIZE; OBJECTDESCR = PACKED RECORD SIZEINBYTES : BYTESEGMENTSIZE; OBJSERIAL: SERIALRANGE; CASE OBJCLASS: IDCLASS OF TYPES: (OBJREPRESENTATION: TYPEREPRESENTATION; CASE OBJFORM: TYPEFORM OF SCALARS: (CASE OBJSCALARKIND: DECLKIND OF DECLARED: (OBJFIRSTCONST: SERIALRANGE); STANDARD: (STDTYPE: (INTSTD,REALSTD,CHARSTD))); SUBRANGES: (OBJRANGETYPE: SERIALRANGE; OBJMIN, OBJMAX: INTEGER); SETS: (SETISPACKED: BOOLEAN; OBJBASETYPE: SERIALRANGE); ARRAYS: (ARRAYISPACKED: BOOLEAN; OBJAELTYPE, OBJINXTYPE: SERIALRANGE); RECORDS: (RECORDISPACKED: BOOLEAN; OBJNONVARPART, OBJVARPART: SERIALRANGE); FILES: (FILEISPACKED, FILEISTEXT: BOOLEAN; OBJFELTYPE: SERIALRANGE); VARIANTPART: (OBJTAGFIELD, OBJTAGTYPE, OBJFSTVARIANT: SERIALRANGE); VARIANT: (OBJSUBNONVARPART, OBJSUBVARPART, OBJNEXTVARIANT: SERIALRANGE; OBJVARIANTVALUE: INTEGER)); CONSTS: (CONSTNAME: ALFA; CONSTVALUE: INTEGER; NEXTCONST: SERIALRANGE); VARS: (VARNAME: ALFA; VARTYPE: SERIALRANGE; ISVARPARAM: BOOLEAN; LOCALADDRESS: OBJADDRRANGE; NEXTLOCALVAR: SERIALRANGE); FIELD: (FIELDTYPE: SERIALRANGE; OBJOFFSET: FIELDOFFSET; NEXTFIELD: SERIALRANGE); PROG,PROC,FUNC: (* THE SERIAL NO. OF THIS OBJECT-TABLE ENTRY SERVES TO IDENTIFY THE CORRESPONDING BLOCK IN THE OBJECT PROGRAM. *) (BLOCKNAME: ALFA; FIRSTLOCALVAR: SERIALRANGE) END; KINDOFTOKEN = (SYMBOLTOKEN,FLOWTOKEN,BREAKTOKEN) ; KINDOFBREAK = (BLOCKHEAD,BLOCKBODY,STATLABEL,CASELABELLIST) ; KINDOFBLOCK = (PROGBLOCK, PROCBLOCK, FUNCBLOCK, UNKNOWNBLOCK); COUNTERADDRRANGE = SEGMENTSIZE; FLOWADDRRANGE = CODEADDRESS; TOKENREC = PACKED RECORD SIZEINBYTES : BYTESEGMENTSIZE; CASE TOKENKIND: KINDOFTOKEN OF SYMBOLTOKEN: (CASE TOKENSYMBOL: SYMBOLTYPE OF IDENT: (TOKENSPELLING: ALFA); INTCONST: (TOKENINTVAL: INTEGER); REALCONST: (TOKENREALVAL: REAL); CHARCONST: (TOKENCHARVAL: BYTE); MULOP, ADDOP, RELOP: (TOKENOP: OPTYPE) ); FLOWTOKEN: (FLOWADDRESS: FLOWADDRRANGE; CASE COUNTED: BOOLEAN OF TRUE: (COUNTADDRESS: COUNTERADDRRANGE) ); BREAKTOKEN: (BREAKADDRESS: FLOWADDRRANGE; BREAKKIND: KINDOFBREAK) END; (* TYPES USED BY THE CODE GENERATOR *) STDAREATYPE = (CODEAREA, PLTAREA, DIAGOBJECTAREA, DIAGTOKENAREA, DIAGMAPAREA) ; DIAGAREATYPE = DIAGOBJECTAREA..DIAGMAPAREA ; STDAREAVECTOR = ARRAY [STDAREATYPE] OF INTEGER ; CODEARRAY = ARRAY [ 0..CODEMAX ] OF INTEGER ; LONGPINSLITERAL = MININTFORLONGLITERAL..MAXINTFORLONGLITERAL ; MASKFORJUMP = 0..15 ; ORDERCODE = 0..256 ; REGISTER = ( NONE,UNASSIGNED,LNB,XNB,PC,CTB,TOS,BREGISTER ) ; MODE = (UNMODIFIED,MODIFYDR,DESCRIPTORINSTORE, MODIFYDESCRIPTORINSTORE) ; FIXUPREC = RECORD NEXTFIXUP : FIXUPENTRY ; CODEREFERENCE : CODERANGE END ; FRAMESIZEFIXUPREC = RECORD NEXTFSFIXUP : FRAMESIZEFIXUPENTRY ; STACKCOLLAPSECODEOFFSET : CODEADDRESS END ; CONSTENTRY = @CONSTREC ; CONSTREC = RECORD NEXTCONST : CONSTENTRY ; CONSTVALUE : VALU ; FIXUPLIST : FIXUPENTRY ; CASE DESCRIBED : BOOLEAN OF TRUE : ( DESC : FORMATOFDESCRIPTOR ) END ; BASEENTRY = @BASEREC ; BASEREC = RECORD BASELEVEL : DISPRANGE ; BASEOFFSET : SEGMENTSIZE ; BASEDESCRIPTOR : FORMATOFDESCRIPTOR ; NEXTBASE : BASEENTRY END ; STACKKIND = (REFERENCE,KONSTANT,ONSTACKRESULT, CONDITION,PARAMETERSPASSED,STATEMENTBASE) ; CONDKIND = (JUMPONACC,JUMPONCC,MULTIJUMPCONDITION) ; ACCESSKIND = (DIRECT,BYADDRESS,BYDESCRIPTOR,ONSTACKADDRESS) ; REFRECORD = RECORD BYTEADJUSTMENT : INTEGER ; PACKEDITEM : BOOLEAN ; STATICLEVEL : DISPRANGE ; OFFSET : SEGMENTSIZE ; CASE ACCESS : ACCESSKIND OF BYDESCRIPTOR : (CURRENTDESCRIPTOR : FORMATOFDESCRIPTOR) END ; ACCJUMP = RECORD JATORDER : BOOLEAN ; JUMPKIND : MASKFORJUMP END ; STACKREC = RECORD REP : TYPEREPRESENTATION ; ELEMENTSIZE : BYTESEGMENTSIZE ; NEXTENTRY : STACKENTRY ; CASE KIND : STACKKIND OF REFERENCE : (POSITION : REFRECORD ; CASE INDEXED : BOOLEAN OF TRUE : (INDICES : STACKENTRY )) ; KONSTANT : (KONSTVALUE : VALU) ; CONDITION : (CASE KINDOFCONDITION : CONDKIND OF JUMPONACC : (FALSEACCJUMP : ACCJUMP) ; JUMPONCC : (FALSECCJUMP : MASKFORJUMP) ; MULTIJUMPCONDITION : (JUMPCONDITION : BOOLEAN ; JUMPDESTINATION : CODESEQUENCE)) ; PARAMETERSPASSED : (WORDSPASSED : SEGMENTSIZE) ; STATEMENTBASE : (CODEWASBEINGGENERATED : BOOLEAN) END ; INTERNALCODESUPPORTTASK = GETTEXTFILE..ASSIGNARRAY ; EXTCALLSUPPORTTASK = PROGPRELUDE..CASEABORT ; EXTCALLINFOREC = RECORD WORDSPASSED : SEGMENTSIZE ; EXTCALLNAME : ALFA END ; SUPPORTSTATUSREC = RECORD CASE USEJLK : BOOLEAN OF FALSE : (CASE USEEXTERNALCALL : BOOLEAN OF TRUE : (CASE EXTCALLUSEDYET : BOOLEAN OF TRUE : (EXTCALLDESTINATION : CODESEQUENCE) ) ) ; TRUE : (CASE JLKUSEDYET : BOOLEAN OF TRUE : (JLKDESTINATION : CODESEQUENCE) ) END ; POWERRANGE = 0..WORDLENGTH ; OPERANDDESCRIPTION = RECORD ENTRY : STACKENTRY ; ISCONSTANT , ISGEZERO,ISZERO, ISPOWEROF2 : BOOLEAN ; CVALUE : INTEGER ; LOG2 : POWERRANGE END ; VAR (* GLOBAL VARIABLES USED BY THE SOURCE & LISTING HANDLER *) CH : CHAR; ERRORCOUNT : INTEGER; SOURCE : SOURCELINE; LISTINGP : TEXTPT; LISTINGCONTROL : LISTINGCONTROLREC; STARTCLOCK,ENDCLOCK : INTEGER ; ASUFFIXWASIGNORED, LINEADVANCEALLOWED : BOOLEAN; ERRORSET : ARRAY [0..ERRSETSIZE] OF SET OF 0..ERRSETMAX ; NESTINGLEVEL : RECORD LINESTART : 1..99 ; CURRENT : 1..99 END ; (* GLOBAL VARIABLES USED BY THE LEXICAL ANALYSER *) SYMBOL : SYMBOLTYPE ; OPERATOR : OPTYPE ; CONSTANT : VALU ; SPELLING : ALFA ; CODETABLE : CHARSETP ; STRINGBASE : STRINGP ; (* TABLES USED BY THE LEXICAL ANALYSER *) ONECHARSYMBOLS : ARRAY[CHAR] OF RECORD SYMBOLVALUE : SYMBOLTYPE ; OPVALUE : OPTYPE END ; FORCETOUPPERCASE : PACKED ARRAY [CHAR] OF CHAR ; WORDSYMBOLS : ARRAY[ 1..NOWORDSYMBOLS] OF RECORD SPELLING : ALFA ; SYMBOLVALUE : SYMBOLTYPE ; OPVALUE : OPTYPE END ; LASTOFLENGTH : ARRAY[0..MAXWORDSYMLEN] OF 0..NOWORDSYMBOLS ; (* GLOBAL VARIABLES USED BY THE DIAGNOSTICS HANDLER *) NEXTSERIAL : SERIALRANGE; DIAGMAPSIZE, DIAGOBJSIZE, DIAGTOKENSIZE : BYTESEGMENTSIZE; PREVLINE : INTEGER; PREVINS : CODEADDRESS; TOKENBEINGSAVED : TOKENREC; TOKENSTOBESAVED : BOOLEAN; MUSTCOUNTNEXTFLOWUNIT : BOOLEAN; GOTOSPOSSIBLE : BOOLEAN; (* GLOBAL VARIABLES CORRESPONDING TO PROGRAMMER OPTIONS *) OPTIONSCHOSEN : SETOFOPTIONS ; REQD, LOCALLYREQD : ARRAY [OPTIONTYPE] OF BOOLEAN; PARMVALUE : ARRAY [INTOPTIONTYPE] OF INTEGER; USERDEFGLOBALID : ALFA; COUNTREQD : BOOLEAN; OPTIONNAME : ARRAY [OPTIONTYPE] OF ALFA16; LOCALBOOLOPTIONS, ALLLOCALOPTIONS, ALLGLOBALOPTIONS : SETOFOPTIONS; DELAYEDOPTIONINFO : DELAYEDLISTINGOPTIONREC; (* GLOBAL VARIABLES USED BY THE SYNTAX ANALYSER *) BLOCKBEGSYS,TYPEBEGSYS,CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEDELS, STATBEGSYS,FACBEGSYS,SELECTSYMBOLS,PARAMBEGSYS : SETOFSYMBOLS ; (* TABLE USED BY SYNTAX ANALYSER *) MISSINGCODEFOR : ARRAY[SYMBOLTYPE] OF 0..MAXERRORNUMBER ; STDPFNAMES : ARRAY[STDPROCFUNCS] OF ALFA ; BYTETYPE, INTTYPE,REALTYPE,BOOLTYPE,CHARTYPE,CODEFTYPE, ALFATYPE,ALFA8TYPE, TEXTTYPE,NILTYPE,UNISETTYPE,LAYOUTTYPE : TYPENTRY ; EXPTYPE,VARTYPE : TYPENTRY ; INPUTFILE,OUTPUTFILE : IDENTRY ; EMPTYSET : VALU ; DEFAULTENTRY : ARRAY[IDCLASS] OF IDENTRY ; TOP,LEVEL,LEVELFOUND : DISPRANGE ; DISPLAY : ARRAY [DISPRANGE] OF SCOPEREC ; SPACES : ALFA ; BYTEREPRESENTATION, REALREPRESENTATION,BOOLEANREPRESENTATION, CHARREPRESENTATION,INTEGERREPRESENTATION, POINTERREPRESENTATION,DEFAULTREPRESENTATION, LAYOUTREPRESENTATION, ALFAREPRESENTATION,ALFA8REPRESENTATION : TYPEREPRESENTATION ; DEFAULTADDRESS : RUNTIMEADDRESS ; (* VARIABLES AND TABLES USED BY THE CODE GENERATOR *) OBJECTCODE : BOOLEAN ; CODEINDEX : 0..CODETOPANDONE ; CODE : CODEARRAY ; NEXTINS,STARTOFCODE : CODEADDRESS ; GLOBALSIZE : BYTESEGMENTSIZE ; STDAREASIZES : STDAREAVECTOR ; MODULENAME : ALFA ; TYPEANDBOUND : ARRAY [ FORMATOFDESCRIPTOR ] OF INTEGER ; STOREACCATTOSPENDING : BOOLEAN ; LASTCONSTENTRY : CONSTENTRY ; GLOBALDESCRIPTORS : ARRAY [FORMATOFDESCRIPTOR] OF SEGMENTSIZE ; ACCORDERS,FORCESTOREORDERS : ARRAY[0..7] OF SET OF 0..31 ; ACCESSDESCRIPTOR : ARRAY [BYTERANGE] OF FORMATOFDESCRIPTOR ; BYTESFOR : ARRAY [FORMATOFDESCRIPTOR] OF 1..16 ; UNSCALEDDESCRIPTORFOR : ARRAY [FORMATOFDESCRIPTOR] OF FORMATOFDESCRIPTOR ; ADDRESSED : RECORD K1 : REGISTER ; K2 : MODE ; N : INTEGER ; CASE ISDESCRIPTORINUSE : BOOLEAN OF TRUE : ( ADDRESSEDDESCRIPTOR : FORMATOFDESCRIPTOR ) END ; FIRSTBASEENTRY : BASEENTRY ; TOPSTACKENTRY, FIRSTFREEENTRY : STACKENTRY ; EXTCALLINFOTABLE : ARRAY [EXTCALLSUPPORTTASK] OF EXTCALLINFOREC ; SUPPORTSTATUSTABLE : ARRAY [SUPPORTTASK] OF SUPPORTSTATUSREC ; BYTEVECTOR : VALU ; CURRENTLINE : POSITIVEINTEGER ; MAINPROGRAM : CODESEQUENCE ; REVERSEDOPERANDS : BOOLEAN ; BODY,BODYPRELUDE : CODESEQUENCE ; CODEISTOBEGENERATED : BOOLEAN ; BADGENERATEDCODE : BOOLEAN ; OVERFLOWOCCURRED,POSOVERFLOW : BOOLEAN ; REVERSEOF : ARRAY[LTOP..EQOP] OF LTOP..EQOP ; POINTFIVE,CODEDESCRIPTOR : VALU ; FALSECCMASKFOR : ARRAY[LTOP..EQOP] OF MASKFORJUMP ; FALSESTRINGMASKFOR : ARRAY[LTOP..EQOP] OF MASKFORJUMP ; FALSEINTEGERJUMPFOR : ARRAY[LTOP..EQOP] OF ACCJUMP ; SPECIALORDER : ARRAY [ORF..ISHF] OF ORDERCODE ; REALMATH : ARRAY[SINF..ARCTANF] OF SUPPORTTASK ; LINEFEED,PAGETHROW : VALU ; FILEVARIABLE : SEGMENTSIZE ; WHICHMODE : ARRAY[BOOLEAN] OF READORWRITEFILE ; WHICHFILEPROCEDURE : ARRAY[GETP..REWRITEP,BOOLEAN] OF SUPPORTTASK ; READREPRESENTATION : ARRAY[INPUTKIND] OF TYPEREPRESENTATION ; READPROCEDURE : ARRAY[INPUTKIND] OF SUPPORTTASK ; WRITEPROCEDURE : ARRAY[INTKIND..BOOLKIND] OF SUPPORTTASK ; DEFAULTWIDTH : ARRAY[INTKIND..BOOLKIND] OF 1..100 ; (*---- EXTERNAL COMPILATION SUPPORT INTERFACE ----*) (* -------------------------------------- *) (* -IN "CTSYSIF" MODULE -INTERFACE TO ICL CE AND EDINBURGH C-T *) (* ROUTINES -FACILITIES FOR JCL OPTIONS COMMUNICATION, SOURCE *) (* INPUT, LISTING FILE ACCESS AND PAGE HEADING SPECIFICATION, *) (* OBJECT CODE LISTING, COMPILATION ERROR NOTIFICATION, OBJECT *) (* MODULE GENERATION (-THE OLD "LPUT INTERFACE") *) PROCEDURE ICL9LPCTGIVEENVOPTIONS (VAR OPTIONSSETON : SETOFOPTIONS ; VAR ORDCHARCODEREQUESTED : INTEGER ) ; EXTERN ; PROCEDURE ICL9LPCTNEXTSOURCELINE (VAR LINE : SOURCELINEBUF; VAR LENGTH : LINEPOSITION; VAR STATUS : EXTERNSOURCESTATUS) ; EXTERN ; PROCEDURE ICL9LPCTGETLISTFILEPTR (VAR LISTFILEP : TEXTPT) ; EXTERN ; PROCEDURE ICL9LPCTUPDATELISTHEADING (KIND : LISTPAGEHEADINGKIND; VARIABLEPART : ALFA) ; EXTERN ; PROCEDURE ICL9LPCTSUMMARYHEADING (MINLINECOUNT : POSITIVEINTEGER; THROWPAGE : BOOLEAN) ; EXTERN ; PROCEDURE ICL9LPCTPLILIST (CODESIZEB : BYTESEGMENTSIZE ; FROMAD : VADDRESS ; QUOTECODEOFFSETB : BYTESEGMENTSIZE ) ; EXTERN ; PROCEDURE ICL9LPNOTECOMPILEERRORS (ERRORCOUNT : POSITIVEINTEGER) ; EXTERN ; PROCEDURE ICL9LPOMGINIT (COMPILERVERSION, COMPILERMARK : BYTE ) ; EXTERN ; PROCEDURE ICL9LPOMGFINISH (STDAREASIZES : STDAREAVECTOR ; GLOBALAREASIZE : BYTESEGMENTSIZE) ; EXTERN ; PROCEDURE ICL9LPOMGMNENTRY (MAINENTRYNAME : ALFA ; PLTDESCOFFSETWD : SEGMENTSIZE) ; EXTERN ; PROCEDURE ICL9LPOMGENTRY (ENTRYNAME : ALFA ; PLTDESCOFFSETWD : SEGMENTSIZE) ; EXTERN ; PROCEDURE ICL9LPOMGEXTREF (EXTREFNAME : ALFA ; PLTDESCOFFSETWD : SEGMENTSIZE) ; EXTERN ; PROCEDURE ICL9LPOMGRELOC (BASEAREA : STDAREATYPE ; OFFSETINAREAB : BYTESEGMENTSIZE ; PLTDESCOFFSETWD : SEGMENTSIZE) ; EXTERN ; PROCEDURE ICL9LPOMGAREANAM (AREANAME : ALFA ; AREASIZEB : BYTESEGMENTSIZE ; PLTDESCOFFSETWD : SEGMENTSIZE) ; EXTERN ; PROCEDURE ICL9LPOMGCOPY (COPYSIZEB : BYTESEGMENTSIZE ; FROMAD : VADDRESS ; INTOAREA : STDAREATYPE ; OFFSETINAREAB : BYTESEGMENTSIZE) ; EXTERN ; (*---- BASIC ERROR HANDLING SPECS. ----*) (* --------------------------- *) PROCEDURE ERROR (CODE : INTEGER); FORWARD; (*#E+ %KEYEDENTRY ON *) PROCEDURE ICL9LPCTERROR (CODE : INTEGER); BEGIN ERROR (CODE) ; END (* ICL9LPCTERROR *) ; (*#E- %KEYEDENTRY OFF *) PROCEDURE NOTECOMPILATIONERRORCOUNT; BEGIN ICL9LPNOTECOMPILEERRORS(ERRORCOUNT); END (* NOTECOMPILATIONERRORCOUNT *); (* ---------------- THE DIAGNOSTICS HANDLER ----------------------- *) (* ---- CODE MAP HANDLING ---- *) PROCEDURE PUTMAPBYTE (B:BYTE); VAR PACKEDB : PACKED ARRAY [0..0] OF BYTE ; BEGIN PACKEDB[0] := B ; ICL9LPOMGCOPY(1, ADDRESSOF(PACKEDB), DIAGMAPAREA, DIAGMAPSIZE); (* IF (DIAGMAPSIZE<60) OR (DIAGMAPSIZE>=10440) THEN WRITELN(LISTINGP@, 'MAP BYTE', DIAGMAPSIZE:6, B:6, '=':3, B DIV 128:3, B MOD 128 DIV 64:3, B MOD 64 DIV 32:3, B MOD 32:3, ' LINE =', SOURCE.LINENUMBER:6); *) DIAGMAPSIZE := DIAGMAPSIZE + 1; END (* PUTMAPBYTE *) ; PROCEDURE INITMAPFILE; BEGIN DIAGMAPSIZE := 0; PREVLINE := 0; PREVINS := 0; END (* INITMAPFILE *) ; PROCEDURE ENDMAPFILE; BEGIN END (* ENDMAPFILE *) ; PROCEDURE MAPTHISBLOCK (BLOCK : IDENTRY); VAR BLOCKKIND : KINDOFBLOCK; I, NAMELENGTH : 0..ALFALENGTH; BEGIN IF CODEISTOBEGENERATED AND REQD[LINEMAP] THEN BEGIN PUTMAPBYTE(0); PUTMAPBYTE(0); IF REQD[DUMP] THEN BEGIN PUTMAPBYTE(BLOCK@.SERIAL DIV 256); PUTMAPBYTE(BLOCK@.SERIAL MOD 256); END ELSE WITH BLOCK@ DO BEGIN IF KLASS=PROG THEN BLOCKKIND:=PROGBLOCK ELSE IF KLASS=PROC THEN BLOCKKIND:=PROCBLOCK ELSE IF KLASS=FUNC THEN BLOCKKIND:=FUNCBLOCK ELSE (* SHOULD NEVER HAPPEN *) BLOCKKIND:=UNKNOWNBLOCK; PUTMAPBYTE(ORD(BLOCKKIND)); IF NAME[1]=BLANK THEN NAMELENGTH:=0 ELSE BEGIN NAMELENGTH:=ALFALENGTH; WHILE NAME[NAMELENGTH]=BLANK DO NAMELENGTH:=NAMELENGTH-1; END; PUTMAPBYTE(NAMELENGTH); FOR I:=1 TO NAMELENGTH DO PUTMAPBYTE( ORD(NAME[I]) ); END ; END; END (* MAPTHISBLOCK *) ; PROCEDURE MAPTHISLINE; CONST TOOMUCHOBJECTCODEINTHISLINE = 294; VAR CODEDELTA, LINEDELTA : 0..MAXINT; CODEDELTABYTE, LINEDELTABYTE : BYTE; LONGLINEDELTA, LONGCODEDELTA : BOOLEAN; BEGIN IF CODEISTOBEGENERATED THEN BEGIN CODEDELTA := NEXTINS - PREVINS; IF (CODEDELTA>0) AND REQD[LINEMAP] THEN BEGIN PREVINS := NEXTINS; LINEDELTA := SOURCE.LINENUMBER - PREVLINE - 1; PREVLINE := SOURCE.LINENUMBER; WHILE LINEDELTA>511 DO BEGIN PUTMAPBYTE(192); PUTMAPBYTE(255); LINEDELTA := LINEDELTA - 511; END; LONGLINEDELTA := LINEDELTA>1; IF LONGLINEDELTA THEN BEGIN LINEDELTABYTE := LINEDELTA MOD 256; LINEDELTA := LINEDELTA DIV 256; END; LONGCODEDELTA := CODEDELTA>31; IF LONGCODEDELTA THEN BEGIN CODEDELTABYTE := CODEDELTA MOD 256; CODEDELTA := CODEDELTA DIV 256; IF CODEDELTA>31 THEN BEGIN CODEDELTABYTE := 255; CODEDELTA := 31; ERROR(TOOMUCHOBJECTCODEINTHISLINE); END; END; PUTMAPBYTE(ORD(LONGLINEDELTA)*128 + LINEDELTA*64 + ORD(LONGCODEDELTA)*32 + CODEDELTA); IF LONGCODEDELTA THEN PUTMAPBYTE(CODEDELTABYTE); IF LONGLINEDELTA THEN PUTMAPBYTE(LINEDELTABYTE); END; END; END (* MAPTHISLINE *) ; PROCEDURE NEWCODEDELTAINMAP; VAR CODEDELTA: BYTE; BEGIN CODEDELTA:=NEXTINS-PREVINS; PREVINS:=NEXTINS; PUTMAPBYTE(CODEDELTA DIV 256); PUTMAPBYTE(CODEDELTA MOD 256); END (* NEWCODEDELTAINMAP *); (* N.B. :- *) (* THE FOLLOWING THREE PROCEDURES SHOULD ALWAYS BE CALLED AS A TRIO *) (* IN IMMEDIATE SEQUENCE, I.E. WITH NO CALLS TO OTHER "MAP" PROCEDURES *) (* INTERVENING. *) PROCEDURE STARTMAPFORJLKTASK; BEGIN IF CODEISTOBEGENERATED AND REQD[LINEMAP] THEN BEGIN PUTMAPBYTE(0); PUTMAPBYTE(1); NEWCODEDELTAINMAP; END; END (* STARTMAPFORJLKTASK *); PROCEDURE MAPFENCEFORJLKTASK; BEGIN IF CODEISTOBEGENERATED AND REQD[LINEMAP] THEN BEGIN NEWCODEDELTAINMAP; END; END (* MAPFENCEFORJLKTASK *); PROCEDURE ENDMAPFORJLKTASK; BEGIN IF CODEISTOBEGENERATED AND REQD[LINEMAP] THEN BEGIN NEWCODEDELTAINMAP; END; END (* ENDMAPFORJLKTASK *); (* ---- TOKEN FILE HANDLING ---- *) PROCEDURE PUTTOKEN; BEGIN END (* PUTTOKEN *) ; PROCEDURE INITTOKENFILE; BEGIN DIAGTOKENSIZE := 0; TOKENSTOBESAVED := FALSE END (* INITTOKENFILE *) ; PROCEDURE ENDTOKENFILE; BEGIN IF COUNTREQD AND TOKENSTOBESAVED THEN PUTTOKEN (* THE LAST TOKEN *) END (* ENDTOKENFILE *) ; PROCEDURE MARKFLOWPOINT (FLOWLOC: FLOWADDRRANGE; WILLBECOUNTED: BOOLEAN; COUNTLOC: COUNTERADDRRANGE) ; VAR TOKEN: TOKENREC; BEGIN IF CODEISTOBEGENERATED AND COUNTREQD THEN BEGIN TOKEN := TOKENBEINGSAVED; WITH TOKENBEINGSAVED DO BEGIN TOKENKIND := FLOWTOKEN; FLOWADDRESS := FLOWLOC; COUNTED := WILLBECOUNTED; IF WILLBECOUNTED THEN COUNTADDRESS := COUNTLOC; END; PUTTOKEN; TOKENBEINGSAVED := TOKEN END END (* MARKFLOWPOINT *) ; PROCEDURE MARKBREAK (KIND: KINDOFBREAK) ; VAR TOKEN: TOKENREC; BEGIN IF CODEISTOBEGENERATED AND COUNTREQD THEN BEGIN TOKEN := TOKENBEINGSAVED; WITH TOKENBEINGSAVED DO BEGIN TOKENKIND := BREAKTOKEN; BREAKADDRESS := NEXTINS; BREAKKIND := KIND; END; PUTTOKEN; TOKENBEINGSAVED := TOKEN END END (* MARKLABEL *) ; PROCEDURE PRESERVETOKEN; BEGIN IF CODEISTOBEGENERATED AND COUNTREQD THEN BEGIN IF TOKENSTOBESAVED THEN PUTTOKEN; (* THE PREVIOUS TOKEN, IF ANY *) WITH TOKENBEINGSAVED DO BEGIN TOKENKIND := SYMBOLTOKEN; TOKENSYMBOL := SYMBOL; CASE SYMBOL OF IDENT: TOKENSPELLING := SPELLING; INTCONST: TOKENINTVAL := CONSTANT.IVAL1; REALCONST: TOKENREALVAL := CONSTANT.RVAL; CHARCONST: TOKENCHARVAL := CONSTANT.CVAL; MULOP, ADDOP, RELOP: TOKENOP := OPERATOR; STRINGCONST, NOTSY,LEFTPARENT,RIGHTPARENT,LEFTBRACKET,RIGHTBRACKET, COMMA,SEMICOLON,PERIOD,DOTDOTSY,ARROW,COLON,BECOMES, LABELSY,CONSTSY,TYPESY,VARSY,FUNCSY,PROCSY,SETSY, PACKEDSY,ARRAYSY,RECORDSY,FILESY, BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY, GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY, THENSY,PROGRAMSY,VALUESY,OTHERSY: END (* CASE *) END (* WITH *) END END (* PRESERVETOKEN *) ; PROCEDURE STARTSAVINGTOKENS ; BEGIN TOKENSTOBESAVED := TRUE END (* STARTSAVINGTOKENS *) ; PROCEDURE STOPSAVINGTOKENS ; BEGIN TOKENSTOBESAVED := FALSE END (* STOPSAVINGTOKENS *) ; (* ---- OBJECT FILE HANDLING ---- *) PROCEDURE INITOBJECTFILE; BEGIN DIAGOBJSIZE := 0; NEXTSERIAL := NILSERIAL+1; END (* INITOBJECTFILE *) ; PROCEDURE PUTOBJECT (VAR OBJECT: OBJECTDESCR); BEGIN WITH OBJECT DO BEGIN ICL9LPOMGCOPY(SIZEINBYTES, ADDRESSOF(OBJECT), DIAGOBJECTAREA, DIAGOBJSIZE); DIAGOBJSIZE := DIAGOBJSIZE + SIZEINBYTES; (* IF (OBJSERIAL>2000) OR (OBJSERIAL<=300) THEN BEGIN WRITE(LISTINGP@, 'OBJECT', OBJSERIAL:6); CASE OBJCLASS OF CONSTS: WRITE(LISTINGP@, ' CONST ', CONSTNAME, CONSTVALUE:6, NEXTCONST:6); VARS: WRITE(LISTINGP@, ' VAR ', VARNAME, VARTYPE:6, LOCALADDRESS:6, NEXTLOCALVAR:6); FIELD: WRITE(LISTINGP@, ' FIELD ', FIELDTYPE:6, NEXTFIELD:6); PROG, PROC, FUNC: WRITE(LISTINGP@, ' BLOCK ', BLOCKNAME, FIRSTLOCALVAR:6); TYPES: WRITE(LISTINGP@, ' TYPE ', ORD(OBJFORM):6); END; WRITELNLISTINGP@); END; *) END; END (* PUTOBJECT *) ; PROCEDURE ENDOBJECTFILE; BEGIN END (*ENDOBJECTFILE*) ; PROCEDURE ISERIALISE (ID: IDENTRY); BEGIN IF CODEISTOBEGENERATED AND (ID<>NIL) THEN BEGIN ID@.SERIAL := NEXTSERIAL; NEXTSERIAL := NEXTSERIAL+1 END END (* ISERIALISE *) ; PROCEDURE TSERIALISE (TYP: TYPENTRY); BEGIN IF CODEISTOBEGENERATED AND (TYP<>NIL) THEN BEGIN TYP@.SERIAL := NEXTSERIAL; NEXTSERIAL := NEXTSERIAL+1 END END (* TSERIALISE *) ; FUNCTION IDSERIALOF (ID: IDENTRY): SERIALRANGE; BEGIN IF ID=NIL THEN IDSERIALOF := NILSERIAL ELSE IDSERIALOF := ID@.SERIAL END (* IDSERIALOF *) ; FUNCTION TYPESERIALOF (TYP: TYPENTRY): SERIALRANGE; BEGIN IF TYP=NIL THEN TYPESERIALOF := NILSERIAL ELSE TYPESERIALOF := TYP@.SERIAL END (* TYPESERIALOF *) ; FUNCTION INTERNALVALUE (GENERALISEDVALUE : VALU) : INTEGER; BEGIN WITH GENERALISEDVALUE DO CASE KIND OF INTVALUE: INTERNALVALUE := IVAL1; BOOLVALUE: INTERNALVALUE := ORD(BVAL); CHARVALUE: INTERNALVALUE := CVAL END END (* INTERNALVALUE *) ; PROCEDURE FILEID (ID, NEXTID: IDENTRY); VAR OBJECT: OBJECTDESCR; SERIALOFNEXTID: SERIALRANGE; BEGIN IF ID<>NIL THEN BEGIN SERIALOFNEXTID := IDSERIALOF(NEXTID); WITH ID@, OBJECT DO BEGIN OBJSERIAL := SERIAL; OBJCLASS := KLASS; CASE KLASS OF CONSTS: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, CONSTS); CONSTNAME := NAME; CONSTVALUE := INTERNALVALUE(VALUES); NEXTCONST := SERIALOFNEXTID END; VARS: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, VARS); VARNAME := NAME; VARTYPE := TYPESERIALOF(IDTYPE); ISVARPARAM := VARPARAM; LOCALADDRESS := VARADDRESS.RELATIVEADDRESS; NEXTLOCALVAR := SERIALOFNEXTID END; FIELD: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, FIELD); FIELDTYPE := TYPESERIALOF(IDTYPE); OBJOFFSET := OFFSET; NEXTFIELD := SERIALOFNEXTID END; PROG,PROC,FUNC: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, PROG); BLOCKNAME := NAME; FIRSTLOCALVAR := SERIALOFNEXTID END END (* CASE *) END (* WITH *) ; PUTOBJECT(OBJECT) END END (* FILEID *) ; PROCEDURE FILETYPE (TYP: TYPENTRY); VAR OBJECT: OBJECTDESCR; PROCEDURE FILEIDLIST (FIRSTID: IDENTRY); VAR THISID, NEXTID: IDENTRY; BEGIN THISID := FIRSTID; WHILE THISID<>NIL DO BEGIN NEXTID := THISID@.NEXT; FILEID(THISID,NEXTID); THISID := NEXTID END END (* FILEIDLIST *) ; BEGIN (* FILETYPE *) IF TYP<>NIL THEN BEGIN WITH TYP@, OBJECT DO BEGIN OBJSERIAL := SERIAL; OBJCLASS := TYPES; OBJREPRESENTATION := REPRESENTATION; OBJFORM := FORM; CASE FORM OF SCALARS: BEGIN OBJSCALARKIND := SCALARKIND; CASE SCALARKIND OF STANDARD: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, SCALARS,STANDARD); IF TYP=INTTYPE THEN STDTYPE := INTSTD ELSE IF TYP=REALTYPE THEN STDTYPE := REALSTD ELSE IF TYP=CHARTYPE THEN STDTYPE := CHARSTD; END; DECLARED: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, SCALARS, DECLARED); FILEIDLIST(FIRSTCONST); OBJFIRSTCONST := IDSERIALOF(FIRSTCONST) END END (* CASE SCALARKIND *) ; END; SUBRANGES: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, SUBRANGES); OBJRANGETYPE := TYPESERIALOF(RANGETYPE); OBJMIN := MIN; OBJMAX := MAX END; POINTERS: SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, POINTERS); SETS: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, SETS); SETISPACKED := PACKEDSET; OBJBASETYPE := TYPESERIALOF(BASETYPE) END; ARRAYS: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, ARRAYS); ARRAYISPACKED := PACKEDARRAY; OBJAELTYPE := TYPESERIALOF(AELTYPE); OBJINXTYPE := TYPESERIALOF(INXTYPE) END; RECORDS: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, RECORDS); FILEIDLIST(NONVARPART); RECORDISPACKED := PACKEDRECORD; OBJNONVARPART := IDSERIALOF(NONVARPART); OBJVARPART := TYPESERIALOF(VARPART) END; FILES: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, FILES); FILEISPACKED := PACKEDFILE; FILEISTEXT := TEXTFILE; OBJFELTYPE := TYPESERIALOF(FELTYPE) END; VARIANTPART: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, VARIANTPART); FILEID(TAGFIELD,NIL); OBJTAGFIELD := IDSERIALOF(TAGFIELD); OBJTAGTYPE := TYPESERIALOF(TAGTYPE) ; OBJFSTVARIANT := TYPESERIALOF(FIRSTVARIANT) END; VARIANT: BEGIN SIZEINBYTES := BYTESIZEOF (OBJECT, TYPES, VARIANT); FILEIDLIST(FSTVARFIELD); OBJSUBNONVARPART := IDSERIALOF(FSTVARFIELD); OBJSUBVARPART := TYPESERIALOF(SUBVARPART); OBJNEXTVARIANT := TYPESERIALOF(NEXTVARIANT); OBJVARIANTVALUE := INTERNALVALUE(VARIANTVALUE) END END (* CASE FORM *) END (* WITH *) ; PUTOBJECT(OBJECT) END END (* FILETYPE *) ; PROCEDURE FILESCOPE (BLOCKID: IDENTRY) ; VAR PREVIOUSVAR: IDENTRY; THISTYPE: TYPENTRY; PROCEDURE FILELOCALVARS (ENTRY: IDENTRY) ; BEGIN IF ENTRY<>NIL THEN WITH ENTRY@ DO BEGIN FILELOCALVARS(RIGHTLINK); IF KLASS=VARS THEN BEGIN FILEID(ENTRY,PREVIOUSVAR); PREVIOUSVAR := ENTRY END; FILELOCALVARS(LEFTLINK); END END (* FILELOCALVARS *) ; BEGIN (* FILESCOPE *) IF CODEISTOBEGENERATED AND REQD[DUMP] THEN WITH DISPLAY[LEVEL] DO BEGIN (* FILE LOCAL VARIABLES, INCLUDING FORMAL PARAMETERS *) PREVIOUSVAR := NIL; FILELOCALVARS(IDSCOPE); (* FILE BLOCK *) FILEID(BLOCKID,PREVIOUSVAR); (* FILE TYPES *) THISTYPE := TYPECHAIN; WHILE THISTYPE<>NIL DO BEGIN FILETYPE(THISTYPE); THISTYPE := THISTYPE@.NEXT END; END END (* FILESCOPE *) ; PROCEDURE FILESTDTYPES ; (* ... WHICH HAVE NOT YET BEEN SERIALISED *) BEGIN IF CODEISTOBEGENERATED AND REQD[DUMP] THEN BEGIN TSERIALISE(INTTYPE); FILETYPE(INTTYPE); TSERIALISE(REALTYPE); FILETYPE(REALTYPE); TSERIALISE(CHARTYPE); FILETYPE(CHARTYPE); (* SERIALISE BOOLEAN CONSTANTS *) WITH BOOLTYPE@ DO BEGIN ISERIALISE(FIRSTCONST); ISERIALISE(FIRSTCONST@.NEXT) END; TSERIALISE(BOOLTYPE); FILETYPE(BOOLTYPE); TSERIALISE(TEXTTYPE); FILETYPE(TEXTTYPE); TSERIALISE(ALFATYPE@.INXTYPE); FILETYPE(ALFATYPE@.INXTYPE); TSERIALISE(ALFATYPE); FILETYPE(ALFATYPE); TSERIALISE(ALFA8TYPE@.INXTYPE); FILETYPE(ALFA8TYPE@.INXTYPE); TSERIALISE(ALFA8TYPE); FILETYPE(ALFA8TYPE); END END (* FILESTDTYPES *) ; (* ---- FLOW ANALYSIS ---- *) PROCEDURE INITFLOWANALYSISOFBODY ; VAR D : DISPRANGE; BEGIN IF CODEISTOBEGENERATED AND COUNTREQD THEN BEGIN GOTOSPOSSIBLE := FALSE; FOR D := GLOBALLEVEL TO LEVEL DO GOTOSPOSSIBLE := GOTOSPOSSIBLE OR (DISPLAY[D].FIRSTLABEL<>NIL); MUSTCOUNTNEXTFLOWUNIT := TRUE END END (* INITFLOWANALYSISOFBODY *) ; PROCEDURE ENTERFLOWUNIT (FLOWROUTINE : SUPPORTTASK; VAR FLOWLOC : FLOWADDRRANGE; VAR COUNTLOC : COUNTERADDRRANGE) ; FORWARD ; (* IN THE CODE GENERATOR *) PROCEDURE FLOWPOINT ; VAR FLOWROUTINE : SUPPORTTASK; WILLBECOUNTED : BOOLEAN; FLOWLOC : FLOWADDRRANGE; COUNTLOC : COUNTERADDRRANGE; BEGIN IF CODEISTOBEGENERATED AND COUNTREQD THEN BEGIN WILLBECOUNTED := TRUE; IF LOCALLYREQD[TRACE] THEN FLOWROUTINE := TRACEFLOW ELSE IF REQD[RETRO] THEN FLOWROUTINE := RETROFLOW ELSE IF REQD[PROFILE] AND MUSTCOUNTNEXTFLOWUNIT THEN FLOWROUTINE := COUNTFLOW ELSE WILLBECOUNTED := FALSE; IF WILLBECOUNTED THEN BEGIN ENTERFLOWUNIT(FLOWROUTINE,FLOWLOC,COUNTLOC); MARKFLOWPOINT(FLOWLOC,TRUE,COUNTLOC) END ELSE MARKFLOWPOINT(NEXTINS,FALSE,0); MUSTCOUNTNEXTFLOWUNIT := GOTOSPOSSIBLE END END (* FLOWPOINT *) ; PROCEDURE COUNTNEXTFLOWUNIT ; BEGIN IF CODEISTOBEGENERATED THEN MUSTCOUNTNEXTFLOWUNIT := TRUE END (* COUNTNEXTFLOWUNIT *) ; (* ------------------------------ *) PROCEDURE GETDIAGAREASIZES (VAR OBJSIZE, TOKENSIZE, MAPSIZE : INTEGER) ; BEGIN OBJSIZE := DIAGOBJSIZE ; TOKENSIZE := DIAGTOKENSIZE ; MAPSIZE := DIAGMAPSIZE ; END (* GETDIAGAREASIZES *) ; PROCEDURE INITDIAGNOSTICS ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN INITTOKENFILE; INITOBJECTFILE; INITMAPFILE; END; END (* INITDIAGNOSTICS *) ; PROCEDURE ENDDIAGNOSTICS ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN ENDTOKENFILE; ENDOBJECTFILE; ENDMAPFILE; END; END (* ENDDIAGNOSTICS *) ; (*---- GENERAL PURPOSE PROCEDURES AND FUNCTIONS USED BY BOTH THE SYNTAX ANALYSER AND THE CODE GENERATOR. ----*) FUNCTION TWOSCOMPLEMENT ( A : INTEGER ; MODULUS : POSITIVEINTEGER ) : INTEGER ; BEGIN IF A >= 0 THEN TWOSCOMPLEMENT := A ELSE TWOSCOMPLEMENT := MODULUS + A END (* TWOSCOMPLEMENT *) ; FUNCTION EQUALVALUES ( A,B : VALU ) : BOOLEAN ; VAR P,Q : STRINGP ; EQUALSTRINGS : BOOLEAN ; BEGIN IF ( A.KIND = B.KIND ) AND ( A.SIZE = B.SIZE ) THEN CASE A.KIND OF INTVALUE : IF A.SIZE = 1 THEN EQUALVALUES := (A.IVAL1=B.IVAL1) ELSE EQUALVALUES := (A.IVAL1=B.IVAL1) AND (A.IVAL2=B.IVAL2) ; BOOLVALUE : EQUALVALUES := A.BVAL = B.BVAL ; CHARVALUE : EQUALVALUES := A.CVAL = B.CVAL ; REALVALUE : EQUALVALUES := A.RVAL = B.RVAL ; SETVALUE : EQUALVALUES := A.SVAL = B.SVAL ; STRINGVALUE : BEGIN P := A.STRING ; Q := B.STRING ; EQUALSTRINGS := TRUE ; WHILE ( P <> NIL ) AND ( Q <> NIL ) AND EQUALSTRINGS DO BEGIN IF P@.WORD <> Q@.WORD THEN EQUALSTRINGS := FALSE ; P := P@.NEXTWORD ; Q := Q@.NEXTWORD END ; IF ( P <> NIL ) OR ( Q <> NIL ) THEN EQUALVALUES := FALSE ELSE EQUALVALUES := EQUALSTRINGS END END ELSE EQUALVALUES := FALSE END (* EQUALVALUES *) ; PROCEDURE A8TOALFA ( A8 : ALFA8 ; VAR A : ALFA ) ; VAR I : ALFARANGE ; BEGIN FOR I := 1 TO ALFA8LENGTH DO A[I] := A8[I] ; FOR I := ALFA8LENGTH+1 TO ALFALENGTH DO A[I] := BLANK ; END (* A8TOALFA *) ; PROCEDURE ALFATOA8 ( A : ALFA ; VAR A8 : ALFA8 ) ; VAR I : ALFA8RANGE ; BEGIN FOR I := 1 TO ALFA8LENGTH DO A8[I] := A[I] ; END (* ALFATOA8 *) ; FUNCTION BYTESNEEDEDFOR ( N : INTEGER ) : BYTERANGE ; VAR BYTESREQUIRED : 0..BYTESINWORD ; BEGIN BYTESREQUIRED := 0 ; REPEAT BYTESREQUIRED := BYTESREQUIRED + 1 ; N := N DIV (MAXINTFORBYTE + 1) UNTIL N = 0 ; BYTESNEEDEDFOR := BYTESREQUIRED END (* BYTESNEEDEDFOR *) ; FUNCTION NUMBERISPOWEROF2 ( N : INTEGER ; VAR POWER : POWERRANGE ) : BOOLEAN ; VAR LOCALPOWER : POWERRANGE ; BEGIN LOCALPOWER := 0 ; IF N <> 0 THEN WHILE N MOD 2 = 0 DO BEGIN LOCALPOWER := LOCALPOWER + 1 ; N := N DIV 2 END ; POWER := LOCALPOWER ; NUMBERISPOWEROF2 := N = 1 ; END (* NUMBERISPOWEROF2 *) ; PROCEDURE GETBOUNDS ( BOUNDTYPE : TYPENTRY ; VAR BOUNDMIN,BOUNDMAX : INTEGER ) ; VAR NEXTCONST : IDENTRY ; BEGIN WITH BOUNDTYPE@ DO IF FORM = SUBRANGES THEN BEGIN BOUNDMIN := MIN ; BOUNDMAX := MAX END ELSE BEGIN BOUNDMIN := 0 ; IF BOUNDTYPE = CHARTYPE THEN BOUNDMAX := CHARREPRESENTATION.MAX ELSE IF BOUNDTYPE@.FIRSTCONST <> NIL THEN BEGIN NEXTCONST := BOUNDTYPE@.FIRSTCONST ; REPEAT BOUNDMAX := NEXTCONST@.VALUES.IVAL1 ; NEXTCONST := NEXTCONST@.NEXT UNTIL NEXTCONST = NIL END ELSE BOUNDMAX := 0 END END (* GETBOUNDS *) ; FUNCTION CARDINALITY ( THISTYPE : TYPENTRY ) : POSITIVEINTEGER ; VAR MAX,MIN : INTEGER ; BEGIN GETBOUNDS(THISTYPE,MIN,MAX) ; CARDINALITY := MAX - MIN + 1 END (* CARDINALITY *) ; (*---- T H E C O D E G E N E R A T O R ----*) (* --------------------------------- *) PROCEDURE CREATESTACK ; FORWARD ; PROCEDURE INITDISPLAY ; FORWARD ; PROCEDURE INITCODEGENERATION ; VAR I : 0..7 ; BEGIN NEXTINS := 0 ; FOR I := 0 TO 7 DO BEGIN ACCORDERS[I] := [ ] ; FORCESTOREORDERS[I] := [ ] END ; ACCORDERS[0] := [ CYD MOD 32 ] ; ACCORDERS[2] := [ SL MOD 32 , ST MOD 32 , SLSS MOD 32 , SLSQ MOD 32 , SLSD MOD 32 , STUH MOD 32 ] ; ACCORDERS[3] := [ L MOD 32 , LSS MOD 32 , LSD MOD 32 , LSQ MOD 32 , LUH MOD 32 ] ; ACCORDERS[4] := [ LOR MOD 32 , LAND MOD 32 , NEQ MOD 32 ] ; ACCORDERS[5] := [ FLT MOD 32 , IDV MOD 32 , FIX MOD 32 , RDV MOD 32 , IRDV MOD 32 , RRDV MOD 32 , RDVD MOD 32 , IMDV MOD 32 ] ; ACCORDERS[6] := [ UAD MOD 32 , USB MOD 32 , USH MOD 32 , ROT MOD 32 , SHS MOD 32 , SHZ MOD 32 , URSB MOD 32 ] ; ACCORDERS[7] := [ IAD MOD 32 , ISB MOD 32 , ISH MOD 32 , RSB MOD 32 , RSC MOD 32 , RMY MOD 32 , RRSB MOD 32 , RMYD MOD 32 , IMY MOD 32 , IRSB MOD 32 , RAD MOD 32 ] ; FORCESTOREORDERS[0] := [ PRCL MOD 32 , CYD MOD 32 ] ; FORCESTOREORDERS[1] := [ LCT MOD 32 , MPSR MOD 32 ,EXIT MOD 32] ; FORCESTOREORDERS[2] := [ SLD MOD 32 , SLB MOD 32 ] ; FORCESTOREORDERS[3] := [ ASF MOD 32 , LLN MOD 32 , LXN MOD 32 , RALN MOD 32 ] ; GLOBALDESCRIPTORS[ONEBYTE ] := BASESTART + 0 ; GLOBALDESCRIPTORS[TWOBYTE ] := BASESTART + 2 ; GLOBALDESCRIPTORS[THREEBYTE ] := BASESTART + 4 ; GLOBALDESCRIPTORS[ONEWORDUNSCALED] := BASESTART + 6 ; GLOBALDESCRIPTORS[ONEWORDSCALED ] := BASESTART + 8 ; GLOBALDESCRIPTORS[TWOWORDUNSCALED] := BASESTART + 10 ; GLOBALDESCRIPTORS[TWOWORDSCALED ] := BASESTART + 12 ; GLOBALDESCRIPTORS[FORWORDSCALED ] := BASESTART + 14 ; GLOBALDESCRIPTORS[FORWORDUNSCALED] := BASESTART + 16 ; TYPEANDBOUND [ ONEBYTE ] := BYTEDESCRIPTOR + XFFFFFF ; TYPEANDBOUND [ TWOBYTE ] := TWOBYTEDESCRIPTOR ; TYPEANDBOUND [ THREEBYTE ] := THREBYTEDESCRIPTOR ; TYPEANDBOUND [ ONEWORDUNSCALED ] := UNSCLONEWORD + XFFFFFF ; TYPEANDBOUND [ ONEWORDSCALED ] := SCLONEWORD + XFFFFFF ; TYPEANDBOUND [ TWOWORDUNSCALED ] := UNSCLTWOWORD + XFFFFFF ; TYPEANDBOUND [ TWOWORDSCALED ] := SCLTWOWORD + XFFFFFF ; TYPEANDBOUND [ FORWORDUNSCALED ] := UNSCLFOURWORD + XFFFFFF ; TYPEANDBOUND [ FORWORDSCALED ] := SCLFOURWORD + XFFFFFF ; ACCESSDESCRIPTOR[1] := ONEBYTE ; ACCESSDESCRIPTOR[2] := TWOBYTE ; ACCESSDESCRIPTOR[3] := THREEBYTE ; ACCESSDESCRIPTOR[4] := ONEWORDSCALED ; BYTESFOR[ONEBYTE ] := 1 ; BYTESFOR[TWOBYTE ] := 1 ; BYTESFOR[THREEBYTE ] := 1 ; BYTESFOR[ONEWORDUNSCALED ] := 4 ; BYTESFOR[ONEWORDSCALED ] := 4 ; BYTESFOR[TWOWORDUNSCALED ] := 8 ; BYTESFOR[TWOWORDSCALED ] := 8 ; BYTESFOR[FORWORDUNSCALED] := 16 ; BYTESFOR[FORWORDSCALED ] := 16 ; UNSCALEDDESCRIPTORFOR[ONEBYTE ] := ONEBYTE ; UNSCALEDDESCRIPTORFOR[TWOBYTE ] := TWOBYTE ; UNSCALEDDESCRIPTORFOR[THREEBYTE ] := THREEBYTE ; UNSCALEDDESCRIPTORFOR[ONEWORDUNSCALED ] := ONEWORDUNSCALED ; UNSCALEDDESCRIPTORFOR[ONEWORDSCALED ] := ONEWORDUNSCALED ; UNSCALEDDESCRIPTORFOR[TWOWORDUNSCALED ] := TWOWORDUNSCALED ; UNSCALEDDESCRIPTORFOR[TWOWORDSCALED ] := TWOWORDUNSCALED ; UNSCALEDDESCRIPTORFOR[FORWORDUNSCALED] := FORWORDUNSCALED ; UNSCALEDDESCRIPTORFOR[FORWORDSCALED ] := FORWORDUNSCALED ; WITH DEFAULTADDRESS DO BEGIN BLOCKLEVEL := GLOBALLEVEL ; RELATIVEADDRESS := 0 ; END ; WITH BYTEREPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 1 ; BYTESIZE := 1 ; MIN := 0 ; MAX := MAXINTFORBYTE ; END ; WITH INTEGERREPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 1 ; BYTESIZE := BYTESINWORD ; MIN := -MAXINT ; MAX := +MAXINT END ; WITH REALREPRESENTATION DO BEGIN ACCESSDESCRIPTOR := TWOWORDSCALED ; SIZE := 2 END ; WITH BOOLEANREPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 1 ; BYTESIZE := 1 ; MIN := 0 ; MAX := 1 END ; WITH CHARREPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 1 ; BYTESIZE := 1 ; MIN := ORDSMALLESTCHAR ; MAX := ORDLARGESTCHAR END ; WITH ALFAREPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 8 END ; WITH ALFA8REPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 2 END ; WITH LAYOUTREPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 1 ; BYTESIZE := 1 ; MIN := THROWLINE ; MAX := THROWPAGE END ; POINTERREPRESENTATION := INTEGERREPRESENTATION ; DEFAULTREPRESENTATION := INTEGERREPRESENTATION ; REVERSEOF[LTOP] := GTOP ; REVERSEOF[LEOP] := GEOP ; REVERSEOF[GEOP] := LEOP ; REVERSEOF[GTOP] := LTOP ; REVERSEOF[NEOP] := NEOP ; REVERSEOF[EQOP] := EQOP ; FALSECCMASKFOR[LTOP] := REGEQORGREATERTHANOPERAND ; FALSECCMASKFOR[LEOP] := REGGREATERTHANOPERAND ; FALSECCMASKFOR[GEOP] := REGLESSTHANOPERAND ; FALSECCMASKFOR[GTOP] := REGEQORLESSTHANOPERAND ; FALSECCMASKFOR[NEOP] := REGEQUALTOOPERAND ; FALSECCMASKFOR[EQOP] := REGNOTEQUALTOOPERAND ; FALSESTRINGMASKFOR[LTOP] := 14 ; FALSESTRINGMASKFOR[LEOP] := 6 ; FALSESTRINGMASKFOR[GEOP] := 5 ; FALSESTRINGMASKFOR[GTOP] := 13 ; FALSESTRINGMASKFOR[NEOP] := 8 ; FALSESTRINGMASKFOR[EQOP] := 7 ; WITH FALSEINTEGERJUMPFOR[LTOP] DO BEGIN JATORDER := FALSE ; JUMPKIND := INTACCLESSTHANZERO END ; WITH FALSEINTEGERJUMPFOR[LEOP] DO BEGIN JATORDER := TRUE ; JUMPKIND := INTACCGREATERTHANZERO END ; WITH FALSEINTEGERJUMPFOR[GEOP] DO BEGIN JATORDER := TRUE ; JUMPKIND := INTACCLESSTHANZERO END ; WITH FALSEINTEGERJUMPFOR[GTOP] DO BEGIN JATORDER := FALSE ; JUMPKIND := INTACCGREATERTHANZERO END ; WITH FALSEINTEGERJUMPFOR[NEOP] DO BEGIN JATORDER := TRUE ; JUMPKIND := INTACCEQUALTOZERO END ; WITH FALSEINTEGERJUMPFOR[EQOP] DO BEGIN JATORDER := FALSE ; JUMPKIND := INTACCEQUALTOZERO END ; CREATESTACK ; INITDISPLAY ; STOREACCATTOSPENDING := FALSE ; CODEISTOBEGENERATED := TRUE ; BADGENERATEDCODE := FALSE ; SPECIALORDER[ORF] := LOR ; SPECIALORDER[ANDF] := LAND ; SPECIALORDER[NEQF] := NEQ ; SPECIALORDER[USHF] := USH ; SPECIALORDER[ROTF] := ROT ; SPECIALORDER[ISHF] := ISH ; WITH POINTFIVE DO BEGIN SIZE := 2 ; KIND := REALVALUE ; RVAL := 1/2 END ; WITH CODEDESCRIPTOR DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1:= NOBNDCODEDESCRIPTOR END ; REALMATH[SINF ] := SINFUNC ; REALMATH[COSF ] := COSFUNC ; REALMATH[EXPF ] := EXPFUNC ; REALMATH[LNF ] := LNFUNC ; REALMATH[SQRTF ] := SQRTFUNC ; REALMATH[ARCTANF] := ARCTANFUNC ; WHICHMODE[FALSE] := WRITEFILE ; WHICHMODE[TRUE] := READFILE ; WHICHFILEPROCEDURE[RESETP ,TRUE ] := RESETFILE ; WHICHFILEPROCEDURE[REWRITEP ,TRUE ] := REWRITEFILE ; WHICHFILEPROCEDURE[GETP ,TRUE ] := GETTEXTFILE ; WHICHFILEPROCEDURE[PUTP ,TRUE ] := PUTTEXTFILE ; WHICHFILEPROCEDURE[RESETP ,FALSE] := RESETFILE ; WHICHFILEPROCEDURE[REWRITEP ,FALSE] := REWRITEFILE ; WHICHFILEPROCEDURE[GETP ,FALSE] := GETRECFILE ; WHICHFILEPROCEDURE[PUTP ,FALSE] := PUTRECFILE ; READREPRESENTATION[INTKIND] := INTEGERREPRESENTATION ; READREPRESENTATION[REALKIND] := REALREPRESENTATION ; READREPRESENTATION[CHARKIND] := CHARREPRESENTATION ; READPROCEDURE[INTKIND] := READINTEGER ; READPROCEDURE[REALKIND] := READREAL ; WRITEPROCEDURE[INTKIND] := WRITEINTEGER ; WRITEPROCEDURE[BOOLKIND] := WRITEBOOL ; WRITEPROCEDURE[CHARKIND] := WRITESPACEDCHAR ; WRITEPROCEDURE[REALKIND] := WRITEREAL ; DEFAULTWIDTH[INTKIND] := 12 ; DEFAULTWIDTH[REALKIND] := 24 ; DEFAULTWIDTH[CHARKIND] := 1 ; DEFAULTWIDTH[BOOLKIND] := 5 ; END (* INITCODEGENERATION *) ; PROCEDURE SUSPENDCODEGENERATION ; BEGIN CODEISTOBEGENERATED := FALSE ; END (* SUSPENDCODEGENERATION *) ; PROCEDURE REINSTATECODEGENERATION ; BEGIN CODEISTOBEGENERATED := NOT (REQD[NOCODEGEN] OR BADGENERATEDCODE) ; END (* REINSTATECODEGENERATION *) ; (*---- OBJECT MODULE GENERATION ----*) (* ------------------------ *) PROCEDURE GETGLOBALIDOPTION (VAR USERDEFNAME : ALFA) ; FORWARD ; (* - IN THE OPTIONS HANDLER *) PROCEDURE GETVALIDRTOPTIONS (VAR VALIDRTOPTIONS : SETOFOPTIONS) ; FORWARD ; (* - IN THE OPTIONS HANDLER *) PROCEDURE SETPLTWORD (VALUE : WORD ; PLTWORDOFFSETWD : SEGMENTSIZE) ; BEGIN ICL9LPOMGCOPY (BYTESINWORD, ADDRESSOF (VALUE), PLTAREA, PLTWORDOFFSETWD * BYTESINWORD) ; END (* SETPLTWORD *) ; PROCEDURE GETNEWPLTITEM (VAR PLTITEMOFFSETWD : SEGMENTSIZE) ; BEGIN PLTITEMOFFSETWD := STDAREASIZES [PLTAREA] DIV BYTESINWORD ; STDAREASIZES [PLTAREA] := STDAREASIZES [PLTAREA] + 2*BYTESINWORD ; SETPLTWORD (0, PLTITEMOFFSETWD) ; SETPLTWORD (0, PLTITEMOFFSETWD+1) ; END (* GETNEWPLTITEM *) ; PROCEDURE SETUPMAINENTRY (MAINENTRYNAME : ALFA ; VAR PLTDESCOFFSETWD : SEGMENTSIZE) ; CONST MAINENTRYPLTDESCOFFSETWD = 0 ; (* -EDINBURGH CONVENTION *) BEGIN SETPLTWORD (NOBNDCODEDESCRIPTOR, MAINENTRYPLTDESCOFFSETWD) ; ICL9LPOMGMNENTRY (MAINENTRYNAME, MAINENTRYPLTDESCOFFSETWD) ; PLTDESCOFFSETWD := MAINENTRYPLTDESCOFFSETWD ; END (* SETUPMAINENTRY *) ; PROCEDURE SETUPENTRY (ENTRYNAME : ALFA ; VAR PLTDESCOFFSETWD : SEGMENTSIZE) ; BEGIN GETNEWPLTITEM (PLTDESCOFFSETWD) ; SETPLTWORD (NOBNDCODEDESCRIPTOR, PLTDESCOFFSETWD) ; ICL9LPOMGENTRY (ENTRYNAME, PLTDESCOFFSETWD) ; END (* SETUPENTRY *) ; PROCEDURE SETUPEXTREF (EXTREFNAME : ALFA ; VAR PLTDESCOFFSETWD : SEGMENTSIZE) ; BEGIN GETNEWPLTITEM (PLTDESCOFFSETWD) ; ICL9LPOMGEXTREF (EXTREFNAME, PLTDESCOFFSETWD) ; END (* SETUPEXTREF *) ; PROCEDURE SETDIAGAREADESC (AREA : DIAGAREATYPE ; PLTOFFSETWD : SEGMENTSIZE) ; BEGIN SETPLTWORD (BYTEDESCRIPTOR+STDAREASIZES[AREA], PLTOFFSETWD) ; IF STDAREASIZES[AREA] > 0 THEN ICL9LPOMGRELOC (AREA, 0, PLTOFFSETWD) ELSE SETPLTWORD (NILVALUE, PLTOFFSETWD+1) ; END (* SETDIAGAREADESC *) ; PROCEDURE NOTEVALIDRTOPTIONS (VALIDRTOPTIONS : SETOFOPTIONS) ; BEGIN ICL9LPOMGCOPY (2*BYTESINWORD, (* -ASSUME 2 WORDS REQUIRED TO *) (* REPRESENT A SET VALUE. *) ADDRESSOF (VALIDRTOPTIONS), PLTAREA, RTOPTIONSPLTOFFSETWD * BYTESINWORD) ; END (* NOTEVALIDRTOPTIONS *) ; PROCEDURE INITOBJECTMODULEGEN ; VAR A : STDAREATYPE ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GLOBALSIZE := 0 ; FOR A := CODEAREA TO DIAGMAPAREA DO STDAREASIZES [A] := 0 ; STDAREASIZES [PLTAREA] := PLTSTART * BYTESINWORD ; ICL9LPOMGINIT (VERSIONNO, MARKNO) ; END; END (* INITOBJECTMODULEGEN *) ; PROCEDURE ENDOBJECTMODULEGEN ; VAR GLOBALAREANAME : ALFA ; I : 1..ALFALENGTH ; F : FORMATOFDESCRIPTOR ; GLOBALBASEDESCOFFSET : SEGMENTSIZE ; VALIDRTOPTS : SETOFOPTIONS ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GLOBALSIZE := DISPLAY[GLOBALLEVEL].LOCALSPACEREQUIRED * BYTESINWORD ; GETGLOBALIDOPTION (GLOBALAREANAME) ; IF GLOBALAREANAME = BLANKALFA THEN BEGIN A8TOALFA ('ICL9LPGL', GLOBALAREANAME) ; FOR I := ALFA8LENGTH+1 TO ALFALENGTH DO GLOBALAREANAME [I] := MODULENAME [I-ALFA8LENGTH] ; END ; FOR F := ONEBYTE TO FORWORDUNSCALED DO BEGIN GLOBALBASEDESCOFFSET := GLOBALDESCRIPTORS [F] ; SETPLTWORD (TYPEANDBOUND [F], GLOBALBASEDESCOFFSET) ; ICL9LPOMGAREANAM (GLOBALAREANAME, GLOBALSIZE, GLOBALBASEDESCOFFSET) ; END ; GETDIAGAREASIZES (STDAREASIZES [DIAGOBJECTAREA], STDAREASIZES [DIAGTOKENAREA], STDAREASIZES [DIAGMAPAREA]) ; SETDIAGAREADESC (DIAGOBJECTAREA, DIAGOBJPLTOFFSET) ; SETDIAGAREADESC (DIAGTOKENAREA, DIAGTOKENPLTOFFSET) ; SETDIAGAREADESC (DIAGMAPAREA, DIAGMAPPLTOFFSET) ; GETVALIDRTOPTIONS (VALIDRTOPTS) ; NOTEVALIDRTOPTIONS (VALIDRTOPTS) ; ICL9LPOMGFINISH (STDAREASIZES, GLOBALSIZE) ; END; END (* ENDOBJECTMODULEGEN *) ; (*---- OBJECT CODE GENERATION ----*) (* ---------------------- *) PROCEDURE OPENCODESPACE ; BEGIN STARTOFCODE := NEXTINS ; CODEINDEX := 0 END (* OPENCODESPACE *) ; PROCEDURE COPYHALFWORD ( HALFWORD : INTEGER ) ; BEGIN IF ODD(CODEINDEX) THEN CODE[CODEINDEX DIV 2] := ORX(CODE[CODEINDEX DIV 2],HALFWORD) ELSE BEGIN IF CODEINDEX > 2*CODEMAX + 1 THEN BEGIN ERROR(253) ; CODEINDEX := 0 END ; CODE[CODEINDEX DIV 2] := USHX(16,HALFWORD) END ; CODEINDEX := CODEINDEX + 1 ; NEXTINS := NEXTINS + 1 END (* COPYHALFWORD *) ; PROCEDURE COPYWORD ( WORD : INTEGER ) ; BEGIN IF CODEINDEX > 2*CODEMAX THEN BEGIN ERROR(253) ; CODEINDEX := 0 END ; IF ODD(CODEINDEX) THEN BEGIN CODE[CODEINDEX DIV 2 ] := ORX(CODE[CODEINDEX DIV 2 ],USHX(-16,WORD)) ; CODE[CODEINDEX DIV 2+1] := USHX(16,ANDX(XFFFF,WORD)) END ELSE CODE[CODEINDEX DIV 2] := WORD ; CODEINDEX := CODEINDEX + 2 ; NEXTINS := NEXTINS + 2 END (* COPYWORD *) ; PROCEDURE FORCETOWORDBOUNDARY ; BEGIN IF ODD(CODEINDEX) THEN COPYHALFWORD(0) END (* FORCETOHALFWORD *) ; PROCEDURE COPYSHRTINS( ORDER : ORDERCODE ; OPERAND : INTEGER ) ; BEGIN COPYHALFWORD(256*ORDER+OPERAND) END (* COPYSHRTINS *) ; PROCEDURE COPYLONGINS( ORDER : ORDERCODE ; OPERAND : INTEGER ) ; BEGIN COPYWORD(ORX(USHX(24,ORDER),OPERAND)) END (* COPYLONGINS *) ; PROCEDURE CLOSECODESPACE ; BEGIN FORCETOWORDBOUNDARY ; ICL9LPOMGCOPY (CODEINDEX*BYTESINHALFWORD, ADDRESSOF (CODE), CODEAREA, STARTOFCODE*BYTESINHALFWORD) ; STDAREASIZES [CODEAREA] := STDAREASIZES [CODEAREA] + CODEINDEX * BYTESINHALFWORD ; END (* CLOSECODESPACE *) ; PROCEDURE INSERTLITERALPINS ( ORDER : ORDERCODE ; OPERAND : LONGPINSLITERAL ; CODEAREAOFFSET : CODEADDRESS ) ; VAR CODEWORD : INTEGER ; BEGIN CODEWORD := ORX (USHX(24, ORDER), TWOSCOMPLEMENT (OPERAND, TWOTOTHE18) + TWOTOTHE18 * 8 * 4 * 3) ; ICL9LPOMGCOPY (BYTESINWORD, ADDRESSOF (CODEWORD), CODEAREA, CODEAREAOFFSET * BYTESINHALFWORD) ; END (* INSERTLITERALPINS *) ; (*---- STACK FRAME SIZE FIXUP HANDLING ----*) (* ------------------------------- *) PROCEDURE STARTFRAMESIZEFIXUPLIST ( VAR LIST : FRAMESIZEFIXUPENTRY ) ; BEGIN LIST := NIL ; END (* STARTFRAMESIZEFIXUPLIST *) ; PROCEDURE APPENDFRAMESIZEFIXUP ( VAR LIST : FRAMESIZEFIXUPENTRY ) ; VAR THISFIXUP : FRAMESIZEFIXUPENTRY ; BEGIN NEW (THISFIXUP) ; WITH THISFIXUP@ DO BEGIN NEXTFSFIXUP := LIST ; STACKCOLLAPSECODEOFFSET := NEXTINS ; END ; LIST := THISFIXUP ; END (* APPENDFRAMESIZEFIXUP *) ; PROCEDURE ENDFRAMESIZEFIXUPLIST ( LIST : FRAMESIZEFIXUPENTRY ; FRAMESIZE : SEGMENTSIZE ) ; VAR THISFIXUP, NEXTFIXUP : FRAMESIZEFIXUPENTRY ; BEGIN NEXTFIXUP := LIST ; WHILE NEXTFIXUP <> NIL DO BEGIN THISFIXUP := NEXTFIXUP ; WITH THISFIXUP@ DO BEGIN INSERTLITERALPINS (IAD, FRAMESIZE, STACKCOLLAPSECODEOFFSET) ; NEXTFIXUP := NEXTFSFIXUP ; END ; DISPOSE (THISFIXUP) ; END ; END (* ENDFRAMESIZEFIXUPLIST *) ; PROCEDURE DOFRAMESIZEFIXUPS ; VAR THISLABEL : LABELENTRY ; BEGIN WITH DISPLAY [LEVEL] DO BEGIN THISLABEL := FIRSTLABEL ; WHILE THISLABEL <> NIL DO WITH THISLABEL@ DO BEGIN ENDFRAMESIZEFIXUPLIST (LABELLEDCODE.FRAMESIZEFIXUPLIST, LOCALADDRESS) ; THISLABEL := NEXTLABEL ; END ; END ; END (* DOFRAMESIZEFIXUPS *) ; (*---- FIX UP LIST GENERATION ----*) (* ---------------------- *) PROCEDURE STARTFIXUPLIST ( VAR LIST : FIXUPENTRY ) ; BEGIN LIST := NIL END (* STARTFIXUPLIST *) ; PROCEDURE APPENDFIXUP ( VAR LIST : FIXUPENTRY ) ; VAR FIXUP : FIXUPENTRY ; BEGIN NEW(FIXUP) ; WITH FIXUP@ DO BEGIN NEXTFIXUP := LIST ; CODEREFERENCE := CODEINDEX END ; LIST := FIXUP END (* APPENDFIXUP *) ; PROCEDURE ENDFIXUPLIST ( LIST : FIXUPENTRY ) ; VAR THISFIXUP,NXTFIXUP : FIXUPENTRY ; PROCEDURE INSERTLITERAL ( INDEX : CODERANGE ; LITERAL : INTEGER ) ; VAR INDEXDIV2 : 0..CODEMAX ; BEGIN INDEXDIV2 := INDEX DIV 2 ; IF ODD(INDEX) THEN BEGIN CODE[INDEXDIV2] := ORX(USHX(2,USHX(-2,CODE[INDEXDIV2])), USHX(-16,LITERAL)) ; CODE[INDEXDIV2+1] := ORX(ANDX(CODE[INDEXDIV2+1],XFFFF), USHX(16,ANDX(LITERAL,XFFFF))) END ELSE CODE[INDEXDIV2] := ORX(ANDX(CODE[INDEXDIV2],XFFFC0000),LITERAL) END (* INSERTLITERAL *) ; BEGIN NXTFIXUP := LIST ; WHILE NXTFIXUP <> NIL DO BEGIN THISFIXUP := NXTFIXUP ; WITH THISFIXUP@ DO BEGIN INSERTLITERAL(CODEREFERENCE,CODEINDEX-CODEREFERENCE) ; NXTFIXUP := NEXTFIXUP END ; DISPOSE(THISFIXUP) END END (* ENDFIXUPLIST *) ; (*---- CONSTANT GENERATION ----*) (* ------------------- *) PROCEDURE OPENCONSTANTSPACE ; BEGIN LASTCONSTENTRY := NIL END (* OPENCONSTANTSPACE *) ; PROCEDURE NEWCONSTANT ( VAR CONSTANT : CONSTENTRY ; NEWVALUE : VALU ; HASDESCRIPTOR : BOOLEAN ) ; BEGIN IF HASDESCRIPTOR THEN NEW(CONSTANT,TRUE) ELSE NEW(CONSTANT,FALSE) ; WITH CONSTANT@ DO BEGIN NEXTCONST := LASTCONSTENTRY ; STARTFIXUPLIST(FIXUPLIST) ; CONSTVALUE := NEWVALUE ; DESCRIBED := HASDESCRIPTOR END ; LASTCONSTENTRY := CONSTANT END (* NEWCONSTANT *) ; PROCEDURE CODEVALUE ( NEWVALUE : VALU ) ; VAR THISCONST,NXTCONST : CONSTENTRY ; FOUND : BOOLEAN ; BEGIN NXTCONST := LASTCONSTENTRY ; FOUND := FALSE ; WHILE ( NXTCONST <> NIL ) AND NOT FOUND DO BEGIN THISCONST := NXTCONST ; WITH THISCONST@ DO IF EQUALVALUES(NEWVALUE,CONSTVALUE) AND NOT DESCRIBED THEN FOUND := TRUE ELSE NXTCONST := NEXTCONST END ; IF NOT FOUND THEN NEWCONSTANT(THISCONST,NEWVALUE,FALSE) ; APPENDFIXUP(THISCONST@.FIXUPLIST) END (* CONSTANT *) ; PROCEDURE DESCRIBEDCONSTANT ( DESCRIPTOR : FORMATOFDESCRIPTOR ; NEWVALUE : VALU ) ; VAR THISCONST,NXTCONST : CONSTENTRY ; FOUND : BOOLEAN ; BEGIN NXTCONST := LASTCONSTENTRY ; FOUND := FALSE ; WHILE ( NXTCONST <> NIL ) AND NOT FOUND DO BEGIN THISCONST := NXTCONST ; WITH THISCONST@ DO IF EQUALVALUES(NEWVALUE,CONSTVALUE) AND DESCRIBED AND ( DESC = DESCRIPTOR ) THEN FOUND := TRUE ELSE NXTCONST := NEXTCONST END ; IF NOT FOUND THEN BEGIN NEWCONSTANT(THISCONST,NEWVALUE,TRUE) ; THISCONST@.DESC := DESCRIPTOR END ; APPENDFIXUP(THISCONST@.FIXUPLIST) END (* DESCRIBEDCONSTANT *) ; PROCEDURE CLOSECONSTANTSPACE ; VAR THISCONST,NXTCONST : CONSTENTRY ; THISWORD : STRINGP ; WORDAFTER : STRINGP; OBJWORD : PACKED ARRAY [1..CHARSINWORD] OF 0..MAXINTFORBYTE; I : 1..CHARSINWORD; BEGIN FORCETOWORDBOUNDARY ; NXTCONST := LASTCONSTENTRY ; WHILE NXTCONST <> NIL DO BEGIN THISCONST := NXTCONST ; WITH THISCONST@ DO BEGIN ENDFIXUPLIST(FIXUPLIST) ; IF DESCRIBED THEN BEGIN COPYWORD(TYPEANDBOUND[DESC]) ; COPYWORD(8) END ; WITH CONSTVALUE DO BEGIN IF KIND = STRINGVALUE THEN BEGIN THISWORD := STRING ; WHILE THISWORD <> NIL DO BEGIN WITH THISWORD@ DO BEGIN FOR I := 1 TO CHARSINWORD DO OBJWORD[I] := CODETABLE@[WORD[I]]; COPYWORD(ORD(OBJWORD)); WORDAFTER := NEXTWORD; END; THISWORD := WORDAFTER; END END ELSE BEGIN COPYWORD(IVAL1) ; IF SIZE = 2 THEN COPYWORD(IVAL2) END ; NXTCONST := NEXTCONST END END ; IF THISCONST@.DESCRIBED THEN DISPOSE ( THISCONST , TRUE ) ELSE DISPOSE ( THISCONST , FALSE ) END END (* CLOSECONSTANTSPACE *) ; (*---- THE INSTRUCTION GENERATOR ----*) (* ------------------------- *) PROCEDURE PRIMARY ( ORDER : ORDERCODE ; K1 : REGISTER ; K2 : MODE ; N : INTEGER ) ; VAR NEWVALUE : VALU ; BEGIN CASE K1 OF NONE : IF K2 = UNMODIFIED THEN IF ( N >= -64 ) AND ( N < 64 ) THEN COPYSHRTINS(ORDER,TWOSCOMPLEMENT(N,128)) ELSE COPYLONGINS (ORDER,TWOSCOMPLEMENT(N,TWOTOTHE18)+TWOTOTHE18*8*4*3) ELSE IF K2 = MODIFYDR THEN IF N = 0 THEN COPYSHRTINS(ORDER,4*(7+8*(2+4*3))) ELSE COPYLONGINS(ORDER,N+TWOTOTHE18*(8*(1+4*3))); LNB : IF ( K2 IN [UNMODIFIED,DESCRIPTORINSTORE] ) AND ( N<128 ) THEN IF K2 = UNMODIFIED THEN COPYSHRTINS(ORDER,N+128*1) ELSE COPYSHRTINS(ORDER,N+128*2) ELSE COPYLONGINS(ORDER,N+TWOTOTHE18*(2+8*(ORD(K2)+4*3))) ; XNB , CTB : COPYLONGINS(ORDER,N+TWOTOTHE18*(ORD(K1)+8*(ORD(K2)+4*3))) ; PC : COPYLONGINS (ORDER,TWOSCOMPLEMENT(N,TWOTOTHE18)+ TWOTOTHE18*(4+8*(ORD(K2)+4*3))) ; TOS : COPYSHRTINS(ORDER,4*(6+8*(ORD(K2)+4*3))) ; BREGISTER : IF K2 = MODIFYDR THEN COPYSHRTINS(ORDER,4*(7+8*(3+4*3))) ELSE COPYSHRTINS(ORDER,4*(7+8*(ORD(K2)+4*3))) END END (* PRIMARY *) ; PROCEDURE CLEARPENDINGINSTRUCTIONS ; BEGIN IF STOREACCATTOSPENDING THEN BEGIN PRIMARY(ST,TOS,UNMODIFIED,0) ; STOREACCATTOSPENDING := FALSE END END (* CLEARPENDINGINSTRUCTIONS *) ; PROCEDURE PINS ( ORDER : ORDERCODE ; K1 : REGISTER ; K2 : MODE ; N : INTEGER ) ; BEGIN IF ORDER MOD 32 IN ACCORDERS[ORDER DIV 32] THEN IF STOREACCATTOSPENDING AND ((ORDER = LSS) OR (ORDER = LSD) OR (ORDER = L )) THEN BEGIN IF K1 <> TOS THEN BEGIN IF ORDER = LSS THEN ORDER := SLSS ELSE IF ORDER = LSD THEN ORDER := SLSD ELSE ORDER := SL ; PRIMARY(ORDER,K1,K2,N) ; END ELSE IF K2 <> UNMODIFIED THEN BEGIN PRIMARY(ST,TOS,UNMODIFIED,0) ; PRIMARY(ORDER,K1,K2,N) END ; STOREACCATTOSPENDING := FALSE END ELSE BEGIN IF STOREACCATTOSPENDING THEN BEGIN PRIMARY(ST,TOS,UNMODIFIED,0) ; STOREACCATTOSPENDING := FALSE END ; IF (ORDER = ST) AND (K1 = TOS) AND (K2=UNMODIFIED) THEN STOREACCATTOSPENDING := TRUE ELSE PRIMARY(ORDER,K1,K2,N) END ELSE IF STOREACCATTOSPENDING AND ( ORDER = LB ) AND ( K1 = TOS ) AND ( K2 = UNMODIFIED ) THEN BEGIN PRIMARY(ST,BREGISTER,UNMODIFIED,0) ; STOREACCATTOSPENDING := FALSE END ELSE BEGIN IF STOREACCATTOSPENDING THEN IF ( K1 = TOS ) OR ( ORDER MOD 32 IN FORCESTOREORDERS[ORDER DIV 32] ) THEN BEGIN PRIMARY(ST,TOS,UNMODIFIED,0) ; STOREACCATTOSPENDING := FALSE END ; PRIMARY(ORDER,K1,K2,N) END END (* PINS *) ; PROCEDURE CONSTPINS ( ORDER : ORDERCODE ; N : INTEGER ) ; VAR NEWVALUE : VALU ; BEGIN IF ( N >= -131072 ) AND ( N < 131072 ) THEN PINS(ORDER,NONE,UNMODIFIED,N) ELSE BEGIN WITH NEWVALUE DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := N END ; CODEVALUE(NEWVALUE) ; PINS(ORDER,PC,UNMODIFIED,0) END END (* CONSTPINS *) ; PROCEDURE LONGCONSTPINS ( ORDER : ORDERCODE ; OPERAND : LONGPINSLITERAL ) ; BEGIN CLEARPENDINGINSTRUCTIONS ; COPYLONGINS (ORDER, TWOSCOMPLEMENT (OPERAND, TWOTOTHE18) + TWOTOTHE18 * 8 * 4 * 3) ; END (* LONGCONSTPINS *) ; PROCEDURE PRECALL ; BEGIN CONSTPINS(PRCL,4) ; END (* PRECALL *) ; PROCEDURE LDTBPINS ( DESCRIPTOR : FORMATOFDESCRIPTOR ) ; BEGIN PINS(LDTB,CTB,UNMODIFIED,GLOBALDESCRIPTORS[DESCRIPTOR]) END (* LDTBPINS *) ; PROCEDURE SINS ( ORDER : ORDERCODE ; LENGTH : POSITIVEINTEGER ) ; BEGIN IF LENGTH <= 128 THEN COPYSHRTINS(ORDER,LENGTH-1) ELSE BEGIN CONSTPINS(LDB,LENGTH) ; COPYSHRTINS(ORDER,256*1) END END (* SINS *) ; PROCEDURE TINS ( ORDER : ORDERCODE ; MASK : MASKFORJUMP ; VAR DESTINATION : CODESEQUENCE ) ; VAR LITERAL : INTEGER ; BEGIN CLEARPENDINGINSTRUCTIONS ; WITH DESTINATION DO IF EXPECTED THEN BEGIN APPENDFIXUP(FIXUPLIST) ; LITERAL := 0 END ELSE LITERAL := TWOSCOMPLEMENT(STARTADDRESS-NEXTINS,TWOTOTHE18) ; COPYLONGINS(ORDER,LITERAL+TWOTOTHE18*(0+8*ORD(MASK))) END (* TINS *) ; PROCEDURE JUMPPINS ( ORDER : ORDERCODE ; VAR DESTINATION : CODESEQUENCE ) ; BEGIN CLEARPENDINGINSTRUCTIONS ; WITH DESTINATION DO IF EXPECTED THEN BEGIN APPENDFIXUP(FIXUPLIST) ; IF ORDER = JMP THEN COPYLONGINS(J,TWOTOTHE18*(0+8*(0+4*3))) ELSE COPYLONGINS(ORDER,TWOTOTHE18*(0+8*(0+4*3))) END ELSE IF ORDER = JMP THEN COPYLONGINS(J, TWOSCOMPLEMENT(STARTADDRESS-NEXTINS,TWOTOTHE18) + TWOTOTHE18*(0+8*(0+4*3))) ELSE PRIMARY(ORDER,NONE,UNMODIFIED,STARTADDRESS-NEXTINS) END (* JUMPPINS *) ; PROCEDURE LONGJUMP ( ORDER : ORDERCODE ; VAR DESTINATION : CODESEQUENCE ) ; BEGIN CLEARPENDINGINSTRUCTIONS ; WITH DESTINATION DO IF KIND IN [ SIMPLESEQUENCE,PROCSEQUENCE ] THEN IF EXPECTED THEN BEGIN IF NOT INPLTADDRESS THEN BEGIN INPLTADDRESS := TRUE ; GETNEWPLTITEM (PLTREF) ; END ; PRIMARY(ORDER,CTB,UNMODIFIED,PLTREF+1) END ELSE PRIMARY(ORDER,NONE,UNMODIFIED,STARTADDRESS-NEXTINS) ELSE BEGIN PRIMARY (ORDER,CTB,DESCRIPTORINSTORE,PLTEXTERNALREFERENCE) ; IF KIND = EXTERNALSEQUENCE THEN BEGIN PRIMARY(LCT,LNB,UNMODIFIED,4) ; PRIMARY(LXN,CTB,UNMODIFIED,GLOBALADDRESS+1) END END END (* LONGJUMP *) ; (*---- SEQUENTIAL CODE GENERATION ----*) (* -------------------------- *) PROCEDURE STARTCODESEQUENCE ( VAR SEQUENCE : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN CLEARPENDINGINSTRUCTIONS ; WITH SEQUENCE DO BEGIN KIND := SIMPLESEQUENCE ; EXPECTED := FALSE ; STARTADDRESS := NEXTINS END END ; END (* STARTCODESEQUENCE *) ; PROCEDURE EXPECTCODESEQUENCE ( VAR SEQUENCE : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH SEQUENCE DO BEGIN KIND := SIMPLESEQUENCE ; STARTFRAMESIZEFIXUPLIST (FRAMESIZEFIXUPLIST) ; EXPECTED := TRUE ; INPLTADDRESS := FALSE ; STARTFIXUPLIST(FIXUPLIST) END END (* EXPECTCODESEQUENCE *) ; PROCEDURE EXPECTPROCSEQUENCE ( VAR SEQUENCE : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH SEQUENCE DO BEGIN KIND := PROCSEQUENCE ; STARTFRAMESIZEFIXUPLIST (FRAMESIZEFIXUPLIST) ; EXPECTED := TRUE ; INPLTADDRESS := FALSE ; STARTFIXUPLIST(FIXUPLIST) END END (* EXPECTPROCSEQUENCE *) ; PROCEDURE PROCISENTRYSEQUENCE ( NAME : ALFA ; VAR SEQUENCE : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH SEQUENCE DO BEGIN KIND := ENTRYSEQUENCE ; SETUPENTRY (NAME, PLTENTRYREFERENCE) ; SETUPEXTREF (NAME, PLTEXTERNALREFERENCE) ; END END (* PROCISENTRYSEQUENCE *) ; PROCEDURE PROCISMAINENTRYSEQUENCE ( NAME : ALFA ; VAR SEQUENCE : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH SEQUENCE DO BEGIN KIND := ENTRYSEQUENCE ; SETUPMAINENTRY (NAME, PLTENTRYREFERENCE) ; END END (* PROCISMAINENTRYSEQUENCE *) ; PROCEDURE PROCISEXTERNALSEQUENCE ( NAME : ALFA ; VAR SEQUENCE : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH SEQUENCE DO BEGIN KIND := EXTERNALSEQUENCE ; SETUPEXTREF (NAME, PLTEXTERNALREFERENCE) ; END END (* PROCISEXTERNALSEQUENCE *) ; PROCEDURE NEXTISCODESEQUENCE ( VAR SEQUENCE : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN CLEARPENDINGINSTRUCTIONS ; WITH SEQUENCE DO CASE KIND OF SIMPLESEQUENCE , PROCSEQUENCE : BEGIN ENDFIXUPLIST(FIXUPLIST) ; IF INPLTADDRESS THEN ICL9LPOMGRELOC (CODEAREA, NEXTINS*BYTESINHALFWORD, PLTREF) ; EXPECTED := FALSE ; STARTADDRESS := NEXTINS ; IF KIND = PROCSEQUENCE THEN PINS(STCT,LNB,UNMODIFIED,4) END ; ENTRYSEQUENCE : BEGIN ICL9LPOMGRELOC (CODEAREA, NEXTINS*BYTESINHALFWORD, PLTENTRYREFERENCE) ; IF PLTENTRYREFERENCE <> 0 THEN CONSTPINS(INCA,-BYTESINWORD*PLTENTRYREFERENCE) ; PINS(STD,LNB,UNMODIFIED,3) ; PINS(LCT,LNB,UNMODIFIED,4) ; PINS(LXN,CTB,UNMODIFIED,GLOBALADDRESS+1 ) END END END ; END (* NEXTISCODESEQUENCE *) ; (*---- SUPPORT TASK IMPLEMENTATION ----*) (* --------------------------- *) PROCEDURE OPENSUPPORTTASKCONTROL ; VAR I : SUPPORTTASK ; BEGIN WITH EXTCALLINFOTABLE [PROGPRELUDE] DO BEGIN WORDSPASSED := 8 ; EXTCALLNAME := 'ICL9LPINITRUN ' END ; WITH EXTCALLINFOTABLE [PROGPOSTLUDE] DO BEGIN WORDSPASSED := 5 ; EXTCALLNAME := 'ICL9LPFINISHRUN ' END ; WITH EXTCALLINFOTABLE [SINFUNC] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPSIN ' END ; WITH EXTCALLINFOTABLE [COSFUNC] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPCOS ' END ; WITH EXTCALLINFOTABLE [EXPFUNC] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPEXP ' END ; WITH EXTCALLINFOTABLE [LNFUNC] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPLN ' END ; WITH EXTCALLINFOTABLE [SQRTFUNC] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPSQRT ' END ; WITH EXTCALLINFOTABLE [ARCTANFUNC] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPARCTAN ' END ; WITH EXTCALLINFOTABLE [OPENFILE] DO BEGIN WORDSPASSED := 20 ; EXTCALLNAME := 'ICL9LPFILEDECL ' END ; WITH EXTCALLINFOTABLE [CLOSEFILE] DO BEGIN WORDSPASSED := 5 ; EXTCALLNAME := 'ICL9LPFILECLOSE ' END ; WITH EXTCALLINFOTABLE [RESETFILE] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPRESET ' END ; WITH EXTCALLINFOTABLE [REWRITEFILE] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPREWRITE ' END ; WITH EXTCALLINFOTABLE [GETRECFILE] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPGETRECORD ' END ; WITH EXTCALLINFOTABLE [PUTRECFILE] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPPUTRECORD ' END ; WITH EXTCALLINFOTABLE [READINTEGER] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPREADINT ' END ; WITH EXTCALLINFOTABLE [READREAL] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPREADREAL ' END ; WITH EXTCALLINFOTABLE [WRITEINTEGER] DO BEGIN WORDSPASSED := 9 ; EXTCALLNAME := 'ICL9LPWRITEINT ' END ; WITH EXTCALLINFOTABLE [WRITEBOOL] DO BEGIN WORDSPASSED := 9 ; EXTCALLNAME := 'ICL9LPWRITEBOOL ' END ; WITH EXTCALLINFOTABLE [WRITEREAL] DO BEGIN WORDSPASSED := 11 ; EXTCALLNAME := 'ICL9LPWRITEREAL ' END ; WITH EXTCALLINFOTABLE [WRITESPACEDCHAR] DO BEGIN WORDSPASSED := 9 ; EXTCALLNAME := 'ICL9LPWRITECHAR ' END ; WITH EXTCALLINFOTABLE [WRITSTRING] DO BEGIN WORDSPASSED := 10 ; EXTCALLNAME := 'ICL9LPWRITESTR ' END ; WITH EXTCALLINFOTABLE [WRITEWORDSTRING] DO BEGIN WORDSPASSED := 9 ; EXTCALLNAME := 'ICL9LPWRITEWDSTR ' ; END ; WITH EXTCALLINFOTABLE [READCONTROL] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPREADLINE ' END ; WITH EXTCALLINFOTABLE [WRITECONTROL] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPWRITELINE ' END ; WITH EXTCALLINFOTABLE [PAGECONTROL] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPPAGE ' END ; ; WITH EXTCALLINFOTABLE [GETSPACE] DO BEGIN WORDSPASSED := 6 ; EXTCALLNAME := 'ICL9LPNEW ' END ; WITH EXTCALLINFOTABLE [RETURNSPACE] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPDISPOSE ' END ; WITH EXTCALLINFOTABLE [SETDATEANDTIMEVARS] DO BEGIN WORDSPASSED := 9 ; EXTCALLNAME := 'ICL9LPDATETIME ' END ; WITH EXTCALLINFOTABLE [HALTSYSTEM] DO BEGIN WORDSPASSED := 7 ; EXTCALLNAME := 'ICL9LPHALT ' END ; WITH EXTCALLINFOTABLE [READCLOCK] DO BEGIN WORDSPASSED := 5 ; EXTCALLNAME := 'ICL9LPCLOCK ' END ; WITH EXTCALLINFOTABLE [SETCHARACTERSET] DO BEGIN WORDSPASSED := 6 ; EXTCALLNAME := 'ICL9LPCHARCODEIS ' END ; WITH EXTCALLINFOTABLE [RANGEABORT] DO BEGIN WORDSPASSED := 6 ; EXTCALLNAME := 'ICL9LPRANGEERROR ' END ; WITH EXTCALLINFOTABLE [CASEABORT] DO BEGIN WORDSPASSED := 5 ; EXTCALLNAME := 'ICL9LPCASEERROR ' END ; WITH BYTEVECTOR DO BEGIN SIZE := 2 ; KIND := INTVALUE ; IVAL1 := NOBNDBYTEDESCRIPTOR + XFFFFFF ; IVAL2 := 0 END ; FOR I := GETTEXTFILE TO CASEABORT DO WITH SUPPORTSTATUSTABLE [I] DO BEGIN USEJLK := (I IN [RANGEABORT, CASEABORT]) ; IF USEJLK THEN JLKUSEDYET := FALSE ELSE BEGIN USEEXTERNALCALL := (I >= PROGPRELUDE) ; IF USEEXTERNALCALL THEN EXTCALLUSEDYET := FALSE ; END ; END (* FOR, WITH *) ; END (* OPENSUPPORTTASKCONTROL *) ; PROCEDURE DOSUPPORTTASK (WHICH : SUPPORTTASK) ; FORWARD ; PROCEDURE DOINTERNALSUPPORT (WHICH : INTERNALCODESUPPORTTASK) ; PROCEDURE DOGETTEXTFILE ; VAR SETEOL, NORMAL, DONE : CODESEQUENCE ; BEGIN EXPECTCODESEQUENCE (SETEOL) ; EXPECTCODESEQUENCE (NORMAL) ; EXPECTCODESEQUENCE (DONE) ; PINS (LB, NONE, MODIFYDR, FVADD) ; CONSTPINS (ADB, 1) ; PINS (STB, NONE, MODIFYDR, FVADD) ; PINS (CPB, NONE, MODIFYDR, LINEEND) ; TINS (JCC, REGLESSTHANOPERAND, NORMAL) ; TINS (JCC, REGEQUALTOOPERAND, SETEOL) ; DOSUPPORTTASK (READCONTROL) ; JUMPPINS (J, DONE) ; NEXTISCODESEQUENCE (SETEOL) ; CONSTPINS (LSS, ORD (TRUE)) ; PINS (ST, NONE, MODIFYDR, EOLNOFFSET DIV BYTESINWORD) ; NEXTISCODESEQUENCE (NORMAL) ; CODEVALUE (BYTEVECTOR) ; PINS (SLD, PC, UNMODIFIED, 0) ; PINS (LSS, BREGISTER, MODIFYDR, 0) ; PINS (ST, TOS, DESCRIPTORINSTORE, 0) ; NEXTISCODESEQUENCE (DONE) ; END (* DOGETTEXTFILE *) ; PROCEDURE DOPUTTEXTFILE ; VAR NORMAL, DONE : CODESEQUENCE ; BEGIN EXPECTCODESEQUENCE(NORMAL) ; EXPECTCODESEQUENCE(DONE) ; PINS(LB,NONE,MODIFYDR,FVADD) ; CONSTPINS(ADB,1) ; PINS(STB,NONE,MODIFYDR,FVADD) ; PINS(CPB,NONE,MODIFYDR,LINEEND) ; TINS(JCC,REGEQORLESSTHANOPERAND,NORMAL) ; DOSUPPORTTASK(WRITECONTROL) ; JUMPPINS(J,DONE) ; NEXTISCODESEQUENCE(NORMAL) ; PINS(LSS,NONE,MODIFYDR,FILECHAR) ; CONSTPINS(SBB,1) ; CODEVALUE(BYTEVECTOR) ; PINS(LD,PC,UNMODIFIED,0) ; PINS(ST,BREGISTER,MODIFYDR,0) ; NEXTISCODESEQUENCE(DONE) ; END (* DOPUTTEXTFILE *) ; PROCEDURE DOTRUNCATE ; VAR POSORNOBITSLOST : CODESEQUENCE ; BEGIN CONSTPINS(RSC,55) ; CONSTPINS(RSC,-120) ; CONSTPINS(RSC,65) ; PINS(FIX,BREGISTER,UNMODIFIED,0) ; CONSTPINS(MYB,4) ; PINS(ISH,BREGISTER,UNMODIFIED,0) ; EXPECTCODESEQUENCE(POSORNOBITSLOST) ; TINS(JAF,INTACCLESSTHANZERO,POSORNOBITSLOST) ; TINS(JCC,NOBITSLOST+POSSHIFT,POSORNOBITSLOST) ; CONSTPINS(IAD,1) ; NEXTISCODESEQUENCE(POSORNOBITSLOST) ; CONSTPINS(ISH,32) ; CONSTPINS(ISH,-32) ; PINS(STUH,BREGISTER,UNMODIFIED,0) ; END (* DOTRUNCATE *) ; PROCEDURE DOASSIGNARRAY ; VAR ASSIGNLOOP, DONE : CODESEQUENCE ; BEGIN EXPECTCODESEQUENCE(DONE) ; TINS(JAT,BEQUALTOZERO,DONE) ; STARTCODESEQUENCE(ASSIGNLOOP) ; CONSTPINS(SBB,1) ; PINS(LSS,XNB,MODIFYDESCRIPTORINSTORE,JLKPARAMETERAREA+2) ; PINS(ST,XNB,MODIFYDESCRIPTORINSTORE,JLKPARAMETERAREA) ; TINS(JAF,BEQUALTOZERO,ASSIGNLOOP) ; NEXTISCODESEQUENCE(DONE) ; END (* DOASSIGNARRAY *) ; BEGIN (* DOINTERNALSUPPORT *) CASE WHICH OF GETTEXTFILE : DOGETTEXTFILE ; PUTTEXTFILE : DOPUTTEXTFILE ; TRUNCATE : DOTRUNCATE ; ASSIGNARRAY : DOASSIGNARRAY ; END (* CASE *) ; END (* DOINTERNALSUPPORT *) ; PROCEDURE PARAMSFOREXTCALLSUPPORT (WHICH : EXTCALLSUPPORTTASK) ; BEGIN IF WHICH <> OPENFILE THEN PRECALL ; IF WHICH IN [ PROGPRELUDE , SINFUNC , COSFUNC , SQRTFUNC , EXPFUNC , LNFUNC , ARCTANFUNC , WRITEINTEGER , WRITEBOOL , WRITEREAL , WRITESPACEDCHAR , WRITSTRING , WRITEWORDSTRING , GETSPACE , RETURNSPACE , RANGEABORT , SETDATEANDTIMEVARS, SETCHARACTERSET ] THEN PINS(ST,TOS,UNMODIFIED,0) ; IF WHICH IN [ PROGPRELUDE , WRITSTRING ] THEN PINS(STB,TOS,UNMODIFIED,0) ; IF WHICH IN [ RESETFILE , REWRITEFILE , GETRECFILE , PUTRECFILE , READINTEGER , READREAL , WRITEINTEGER, WRITEBOOL , WRITEREAL , WRITESPACEDCHAR , WRITSTRING , WRITEWORDSTRING , READCONTROL , WRITECONTROL , SETDATEANDTIMEVARS, PAGECONTROL , HALTSYSTEM ] THEN PINS(STD,TOS,UNMODIFIED,0) ; CONSTPINS (RALN, EXTCALLINFOTABLE [WHICH] . WORDSPASSED) ; END (* PARAMSFOREXTCALLSUPPORT *) ; PROCEDURE DOSUPPORTTASK ; (* -PARAM. LIST IS :- (WHICH : SUPPORTTASK) *) VAR EC : EXTCALLSUPPORTTASK ; BEGIN WITH SUPPORTSTATUSTABLE [WHICH] DO IF USEJLK THEN BEGIN IF NOT JLKUSEDYET THEN BEGIN JLKUSEDYET := TRUE ; EXPECTCODESEQUENCE (JLKDESTINATION) ; END ; LONGJUMP (JLK, JLKDESTINATION) ; END ELSE IF USEEXTERNALCALL THEN BEGIN EC := WHICH ; IF NOT EXTCALLUSEDYET THEN BEGIN EXTCALLUSEDYET := TRUE ; EXPECTPROCSEQUENCE (EXTCALLDESTINATION) ; PROCISEXTERNALSEQUENCE (EXTCALLINFOTABLE[EC].EXTCALLNAME, EXTCALLDESTINATION) ; END ; PARAMSFOREXTCALLSUPPORT (EC) ; LONGJUMP (CALL, EXTCALLDESTINATION) ; END ELSE DOINTERNALSUPPORT (WHICH) ; END (* DOSUPPORTTASK *) ; PROCEDURE CLOSESUPPORTTASKCONTROL ; VAR S : SUPPORTTASK ; I : INTERNALCODESUPPORTTASK ; E : EXTCALLSUPPORTTASK ; EXTCALLDEST : CODESEQUENCE ; BEGIN OPENCODESPACE ; OPENCONSTANTSPACE ; FOR S := GETTEXTFILE TO CASEABORT DO WITH SUPPORTSTATUSTABLE [S] DO IF USEJLK THEN IF JLKUSEDYET THEN BEGIN NEXTISCODESEQUENCE (JLKDESTINATION) ; STARTMAPFORJLKTASK; PINS(STSF,XNB,UNMODIFIED,JLKSUPPORTLINKOFFSET); MAPFENCEFORJLKTASK; IF USEEXTERNALCALL THEN BEGIN E := S ; EXPECTPROCSEQUENCE (EXTCALLDEST) ; PROCISEXTERNALSEQUENCE (EXTCALLINFOTABLE[E].EXTCALLNAME, EXTCALLDEST) ; PARAMSFOREXTCALLSUPPORT (E) ; LONGJUMP (CALL, EXTCALLDEST) ; END ELSE BEGIN I := S ; DOINTERNALSUPPORT (I) ; END ; PINS (J, TOS, UNMODIFIED, 0) ; ENDMAPFORJLKTASK; END ; CLOSECONSTANTSPACE ; CLOSECODESPACE ; END (* CLOSESUPPORTTASKCONTROL *) ; (*---- STACK HOUSEKEEPING ----*) (* ------------------ *) PROCEDURE CREATESTACK ; VAR I : 1..STACKMAX ; LASTENTRY,ENTRY : STACKENTRY ; BEGIN NEW(FIRSTFREEENTRY) ; LASTENTRY := FIRSTFREEENTRY ; FOR I := 2 TO STACKMAX - 1 DO BEGIN NEW(ENTRY) ; LASTENTRY@.NEXTENTRY := ENTRY ; LASTENTRY := ENTRY END ; LASTENTRY@.NEXTENTRY := NIL END (* CREATESTACK *) ; PROCEDURE INITSTACK ; BEGIN TOPSTACKENTRY := NIL END (* INITSTACK *) ; PROCEDURE GETSTACKENTRY ( VAR ENTRY : STACKENTRY ) ; BEGIN ENTRY := FIRSTFREEENTRY ; IF FIRSTFREEENTRY = NIL THEN BEGIN NEW(ENTRY) END ELSE FIRSTFREEENTRY := FIRSTFREEENTRY@.NEXTENTRY END (* GETSTACKENTRY *) ; PROCEDURE FREESTACKENTRY ( ENTRY : STACKENTRY ) ; BEGIN ENTRY@.NEXTENTRY := FIRSTFREEENTRY ; FIRSTFREEENTRY := ENTRY END (* FREESTACKENTRY *) ; PROCEDURE STACK ( ENTRY : STACKENTRY ) ; BEGIN ENTRY@.NEXTENTRY := TOPSTACKENTRY ; TOPSTACKENTRY := ENTRY END (* STACK *) ; PROCEDURE UNSTACK ( VAR ENTRY : STACKENTRY ) ; BEGIN ENTRY := TOPSTACKENTRY ; TOPSTACKENTRY := TOPSTACKENTRY@.NEXTENTRY END (* UNSTACK *) ; (*---- TEMPORARY LOCATION MANAGEMENT ----*) (* ----------------------------- *) PROCEDURE REQUEST2LOCATIONS ( VAR NEXTFREELOCATION : SEGMENTSIZE ) ; BEGIN WITH DISPLAY[LEVEL] DO BEGIN NEXTFREELOCATION := LOCALADDRESS ; LOCALADDRESS := LOCALADDRESS + 2 ; LOCALSPACEREQUIRED := LOCALSPACEREQUIRED + 2 END END (* REQUEST2LOCATIONS *) ; PROCEDURE ASSIGNTEMPORARYREFERENCETO ( ENTRY : STACKENTRY ) ; VAR LOCALOFFSET : SEGMENTSIZE ; BEGIN REQUEST2LOCATIONS(LOCALOFFSET) ; WITH ENTRY@,POSITION DO BEGIN KIND := REFERENCE ; BYTEADJUSTMENT := 0 ; PACKEDITEM := FALSE ; STATICLEVEL := LEVEL ; OFFSET := LOCALOFFSET ; INDEXED := FALSE ; ACCESS := DIRECT END END (* ASSIGNTEMPORARYREFERENCETO *) ; FUNCTION RUNTIMESTACKREFERENCEIN ( ENTRY : STACKENTRY ) : BOOLEAN ; VAR INDEX : STACKENTRY ; STACKREFERENCE : BOOLEAN ; BEGIN WITH ENTRY@ DO CASE KIND OF REFERENCE : WITH POSITION DO IF ACCESS = ONSTACKADDRESS THEN RUNTIMESTACKREFERENCEIN := TRUE ELSE IF INDEXED THEN BEGIN INDEX := INDICES ; REPEAT STACKREFERENCE := RUNTIMESTACKREFERENCEIN(INDEX) ; INDEX := INDEX@.NEXTENTRY UNTIL (INDEX = NIL) OR STACKREFERENCE ; RUNTIMESTACKREFERENCEIN := STACKREFERENCE END ELSE RUNTIMESTACKREFERENCEIN := FALSE ; KONSTANT : RUNTIMESTACKREFERENCEIN := FALSE ; ONSTACKRESULT , CONDITION : RUNTIMESTACKREFERENCEIN := TRUE END ; END (* RUNTIMESTACKREFERENCEIN *) ; (*---- RUN-TIME DISPLAY MANAGEMENT ----*) (* --------------------------- *) PROCEDURE INITDISPLAY ; BEGIN NEW(FIRSTBASEENTRY) ; WITH FIRSTBASEENTRY@ DO BEGIN BASELEVEL := GLOBALLEVEL ; NEXTBASE := NIL END END (* INITDISPLAY *) ; PROCEDURE ADDRESSBASEOF ( STATICLEVEL : DISPRANGE ; DESCRIPTOR : FORMATOFDESCRIPTOR ) ; VAR THISBASE,LASTBASE,BASE : BASEENTRY ; FOUND : BOOLEAN ; BEGIN IF STATICLEVEL = GLOBALLEVEL THEN WITH ADDRESSED DO BEGIN K1 := CTB ; K2 := UNMODIFIED ; N := GLOBALDESCRIPTORS[DESCRIPTOR] END ELSE IF (STATICLEVEL = LEVEL-1) AND (DESCRIPTOR = ONEWORDSCALED) THEN WITH ADDRESSED DO BEGIN K1 := LNB ; K2 := UNMODIFIED ; N := LOCATIONOFSTATICLINK END ELSE BEGIN THISBASE := FIRSTBASEENTRY ; LASTBASE := NIL ; FOUND := FALSE ; WHILE THISBASE@.BASELEVEL > STATICLEVEL DO BEGIN LASTBASE := THISBASE ; THISBASE := THISBASE@.NEXTBASE END ; WHILE (THISBASE@.BASELEVEL = STATICLEVEL) AND NOT FOUND DO BEGIN IF THISBASE@.BASEDESCRIPTOR = DESCRIPTOR THEN FOUND := TRUE ELSE BEGIN LASTBASE := THISBASE ; THISBASE := THISBASE@.NEXTBASE END END ; IF NOT FOUND THEN BEGIN NEW(BASE) ; WITH BASE@ DO BEGIN BASELEVEL := STATICLEVEL ; BASEDESCRIPTOR := DESCRIPTOR ; REQUEST2LOCATIONS(BASEOFFSET) ; NEXTBASE := THISBASE ; IF LASTBASE <> NIL THEN LASTBASE@.NEXTBASE := BASE ELSE FIRSTBASEENTRY := BASE END END ; WITH ADDRESSED DO BEGIN K1 := LNB ; K2 := UNMODIFIED ; IF FOUND THEN N := THISBASE@.BASEOFFSET ELSE N:= BASE@.BASEOFFSET END END END (* ADDRESSBASEOF *) ; PROCEDURE ADDRESSSTACKBASEWORDOF ( STATICLEVEL : DISPRANGE ) ; BEGIN IF STATICLEVEL = GLOBALLEVEL THEN WITH ADDRESSED DO BEGIN K1 := XNB ; K2 := UNMODIFIED ; N := GLOBALLNBDESCOFFSET ; END ELSE ADDRESSBASEOF (STATICLEVEL, ONEWORDSCALED) ; END (* ADDRESSSTACKBASEWORDOF *) ; PROCEDURE CREATELOCALDISPLAY ; VAR LEVELINDR,LOOPLEVEL,THISLEVEL : DISPRANGE ; DRHASONEWORDDESC : BOOLEAN ; THISBASE,BASE,NEXT : BASEENTRY ; BEGIN IF FIRSTBASEENTRY@.BASELEVEL <> GLOBALLEVEL THEN BEGIN IF FIRSTBASEENTRY@.BASELEVEL = LEVEL THEN BEGIN PINS(STLN,BREGISTER,UNMODIFIED,0) ; PINS(LDA,BREGISTER,UNMODIFIED,0) ; LEVELINDR := LEVEL ; DRHASONEWORDDESC := FALSE END ELSE BEGIN PINS(LD,LNB,UNMODIFIED,LOCATIONOFSTATICLINK) ; LEVELINDR := LEVEL - 1 ; DRHASONEWORDDESC := TRUE END ; THISBASE := FIRSTBASEENTRY ; REPEAT THISLEVEL := THISBASE@.BASELEVEL ; IF LEVELINDR <> THISLEVEL THEN BEGIN IF NOT DRHASONEWORDDESC THEN BEGIN LDTBPINS(ONEWORDSCALED) ; DRHASONEWORDDESC := TRUE END ; FOR LOOPLEVEL := LEVELINDR DOWNTO THISLEVEL + 1 DO PINS(LDA,NONE,MODIFYDR,LOCATIONOFSTATICLINK+1) ; LEVELINDR := THISLEVEL END ; REPEAT WITH THISBASE@ DO BEGIN IF BASEDESCRIPTOR = ONEWORDSCALED THEN BEGIN IF NOT DRHASONEWORDDESC THEN LDTBPINS(ONEWORDSCALED) ; DRHASONEWORDDESC := TRUE END ELSE BEGIN LDTBPINS(BASEDESCRIPTOR) ; DRHASONEWORDDESC := FALSE END ; PINS(STD,LNB,UNMODIFIED,BASEOFFSET) END ; NEXT := THISBASE@.NEXTBASE ; DISPOSE(THISBASE) ; THISBASE := NEXT UNTIL THISBASE@.BASELEVEL <> THISLEVEL UNTIL THISBASE@.BASELEVEL = GLOBALLEVEL ; FIRSTBASEENTRY := THISBASE END END (*CREATELOCALDISPLAY*) ; (*---- ADDRESSING OF RUN-TIME VARIABLES ----*) (* -------------------------------- *) PROCEDURE LOADDR ( ENTRY : STACKENTRY ; DESCRIPTOR : FORMATOFDESCRIPTOR ) ; FORWARD ; PROCEDURE ADDRESSVALUE ( ENTRY : STACKENTRY ) ; FORWARD ; PROCEDURE ADDRESS ( ENTRY : STACKENTRY ) ; VAR DESIREDDESCRIPTOR : FORMATOFDESCRIPTOR ; ADJUSTMENT : INTEGER ; SCALEFACTOR : 1..16 ; BMULTIPLIER : POSITIVEINTEGER ; NOINDEXEVALUATEDYET,WASINDEXED : BOOLEAN ; NEXTINDEX,THISINDEX : STACKENTRY ; BEGIN WITH ENTRY@,POSITION DO IF (ACCESS = DIRECT) AND NOT PACKEDITEM AND NOT INDEXED AND ( STATICLEVEL IN [LEVEL,GLOBALLEVEL] ) THEN WITH ADDRESSED DO BEGIN IF STATICLEVEL = GLOBALLEVEL THEN K1 := XNB ELSE K1 := LNB ; K2 := UNMODIFIED ; N := OFFSET + BYTEADJUSTMENT DIV BYTESINWORD ; ISDESCRIPTORINUSE := FALSE END ELSE BEGIN IF ACCESS = DIRECT THEN BEGIN ADJUSTMENT := OFFSET*BYTESINWORD + BYTEADJUSTMENT ; OFFSET := 0 END ELSE ADJUSTMENT := BYTEADJUSTMENT ; BYTEADJUSTMENT := 0 ; IF REP.SIZE = 1 THEN IF PACKEDITEM THEN DESIREDDESCRIPTOR := ACCESSDESCRIPTOR[REP.BYTESIZE] ELSE DESIREDDESCRIPTOR := ONEWORDSCALED ELSE IF REP.SIZE = 2 THEN DESIREDDESCRIPTOR := TWOWORDSCALED ELSE DESIREDDESCRIPTOR := REP.ACCESSDESCRIPTOR ; SCALEFACTOR := BYTESFOR[DESIREDDESCRIPTOR] ; IF INDEXED THEN BEGIN ADDRESSVALUE(INDICES) ; WITH ADDRESSED DO PINS(LB,K1,K2,N) ; WITH INDICES@ DO BEGIN IF ELEMENTSIZE MOD SCALEFACTOR <> 0 THEN SCALEFACTOR := 1 ; IF ELEMENTSIZE DIV SCALEFACTOR <> 1 THEN CONSTPINS(MYB,ELEMENTSIZE DIV SCALEFACTOR) ; NEXTINDEX := NEXTENTRY END ; FREESTACKENTRY(INDICES) ; WHILE NEXTINDEX <> NIL DO BEGIN THISINDEX := NEXTINDEX ; IF THISINDEX@.ELEMENTSIZE MOD SCALEFACTOR <> 0 THEN BEGIN CONSTPINS(MYB,SCALEFACTOR) ; SCALEFACTOR := 1 END ; ADDRESSVALUE(THISINDEX) ; WITH ADDRESSED DO PINS(SLB,K1,K2,N) ; CONSTPINS (MYB,THISINDEX@.ELEMENTSIZE DIV SCALEFACTOR) ; PINS(ADB,TOS,UNMODIFIED,0) ; NEXTINDEX := THISINDEX@.NEXTENTRY ; FREESTACKENTRY(THISINDEX) END ; IF ADJUSTMENT <> 0 THEN BEGIN IF ADJUSTMENT MOD SCALEFACTOR <> 0 THEN BEGIN CONSTPINS(MYB,SCALEFACTOR) ; SCALEFACTOR := 1 END ; CONSTPINS(ADB,ADJUSTMENT DIV SCALEFACTOR ) ; ADJUSTMENT := 0 END ; IF SCALEFACTOR <> BYTESFOR[DESIREDDESCRIPTOR] THEN DESIREDDESCRIPTOR := UNSCALEDDESCRIPTORFOR[DESIREDDESCRIPTOR] ; INDEXED := FALSE ; WASINDEXED := TRUE END ELSE BEGIN IF ADJUSTMENT MOD SCALEFACTOR = 0 THEN ADJUSTMENT := ADJUSTMENT DIV SCALEFACTOR ELSE DESIREDDESCRIPTOR := UNSCALEDDESCRIPTORFOR[DESIREDDESCRIPTOR] ; WASINDEXED := FALSE END ; IF ADJUSTMENT = 0 THEN IF (ACCESS = BYDESCRIPTOR) AND (STATICLEVEL IN [LEVEL,GLOBALLEVEL]) AND (CURRENTDESCRIPTOR = DESIREDDESCRIPTOR) THEN WITH ADDRESSED DO BEGIN IF STATICLEVEL = GLOBALLEVEL THEN K1 := XNB ELSE K1 := LNB ; IF WASINDEXED THEN K2 := MODIFYDESCRIPTORINSTORE ELSE K2 := DESCRIPTORINSTORE ; N := OFFSET END ELSE IF ACCESS = DIRECT THEN BEGIN ADDRESSBASEOF (STATICLEVEL,DESIREDDESCRIPTOR) ; WITH ADDRESSED DO IF WASINDEXED THEN K2 := MODIFYDESCRIPTORINSTORE ELSE K2 := DESCRIPTORINSTORE END ELSE BEGIN LOADDR(ENTRY,DESIREDDESCRIPTOR) ; WITH ADDRESSED DO IF WASINDEXED THEN BEGIN K1 := BREGISTER ; K2 := MODIFYDR END ELSE BEGIN K1 := NONE ; K2 := MODIFYDR ; N := 0 END END ELSE BEGIN LOADDR(ENTRY,DESIREDDESCRIPTOR) ; WITH ADDRESSED DO BEGIN K1 := NONE ; K2 := MODIFYDR ; N := ADJUSTMENT END END ; WITH ADDRESSED DO BEGIN ISDESCRIPTORINUSE := TRUE ; ADDRESSEDDESCRIPTOR := DESIREDDESCRIPTOR END END END (* ADDRESS *) ; PROCEDURE ADDRESSVALUE ; VAR PCOFFSET : INTEGER ; BEGIN WITH ENTRY@ DO CASE KIND OF REFERENCE : ADDRESS(ENTRY) ; KONSTANT : WITH KONSTVALUE DO IF KIND <> STRINGVALUE THEN IF ( SIZE = 1 ) AND ( ABS(IVAL1) < 131072 ) THEN WITH ADDRESSED DO BEGIN K1 := NONE ; K2 := UNMODIFIED ; N := IVAL1 END ELSE IF ( SIZE = 2 ) AND ( IVAL1 = 0 ) AND ( IVAL2 >= 0 ) AND ( IVAL2 < 131072 ) THEN WITH ADDRESSED DO BEGIN K1 := NONE ; K2 := UNMODIFIED ; N := IVAL2 END ELSE BEGIN CODEVALUE(KONSTVALUE) ; WITH ADDRESSED DO BEGIN K1 := PC ; K2 := UNMODIFIED ; N := 0 END END ELSE BEGIN CODEVALUE(KONSTVALUE) ; WITH ADDRESSED DO BEGIN K1 := PC ; K2 := UNMODIFIED ; N := 0 END END ; ONSTACKRESULT : WITH ADDRESSED DO BEGIN K1 := TOS ; K2 := UNMODIFIED ; N := 0 END END END (* ADDRESSVALUE *) ; PROCEDURE LOADDR ; VAR TYPEANDBOUND,EIGHT : VALU ; PROCEDURE FORMDESCRIPTOR ( NEWTYPEANDBOUNDREQUIRED : BOOLEAN ; ADDRESSADJUSTMENT : BYTESEGMENTSIZE ) ; BEGIN IF NEWTYPEANDBOUNDREQUIRED THEN LDTBPINS(DESCRIPTOR) ; IF ADDRESSADJUSTMENT <> 0 THEN CONSTPINS(INCA,ADDRESSADJUSTMENT) END (* FORMDESCRIPTOR *) ; BEGIN WITH ENTRY@ DO CASE KIND OF REFERENCE : IF INDEXED THEN BEGIN ADDRESS(ENTRY) ; WITH ADDRESSED DO BEGIN IF K2 = MODIFYDESCRIPTORINSTORE THEN PINS(LD,K1,UNMODIFIED,N) ; IF ADDRESSEDDESCRIPTOR IN [ ONEWORDSCALED , TWOWORDSCALED , FORWORDSCALED ] THEN PINS(MODD,BREGISTER,UNMODIFIED,0) ELSE PINS(INCA,BREGISTER,UNMODIFIED,0) ; IF DESCRIPTOR <> ADDRESSEDDESCRIPTOR THEN FORMDESCRIPTOR(TRUE,0) END END ELSE BEGIN WITH POSITION DO BEGIN IF (ACCESS = BYDESCRIPTOR) AND (DESCRIPTOR <> CURRENTDESCRIPTOR) THEN BEGIN ACCESS := BYADDRESS ; OFFSET := OFFSET + 1 END ; CASE ACCESS OF DIRECT : BEGIN ADDRESSBASEOF(STATICLEVEL,DESCRIPTOR) ; WITH ADDRESSED DO PINS(LD,K1,K2,N) ; FORMDESCRIPTOR (FALSE,OFFSET*BYTESINWORD+BYTEADJUSTMENT) END ; BYADDRESS : IF STATICLEVEL IN [LEVEL,GLOBALLEVEL] THEN BEGIN IF STATICLEVEL = GLOBALLEVEL THEN PINS(LDA,XNB,UNMODIFIED,OFFSET) ELSE PINS(LDA,LNB,UNMODIFIED,OFFSET) ; FORMDESCRIPTOR(TRUE,BYTEADJUSTMENT) END ELSE BEGIN IF DESCRIPTOR = ONEWORDSCALED THEN ADDRESSBASEOF(STATICLEVEL,ONEWORDSCALED ) ELSE ADDRESSBASEOF(STATICLEVEL,ONEWORDUNSCALED); WITH ADDRESSED DO PINS(LD,K1,K2,N) ; IF DESCRIPTOR = ONEWORDSCALED THEN PINS(LDA,NONE,MODIFYDR,OFFSET) ELSE PINS(LDA,NONE,MODIFYDR,OFFSET*BYTESINWORD); IF DESCRIPTOR IN [ONEWORDSCALED,ONEWORDUNSCALED] THEN FORMDESCRIPTOR(FALSE,BYTEADJUSTMENT) ELSE FORMDESCRIPTOR(TRUE,BYTEADJUSTMENT) END ; BYDESCRIPTOR : BEGIN IF STATICLEVEL = GLOBALLEVEL THEN PINS(LD,XNB,UNMODIFIED,OFFSET) ELSE IF STATICLEVEL = LEVEL THEN PINS(LD,LNB,UNMODIFIED,OFFSET) ELSE BEGIN ADDRESSBASEOF (STATICLEVEL,TWOWORDUNSCALED) ; WITH ADDRESSED DO PINS(LD,K1,K2,N) ; PINS(LD,NONE,MODIFYDR,OFFSET*BYTESINWORD) END ; FORMDESCRIPTOR(FALSE,BYTEADJUSTMENT) END ; ONSTACKADDRESS : BEGIN PINS(LDA,TOS,UNMODIFIED,0) ; FORMDESCRIPTOR(TRUE,BYTEADJUSTMENT) END END END END ; KONSTANT : BEGIN DESCRIBEDCONSTANT(DESCRIPTOR,KONSTVALUE) ; PINS(LDRL,PC,UNMODIFIED,0) END END END (* LOADDR *) ; PROCEDURE LOADVIRTUALADDRESS ( ENTRY : STACKENTRY ) ; BEGIN LOADDR(ENTRY,ONEWORDSCALED) ; CONSTPINS(CYD,0) ; PINS(STUH,BREGISTER,UNMODIFIED,0) END (* LOADVIRTUALADDRESS *) ; (*---- LOADING OF RUN-TIME VARIABLES ----*) (* ----------------------------- *) PROCEDURE JUMPIF ( ENTRY : STACKENTRY ; JUMPONTRUE : BOOLEAN ; VAR DESTINATION : CODESEQUENCE ) ; FORWARD ; PROCEDURE LOADACC ( ENTRY : STACKENTRY ) ; VAR TOBEJUMPEDON : BOOLEAN ; TOLOADCONDITIONJUMPEDON , AFTERCONDITIONLOADED : CODESEQUENCE ; BEGIN WITH ENTRY@ DO BEGIN CASE KIND OF REFERENCE , KONSTANT : BEGIN ADDRESSVALUE(ENTRY) ; WITH ADDRESSED DO IF REP.SIZE = 1 THEN PINS(LSS,K1,K2,N) ELSE PINS(LSD,K1,K2,N) END ; ONSTACKRESULT : IF REP.SIZE = 1 THEN PINS(LSS,TOS,UNMODIFIED,0) ELSE PINS(LSD,TOS,UNMODIFIED,0) ; CONDITION : BEGIN IF KINDOFCONDITION = MULTIJUMPCONDITION THEN TOBEJUMPEDON := JUMPCONDITION ELSE TOBEJUMPEDON := FALSE ; EXPECTCODESEQUENCE(TOLOADCONDITIONJUMPEDON) ; EXPECTCODESEQUENCE(AFTERCONDITIONLOADED) ; JUMPIF(ENTRY,TOBEJUMPEDON,TOLOADCONDITIONJUMPEDON) ; CONSTPINS(LSS,ORD(NOT TOBEJUMPEDON)) ; JUMPPINS(J,AFTERCONDITIONLOADED) ; NEXTISCODESEQUENCE(TOLOADCONDITIONJUMPEDON) ; CONSTPINS(LSS,ORD(TOBEJUMPEDON)) ; NEXTISCODESEQUENCE(AFTERCONDITIONLOADED) END END ; KIND := ONSTACKRESULT END END (* LOADACC *) ; PROCEDURE LOADANDADDRESS ( LEFTOPERAND,RIGHTOPERAND : STACKENTRY ) ; BEGIN IF RUNTIMESTACKREFERENCEIN(RIGHTOPERAND) THEN BEGIN LOADACC(RIGHTOPERAND) ; ADDRESSVALUE(LEFTOPERAND) ; REVERSEDOPERANDS := TRUE END ELSE BEGIN LOADACC(LEFTOPERAND) ; ADDRESSVALUE(RIGHTOPERAND) ; REVERSEDOPERANDS := FALSE END END (* LOADANDADDRESS *) ; PROCEDURE JUMPIF ; VAR FALLTHROUGHCONDITION : CODESEQUENCE ; BEGIN WITH ENTRY@ DO CASE KIND OF REFERENCE , ONSTACKRESULT : BEGIN LOADACC(ENTRY) ; IF JUMPONTRUE THEN TINS(JAF,INTACCEQUALTOZERO,DESTINATION) ELSE TINS(JAT,INTACCEQUALTOZERO,DESTINATION) END ; KONSTANT : IF KONSTVALUE.BVAL = JUMPONTRUE THEN JUMPPINS(J,DESTINATION) ; CONDITION : CASE KINDOFCONDITION OF JUMPONACC : WITH FALSEACCJUMP DO IF NOT (JUMPONTRUE = JATORDER) THEN TINS(JAT,JUMPKIND,DESTINATION) ELSE TINS(JAF,JUMPKIND,DESTINATION) ; JUMPONCC : IF JUMPONTRUE THEN TINS(JCC,ALLCCCONDITIONSSET-FALSECCJUMP,DESTINATION) ELSE TINS(JCC,FALSECCJUMP,DESTINATION) ; MULTIJUMPCONDITION : IF JUMPCONDITION = JUMPONTRUE THEN BEGIN EXPECTCODESEQUENCE(FALLTHROUGHCONDITION) ; JUMPPINS(J,FALLTHROUGHCONDITION) ; NEXTISCODESEQUENCE(JUMPDESTINATION) ; JUMPPINS(J,DESTINATION) ; NEXTISCODESEQUENCE(FALLTHROUGHCONDITION) END ELSE BEGIN JUMPPINS(J,DESTINATION) ; NEXTISCODESEQUENCE(JUMPDESTINATION) END END END END (* JUMPIF *) ; PROCEDURE SWAPTOPSTACKENTRIES ; VAR TOPENTRY,NEXTTOTOPENTRY : STACKENTRY ; BEGIN UNSTACK(TOPENTRY) ; UNSTACK(NEXTTOTOPENTRY) ; IF RUNTIMESTACKREFERENCEIN(TOPENTRY) AND RUNTIMESTACKREFERENCEIN(NEXTTOTOPENTRY) THEN BEGIN LOADACC(TOPENTRY) ; ADDRESSVALUE(NEXTTOTOPENTRY) ; WITH NEXTTOTOPENTRY@ DO BEGIN WITH ADDRESSED DO IF REP.SIZE = 1 THEN PINS(SLSS,K1,K2,N) ELSE PINS(SLSD,K1,K2,N) ; PINS(ST,TOS,UNMODIFIED,0) ; KIND := ONSTACKRESULT END END ; STACK(TOPENTRY) ; STACK(NEXTTOTOPENTRY) END (* SWAPTOPSTACKENTRIES *) ; (*---- RANGE CHECK MANAGEMENT -----*) (* ---------------------- *) PROCEDURE RANGECHECK ( ENTRYTOBECHECKED : STACKTOP ; MINREQUIRED,MAXREQUIRED : INTEGER ) ; VAR ACTUALMIN,ACTUALMAX : INTEGER ; MINTESTREQUIRED,MAXTESTREQUIRED : BOOLEAN ; OK, NOTOK : CODESEQUENCE ; BEGIN IF ENTRYTOBECHECKED = TOPOFSTACK THEN WITH TOPSTACKENTRY@.REP DO BEGIN ACTUALMIN := MIN ; ACTUALMAX := MAX END ELSE WITH TOPSTACKENTRY@.NEXTENTRY@.REP DO BEGIN ACTUALMIN := MIN ; ACTUALMAX := MAX END ; MINTESTREQUIRED := FALSE ; MAXTESTREQUIRED := FALSE ; IF ACTUALMIN < MINREQUIRED THEN IF MINREQUIRED > ACTUALMAX THEN ERROR(302) ELSE MINTESTREQUIRED := TRUE ; IF ACTUALMAX > MAXREQUIRED THEN IF MAXREQUIRED < ACTUALMIN THEN ERROR(302) ELSE MAXTESTREQUIRED := TRUE ; IF LOCALLYREQD[CHECKS] AND ( MINTESTREQUIRED OR MAXTESTREQUIRED ) THEN BEGIN IF ENTRYTOBECHECKED = NEXTTOTOP THEN SWAPTOPSTACKENTRIES ; LOADACC(TOPSTACKENTRY) ; EXPECTCODESEQUENCE (NOTOK) ; EXPECTCODESEQUENCE (OK) ; IF MINTESTREQUIRED THEN IF MAXTESTREQUIRED THEN IF MINREQUIRED = 0 THEN TINS (JAT, INTACCLESSTHANZERO, NOTOK) ELSE BEGIN CONSTPINS (ICP, MINREQUIRED) ; TINS (JCC, REGLESSTHANOPERAND, NOTOK) ; END ELSE IF MINREQUIRED = 0 THEN TINS (JAF, INTACCLESSTHANZERO, OK) ELSE BEGIN CONSTPINS (ICP, MINREQUIRED) ; TINS (JCC, REGEQORGREATERTHANOPERAND, OK) ; END ; IF MAXTESTREQUIRED THEN IF MAXREQUIRED = 0 THEN TINS (JAF, INTACCGREATERTHANZERO, OK) ELSE BEGIN CONSTPINS (ICP, MAXREQUIRED) ; TINS (JCC, REGEQORLESSTHANOPERAND, OK) ; END ; NEXTISCODESEQUENCE (NOTOK) ; DOSUPPORTTASK (RANGEABORT) ; NEXTISCODESEQUENCE (OK) ; PINS(ST,TOS,UNMODIFIED,0) ; IF ENTRYTOBECHECKED = NEXTTOTOP THEN SWAPTOPSTACKENTRIES END END (* RANGECHECK *) ; (*---- BLOCK AND PROGRAM HOUSEKEEPING ----*) (* ------------------------------ *) PROCEDURE OPENNAMESPACE ; BEGIN WITH DISPLAY[LEVEL] DO IF LEVEL = GLOBALLEVEL THEN BEGIN LOCALADDRESS := STARTOFGLOBALSPACE ; LOCALSPACEREQUIRED := STARTOFGLOBALSPACE END ELSE BEGIN IF LEVEL = GLOBALLEVEL + 1 THEN LOCALADDRESS := ADMINSPACEFORCALL ELSE LOCALADDRESS := ADMINSPACEFORCALL+STATICLINKSPACE ; LOCALSPACEREQUIRED := 0 END END (* OPENNAMESPACE *) ; PROCEDURE CLOSENAMESPACE ; BEGIN END (* CLOSENAMESPACE *) ; PROCEDURE OPENPROGRAM ( PROGRAMNAME : ALFA ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN MODULENAME := PROGRAMNAME ; OPENSUPPORTTASKCONTROL ; EXPECTPROCSEQUENCE(MAINPROGRAM) ; PROCISMAINENTRYSEQUENCE(PROGRAMNAME,MAINPROGRAM) END END (* OPENPROGRAM *) ; PROCEDURE CLOSEPROGRAM ; BEGIN IF CODEISTOBEGENERATED THEN CLOSESUPPORTTASKCONTROL ; END (* CLOSEPROGRAM *) ; PROCEDURE ENTERBODY ( BLOCKID : IDENTRY ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN OPENCODESPACE ; OPENCONSTANTSPACE ; INITSTACK ; STARTCODESEQUENCE(BODY) END END (* ENTERBODY *) ; PROCEDURE LEAVEBODY ( BLOCKID : IDENTRY ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN CONSTPINS(EXIT,EXITPARAMETER) ; NEXTISCODESEQUENCE(BLOCKID@.CODEBODY) ; WITH DISPLAY[LEVEL] DO IF LOCALSPACEREQUIRED <> 0 THEN CONSTPINS(ASF,LOCALSPACEREQUIRED) ; CREATELOCALDISPLAY ; JUMPPINS(J,BODY) ; CLOSECONSTANTSPACE ; DOFRAMESIZEFIXUPS ; CLOSECODESPACE END END (* LEAVEBODY *) ; PROCEDURE LISTOBJCODEBLOCK ; BEGIN ICL9LPCTPLILIST (CODEINDEX*BYTESINHALFWORD, ADDRESSOF (CODE), STARTOFCODE*BYTESINHALFWORD) ; END ; PROCEDURE ENTERPROGRAM ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN OPENCODESPACE ; OPENCONSTANTSPACE ; INITSTACK ; STARTCODESEQUENCE(BODY) END END (* ENTERPROGRAM *) ; PROCEDURE LEAVEPROGRAM ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN DOSUPPORTTASK(PROGPOSTLUDE) ; CONSTPINS(EXIT,EXITPARAMETER) ; NEXTISCODESEQUENCE(MAINPROGRAM) ; WITH DISPLAY[GLOBALLEVEL] DO BEGIN PINS(LSS,CTB,UNMODIFIED,GLOBALADDRESS+1) ; CONSTPINS(LUH,LOCALSPACEREQUIRED) ; CONSTPINS(LB,ORD(REQD[COMPILER])) ; DOSUPPORTTASK(PROGPRELUDE) ; CONSTPINS(LSS,PARMVALUE[CHARCODE]) ; DOSUPPORTTASK(SETCHARACTERSET) END ; CREATELOCALDISPLAY ; JUMPPINS(J,BODY) ; CLOSECONSTANTSPACE ; CLOSECODESPACE END END (* LEAVEPROGRAM *) ; PROCEDURE ENTERFLOWUNIT; (*FORWARD-DECLARED*) BEGIN END (*ENTERFLOWUNIT*) ; PROCEDURE OPENSTATEMENT ( LINENUMBER : POSITIVEINTEGER ; STATKIND : SYMBOLTYPE ) ; VAR STATENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN CLEARPENDINGINSTRUCTIONS ; GETSTACKENTRY(STATENTRY) ; WITH STATENTRY@ DO BEGIN KIND := STATEMENTBASE ; CODEWASBEINGGENERATED := CODEISTOBEGENERATED END ; STACK(STATENTRY) END (* OPENSTATEMENT *) ; PROCEDURE CLOSSTATEMENT ; VAR DEBRIS,STATENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN CLEARPENDINGINSTRUCTIONS ; WHILE TOPSTACKENTRY@.KIND <> STATEMENTBASE DO BEGIN UNSTACK(DEBRIS) ; FREESTACKENTRY(DEBRIS) END ; UNSTACK(STATENTRY) ; FREESTACKENTRY(STATENTRY) END (* CLOSSTATEMENT *) ; (*---- REPRESENTATION AND STORAGE OF DATA ----*) (* ---------------------------------- *) PROCEDURE CHECKSETBASETYPE ( ENTRY : TYPENTRY ) ; BEGIN IF ( ENTRY@.REPRESENTATION.MIN < 0 ) OR ( ENTRY@.REPRESENTATION.MAX > SUPREMEELEMENTINSET ) THEN ERROR ( 398 ) END (* CHECKSETBASETYPE *) ; PROCEDURE SETREPRESENTATIONFOR ( ENTRY : TYPENTRY ) ; VAR NEXTCONST : IDENTRY ; NEXTVALUE,INDEXMIN,INDEXMAX,NOELEMENTS : INTEGER ; WORDSNEEDED,WORDSUSED : SEGMENTSIZE ; PROCEDURE ALLOCLEVEL ( NONVARIANTPART : IDENTRY ; VARIANTPART : TYPENTRY ; STARTWORD : SEGMENTSIZE ; VAR MAXWORDSIZE : SEGMENTSIZE ) ; VAR WORDFREE,THISVARWORDSIZE : SEGMENTSIZE ; THISFIELD : IDENTRY ; THISVARIANT : TYPENTRY ; PROCEDURE ALLOCFIELD ( FIELDENTRY : IDENTRY ) ; VAR WORDSNEEDED : SEGMENTSIZE ; BEGIN WITH FIELDENTRY@ DO IF IDTYPE <> NIL THEN BEGIN WORDSNEEDED := IDTYPE@.REPRESENTATION.SIZE ; WITH OFFSET DO BEGIN BYTEOFFSET := WORDFREE*BYTESINWORD ; BYTESIZE := WORDSNEEDED*BYTESINWORD END ; WORDFREE := WORDFREE + WORDSNEEDED END END (* ALLOCFIELD *) ; BEGIN WORDFREE := STARTWORD ; THISFIELD := NONVARIANTPART ; WHILE THISFIELD <> NIL DO BEGIN ALLOCFIELD(THISFIELD) ; THISFIELD := THISFIELD@.NEXT END ; IF VARIANTPART <> NIL THEN BEGIN WITH VARIANTPART@ DO BEGIN IF TAGFIELD <> NIL THEN ALLOCFIELD(TAGFIELD) ; MAXWORDSIZE := WORDFREE ; REPRESENTATION.SIZE := WORDFREE ; THISVARIANT := FIRSTVARIANT ; WHILE THISVARIANT <> NIL DO BEGIN WITH THISVARIANT@ DO BEGIN ALLOCLEVEL (FSTVARFIELD,SUBVARPART,WORDFREE,THISVARWORDSIZE) ; REPRESENTATION.SIZE := THISVARWORDSIZE ; IF THISVARWORDSIZE > MAXWORDSIZE THEN MAXWORDSIZE := THISVARWORDSIZE END ; THISVARIANT := THISVARIANT@.NEXTVARIANT END END END ELSE MAXWORDSIZE := WORDFREE END (* ALLOCLEVEL *) ; BEGIN IF ENTRY <> NIL THEN WITH ENTRY@ DO CASE FORM OF SCALARS : IF SCALARKIND = DECLARED THEN WITH REPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := 1 ; NEXTCONST := FIRSTCONST ; NEXTVALUE := 0 ; WHILE NEXTCONST <> NIL DO BEGIN WITH NEXTCONST@ DO BEGIN VALUES.SIZE := 1 ; VALUES.KIND := INTVALUE ; VALUES.IVAL1 := NEXTVALUE END ; NEXTVALUE := NEXTVALUE + 1 ; NEXTCONST := NEXTCONST@.NEXT END ; MIN := 0 ; MAX := NEXTVALUE - 1 ; BYTESIZE := BYTESNEEDEDFOR(NEXTVALUE-1) END ; SUBRANGES : IF RANGETYPE = REALTYPE THEN REPRESENTATION := REALTYPE@.REPRESENTATION ELSE BEGIN REPRESENTATION.ACCESSDESCRIPTOR := ONEWORDSCALED ; REPRESENTATION.SIZE := 1 ; REPRESENTATION.MIN := MIN ; REPRESENTATION.MAX := MAX ; IF MIN < 0 THEN REPRESENTATION.BYTESIZE := BYTESINWORD ELSE REPRESENTATION.BYTESIZE := BYTESNEEDEDFOR(MAX) END ; POINTERS : REPRESENTATION := POINTERREPRESENTATION ; SETS : WITH REPRESENTATION DO BEGIN ACCESSDESCRIPTOR := TWOWORDSCALED ; SIZE := 2 END ; ARRAYS : IF (AELTYPE <> NIL) AND (INXTYPE <> NIL) THEN BEGIN GETBOUNDS(INXTYPE,INDEXMIN,INDEXMAX) ; IF (INDEXMIN<=MAXINT-TWOTOTHE18) AND (INDEXMIN+TWOTOTHE18<=INDEXMAX) THEN BEGIN ERROR(398) ; NOELEMENTS := 0 ; END ELSE NOELEMENTS := INDEXMAX - INDEXMIN + 1 ; IF PACKEDARRAY AND (AELTYPE@.REPRESENTATION.SIZE = 1) AND (AELTYPE@.REPRESENTATION.BYTESIZE = 1) THEN WORDSNEEDED := NOELEMENTS DIV BYTESINWORD + ORD(NOELEMENTS MOD BYTESINWORD <> 0) ELSE WORDSNEEDED := NOELEMENTS * AELTYPE@.REPRESENTATION.SIZE ; WITH REPRESENTATION DO BEGIN ACCESSDESCRIPTOR := AELTYPE@.REPRESENTATION.ACCESSDESCRIPTOR ; SIZE := WORDSNEEDED ; IF WORDSNEEDED = 1 THEN BEGIN BYTESIZE := BYTESINWORD ; MIN := -MAXINT ; MAX := +MAXINT END END END ELSE REPRESENTATION := DEFAULTREPRESENTATION ; RECORDS : BEGIN ALLOCLEVEL(NONVARPART,VARPART,0,WORDSUSED) ; WITH REPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := WORDSUSED ; IF WORDSUSED = 1 THEN BEGIN MIN := -MAXINT ; MAX := +MAXINT ; BYTESIZE := BYTESINWORD END END END ; FILES : WITH REPRESENTATION DO BEGIN ACCESSDESCRIPTOR := ONEWORDSCALED ; SIZE := FILEBLOCKSIZE END END END (* SETREPRESENTATIONFOR *) ; PROCEDURE SETPARAMETERADDRESSFOR ( ENTRY : IDENTRY ) ; BEGIN WITH ENTRY@,DISPLAY[LEVEL] DO BEGIN CASE KLASS OF VARS : BEGIN VARADDRESS.BLOCKLEVEL := LEVEL ; VARADDRESS.RELATIVEADDRESS := LOCALADDRESS ; IF IDTYPE <> NIL THEN IF VARPARAM THEN LOCALADDRESS := LOCALADDRESS + 2 ELSE LOCALADDRESS := LOCALADDRESS + IDTYPE@.REPRESENTATION.SIZE END ; PROC , FUNC : BEGIN WITH FADDRESS DO BEGIN BLOCKLEVEL := LEVEL ; RELATIVEADDRESS := LOCALADDRESS END ; LOCALADDRESS := LOCALADDRESS + 4 END END (* CASE *) ; IF LOCALADDRESS > WORDSINSEGMENT THEN ERROR(398) ; END (* WITH *) ; END (* SETPARAMETERADDRESSFOR *) ; PROCEDURE SETADDRESSFOR ( ENTRY : IDENTRY ) ; BEGIN WITH ENTRY@,DISPLAY[LEVEL] DO BEGIN CASE KLASS OF VARS : BEGIN VARADDRESS.BLOCKLEVEL := LEVEL ; VARADDRESS.RELATIVEADDRESS := LOCALADDRESS END ; FUNC : BEGIN RESULT.BLOCKLEVEL := LEVEL ; RESULT.RELATIVEADDRESS := LOCALADDRESS END END ; IF IDTYPE <> NIL THEN WITH IDTYPE@.REPRESENTATION DO BEGIN LOCALADDRESS := LOCALADDRESS + SIZE ; IF LOCALADDRESS > WORDSINSEGMENT THEN ERROR(398) ; LOCALSPACEREQUIRED := LOCALSPACEREQUIRED + SIZE END END END (* SETADDRESSFOR *) ; (*---- VARIABLE AND CONSTANT ACCESS ----*) (* ---------------------------- *) PROCEDURE STACKCONSTANT ( CONSTVALUE : VALU ) ; VAR CONSTENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GETSTACKENTRY(CONSTENTRY) ; WITH CONSTENTRY@ DO BEGIN REP.SIZE := CONSTVALUE.SIZE ; CASE CONSTVALUE.KIND OF INTVALUE , BOOLVALUE , CHARVALUE : BEGIN REP.MIN := CONSTVALUE.IVAL1 ; REP.MAX := CONSTVALUE.IVAL1 ; IF CONSTVALUE.IVAL1 >= 0 THEN REP.BYTESIZE := BYTESNEEDEDFOR(CONSTVALUE.IVAL1) ELSE REP.BYTESIZE := BYTESINWORD END ; REALVALUE : ; SETVALUE : ; STRINGVALUE : IF REP.SIZE = 1 THEN BEGIN REP.MIN := -MAXINT ; REP.MAX := +MAXINT ; REP.BYTESIZE := BYTESINWORD END END ; KIND := KONSTANT ; KONSTVALUE := CONSTVALUE END ; STACK(CONSTENTRY) END END (* STACKCONSTANT *) ; PROCEDURE STACKREFERENCE ( DESCRIPTORINLOCATION : BOOLEAN ; LOCATION : RUNTIMEADDRESS ; REPRESENTATION : TYPEREPRESENTATION ) ; VAR REFENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GETSTACKENTRY(REFENTRY) ; WITH REFENTRY@,POSITION DO BEGIN REP := REPRESENTATION ; KIND := REFERENCE ; INDEXED := FALSE ; BYTEADJUSTMENT := 0 ; PACKEDITEM := FALSE ; STATICLEVEL := LOCATION.BLOCKLEVEL ; OFFSET := LOCATION.RELATIVEADDRESS ; IF DESCRIPTORINLOCATION THEN BEGIN ACCESS := BYDESCRIPTOR ; CURRENTDESCRIPTOR := REPRESENTATION.ACCESSDESCRIPTOR END ELSE ACCESS := DIRECT END ; STACK(REFENTRY) END END (* STACKREFERENCE *) ; PROCEDURE FIELDREFERENCE ( FIELD : FIELDOFFSET ; FIELDREPRESENTATION : TYPEREPRESENTATION ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH TOPSTACKENTRY@ DO BEGIN WITH POSITION DO BYTEADJUSTMENT := BYTEADJUSTMENT + FIELD.BYTEOFFSET ; REP := FIELDREPRESENTATION END END (* FIELDREFERENCE *) ; PROCEDURE PNTERREFERENCE ( REPRESENTATION : TYPEREPRESENTATION ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH TOPSTACKENTRY@,POSITION DO BEGIN IF ( KIND = REFERENCE ) AND ( ACCESS = DIRECT ) AND NOT INDEXED THEN BEGIN OFFSET := OFFSET + BYTEADJUSTMENT DIV BYTESINWORD ; BYTEADJUSTMENT := 0 ; ACCESS := BYADDRESS END ELSE BEGIN LOADACC(TOPSTACKENTRY) ; KIND := REFERENCE ; BYTEADJUSTMENT := 0 ; PACKEDITEM := FALSE ; INDEXED := FALSE ; ACCESS := ONSTACKADDRESS ; PINS(ST,TOS,UNMODIFIED,0) END ; REP := REPRESENTATION END END (* PNTERREFERENCE *) ; PROCEDURE FILEREFERENCE ( PACKEDFILE,TEXTFILE : BOOLEAN ; ELEMENTREPRESENTATION :TYPEREPRESENTATION ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH TOPSTACKENTRY@ DO IF TEXTFILE THEN REP := ELEMENTREPRESENTATION ELSE PNTERREFERENCE(ELEMENTREPRESENTATION) END (* FILEREFERENCE *) ; PROCEDURE INDEXEDREFERENCE ( PACKEDARRAY : BOOLEAN ; LOWERBOUND,UPPERBOUND : INTEGER ; ELEMENTREPRESENTATION : TYPEREPRESENTATION ) ; VAR INDEX : STACKENTRY ; ARRAYISPACKED : BOOLEAN ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN RANGECHECK(TOPOFSTACK,LOWERBOUND,UPPERBOUND) ; UNSTACK(INDEX) ; WITH ELEMENTREPRESENTATION DO IF PACKEDARRAY AND (SIZE = 1) AND (BYTESIZE = 1) THEN ARRAYISPACKED := TRUE ELSE ARRAYISPACKED := FALSE ; WITH INDEX@ DO IF (KIND = CONDITION) OR (KIND = REFERENCE) AND (INDEXED OR POSITION.PACKEDITEM) THEN BEGIN LOADACC(INDEX) ; PINS(ST,TOS,UNMODIFIED,0) END ; IF INDEX@.KIND = KONSTANT THEN BEGIN WITH TOPSTACKENTRY@.POSITION DO BEGIN IF ARRAYISPACKED THEN BYTEADJUSTMENT := BYTEADJUSTMENT + ( INDEX@.KONSTVALUE.IVAL1 - LOWERBOUND ) * ELEMENTREPRESENTATION.BYTESIZE ELSE BYTEADJUSTMENT := BYTEADJUSTMENT + ( INDEX@.KONSTVALUE.IVAL1 - LOWERBOUND ) * ELEMENTREPRESENTATION.SIZE * BYTESINWORD ; PACKEDITEM := ARRAYISPACKED END ; FREESTACKENTRY(INDEX) END ELSE WITH TOPSTACKENTRY@,POSITION DO BEGIN IF ARRAYISPACKED THEN BEGIN INDEX@.ELEMENTSIZE := 1 ; BYTEADJUSTMENT := BYTEADJUSTMENT - ELEMENTREPRESENTATION.BYTESIZE * LOWERBOUND END ELSE BEGIN INDEX@.ELEMENTSIZE := ELEMENTREPRESENTATION.SIZE*BYTESINWORD ; BYTEADJUSTMENT := BYTEADJUSTMENT - ELEMENTREPRESENTATION.SIZE*LOWERBOUND*BYTESINWORD END ; PACKEDITEM := ARRAYISPACKED ; IF INDEXED THEN INDEX@.NEXTENTRY := INDICES ELSE BEGIN INDEX@.NEXTENTRY := NIL ; INDEXED := TRUE END ; INDICES := INDEX END ; TOPSTACKENTRY@.REP := ELEMENTREPRESENTATION END END (* INDEXEDREFERENCE *) ; PROCEDURE OPENWITH ( VAR WITHBASE : STACKENTRY ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH TOPSTACKENTRY@,POSITION DO IF (KIND <> REFERENCE) OR (ACCESS <> DIRECT ) OR PACKEDITEM OR INDEXED THEN BEGIN LOADDR(TOPSTACKENTRY,ONEWORDSCALED) ; ASSIGNTEMPORARYREFERENCETO(TOPSTACKENTRY) ; IF STATICLEVEL = GLOBALLEVEL THEN PINS(STD,XNB,UNMODIFIED,OFFSET) ELSE PINS(STD,LNB,UNMODIFIED,OFFSET) ; ACCESS := BYDESCRIPTOR ; CURRENTDESCRIPTOR := ONEWORDSCALED END ; WITHBASE := TOPSTACKENTRY END END (* OPENWITH *) ; PROCEDURE WITHREFERENCE ( WITHBASE : STACKENTRY ; FIELD : FIELDOFFSET ; FIELDREPRESENTATION : TYPEREPRESENTATION ) ; VAR FIELDENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GETSTACKENTRY(FIELDENTRY) ; FIELDENTRY@ := WITHBASE@ ; WITH FIELDENTRY@ DO BEGIN REP := FIELDREPRESENTATION ; WITH POSITION DO BYTEADJUSTMENT := BYTEADJUSTMENT + FIELD.BYTEOFFSET END ; STACK(FIELDENTRY) END END (* WITHREFERENCE *) ; PROCEDURE CLOSEWITH ; VAR WITHBASE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(WITHBASE) ; FREESTACKENTRY(WITHBASE) END END (* CLOSEWITH *) ; (*---- SPECIAL PASCAL FUNCTIONS ----*) (* ------------------------ *) PROCEDURE MONADICFUNCTION ( WHICHFUNC : STDPROCFUNCS ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH TOPSTACKENTRY@ DO BEGIN LOADVIRTUALADDRESS(TOPSTACKENTRY) ; REP := POINTERREPRESENTATION ; KIND := ONSTACKRESULT END ; PINS(ST,TOS,UNMODIFIED,0) END END (* MONADICFUNCTION *) ; PROCEDURE DYADICFUNCTION ( WHICHFUNC : STDPROCFUNCS ) ; VAR FIRSTPARAMETER,SECONDPARAMETER,RESULTENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(SECONDPARAMETER) ; UNSTACK(FIRSTPARAMETER ) ; GETSTACKENTRY(RESULTENTRY) ; RESULTENTRY@.REP := INTEGERREPRESENTATION ; IF WHICHFUNC IN [ ORF,ANDF,NEQF ] THEN LOADANDADDRESS(FIRSTPARAMETER,SECONDPARAMETER) ELSE BEGIN LOADACC(SECONDPARAMETER) ; ADDRESSVALUE(FIRSTPARAMETER) END ; WITH ADDRESSED DO PINS(SPECIALORDER[WHICHFUNC],K1,K2,N) ; PINS(ST,TOS,UNMODIFIED,0) ; RESULTENTRY@.KIND := ONSTACKRESULT ; STACK(RESULTENTRY) ; FREESTACKENTRY(FIRSTPARAMETER) ; FREESTACKENTRY(SECONDPARAMETER) END END (* DYADICFUNCTION *) ; PROCEDURE USEVIRTUALADDRESS ( ORDER : ORDERCODE ; ACCESSFORM : FORMATOFDESCRIPTOR ) ; VAR ADDRESSENTRY : STACKENTRY ; BEGIN UNSTACK (ADDRESSENTRY) ; ADDRESSVALUE (ADDRESSENTRY) ; WITH ADDRESSED DO PINS (LDA, K1, K2, N) ; LDTBPINS (ACCESSFORM) ; PINS (ORDER, NONE, MODIFYDR, 0) ; FREESTACKENTRY (ADDRESSENTRY) ; END (* USEVIRTUALADDRESS *) ; PROCEDURE VSSTOREOPERATION ( WHICHOP : STDPROCFUNCS ) ; VAR ITEMFORM : FORMATOFDESCRIPTOR ; ITEMENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN SWAPTOPSTACKENTRIES ; IF WHICHOP = STOREBYTEATP THEN WITH BYTEREPRESENTATION DO RANGECHECK (TOPOFSTACK, MIN, MAX) ; UNSTACK (ITEMENTRY) ; LOADACC (ITEMENTRY) ; FREESTACKENTRY (ITEMENTRY) ; IF WHICHOP = STOREBYTEATP THEN ITEMFORM := ONEBYTE ELSE ITEMFORM := ONEWORDSCALED ; USEVIRTUALADDRESS (ST, ITEMFORM) ; END ; END (* VSSTOREOPERATION *) ; PROCEDURE VSFETCHOPERATION ( WHICHOP : STDPROCFUNCS ) ; VAR ITEMFORM : FORMATOFDESCRIPTOR ; RESULTENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF WHICHOP = BYTEATF THEN ITEMFORM := ONEBYTE ELSE ITEMFORM := ONEWORDSCALED ; USEVIRTUALADDRESS (LSS, ITEMFORM) ; PINS (ST, TOS, UNMODIFIED, 0) ; GETSTACKENTRY (RESULTENTRY) ; WITH RESULTENTRY@ DO BEGIN IF WHICHOP = BYTEATF THEN REP := BYTEREPRESENTATION ELSE REP := INTEGERREPRESENTATION ; KIND := ONSTACKRESULT ; END ; STACK (RESULTENTRY) ; END ; END (* VSFETCHOPERATION *) ; PROCEDURE BYTESIZEVALUEFOR (REP : TYPEREPRESENTATION) ; VAR BYTESIZEVAL : VALU ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH BYTESIZEVAL DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := REP.SIZE * BYTESINWORD ; END ; STACKCONSTANT (BYTESIZEVAL) ; END ; END (* BYTESIZEVALUEFOR *) ; (*---- EXPRESSION EVALUATION ----*) (* --------------------- *) (*---- INTEGER ARITHMETIC ----*) (* ------------------ *) PROCEDURE CTARITHMETIC ( OPERATOR : OPTYPE ; LEFT,RIGHT : INTEGER ; VAR RESULT : INTEGER ) ; BEGIN OVERFLOWOCCURRED := FALSE ; CASE OPERATOR OF PLUS , MINUS : BEGIN IF OPERATOR = MINUS THEN RIGHT := - RIGHT ; IF (LEFT > 0) AND (RIGHT > 0) AND (LEFT > MAXINT - RIGHT) OR (LEFT < 0) AND (RIGHT < 0) AND (-LEFT>MAXINT + RIGHT) THEN BEGIN OVERFLOWOCCURRED := TRUE ; POSOVERFLOW := LEFT > 0 END ELSE RESULT := LEFT + RIGHT END ; MUL : IF RIGHT <> 0 THEN IF ABS(LEFT) > MAXINT DIV ABS(RIGHT) THEN BEGIN OVERFLOWOCCURRED := TRUE ; POSOVERFLOW := (LEFT > 0) AND (RIGHT > 0) OR (LEFT < 0) AND (RIGHT < 0) END ELSE RESULT := LEFT * RIGHT ELSE RESULT := 0 ; IDIV : IF RIGHT = 0 THEN OVERFLOWOCCURRED := TRUE ELSE RESULT := LEFT DIV RIGHT ; IMOD : IF RIGHT = 0 THEN OVERFLOWOCCURRED := TRUE ELSE RESULT := LEFT MOD RIGHT END ; END (* CTARITHMETIC *) ; FUNCTION VALUEISZERO ( ENTRY : STACKENTRY ) : BOOLEAN ; BEGIN WITH ENTRY@ DO IF KIND = KONSTANT THEN WITH KONSTVALUE DO CASE KIND OF INTVALUE : VALUEISZERO := IVAL1 = 0 ; CHARVALUE : VALUEISZERO := CVAL = 0 ; BOOLVALUE : VALUEISZERO := NOT BVAL ; REALVALUE : VALUEISZERO := RVAL = 0 ; SETVALUE : VALUEISZERO := SVAL = [] ; STRINGVALUE : VALUEISZERO := FALSE END ELSE VALUEISZERO := FALSE END (* VALUEISZERO *) ; PROCEDURE ANALYSEINTEGER ( VAR OPERAND : OPERANDDESCRIPTION ) ; BEGIN WITH OPERAND,ENTRY@ DO BEGIN ISCONSTANT := KIND = KONSTANT ; ISGEZERO := REP.MIN >= 0 ; IF ISCONSTANT THEN BEGIN CVALUE := KONSTVALUE.IVAL1 ; ISZERO := CVALUE = 0 ; ISPOWEROF2 := NUMBERISPOWEROF2(CVALUE,LOG2) END ELSE BEGIN ISZERO:= FALSE ; ISPOWEROF2 := FALSE END END END (* ANALYSEINTEGER *) ; PROCEDURE NEGATEINTEGER ; VAR NEWMAX : INTEGER ; BEGIN IF CODEISTOBEGENERATED THEN WITH TOPSTACKENTRY@ DO BEGIN IF KIND = KONSTANT THEN KONSTVALUE.IVAL1 := -KONSTVALUE.IVAL1 ELSE BEGIN LOADACC(TOPSTACKENTRY) ; CONSTPINS(IRSB,0) ; PINS(ST,TOS,UNMODIFIED,0) END ; NEWMAX := -REP.MIN ; REP.MIN := -REP.MAX ; REP.MAX := NEWMAX END END (* NEGATEINTEGER *) ; PROCEDURE BINARYINTEGEROPERATION ( OPERATOR : OPTYPE ) ; VAR LEFTOPERAND,RIGHTOPERAND : OPERANDDESCRIPTION ; RESULTENTRY : STACKENTRY ; RESLT : INTEGER ; RESULTINACC : BOOLEAN ; POWER : POWERRANGE ; PROCEDURE SETLIMITSFORRESULT ; VAR LEFTMIN,LEFTMAX,RIGHTMIN,RIGHTMAX, RESULTMIN,RESULTMAX,SAVEDMIN : INTEGER ; UFCOUNT,OFCOUNT : INTEGER ; PROCEDURE TRYMIN ( POSSIBLEMIN : INTEGER ) ; BEGIN IF POSSIBLEMIN < RESULTMIN THEN RESULTMIN := POSSIBLEMIN END (* TRYMIN *) ; PROCEDURE TRYMAX ( POSSIBLEMAX : INTEGER ) ; BEGIN IF POSSIBLEMAX > RESULTMAX THEN RESULTMAX := POSSIBLEMAX END (* TRYMAX *) ; PROCEDURE TRYPRODUCT ( BOUND1,BOUND2 : INTEGER ) ; VAR PRODUCT : INTEGER ; BEGIN CTARITHMETIC(MUL,BOUND1,BOUND2,PRODUCT) ; IF OVERFLOWOCCURRED THEN IF POSOVERFLOW THEN BEGIN OFCOUNT := OFCOUNT + 1 ; RESULTMAX := MAXINT END ELSE BEGIN UFCOUNT := UFCOUNT + 1 ; RESULTMIN := -MAXINT END ELSE BEGIN TRYMIN(PRODUCT) ; TRYMAX(PRODUCT) END END (* TRYPRODUCT *) ; PROCEDURE TRYQUOTIENT ( BOUND1,BOUND2 : INTEGER ) ; VAR QUOTIENT : INTEGER ; BEGIN CTARITHMETIC(IDIV,BOUND1,BOUND2,QUOTIENT) ; TRYMIN(QUOTIENT) ; TRYMAX(QUOTIENT) END (* TRYQUOTIENT *) ; BEGIN WITH LEFTOPERAND.ENTRY@.REP DO BEGIN LEFTMIN := MIN ; LEFTMAX := MAX END ; WITH RIGHTOPERAND.ENTRY@.REP DO BEGIN RIGHTMIN := MIN ; RIGHTMAX := MAX END ; CASE OPERATOR OF PLUS , MINUS : BEGIN IF OPERATOR = MINUS THEN BEGIN SAVEDMIN := RIGHTMIN ; RIGHTMIN := -RIGHTMAX ; RIGHTMAX := -SAVEDMIN END ; CTARITHMETIC(PLUS,LEFTMIN,RIGHTMIN,RESULTMIN) ; IF OVERFLOWOCCURRED THEN IF POSOVERFLOW THEN ERROR(303) ELSE RESULTMIN := -MAXINT ; CTARITHMETIC(PLUS,LEFTMAX,RIGHTMAX,RESULTMAX) ; IF OVERFLOWOCCURRED THEN IF POSOVERFLOW THEN RESULTMAX := MAXINT ELSE ERROR(303) END ; MUL : BEGIN RESULTMIN := MAXINT ; RESULTMAX := -MAXINT ; OFCOUNT := 0 ; UFCOUNT := 0 ; TRYPRODUCT(LEFTMIN,RIGHTMIN) ; TRYPRODUCT(LEFTMIN,RIGHTMAX) ; TRYPRODUCT(LEFTMAX,RIGHTMIN) ; TRYPRODUCT(LEFTMAX,RIGHTMAX) ; IF (OFCOUNT = 4) OR (UFCOUNT = 4) THEN ERROR(303) END ; IDIV : BEGIN RESULTMIN := MAXINT ; RESULTMAX := -MAXINT ; IF RIGHTMIN <> 0 THEN BEGIN TRYQUOTIENT(LEFTMIN,RIGHTMIN) ; TRYQUOTIENT(LEFTMAX,RIGHTMIN) END ; IF RIGHTMAX <> 0 THEN BEGIN TRYQUOTIENT(LEFTMIN,RIGHTMAX) ; TRYQUOTIENT(LEFTMAX,RIGHTMAX) END ; IF (RIGHTMIN <= 0) AND (RIGHTMAX >=0) THEN BEGIN IF RIGHTMIN < 0 THEN BEGIN TRYQUOTIENT(LEFTMIN,-1) ; TRYQUOTIENT(LEFTMAX,-1) END ; IF RIGHTMAX > 0 THEN BEGIN TRYQUOTIENT(LEFTMIN,1) ; TRYQUOTIENT(LEFTMAX,1) END ; IF (RIGHTMIN = 0) AND (RIGHTMAX = 0) THEN ERROR(303) END END ; IMOD : IF (RIGHTMIN = 0) AND (RIGHTMAX = 0) THEN ERROR(303) ELSE IF (LEFTMIN = LEFTMAX) AND (RIGHTMIN = RIGHTMAX) THEN BEGIN RESULTMIN := LEFTMIN MOD RIGHTMIN ; RESULTMAX := RESULTMIN END ELSE BEGIN RESULTMIN := 0 ; RESULTMAX := 0 ; IF (LEFTMIN < 0) AND (RIGHTMIN < 0) THEN IF LEFTMIN < RIGHTMIN THEN TRYMIN(RIGHTMIN+1) ELSE TRYMIN(LEFTMIN) ; IF (LEFTMIN < 0) AND (RIGHTMAX > 0) THEN IF -LEFTMIN > RIGHTMAX THEN TRYMIN(-RIGHTMAX+1) ELSE TRYMIN(LEFTMIN) ; IF (LEFTMAX > 0) AND (RIGHTMIN < 0) THEN IF LEFTMAX >= -RIGHTMIN THEN TRYMAX(-RIGHTMIN-1) ELSE TRYMAX(LEFTMAX) ; IF (LEFTMAX > 0) AND (RIGHTMAX > 0) THEN IF LEFTMAX >= RIGHTMAX THEN TRYMAX(RIGHTMAX-1) ELSE TRYMAX(LEFTMAX) END END ; WITH RESULTENTRY@ DO BEGIN REP.MIN := RESULTMIN ; REP.MAX := RESULTMAX END END (* SETLIMITSFORRESULT *) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(RIGHTOPERAND.ENTRY) ; UNSTACK(LEFTOPERAND.ENTRY) ; GETSTACKENTRY(RESULTENTRY) ; RESULTENTRY@.REP := INTEGERREPRESENTATION ; SETLIMITSFORRESULT ; ANALYSEINTEGER(LEFTOPERAND) ; ANALYSEINTEGER(RIGHTOPERAND) ; IF LEFTOPERAND.ISCONSTANT AND RIGHTOPERAND.ISCONSTANT THEN BEGIN CTARITHMETIC (OPERATOR,LEFTOPERAND.CVALUE,RIGHTOPERAND.CVALUE,RESLT) ; IF OVERFLOWOCCURRED THEN ERROR(303) ; WITH RESULTENTRY@ DO BEGIN KIND := KONSTANT ; WITH KONSTVALUE DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := RESLT END END END ELSE IF LEFTOPERAND.ISZERO AND ( OPERATOR <> MINUS ) THEN CASE OPERATOR OF PLUS : RESULTENTRY@ := RIGHTOPERAND.ENTRY@ ; MUL , IDIV , IMOD : RESULTENTRY@ := LEFTOPERAND.ENTRY@ END ELSE IF RIGHTOPERAND.ISZERO THEN CASE OPERATOR OF PLUS , MINUS : RESULTENTRY@ := LEFTOPERAND.ENTRY@ ; MUL : RESULTENTRY@ := RIGHTOPERAND.ENTRY@ ; IDIV , IMOD : BEGIN ERROR(300) ; RESULTENTRY@ := RIGHTOPERAND.ENTRY@ END END ELSE BEGIN RESULTINACC := TRUE ; CASE OPERATOR OF PLUS : BEGIN LOADANDADDRESS (LEFTOPERAND.ENTRY,RIGHTOPERAND.ENTRY) ; WITH ADDRESSED DO PINS(IAD,K1,K2,N) END ; MINUS : BEGIN LOADANDADDRESS (LEFTOPERAND.ENTRY,RIGHTOPERAND.ENTRY) ; WITH ADDRESSED DO IF REVERSEDOPERANDS THEN PINS(IRSB,K1,K2,N) ELSE PINS(ISB,K1,K2,N) END ; MUL : IF LEFTOPERAND.ISPOWEROF2 OR RIGHTOPERAND.ISPOWEROF2 THEN BEGIN IF LEFTOPERAND.ISPOWEROF2 THEN BEGIN LOADACC(RIGHTOPERAND.ENTRY) ; POWER := LEFTOPERAND.LOG2 END ELSE BEGIN LOADACC(LEFTOPERAND.ENTRY) ; POWER := RIGHTOPERAND.LOG2 END ; IF POWER <> 0 THEN CONSTPINS(ISH,POWER) END ELSE BEGIN LOADANDADDRESS (LEFTOPERAND.ENTRY,RIGHTOPERAND.ENTRY) ; WITH ADDRESSED DO PINS(IMY,K1,K2,N) END ; IDIV : IF RIGHTOPERAND.ISPOWEROF2 AND LEFTOPERAND.ISGEZERO THEN BEGIN LOADACC(LEFTOPERAND.ENTRY) ; IF RIGHTOPERAND.LOG2 <> 0 THEN CONSTPINS(ISH,-RIGHTOPERAND.LOG2) END ELSE BEGIN LOADANDADDRESS (LEFTOPERAND.ENTRY,RIGHTOPERAND.ENTRY) ; WITH ADDRESSED DO IF REVERSEDOPERANDS THEN PINS(IRDV,K1,K2,N) ELSE PINS(IDV,K1,K2,N) END ; IMOD : BEGIN LOADANDADDRESS (LEFTOPERAND.ENTRY,RIGHTOPERAND.ENTRY) ; WITH ADDRESSED DO IF REVERSEDOPERANDS THEN BEGIN PINS(SL,K1,K2,N) ; PINS(IMDV,TOS,UNMODIFIED,0) END ELSE PINS(IMDV,K1,K2,N) ; RESULTINACC := FALSE END END ; RESULTENTRY@.KIND := ONSTACKRESULT ; IF RESULTINACC THEN PINS(ST,TOS,UNMODIFIED,0) END ; STACK(RESULTENTRY) ; FREESTACKENTRY(LEFTOPERAND.ENTRY) ; FREESTACKENTRY(RIGHTOPERAND.ENTRY) END END (* BINARYINTEGEROPERATION *) ; PROCEDURE INTEGERCOMPARISON ( OPERATOR : OPTYPE ) ; VAR RIGHTOPERAND,LEFTOPERAND : OPERANDDESCRIPTION ; RESULTENTRY : STACKENTRY ; DIFFERENCE : INTEGER ; RESULTVALUE : BOOLEAN ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(RIGHTOPERAND.ENTRY) ; UNSTACK(LEFTOPERAND.ENTRY) ; GETSTACKENTRY(RESULTENTRY) ; RESULTENTRY@.REP := BOOLEANREPRESENTATION ; ANALYSEINTEGER(RIGHTOPERAND) ; ANALYSEINTEGER(LEFTOPERAND) ; IF LEFTOPERAND.ISCONSTANT AND RIGHTOPERAND.ISCONSTANT THEN BEGIN CTARITHMETIC (MINUS,LEFTOPERAND.CVALUE,RIGHTOPERAND.CVALUE,DIFFERENCE) ; CASE OPERATOR OF LTOP : RESULTVALUE := DIFFERENCE < 0 ; GTOP : RESULTVALUE := DIFFERENCE > 0 ; LEOP : RESULTVALUE := DIFFERENCE <= 0 ; GEOP : RESULTVALUE := DIFFERENCE >= 0 ; EQOP : RESULTVALUE := DIFFERENCE = 0 ; NEOP : RESULTVALUE := DIFFERENCE <> 0 END ; WITH RESULTENTRY@ DO BEGIN KIND := KONSTANT ; WITH KONSTVALUE DO BEGIN SIZE := 1 ; KIND := BOOLVALUE ; BVAL := RESULTVALUE END END END ELSE IF LEFTOPERAND.ISZERO OR RIGHTOPERAND.ISZERO THEN BEGIN IF RIGHTOPERAND.ISZERO THEN LOADACC(LEFTOPERAND.ENTRY) ELSE BEGIN LOADACC(RIGHTOPERAND.ENTRY) ; OPERATOR := REVERSEOF[OPERATOR] END ; WITH RESULTENTRY@ DO BEGIN KIND := CONDITION ; KINDOFCONDITION := JUMPONACC ; FALSEACCJUMP := FALSEINTEGERJUMPFOR[OPERATOR] END END ELSE BEGIN LOADANDADDRESS(LEFTOPERAND.ENTRY,RIGHTOPERAND.ENTRY) ; IF REVERSEDOPERANDS THEN OPERATOR := REVERSEOF[OPERATOR] ; WITH ADDRESSED DO PINS(ICP,K1,K2,N) ; WITH RESULTENTRY@ DO BEGIN KIND := CONDITION ; KINDOFCONDITION := JUMPONCC ; FALSECCJUMP := FALSECCMASKFOR[OPERATOR] END END ; STACK(RESULTENTRY) ; FREESTACKENTRY(LEFTOPERAND.ENTRY) ; FREESTACKENTRY(RIGHTOPERAND.ENTRY) END END (* INTEGERCOMPARISON *) ; PROCEDURE INTEGERFUNCTION ( WHICHFUNC : STDPROCFUNCS ) ; VAR MINCHAR, MAXCHAR : INTEGER; B : BOOLEAN ; POSITIVEVALUE : CODESEQUENCE ; PROCEDURE SETLIMITSFORRESULT ; VAR OLDMIN,OLDMAX,NEWMIN,NEWMAX : INTEGER ; BEGIN WITH TOPSTACKENTRY@.REP DO BEGIN OLDMIN := MIN ; OLDMAX := MAX END ; CASE WHICHFUNC OF ABSF , SQRF : BEGIN IF ABS(OLDMIN) < ABS(OLDMAX) THEN BEGIN NEWMIN := ABS(OLDMIN) ; NEWMAX := ABS(OLDMAX) END ELSE BEGIN NEWMIN := ABS(OLDMAX) ; NEWMAX := ABS(OLDMIN) END ; IF (OLDMIN < 0) AND (OLDMAX >= 0) THEN NEWMIN := 0 ; IF WHICHFUNC = SQRF THEN BEGIN CTARITHMETIC(MUL,NEWMIN,NEWMIN,NEWMIN) ; IF OVERFLOWOCCURRED THEN ERROR(303) ; CTARITHMETIC(MUL,NEWMAX,NEWMAX,NEWMAX) END END ; SUCCF : BEGIN CTARITHMETIC(PLUS,OLDMIN,1,NEWMIN) ; CTARITHMETIC(PLUS,OLDMAX,1,NEWMAX) END ; PREDF : BEGIN CTARITHMETIC(MINUS,OLDMAX,1,NEWMAX) ; CTARITHMETIC(MINUS,OLDMIN,1,NEWMIN) END END ; WITH TOPSTACKENTRY@.REP DO BEGIN MIN := NEWMIN ; MAX := NEWMAX END END (* SETLIMITSFORRESULT *) ; BEGIN IF CODEISTOBEGENERATED THEN WITH TOPSTACKENTRY@ DO BEGIN IF WHICHFUNC IN [ ORDF,CHRF ] THEN IF WHICHFUNC = ORDF THEN IF REP.SIZE = 1 THEN BEGIN IF KIND = CONDITION THEN BEGIN LOADACC(TOPSTACKENTRY) ; PINS(ST,TOS,UNMODIFIED,0) END END ELSE ERROR(123) ELSE BEGIN MINCHAR := REP.MIN; MAXCHAR := REP.MAX; RANGECHECK(TOPOFSTACK,CHARREPRESENTATION.MIN,CHARREPRESENTATION.MAX) ; REP := CHARREPRESENTATION; IF MINCHAR>REP.MIN THEN REP.MIN := MINCHAR; IF MAXCHAR ODDF THEN SETLIMITSFORRESULT END END END (* INTEGERFUNCTION *) ; (*---- REAL ARITHMETIC ----*) (* --------------- *) PROCEDURE FLOATINTEGER ( STACKPOSITION : STACKTOP ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF STACKPOSITION = NEXTTOTOP THEN SWAPTOPSTACKENTRIES ; LOADACC(TOPSTACKENTRY) ; CONSTPINS(FLT,0) ; TOPSTACKENTRY@.REP := REALREPRESENTATION ; PINS(ST,TOS,UNMODIFIED,0) ; IF STACKPOSITION = NEXTTOTOP THEN SWAPTOPSTACKENTRIES END END (* FLOATINTEGER *) ; PROCEDURE REALFUNCTION ( WHICHFUNC : STDPROCFUNCS ) ; VAR POSITIVEREAL,AFTERPOSITIVEREAL : CODESEQUENCE ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN LOADACC(TOPSTACKENTRY) ; CASE WHICHFUNC OF ABSF : BEGIN CONSTPINS(USH,1) ; CONSTPINS(USH,-1) END ; SQRF : BEGIN PINS(ST,TOS,UNMODIFIED,0) ; PINS(RMY,TOS,UNMODIFIED,0) END ; TRUNCF,ROUNDF : BEGIN IF WHICHFUNC = ROUNDF THEN BEGIN EXPECTCODESEQUENCE(POSITIVEREAL) ; EXPECTCODESEQUENCE(AFTERPOSITIVEREAL) ; TINS(JAF,REALACCLESSTHANZERO,POSITIVEREAL) ; CODEVALUE(POINTFIVE) ; PINS(RSB,PC,UNMODIFIED,0) ; JUMPPINS(J,AFTERPOSITIVEREAL) ; NEXTISCODESEQUENCE(POSITIVEREAL) ; CODEVALUE(POINTFIVE) ; PINS(RAD,PC,UNMODIFIED,0) ; NEXTISCODESEQUENCE(AFTERPOSITIVEREAL) END ; DOSUPPORTTASK(TRUNCATE) ; TOPSTACKENTRY@.REP := INTEGERREPRESENTATION END ; SINF , COSF , EXPF , LNF , SQRTF , ARCTANF : DOSUPPORTTASK(REALMATH[WHICHFUNC]) END ; PINS(ST,TOS,UNMODIFIED,0) END END(* REALFUNCTION *) ; PROCEDURE NEGATEREAL ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN LOADACC(TOPSTACKENTRY) ; CONSTPINS(RRSB,0) ; PINS(ST,TOS,UNMODIFIED,0) END END (* NEGATEREAL *) ; PROCEDURE BINARYREALOPERATION ( REALOPERATOR : OPTYPE ) ; VAR LEFTOPERAND,RIGHTOPERAND,RESULTENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(RIGHTOPERAND) ; UNSTACK(LEFTOPERAND) ; GETSTACKENTRY(RESULTENTRY) ; RESULTENTRY@.REP := REALREPRESENTATION ; LOADANDADDRESS(LEFTOPERAND,RIGHTOPERAND) ; WITH ADDRESSED DO CASE REALOPERATOR OF PLUS : PINS(RAD,K1,K2,N) ; MINUS : IF REVERSEDOPERANDS THEN PINS(RRSB,K1,K2,N) ELSE PINS(RSB,K1,K2,N) ; MUL : PINS(RMY,K1,K2,N) ; RDIV : IF REVERSEDOPERANDS THEN PINS(RRDV,K1,K2,N) ELSE PINS(RDV,K1,K2,N) END ; RESULTENTRY@.KIND := ONSTACKRESULT ; PINS(ST,TOS,UNMODIFIED,0) ; STACK(RESULTENTRY) ; FREESTACKENTRY(LEFTOPERAND) ; FREESTACKENTRY(RIGHTOPERAND) END END (* BINARYREALOPERATION *) ; PROCEDURE REALCOMPARISON ( OPERATOR : OPTYPE ) ; VAR RIGHTOPERAND,LEFTOPERAND,RESULTENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(RIGHTOPERAND) ; UNSTACK(LEFTOPERAND) ; GETSTACKENTRY(RESULTENTRY) ; RESULTENTRY@.REP := BOOLEANREPRESENTATION ; LOADANDADDRESS(LEFTOPERAND,RIGHTOPERAND) ; IF REVERSEDOPERANDS THEN OPERATOR := REVERSEOF[OPERATOR] ; WITH ADDRESSED DO PINS(RCP,K1,K2,N) ; WITH RESULTENTRY@ DO BEGIN KIND := CONDITION ; KINDOFCONDITION := JUMPONCC ; FALSECCJUMP := FALSECCMASKFOR[OPERATOR] END ; STACK(RESULTENTRY) ; FREESTACKENTRY(LEFTOPERAND) ; FREESTACKENTRY(RIGHTOPERAND) END END (* REALCOMPARISON *) ; (*---- BOOLEAN ARITHMETIC ----*) (* ------------------ *) PROCEDURE NEGATEBOOLEAN ; BEGIN IF CODEISTOBEGENERATED THEN WITH TOPSTACKENTRY@ DO CASE KIND OF KONSTANT : KONSTVALUE.BVAL := NOT KONSTVALUE.BVAL ; REFERENCE , ONSTACKRESULT : BEGIN LOADACC(TOPSTACKENTRY) ; CONSTPINS(NEQ,1) ; PINS(ST,TOS,UNMODIFIED,0) END ; CONDITION : CASE KINDOFCONDITION OF JUMPONACC : FALSEACCJUMP.JATORDER := NOT FALSEACCJUMP.JATORDER ; JUMPONCC : FALSECCJUMP := ALLCCCONDITIONSSET - FALSECCJUMP ; MULTIJUMPCONDITION : JUMPCONDITION := NOT JUMPCONDITION END END END (* NEGATEBOOLEAN *) ; PROCEDURE BINARYBOOLEANOPERATION ( OPERATOR : OPTYPE ; FIRSTSUCHOPERATOR : BOOLEAN ) ; VAR BOOLEANOPERAND,CONDENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(BOOLEANOPERAND) ; IF FIRSTSUCHOPERATOR THEN BEGIN GETSTACKENTRY(CONDENTRY) ; WITH CONDENTRY@ DO BEGIN REP := BOOLEANREPRESENTATION ; KIND := CONDITION ; KINDOFCONDITION := MULTIJUMPCONDITION ; JUMPCONDITION := OPERATOR = OROP ; EXPECTCODESEQUENCE(JUMPDESTINATION) END ; STACK(CONDENTRY) END ; WITH TOPSTACKENTRY@ DO JUMPIF(BOOLEANOPERAND,JUMPCONDITION,JUMPDESTINATION) ; FREESTACKENTRY(BOOLEANOPERAND) END END (* BINARYBOOLEANOPERATOR *) ; (* 09 JUN 78 --------- THE INTRODUCTION OF THE CODE GENERATOR PROCEDURE 'FIXBOOLEANCHECK' IS CONCEPTUALLY SOMETHING OF A KLUDGE. IF THE CURRENT TOP 'STACKENTRY' HAS ITS 'KIND' = 'CONDITION', 'FIXBOOLEANCHECK' FORCES A CONVERSION OF THIS 'STACKENTRY' TO 'KIND' = 'ONSTACKRESULT'. THIS CONVERSION IS NECESSARY IN CERTAIN SYNTACTIC CONTEXTS TO AVOID CORRUPTIONS IN SUBSEQUENT ACCESS TO THE 'CONDITION' DESCRIBED BY THE 'STACKENTRY'. 'FIXBOOLEANCHECK' IS CALLED FROM WITHIN THE SYNTAX ANALYSER IN THE NECESSARY SYNTACTIC CONTEXTS, OF WHICH THERE ARE CURRENTLY 2, LOCATED IN THE FOLLOWING SYNTAX ANALYSER PROCEDURES :- EXPRESSION FORSTATEMENT WRITEPROCEDURE ( - 24 OCT 78 ) *) PROCEDURE FIXBOOLEANCHECK ; BEGIN IF CODEISTOBEGENERATED THEN IF TOPSTACKENTRY@.KIND = CONDITION THEN BEGIN LOADACC(TOPSTACKENTRY) ; PINS(ST,TOS,UNMODIFIED,0) END END; (*---- SET ARITHMETIC ----*) (* -------------- *) FUNCTION BITOFFSETFOR ( I,SETSIZE : INTEGER ) : INTEGER ; CONST WORDLENGTH = 32 ; BEGIN IF SETSIZE = 1 THEN BITOFFSETFOR := I + WORDLENGTH ELSE BITOFFSETFOR := I END (* BITOFFSETFOR *) ; PROCEDURE SINGLETONSET ( SETREPRESENTATION : TYPEREPRESENTATION ) ; CONST WORDLENGTH = 32 ; VAR I : SETRANGE ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF SETREPRESENTATION.SIZE = 1 THEN RANGECHECK(TOPOFSTACK,0,WORDLENGTH-1) ELSE RANGECHECK(TOPOFSTACK,0,2*WORDLENGTH-1) ; WITH TOPSTACKENTRY@ DO BEGIN IF KIND = KONSTANT THEN WITH KONSTVALUE DO BEGIN I := IVAL1 ; SIZE := SETREPRESENTATION.SIZE ; KIND := SETVALUE ; SVAL := [ BITOFFSETFOR(I,SIZE) ] END ELSE WITH SETREPRESENTATION DO BEGIN LOADACC(TOPSTACKENTRY) ; IF SIZE = 1 THEN CONSTPINS(SLSS,1) ELSE CONSTPINS(SLSD,1) ; PINS(USH,TOS,UNMODIFIED,0) ; PINS(ST,TOS,UNMODIFIED,0) END ; REP := SETREPRESENTATION END END END (* SINGLETONSET *) ; PROCEDURE RANGESET ( SETREPRESENTATION : TYPEREPRESENTATION ) ; CONST WORDLENGTH = 32 ; VAR UPPERLIMIT : POSITIVEINTEGER ; UPPERBOUND,LOWERBOUND,RANGEENTRY : STACKENTRY ; I : SETRANGE ; KONSTRANGE : BASICSET ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF SETREPRESENTATION.SIZE = 1 THEN UPPERLIMIT := WORDLENGTH - 1 ELSE UPPERLIMIT := 2*WORDLENGTH - 1 ; RANGECHECK(TOPOFSTACK,0,UPPERLIMIT) ; RANGECHECK(NEXTTOTOP ,0,UPPERLIMIT) ; UNSTACK(UPPERBOUND) ; UNSTACK(LOWERBOUND) ; GETSTACKENTRY(RANGEENTRY) ; RANGEENTRY@.REP := SETREPRESENTATION ; IF ( UPPERBOUND@.KIND = KONSTANT ) AND ( LOWERBOUND@.KIND = KONSTANT ) THEN BEGIN KONSTRANGE := [ ] ; FOR I := LOWERBOUND@.KONSTVALUE.IVAL1 MOD (2*WORDLENGTH) TO UPPERBOUND@.KONSTVALUE.IVAL1 MOD (2*WORDLENGTH) DO KONSTRANGE := KONSTRANGE + [BITOFFSETFOR(I,SETREPRESENTATION.SIZE)] ; WITH RANGEENTRY@ DO BEGIN KIND := KONSTANT ; WITH KONSTVALUE DO BEGIN SIZE := SETREPRESENTATION.SIZE ; KIND := SETVALUE ; SVAL := KONSTRANGE END END END ELSE BEGIN LOADACC(UPPERBOUND) ; IF SETREPRESENTATION.SIZE = 1 THEN BEGIN CONSTPINS(ISB,WORDLENGTH-1) ; CONSTPINS(SLSS,-1) END ELSE BEGIN CONSTPINS(ISB,2*WORDLENGTH-1) ; CONSTPINS(SLSD,-1) END ; PINS(USH,TOS,UNMODIFIED,0) ; ADDRESSVALUE(LOWERBOUND) ; WITH ADDRESSED DO PINS(SLSS,K1,K2,N) ; IF SETREPRESENTATION.SIZE = 1 THEN CONSTPINS(SLSS,-1) ELSE CONSTPINS(SLSD,-1) ; PINS(USH,TOS,UNMODIFIED,0) ; PINS(LAND,TOS,UNMODIFIED,0) ; PINS(ST,TOS,UNMODIFIED,0) ; RANGEENTRY@.KIND := ONSTACKRESULT END ; STACK(RANGEENTRY) ; FREESTACKENTRY(LOWERBOUND) ; FREESTACKENTRY(UPPERBOUND) END END (* RANGESET *) ; PROCEDURE BINARYSETOPERATION ( SETOPERATOR : OPTYPE ) ; VAR RESULTENTRY,LEFTOPERAND,RIGHTOPERAND : STACKENTRY ; LEFT,RIGHT,NEWVALUE : BASICSET ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(RIGHTOPERAND) ; UNSTACK(LEFTOPERAND) ; GETSTACKENTRY(RESULTENTRY) ; IF VALUEISZERO(LEFTOPERAND) THEN RESULTENTRY@.REP := RIGHTOPERAND@.REP ELSE RESULTENTRY@.REP := LEFTOPERAND@.REP ; IF ( LEFTOPERAND@.KIND = KONSTANT ) AND ( RIGHTOPERAND@.KIND = KONSTANT ) THEN BEGIN LEFT := LEFTOPERAND@.KONSTVALUE.SVAL ; RIGHT := RIGHTOPERAND@.KONSTVALUE.SVAL ; CASE SETOPERATOR OF PLUS : NEWVALUE := LEFT + RIGHT ; MINUS : NEWVALUE := LEFT - RIGHT ; MUL : NEWVALUE := LEFT * RIGHT END ; WITH RESULTENTRY@ DO BEGIN KIND := KONSTANT ; WITH KONSTVALUE DO BEGIN SIZE := REP.SIZE ; KIND := SETVALUE ; SVAL := NEWVALUE END END END ELSE IF VALUEISZERO(LEFTOPERAND) OR VALUEISZERO(RIGHTOPERAND) THEN CASE SETOPERATOR OF PLUS : IF VALUEISZERO(LEFTOPERAND) THEN RESULTENTRY@ := RIGHTOPERAND@ ELSE RESULTENTRY@ := LEFTOPERAND@ ; MINUS : RESULTENTRY@ := LEFTOPERAND@ ; MUL : IF VALUEISZERO(LEFTOPERAND) THEN RESULTENTRY@ := LEFTOPERAND@ ELSE RESULTENTRY@ := RIGHTOPERAND@ END ELSE BEGIN IF SETOPERATOR IN [PLUS,MUL] THEN BEGIN LOADANDADDRESS(LEFTOPERAND,RIGHTOPERAND) ; WITH ADDRESSED DO IF SETOPERATOR = PLUS THEN PINS(LOR,K1,K2,N) ELSE PINS(LAND,K1,K2,N) END ELSE BEGIN LOADACC(RIGHTOPERAND) ; CONSTPINS(NEQ,-1) ; ADDRESSVALUE(LEFTOPERAND) ; WITH ADDRESSED DO PINS(LAND,K1,K2,N) END ; PINS(ST,TOS,UNMODIFIED,0) ; RESULTENTRY@.KIND := ONSTACKRESULT END ; STACK(RESULTENTRY) ; FREESTACKENTRY(LEFTOPERAND) ; FREESTACKENTRY(RIGHTOPERAND) END END (* BINARYSETOPERATION *) ; PROCEDURE INSETRANGECHECK ( MAXOFRANGE : INTEGER ) ; VAR FORCEFALSE, RESTACK : CODESEQUENCE ; BEGIN IF TOPSTACKENTRY@.KIND = KONSTANT THEN BEGIN WITH TOPSTACKENTRY@.KONSTVALUE DO IF (IVAL1<0) OR (IVAL1>MAXOFRANGE) THEN IVAL1 := -1 END ELSE BEGIN EXPECTCODESEQUENCE ( FORCEFALSE ) ; EXPECTCODESEQUENCE ( RESTACK ) ; LOADACC ( TOPSTACKENTRY ) ; TINS ( JAT , INTACCLESSTHANZERO , FORCEFALSE ) ; CONSTPINS ( ICP , MAXOFRANGE ) ; TINS ( JCC , REGEQORLESSTHANOPERAND , RESTACK ) ; NEXTISCODESEQUENCE ( FORCEFALSE ) ; CONSTPINS ( LSS , -1 ) ; NEXTISCODESEQUENCE ( RESTACK ) ; PINS ( ST , TOS , UNMODIFIED , 0 ) END END (* INSETRANGECHECK *) ; PROCEDURE SETCOMPARISON ( SETOPERATOR : OPTYPE ) ; VAR LEFTOPERAND,RIGHTOPERAND,RESULTENTRY : STACKENTRY ; LEFT,RIGHT : BASICSET ; ELEMENT : -1..SUPREMEELEMENTINSET ; NEWVALUE : BOOLEAN ; ONEWORDSET : BOOLEAN ; JUMP : ACCJUMP ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF SETOPERATOR = INOP THEN BEGIN SWAPTOPSTACKENTRIES ; IF TOPSTACKENTRY@.NEXTENTRY@.REP.SIZE = 1 THEN INSETRANGECHECK ( WORDLENGTH - 1 ) ELSE INSETRANGECHECK ( 2*WORDLENGTH - 1 ) ; UNSTACK(LEFTOPERAND) ; UNSTACK(RIGHTOPERAND) END ELSE BEGIN UNSTACK(RIGHTOPERAND) ; UNSTACK(LEFTOPERAND) END ; GETSTACKENTRY(RESULTENTRY) ; RESULTENTRY@.REP := BOOLEANREPRESENTATION ; IF ( LEFTOPERAND@.KIND = KONSTANT ) AND ( RIGHTOPERAND@.KIND = KONSTANT ) THEN BEGIN RIGHT := RIGHTOPERAND@.KONSTVALUE.SVAL ; WITH LEFTOPERAND@.KONSTVALUE DO IF SETOPERATOR = INOP THEN ELEMENT:=BITOFFSETFOR(IVAL1,RIGHTOPERAND@.REP.SIZE) ELSE LEFT := SVAL ; CASE SETOPERATOR OF EQOP : NEWVALUE := LEFT = RIGHT ; NEOP : NEWVALUE := LEFT <> RIGHT ; LEOP : NEWVALUE := LEFT <= RIGHT ; GEOP : NEWVALUE := LEFT >= RIGHT ; INOP : NEWVALUE := ELEMENT IN RIGHT END ; WITH RESULTENTRY@ DO BEGIN KIND := KONSTANT ; WITH KONSTVALUE DO BEGIN SIZE := 1 ; KIND := BOOLVALUE ; BVAL := NEWVALUE END END END ELSE BEGIN IF SETOPERATOR = INOP THEN BEGIN IF RIGHTOPERAND@.REP.SIZE = 1 THEN ONEWORDSET := TRUE ELSE ONEWORDSET := FALSE ; WITH LEFTOPERAND@ DO IF KIND = KONSTANT THEN BEGIN LOADACC(RIGHTOPERAND) ; IF ONEWORDSET THEN CONSTPINS(USH,WORDLENGTH-1-KONSTVALUE.IVAL1) ELSE CONSTPINS(USH,2*WORDLENGTH-1-KONSTVALUE.IVAL1) END ELSE BEGIN LOADACC(LEFTOPERAND) ; IF ONEWORDSET THEN CONSTPINS(IRSB,WORDLENGTH-1) ELSE CONSTPINS(IRSB,2*WORDLENGTH-1) ; ADDRESSVALUE(RIGHTOPERAND) ; WITH ADDRESSED DO IF ONEWORDSET THEN PINS(SLSS,K1,K2,N) ELSE PINS(SLSD,K1,K2,N) ; PINS(USH,TOS,UNMODIFIED,0) END ; JUMP := FALSEINTEGERJUMPFOR[LTOP] END ELSE IF SETOPERATOR IN [EQOP,NEOP] THEN BEGIN IF VALUEISZERO(LEFTOPERAND) THEN LOADACC(RIGHTOPERAND) ELSE IF VALUEISZERO(RIGHTOPERAND) THEN LOADACC(LEFTOPERAND) ELSE BEGIN LOADANDADDRESS(LEFTOPERAND,RIGHTOPERAND) ; WITH ADDRESSED DO PINS(NEQ,K1,K2,N) ; END ; JUMP := FALSEINTEGERJUMPFOR[SETOPERATOR] END ELSE BEGIN LOADACC(RIGHTOPERAND) ; CONSTPINS(NEQ,-1) ; ADDRESSVALUE(LEFTOPERAND) ; WITH ADDRESSED DO IF SETOPERATOR = LEOP THEN PINS(LAND,K1,K2,N) ELSE BEGIN PINS(LOR,K1,K2,N) ; CONSTPINS(NEQ,-1) END ; JUMP := FALSEINTEGERJUMPFOR[EQOP] END ; WITH RESULTENTRY@ DO BEGIN KIND := CONDITION ; KINDOFCONDITION := JUMPONACC ; FALSEACCJUMP := JUMP END END ; STACK(RESULTENTRY) ; FREESTACKENTRY(LEFTOPERAND) ; FREESTACKENTRY(RIGHTOPERAND) END END (* SETCOMPARISON *) ; (*---- STRING ARITHMETIC ----*) (* ----------------- *) PROCEDURE STRNGCOMPARISON ( LENGTH : POSITIVEINTEGER ; OPERATOR : OPTYPE ) ; VAR RIGHTSTRING,LEFTSTRING,RESULTENTRY : STACKENTRY ; CCJUMP : MASKFORJUMP ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(RIGHTSTRING) ; UNSTACK(LEFTSTRING) ; GETSTACKENTRY(RESULTENTRY) ; RESULTENTRY@.REP := BOOLEANREPRESENTATION ; IF ( LENGTH = 2*CHARSINWORD ) OR ( LENGTH = CHARSINWORD ) THEN BEGIN LOADANDADDRESS(LEFTSTRING,RIGHTSTRING) ; IF REVERSEDOPERANDS THEN OPERATOR := REVERSEOF[OPERATOR] ; WITH ADDRESSED DO PINS(UCP,K1,K2,N) ; CCJUMP := FALSECCMASKFOR[OPERATOR] END ELSE BEGIN LOADDR(RIGHTSTRING,ONEBYTE) ; CONSTPINS(CYD,0) ; LOADDR(LEFTSTRING,ONEBYTE) ; SINS(CPS,LENGTH) ; CCJUMP := FALSESTRINGMASKFOR[OPERATOR] END ; WITH RESULTENTRY@ DO BEGIN KIND := CONDITION ; KINDOFCONDITION := JUMPONCC ; FALSECCJUMP := CCJUMP END ; STACK(RESULTENTRY) ; FREESTACKENTRY(LEFTSTRING) ; FREESTACKENTRY(RIGHTSTRING) END END (* STRINGCOMPARISON *) ; (*---- 3. ASSIGNMENT ----*) (* ------------- *) PROCEDURE ASSIGNMENTCODE ( DESTINATION,SOURCE : STACKENTRY ) ; VAR SIZE : SEGMENTSIZE ; BEGIN SIZE := DESTINATION@.REP.SIZE ; IF ( SIZE = 1 ) OR ( SIZE = 2 ) THEN BEGIN LOADACC(SOURCE) ; ADDRESS(DESTINATION) ; WITH ADDRESSED DO PINS(ST,K1,K2,N) END ELSE BEGIN LOADDR(SOURCE,ONEBYTE) ; CONSTPINS(CYD,0) ; LOADDR(DESTINATION,ONEBYTE) ; SINS(MV,SIZE*CHARSINWORD) END END (* ASSIGNMENTCODE *) ; PROCEDURE ASSIGN ; VAR EXPRESSION,VARIABLE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH TOPSTACKENTRY@.NEXTENTRY@.REP DO IF SIZE = 1 THEN RANGECHECK(TOPOFSTACK,MIN,MAX) ; UNSTACK(EXPRESSION) ; UNSTACK(VARIABLE) ; ASSIGNMENTCODE(VARIABLE,EXPRESSION) ; FREESTACKENTRY(EXPRESSION) ; FREESTACKENTRY(VARIABLE) END END (* ASSIGN *) ; (*---- PROCEDURE AND FUNCTION CALLS ----*) (* ---------------------------- *) PROCEDURE OPENPARAMETERLIST ( BLOCKLEVEL : DISPRANGE ; CLASSOFCALL : IDCLASS ) ; VAR SPACEFORPARAMETERS : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GETSTACKENTRY(SPACEFORPARAMETERS) ; PRECALL ; WITH SPACEFORPARAMETERS@ DO BEGIN KIND := PARAMETERSPASSED ; IF BLOCKLEVEL = GLOBALLEVEL THEN WORDSPASSED := ADMINSPACEFORCALL ELSE BEGIN ADDRESSBASEOF(BLOCKLEVEL,ONEWORDSCALED) ; WITH ADDRESSED DO PINS(LD,K1,K2,N) ; PINS(STD,TOS,UNMODIFIED,0) ; WORDSPASSED := ADMINSPACEFORCALL + STATICLINKSPACE END END ; STACK(SPACEFORPARAMETERS) END END (* OPENPARAMETERLIST *) ; PROCEDURE CLOSEPARAMETERLIST ; BEGIN END (* CLOSEPARAMETERLIST*) ; PROCEDURE OPENFORMALPARAMETERLIST ( FORMALADDRESS : RUNTIMEADDRESS ; CLASSOFCALL : IDCLASS ) ; VAR SPACEFORPARAMETERS : STACKENTRY ; AFTERLOCALPF : CODESEQUENCE ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GETSTACKENTRY(SPACEFORPARAMETERS) ; PRECALL ; WITH SPACEFORPARAMETERS@ DO BEGIN KIND := PARAMETERSPASSED ; WORDSPASSED := ADMINSPACEFORCALL END ; WITH FORMALADDRESS DO BEGIN ADDRESSBASEOF(BLOCKLEVEL,TWOWORDUNSCALED) ; CONSTPINS(LB,(RELATIVEADDRESS+2)*BYTESINWORD) ; WITH ADDRESSED DO PINS(LSD,K1,MODIFYDESCRIPTORINSTORE,N) ; EXPECTCODESEQUENCE(AFTERLOCALPF) ; TINS(JAT,INTACCEQUALTOZERO,AFTERLOCALPF) ; PINS(ST,TOS,UNMODIFIED,0) ; NEXTISCODESEQUENCE(AFTERLOCALPF) END ; STACK(SPACEFORPARAMETERS) END END (* OPENFORMALPARAMETERLIST *) ; PROCEDURE CLOSEFMALPARAMETERLIST ; BEGIN END (* CLOSEFMALPARAMETERLIST *) ; PROCEDURE PASSVALUE ( REPREQUIRED : TYPEREPRESENTATION ) ; VAR ACTUALVALUE : STACKENTRY ; SIZE : SEGMENTSIZE ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH REPREQUIRED DO IF SIZE = 1 THEN RANGECHECK(TOPOFSTACK,MIN,MAX) ; UNSTACK(ACTUALVALUE) ; SIZE := ACTUALVALUE@.REP.SIZE ; IF ( SIZE = 1 ) OR ( SIZE = 2 ) THEN BEGIN LOADACC(ACTUALVALUE) ; PINS(ST,TOS,UNMODIFIED,0) END ELSE BEGIN LOADDR(ACTUALVALUE,ONEBYTE) ; CONSTPINS(CYD,0) ; PINS(STSF,BREGISTER,UNMODIFIED,0) ; PINS(LDA,BREGISTER,UNMODIFIED,0) ; CONSTPINS(ASF,SIZE) ; SINS(MV,SIZE*CHARSINWORD) END ; WITH TOPSTACKENTRY@ DO WORDSPASSED := WORDSPASSED + SIZE ; FREESTACKENTRY(ACTUALVALUE) END END (* PASSVALUE *) ; PROCEDURE PASSREFERENCE ; VAR ACTUALREFERENCE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(ACTUALREFERENCE) ; LOADDR(ACTUALREFERENCE,ACTUALREFERENCE@.REP.ACCESSDESCRIPTOR) ; PINS(STD,TOS,UNMODIFIED,0) ; WITH TOPSTACKENTRY@ DO WORDSPASSED := WORDSPASSED + 2 ; FREESTACKENTRY(ACTUALREFERENCE) END END (* PASSREFERENCE *) ; PROCEDURE PASSACTUAL ( BLOCKLEVEL : DISPRANGE ; VAR BODY : CODESEQUENCE ) ; VAR AFTERJUMPTOPF : CODESEQUENCE ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN CODEVALUE(CODEDESCRIPTOR) ; PINS(LSS,PC,UNMODIFIED,0) ; PINS(ST,TOS,UNMODIFIED,0) ; EXPECTCODESEQUENCE(AFTERJUMPTOPF) ; JUMPPINS(JLK,AFTERJUMPTOPF) ; LONGJUMP(J,BODY) ; NEXTISCODESEQUENCE(AFTERJUMPTOPF) ; IF BLOCKLEVEL = GLOBALLEVEL THEN CONSTPINS(LSD,0) ELSE BEGIN ADDRESSBASEOF(BLOCKLEVEL,ONEWORDSCALED) ; WITH ADDRESSED DO PINS(LSD,K1,K2,N) END ; PINS(ST,TOS,UNMODIFIED,0) ; WITH TOPSTACKENTRY@ DO WORDSPASSED := WORDSPASSED + 4 END END (* PASSACTUAL *) ; PROCEDURE PASSFORMAL ( FORMALADDRESS : RUNTIMEADDRESS ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH FORMALADDRESS DO BEGIN ADDRESSBASEOF(BLOCKLEVEL,FORWORDUNSCALED) ; CONSTPINS(LB,RELATIVEADDRESS*BYTESINWORD) ; WITH ADDRESSED DO PINS(LSQ,K1,MODIFYDESCRIPTORINSTORE,N) ; PINS(ST,TOS,UNMODIFIED,0) END ; WITH TOPSTACKENTRY@ DO WORDSPASSED := WORDSPASSED + 4 END END (* PASSFORMAL *) ; PROCEDURE RAISELNB ; VAR SPACEFORPARAMETERS : STACKENTRY ; BEGIN UNSTACK(SPACEFORPARAMETERS) ; CONSTPINS(RALN,SPACEFORPARAMETERS@.WORDSPASSED) ; FREESTACKENTRY(SPACEFORPARAMETERS) END (* RAISELNB *) ; PROCEDURE CALLACTUAL ( BLOCKLEVEL : DISPRANGE ; VAR BODY : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN RAISELNB ; LONGJUMP(CALL,BODY) END END (* CALLACTUAL *) ; PROCEDURE CALLFORMAL ( FORMALADDRESS : RUNTIMEADDRESS ) ; VAR GLOBALPF,AFTERGLOBALPF : CODESEQUENCE ; SPACEFORPARAMETERS : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(SPACEFORPARAMETERS) ; WITH FORMALADDRESS DO BEGIN ADDRESSBASEOF(BLOCKLEVEL,FORWORDUNSCALED) ; CONSTPINS(LB,RELATIVEADDRESS*BYTESINWORD) ; WITH ADDRESSED DO PINS(LSQ,K1,MODIFYDESCRIPTORINSTORE,N) ; PINS(STUH,TOS,UNMODIFIED,0) ; EXPECTCODESEQUENCE(GLOBALPF) ; EXPECTCODESEQUENCE(AFTERGLOBALPF) ; TINS(JAT,INTACCEQUALTOZERO,GLOBALPF) ; CONSTPINS(RALN,SPACEFORPARAMETERS@.WORDSPASSED + STATICLINKSPACE + 2) ; JUMPPINS(J,AFTERGLOBALPF) ; NEXTISCODESEQUENCE(GLOBALPF) ; CONSTPINS(RALN,SPACEFORPARAMETERS@.WORDSPASSED + 2) ; NEXTISCODESEQUENCE(AFTERGLOBALPF) ; PINS(CALL,TOS,DESCRIPTORINSTORE,0) ; PINS(LCT,LNB,UNMODIFIED,4) ; PINS(LXN,CTB,UNMODIFIED,GLOBALADDRESS+1) END ; FREESTACKENTRY(SPACEFORPARAMETERS) END END (* CALLFORMAL *) ; PROCEDURE TAKERESULT ( REPRESENTATION : TYPEREPRESENTATION ) ; VAR RESULTENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN GETSTACKENTRY(RESULTENTRY) ; PINS(ST,TOS,UNMODIFIED,0) ; WITH RESULTENTRY@ DO BEGIN REP := REPRESENTATION ; KIND := ONSTACKRESULT END ; STACK(RESULTENTRY) END END (* TAKERESULT *) ; PROCEDURE LEAVERESULT ( RESULTADDRESS : RUNTIMEADDRESS ; REPRESENTATION : TYPEREPRESENTATION ) ; VAR RESULTENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN STACKREFERENCE(FALSE,RESULTADDRESS,REPRESENTATION) ; UNSTACK(RESULTENTRY) ; LOADACC(RESULTENTRY) ; FREESTACKENTRY(RESULTENTRY) END END (* LEAVERESULT *) ; (*---- STANDARD PROCEDURES/FUNCTIONS ----*) (* ----------------------------- *) (*---- PACK/UNPACK PROCEDURES ----*) (* ---------------------- *) PROCEDURE PACKOPERATION ( WHICH : STDPROCFUNCS ; LOWERBOUND,UPPERBOUND : INTEGER ; UNPACKEDREPRESENTATION , PACKEDREPRESENTATION : TYPEREPRESENTATION ; NOOFELEMENTS : POSITIVEINTEGER ) ; VAR PACKINGPOSSIBLE : BOOLEAN ; DESCRIPTOR : FORMATOFDESCRIPTOR ; SOURCE,DESTINATION : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH PACKEDREPRESENTATION DO PACKINGPOSSIBLE := (SIZE = 1) AND (BYTESIZE = 1) ; UPPERBOUND := UPPERBOUND - NOOFELEMENTS + 1 ; IF WHICH = PACKP THEN BEGIN UNSTACK(DESTINATION) ; IF PACKINGPOSSIBLE THEN DESCRIPTOR := ONEBYTE ELSE DESCRIPTOR := ONEWORDSCALED ; LOADDR(DESTINATION,DESCRIPTOR) ; PINS(STD,XNB,UNMODIFIED,JLKPARAMETERAREA) ; INDEXEDREFERENCE (FALSE,LOWERBOUND,UPPERBOUND,UNPACKEDREPRESENTATION) ; UNSTACK(SOURCE) ; LOADDR(SOURCE,ONEWORDSCALED) ; PINS(STD,XNB,UNMODIFIED,JLKPARAMETERAREA+2) END ELSE BEGIN INDEXEDREFERENCE (FALSE,LOWERBOUND,UPPERBOUND,UNPACKEDREPRESENTATION) ; UNSTACK(DESTINATION) ; LOADDR(DESTINATION,ONEWORDSCALED) ; PINS(STD,XNB,UNMODIFIED,JLKPARAMETERAREA) ; UNSTACK(SOURCE) ; IF PACKINGPOSSIBLE THEN DESCRIPTOR := ONEBYTE ELSE DESCRIPTOR := ONEWORDSCALED ; LOADDR(SOURCE,DESCRIPTOR) ; PINS(STD,XNB,UNMODIFIED,JLKPARAMETERAREA+2) END ; CONSTPINS(LB,NOOFELEMENTS*PACKEDREPRESENTATION.SIZE) ; DOSUPPORTTASK(ASSIGNARRAY) ; FREESTACKENTRY(SOURCE) ; FREESTACKENTRY(DESTINATION) END END (* PACKOPERATION *) ; (*---- DATE/TIME/CLOCK PROCEDURES ----*) (* -------------------------- *) PROCEDURE DATEANDTIMEOPERATION ; VAR DATE, TIME : STACKENTRY; BEGIN IF CODEISTOBEGENERATED THEN BEGIN SWAPTOPSTACKENTRIES; UNSTACK(DATE); UNSTACK(TIME); LOADDR(DATE, ONEBYTE); (* -N.B. MUST HAVE A BYTE-VECTOR DESCRIPTOR HERE, TO GET CORRECT *) (* INTERFACE TO A SUPPORT LIBRARY COMPILED WITH THE "IMPLEMENTATION" *) (* VERSION PASCAL COMPILER. *) CONSTPINS(CYD, 0); LOADDR(TIME, ONEBYTE); (* -N.B. SEE COMMENT FOR "DATE" ABOVE. *) DOSUPPORTTASK(SETDATEANDTIMEVARS); FREESTACKENTRY(DATE); FREESTACKENTRY(TIME); END; END (* DATEANDTIMEOPERATION *) ; PROCEDURE CLOCKOPERATION ; VAR CLOCKRESULT : STACKENTRY; BEGIN IF CODEISTOBEGENERATED THEN BEGIN DOSUPPORTTASK(READCLOCK); GETSTACKENTRY(CLOCKRESULT); WITH CLOCKRESULT@ DO BEGIN REP:=INTEGERREPRESENTATION; KIND:=ONSTACKRESULT; END; PINS(ST, TOS, UNMODIFIED,0); STACK(CLOCKRESULT); END; END (* CLOCKOPERATION *) ; (*---- HALT PROCEDURE ----*) (* -------------- *) PROCEDURE HALTOPERATION ( MESSAGELENGTH : POSITIVEINTEGER ) ; VAR MESSAGE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(MESSAGE) ; LOADDR(MESSAGE,ONEBYTE) ; CONSTPINS(LDB,MESSAGELENGTH) ; DOSUPPORTTASK(HALTSYSTEM) ; FREESTACKENTRY(MESSAGE) END END (* HALTOPERATION *) ; (*---- FILE PROCEDURES AND FUNCTIONS ----*) (* ----------------------------- *) PROCEDURE FILEOPEN ( ELEMENTREPRESENTATION : TYPEREPRESENTATION ; PACKEDFILE,TEXTFILE : BOOLEAN ; PERMANENT : BOOLEAN ; FILENAME : ALFA ; UNITNUMBER : POSITIVEINTEGER ) ; TYPE TEXTFILEKIND = (ORDINARYORNONTEXT, STDINPUT, STDOUTPUT) ; VAR FILEREFERENCE : STACKENTRY ; FILETYPE : TEXTFILEKIND ; PROCEDURE STACKFILENAME; (*-DIRTY ONE*) CONST MAXREALINALFAREP=4; (* -SHOULD BE ALFAREPRESENTATION.SIZE DIV *) (* REALREPRESENTATION.SIZE *) TYPE REALINALFARANGE=1..MAXREALINALFAREP; ALFAASREALS=ARRAY [REALINALFARANGE] OF REAL; KLUDGEREC= RECORD CASE ISALFA: BOOLEAN OF TRUE: (A: ALFA); FALSE: (RA: ALFAASREALS) END; VAR I: REALINALFARANGE; KLUDGE: KLUDGEREC; REALVAL: VALU; PARTOFALFA: STACKENTRY; BEGIN WITH KLUDGE, REALVAL DO BEGIN ISALFA:=TRUE; A:=FILENAME; ISALFA:=FALSE; SIZE:=REALREPRESENTATION.SIZE; KIND:=REALVALUE; FOR I:=MAXREALINALFAREP DOWNTO 1 DO BEGIN RVAL:=RA[I]; STACKCONSTANT(REALVAL); END; END; FOR I:=1 TO MAXREALINALFAREP DO BEGIN UNSTACK(PARTOFALFA); LOADACC(PARTOFALFA); PINS(ST, TOS, UNMODIFIED, 0); FREESTACKENTRY(PARTOFALFA); END; END (* STACKFILENAME *); BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(FILEREFERENCE) ; IF LEVEL = GLOBALLEVEL THEN BEGIN PRECALL ; LOADDR(FILEREFERENCE,ONEWORDSCALED) ; PINS(STD,TOS,UNMODIFIED,0) ; STACKFILENAME; CONSTPINS(LSS,ORD(TEXTFILE)) ; CONSTPINS(SLSS,ORD(PERMANENT)) ; IF FILENAME = 'INPUT ' THEN FILETYPE := STDINPUT ELSE IF FILENAME = 'OUTPUT ' THEN FILETYPE := STDOUTPUT ELSE FILETYPE := ORDINARYORNONTEXT ; CONSTPINS(SLSS,ORD(FILETYPE)) ; CONSTPINS(SLSS,UNITNUMBER) ; IF TEXTFILE THEN CONSTPINS(SLSS,0) ELSE CONSTPINS(SLSS,ELEMENTREPRESENTATION.SIZE) ; PINS(ST,TOS,UNMODIFIED,0) ; DOSUPPORTTASK(OPENFILE) END ; FREESTACKENTRY(FILEREFERENCE) END END (* FILEOPEN *) ; PROCEDURE FILECLOSE ( TEXTFILE : BOOLEAN ) ; VAR FILEREFERENCE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(FILEREFERENCE) ; FREESTACKENTRY(FILEREFERENCE) END END (* FILECLOSE *) ; PROCEDURE FILEFUNCTION ( WHICH : STDPROCFUNCS ) ; BEGIN IF CODEISTOBEGENERATED THEN WITH TOPSTACKENTRY@ DO BEGIN REP := BOOLEANREPRESENTATION ; WITH POSITION DO IF WHICH = EOLNF THEN BYTEADJUSTMENT := BYTEADJUSTMENT + EOLNOFFSET ELSE BYTEADJUSTMENT := BYTEADJUSTMENT + EOFOFFSET END END (* FILEFUNCTION *) ; PROCEDURE SELECT ( WHICHFILE : READORWRITEFILE ) ; VAR FILEREFERENCE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(FILEREFERENCE) ; REQUEST2LOCATIONS(FILEVARIABLE) ; LOADDR(FILEREFERENCE,ONEWORDSCALED) ; IF LEVEL = GLOBALLEVEL THEN PINS(STD,XNB,UNMODIFIED,FILEVARIABLE) ELSE PINS(STD,LNB,UNMODIFIED,FILEVARIABLE) ; FREESTACKENTRY(FILEREFERENCE) END END (* SELECT *) ; PROCEDURE LOADFILEDESCRIPTOR ; BEGIN IF LEVEL = GLOBALLEVEL THEN PINS(LD,XNB,UNMODIFIED,FILEVARIABLE) ELSE PINS(LD,LNB,UNMODIFIED,FILEVARIABLE) END (* LOADFILEDESCRIPTOR *) ; PROCEDURE FILEOPERATION ( WHICH : STDPROCFUNCS ; PACKEDFILE,TEXTFILE : BOOLEAN ; ELEMENTREPRESENTATION : TYPEREPRESENTATION ) ; VAR FILEVARIABLE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(FILEVARIABLE) ; LOADDR(FILEVARIABLE,ONEWORDSCALED) ; DOSUPPORTTASK(WHICHFILEPROCEDURE[WHICH,TEXTFILE]) ; FREESTACKENTRY(FILEVARIABLE) END END (* FILEOPERATION *) ; PROCEDURE READOPERATION ( READMODE : INPUTKIND ) ; VAR DESTINATION,VALUEREAD : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF READMODE = CHARKIND THEN IF LEVEL = GLOBALLEVEL THEN PINS(LSS,XNB,DESCRIPTORINSTORE,FILEVARIABLE) ELSE PINS(LSS,LNB,DESCRIPTORINSTORE,FILEVARIABLE) ELSE BEGIN LOADFILEDESCRIPTOR ; DOSUPPORTTASK(READPROCEDURE[READMODE]) END ; GETSTACKENTRY(VALUEREAD) ; WITH VALUEREAD@ DO BEGIN REP := READREPRESENTATION[READMODE] ; KIND := ONSTACKRESULT END ; PINS(ST,TOS,UNMODIFIED,0) ; STACK(VALUEREAD) ; ASSIGN ; IF READMODE = CHARKIND THEN BEGIN LOADFILEDESCRIPTOR ; DOSUPPORTTASK(GETTEXTFILE) END END END (* READOPERATION *) ; PROCEDURE WRITESCALARS ( WRITEMODE : OUTPUTKIND ; FORMAT : FORMATKIND ) ; VAR DIGITSAFTERPOINT,FIELDWIDTH,SCALARVALUE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF WRITEMODE = REALKIND THEN IF FORMAT = FIXED THEN BEGIN UNSTACK(DIGITSAFTERPOINT) ; LOADACC(DIGITSAFTERPOINT) ; FREESTACKENTRY(DIGITSAFTERPOINT) END ELSE CONSTPINS(LSS,-1) ; IF FORMAT <> DEFAULT THEN BEGIN UNSTACK(FIELDWIDTH) ; ADDRESSVALUE(FIELDWIDTH) ; WITH ADDRESSED DO IF WRITEMODE <> REALKIND THEN PINS(LSS,K1,K2,N) ELSE PINS(LUH,K1,K2,N) ; FREESTACKENTRY(FIELDWIDTH) END ELSE IF WRITEMODE <> CHARKIND THEN IF WRITEMODE = REALKIND THEN CONSTPINS(LUH,DEFAULTWIDTH[REALKIND]) ELSE CONSTPINS(LSS,DEFAULTWIDTH[WRITEMODE]) ; UNSTACK(SCALARVALUE) ; IF (WRITEMODE = CHARKIND) AND (FORMAT = DEFAULT) THEN BEGIN LOADACC(SCALARVALUE) ; IF LEVEL = GLOBALLEVEL THEN PINS(ST,XNB,DESCRIPTORINSTORE,FILEVARIABLE) ELSE PINS(ST,LNB,DESCRIPTORINSTORE,FILEVARIABLE) ; DOSUPPORTTASK(PUTTEXTFILE) END ELSE BEGIN ADDRESSVALUE(SCALARVALUE) ; WITH ADDRESSED DO PINS(LUH,K1,K2,N) ; LOADFILEDESCRIPTOR ; DOSUPPORTTASK(WRITEPROCEDURE[WRITEMODE]) END ; FREESTACKENTRY(SCALARVALUE) END END (* WRITESCALARS *) ; PROCEDURE WRITESTRING ( ACTUALLENGTH : POSITIVEINTEGER ; FORMAT : FORMATKIND ) ; VAR STRINGVALUE,FIELDWIDTH : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF FORMAT <> DEFAULT THEN BEGIN UNSTACK(FIELDWIDTH) ; LOADACC(FIELDWIDTH) ; FREESTACKENTRY(FIELDWIDTH) END ; UNSTACK(STRINGVALUE) ; IF (FORMAT = DEFAULT ) AND ( ACTUALLENGTH <= CHARSINWORD ) THEN BEGIN CONSTPINS(LSS,ACTUALLENGTH) ; ADDRESSVALUE(STRINGVALUE) ; WITH ADDRESSED DO PINS(LUH,K1,K2,N) ; LOADFILEDESCRIPTOR ; DOSUPPORTTASK(WRITEWORDSTRING) END ELSE BEGIN LOADDR(STRINGVALUE,ONEBYTE) ; CONSTPINS(LDB,ACTUALLENGTH) ; IF FORMAT = DEFAULT THEN CONSTPINS(LB,ACTUALLENGTH) ELSE PINS(ST,BREGISTER,UNMODIFIED,0) ; CONSTPINS(CYD,0) ; LOADFILEDESCRIPTOR ; DOSUPPORTTASK(WRITSTRING) END ; FREESTACKENTRY(STRINGVALUE) END END (* WRITESTRING *) ; PROCEDURE READLAYOUT ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN LOADFILEDESCRIPTOR ; DOSUPPORTTASK(READCONTROL) END END (* READLAYOUT *) ; PROCEDURE WRITELAYOUT ; VAR LAYOUTVALUE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(LAYOUTVALUE) ; LOADFILEDESCRIPTOR ; IF LAYOUTVALUE@.KONSTVALUE.IVAL1 = THROWLINE THEN DOSUPPORTTASK(WRITECONTROL) ELSE DOSUPPORTTASK(PAGECONTROL) ; FREESTACKENTRY(LAYOUTVALUE) END END (* WRITELAYOUT *) ; (*---- HEAP MANAGEMENT ----*) (* --------------- *) PROCEDURE HEAPOPERATION ( WHICH : STDPROCFUNCS ; REPREQUIRED : TYPEREPRESENTATION ) ; VAR POINTERENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(POINTERENTRY) ; CONSTPINS(LSS,REPREQUIRED.SIZE) ; IF WHICH = NEWP THEN BEGIN DOSUPPORTTASK(GETSPACE) ; ADDRESS(POINTERENTRY) ; WITH ADDRESSED DO PINS(ST,K1,K2,N) END ELSE BEGIN ADDRESS(POINTERENTRY) ; WITH ADDRESSED DO PINS(LUH,K1,K2,N) ; DOSUPPORTTASK(RETURNSPACE) END ; FREESTACKENTRY(POINTERENTRY) END END (* HEAPOPERATION *) ; (*---- CONTROL STATEMENTS ----*) (* ------------------ *) PROCEDURE JUMPONFALSE ( VAR DESTINATION : CODESEQUENCE ) ; VAR BOOLEANENTRY : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(BOOLEANENTRY) ; JUMPIF(BOOLEANENTRY,FALSE,DESTINATION) ; FREESTACKENTRY(BOOLEANENTRY) END END (* JUMPONFALSE *) ; PROCEDURE LABELJUMP ( VAR DESTINATION : CODESEQUENCE ; LABELLEVEL : DISPRANGE ) ; BEGIN IF CODEISTOBEGENERATED THEN IF LABELLEVEL = LEVEL THEN JUMPPINS(J,DESTINATION) ELSE BEGIN PINS (STSF, BREGISTER, UNMODIFIED, 0) ; ADDRESSSTACKBASEWORDOF (LABELLEVEL) ; WITH ADDRESSED DO PINS (LSS, K1, K2, N+1) ; PINS (ISB, BREGISTER, UNMODIFIED, 0) ; CONSTPINS (ISH, -2) ; IF LABELLEVEL=GLOBALLEVEL THEN CONSTPINS (IAD, ADMINSPACEFORCALL) ELSE BEGIN CLEARPENDINGINSTRUCTIONS ; APPENDFRAMESIZEFIXUP (DESTINATION.FRAMESIZEFIXUPLIST) ; LONGCONSTPINS (IAD, 0) ; END ; PINS (ST, BREGISTER, UNMODIFIED, 0) ; ADDRESSSTACKBASEWORDOF (LABELLEVEL) ; WITH ADDRESSED DO PINS (LLN, K1, K2, N+1) ; PINS (ASF, BREGISTER, UNMODIFIED, 0) ; LONGJUMP (J, DESTINATION) ; END (* ELSE *) ; END (* LABELJUMP *) ; PROCEDURE JUMP ( VAR DESTINATION : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN JUMPPINS(J,DESTINATION) END (* JUMP *) ; PROCEDURE OPENCASE ( VAR CASESWITCH : CODESEQUENCE ) ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN LOADACC(TOPSTACKENTRY) ; JUMPPINS(J,CASESWITCH) END END (* OPENCASE *) ; PROCEDURE CLOSECASE ( FIRSTCASE : CASENTRY ) ; VAR CASEJUMPVALUE : STACKENTRY ; PERFORMCHECKANDJUMP : CODESEQUENCE ; FULLTABLE : BOOLEAN ; TABLESIZE : POSITIVEINTEGER ; NEXTTABLEVALUE,FIRSTVALUE : INTEGER ; THISCASE : CASENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN IF FIRSTCASE <> NIL THEN BEGIN EXPECTCODESEQUENCE(PERFORMCHECKANDJUMP) ; JUMPPINS(JLK,PERFORMCHECKANDJUMP) ; WITH TOPSTACKENTRY@.REP DO BEGIN FULLTABLE := ( MIN >= 0 ) AND ( MAX < 8 ) ; IF FULLTABLE THEN BEGIN TABLESIZE := MAX - MIN + 1 ; NEXTTABLEVALUE := 0 END ELSE NEXTTABLEVALUE := FIRSTCASE@.CASEVALUE END ; THISCASE := FIRSTCASE ; FIRSTVALUE := NEXTTABLEVALUE ; REPEAT WHILE NEXTTABLEVALUE < THISCASE@.CASEVALUE DO BEGIN DOSUPPORTTASK(CASEABORT) ; NEXTTABLEVALUE := NEXTTABLEVALUE + 1 END ; JUMPPINS(JMP,THISCASE@.CASELIMB) ; NEXTTABLEVALUE := NEXTTABLEVALUE + 1 ; THISCASE := THISCASE@.NEXTCASE UNTIL THISCASE = NIL ; IF FULLTABLE THEN WHILE NEXTTABLEVALUE < TABLESIZE DO BEGIN DOSUPPORTTASK(CASEABORT) ; NEXTTABLEVALUE := NEXTTABLEVALUE + 1 END ; NEXTISCODESEQUENCE(PERFORMCHECKANDJUMP) ; IF NOT FULLTABLE THEN BEGIN PINS(ST,TOS,UNMODIFIED,0) ; RANGECHECK(TOPOFSTACK,FIRSTVALUE,NEXTTABLEVALUE-1) ; LOADACC(TOPSTACKENTRY) ; IF FIRSTVALUE <> 0 THEN CONSTPINS(ISB,FIRSTVALUE) END ; CONSTPINS(ISH,2) ; PINS(UAD,TOS,UNMODIFIED,0) ; PINS(ST,TOS,UNMODIFIED,0) ; PINS(J,TOS,UNMODIFIED,0) END ; UNSTACK(CASEJUMPVALUE) ; FREESTACKENTRY(CASEJUMPVALUE) END END (* CLOSECASE *) ; PROCEDURE OPENFOR ( INCREASING : BOOLEAN ; VAR STARTOFLOOP,ENDOFFORSTATEMENT : CODESEQUENCE ) ; VAR MINOFLOOP,MAXOFLOOP : INTEGER ; FINAL,INITIAL : OPERANDDESCRIPTION ; LOOPVARIABLE : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN WITH TOPSTACKENTRY@.NEXTENTRY@.NEXTENTRY@.REP DO BEGIN MINOFLOOP := MIN ; MAXOFLOOP := MAX END ; IF INCREASING THEN RANGECHECK(TOPOFSTACK,-MAXINT,MAXOFLOOP) ELSE RANGECHECK(TOPOFSTACK,MINOFLOOP,+MAXINT) ; RANGECHECK(NEXTTOTOP,MINOFLOOP,MAXOFLOOP) ; UNSTACK(FINAL.ENTRY) ; UNSTACK(INITIAL.ENTRY) ; UNSTACK(LOOPVARIABLE) ; ANALYSEINTEGER(FINAL) ; ANALYSEINTEGER(INITIAL) ; IF NOT FINAL.ISCONSTANT THEN BEGIN LOADACC(FINAL.ENTRY) ; ASSIGNTEMPORARYREFERENCETO(FINAL.ENTRY) ; WITH FINAL.ENTRY@.POSITION DO IF STATICLEVEL = GLOBALLEVEL THEN PINS(ST,XNB,UNMODIFIED,OFFSET) ELSE PINS(ST,LNB,UNMODIFIED,OFFSET) END ; LOADACC(INITIAL.ENTRY) ; ADDRESS(LOOPVARIABLE) ; WITH ADDRESSED DO PINS(ST,K1,K2,N) ; IF FINAL.ISCONSTANT AND INITIAL.ISCONSTANT THEN BEGIN IF INCREASING AND (INITIAL.CVALUE > FINAL.CVALUE) OR NOT INCREASING AND (INITIAL.CVALUE < FINAL.CVALUE) THEN JUMPPINS(J,ENDOFFORSTATEMENT) END ELSE BEGIN ADDRESSVALUE(FINAL.ENTRY) ; WITH ADDRESSED DO PINS(ICP,K1,K2,N) ; IF INCREASING THEN TINS(JCC,REGGREATERTHANOPERAND,ENDOFFORSTATEMENT) ELSE TINS(JCC,REGLESSTHANOPERAND,ENDOFFORSTATEMENT) END ; STACK(FINAL.ENTRY) ; STACK(LOOPVARIABLE) ; FREESTACKENTRY(INITIAL.ENTRY) ; STARTCODESEQUENCE(STARTOFLOOP) END END (* OPENFOR *) ; PROCEDURE CLOSEFOR ( INCREASING : BOOLEAN ; VAR STARTOFLOOP : CODESEQUENCE ) ; VAR LOOPVARIABLE,FINAL : STACKENTRY ; BEGIN IF CODEISTOBEGENERATED THEN BEGIN UNSTACK(LOOPVARIABLE) ; UNSTACK(FINAL) ; IF INCREASING THEN BEGIN ADDRESS(LOOPVARIABLE) ; WITH ADDRESSED DO PINS(LB,K1,K2,N) ; ADDRESSVALUE(FINAL) ; WITH ADDRESSED DO PINS(CPIB,K1,K2,N) ; ADDRESS(LOOPVARIABLE) ; WITH ADDRESSED DO PINS(STB,K1,K2,N) ; TINS(JCC,REGLESSTHANOPERAND,STARTOFLOOP) END ELSE BEGIN LOADACC(LOOPVARIABLE) ; CONSTPINS(ISB,1) ; ADDRESS(LOOPVARIABLE) ; WITH ADDRESSED DO PINS(ST,K1,K2,N) ; ADDRESSVALUE(FINAL) ; WITH ADDRESSED DO PINS(ICP,K1,K2,N) ; TINS(JCC,REGEQORGREATERTHANOPERAND,STARTOFLOOP) END ; FREESTACKENTRY(FINAL) ; FREESTACKENTRY(LOOPVARIABLE) END END (* CLOSEFOR *) ; (*--------------------------------------------------------------------*) (*---- S O U R C E L I S T I N G G E N E R A T O R ----*) (* --------------------------------------------- *) PROCEDURE ICL9LPET ( ENO : INTEGER ; VAR TEXT : EMTBUF ) ; EXTERN ; (* ---------------- THE OPTIONS HANDLER ---------------- *) PROCEDURE ICL9LPGETCHARTAB (VAR CHARCODENO : INTEGER; VAR CHARCODETABLE : CHARSETP); EXTERN; PROCEDURE SETCHARSET (CHOSENCHARCODE : INTEGER); BEGIN ICL9LPGETCHARTAB (CHOSENCHARCODE, CODETABLE); WITH CHARREPRESENTATION DO IF CHOSENCHARCODE=ORD(CCEBCDIC) THEN MAX := 255 ELSE IF CHOSENCHARCODE=ORD(CCISO) THEN MAX := 127 ELSE MAX := 63; (*CCICL1900*) END (* SETCHARSET *) ; PROCEDURE INITDELAYEDLISTINGOPTION (THISOPTION : OPTIONTYPE); BEGIN SOURCE.DELAYEDOPTIONPENDING := TRUE; DELAYEDOPTIONINFO.OPTION := THISOPTION; END (* INITDELAYEDLISTINGOPTION *) ; PROCEDURE SETBOOLEANOPTION (OPTION : BOOLOPTIONTYPE; OPTIONVALUE : BOOLEAN; EXTENT : OPTIONSCOPE); BEGIN CASE EXTENT OF LOCALLY: LOCALLYREQD[OPTION] := OPTIONVALUE AND (REQD[OPTION] OR NOT (OPTION IN ALLGLOBALOPTIONS)) ; GLOBALLY: BEGIN IF OPTIONVALUE THEN OPTIONSCHOSEN := OPTIONSCHOSEN + [OPTION] ELSE OPTIONSCHOSEN := OPTIONSCHOSEN - [OPTION] ; REQD[OPTION] := OPTIONVALUE; COUNTREQD := REQD[PROFILE] OR REQD[RETRO] OR REQD[TRACE]; IF OPTION IN LOCALBOOLOPTIONS THEN LOCALLYREQD[OPTION] := REQD[OPTION] END; END (*CASE*); WITH SOURCE DO BEGIN MODES := ' '; IF NOT LOCALLYREQD[CHECKS] THEN MODES[1] := 'U'; IF LOCALLYREQD[TRACE] THEN MODES[2] := 'T'; IF LOCALLYREQD[RETRO] THEN MODES[3] := 'R'; IF LOCALLYREQD[PROFILE] THEN MODES[4] := 'P'; IF LOCALLYREQD[ENTRY] THEN MODES[5] := 'E'; END; END (* SETBOOLEANOPTION *) ; PROCEDURE SETINTEGEROPTION (OPTION : INTOPTIONTYPE; OPTIONVALUE : INTEGER) ; CONST MARGINERROR = 295; BEGIN CASE OPTION OF CHARCODE: BEGIN SETCHARSET(OPTIONVALUE); PARMVALUE[CHARCODE] := OPTIONVALUE; END; MARGIN: BEGIN IF OPTIONVALUE>MAXMARGIN THEN BEGIN OPTIONVALUE := MAXMARGIN; ERROR(MARGINERROR); END; INITDELAYEDLISTINGOPTION(MARGIN); DELAYEDOPTIONINFO.NEWMARGIN := OPTIONVALUE; END; END; (*CASE*) PARMVALUE[OPTION] := OPTIONVALUE; END (* SETINTEGEROPTION *) ; PROCEDURE SETSTRINGOPTION (OPTION : STRINGOPTIONTYPE); PROCEDURE STRINGTOALFA (VAR A :ALFA); VAR SP : STRINGP; J : 1..CHARSINWORD; K : 0..ALFALENGTH; BEGIN (*STRINGTOALFA*) A := BLANKALFA; SP := CONSTANT.STRING; K := 0; WHILE (KNIL) DO WITH SP@ DO BEGIN FOR J := 1 TO CHARSINWORD DO A[K+J] := WORD[J]; K := K + CHARSINWORD; SP := NEXTWORD; END; END (*STRINGTOALFA*) ; BEGIN (*SETSTRINGOPTION *) CASE OPTION OF GLOBALID: BEGIN REQD[GLOBALID] := TRUE; STRINGTOALFA(USERDEFGLOBALID); END; TITLE: BEGIN INITDELAYEDLISTINGOPTION(TITLE); STRINGTOALFA(DELAYEDOPTIONINFO.NEWTITLE); END; END; END (*SETSTRINGOPTION *) ; PROCEDURE PRINTOPTIONS ; VAR OPTION : OPTIONTYPE; FIRSTOPTION : BOOLEAN; OBJCODEOPTIONS, DIAGOPTIONS : SETOFOPTIONS; PROCEDURE WRITEOPTION (OPTION : OPTIONTYPE); VAR I : 1..ALFA16LENGTH; BEGIN IF NOT FIRSTOPTION THEN WRITE(LISTINGP@, ', '); FOR I := 1 TO ALFA16LENGTH DO IF OPTIONNAME[OPTION][I] <> BLANK THEN WRITE(LISTINGP@, OPTIONNAME[OPTION][I]); IF OPTION=CHARCODE THEN CASE PARMVALUE[CHARCODE] OF 0: WRITE(LISTINGP@, '=EBCDIC'); 1: WRITE(LISTINGP@, '=ISO'); 2: WRITE(LISTINGP@, '=ICL1900'); END; (*CASE*) FIRSTOPTION := FALSE; END (* WRITEOPTION *) ; BEGIN (*PRINTOPTIONS *) OBJCODEOPTIONS := [CHECKS, COMPILER, CHARCODE]; DIAGOPTIONS := [LINEMAP, DUMP, PROFILE..TRACE]; FIRSTOPTION := TRUE; WRITE(LISTINGP@, 'OBJECT CODE OPTIONS = ':25, '('); FOR OPTION := CHECKS TO TRACE DO IF (OPTION IN OBJCODEOPTIONS) AND REQD[OPTION] THEN WRITEOPTION(OPTION); WRITEOPTION(CHARCODE); WRITELN(LISTINGP@, ')'); WRITE(LISTINGP@, 'DIAGNOSTICS OPTIONS = ':25); IF DIAGOPTIONS*OPTIONSCHOSEN=[] THEN WRITELN(LISTINGP@, 'NONE') ELSE BEGIN WRITE(LISTINGP@, '('); FIRSTOPTION := TRUE; FOR OPTION := CHECKS TO TRACE DO IF (OPTION IN DIAGOPTIONS) AND REQD[OPTION] THEN WRITEOPTION(OPTION); WRITELN(LISTINGP@, ')'); END; END (* PRINTOPTIONS *) ; PROCEDURE IDENTIFYOPTION (VAR SPELLING : ALFA; VAR OPTION : OPTIONTYPE); VAR I : 1..ALFA16LENGTH; NAME : ALFA16; OPT : OPTIONTYPE; BEGIN FOR I := 1 TO ALFA16LENGTH DO NAME[I] := SPELLING[I]; OPTIONNAME[NOSUCHOPTION] := NAME; OPT := CHECKS; WHILE OPTIONNAME[OPT] <> NAME DO OPT := SUCC(OPT); OPTION := OPT; END; (*IDENTIFYOPTION*) PROCEDURE INITOPTIONS ; VAR OPTION : OPTIONTYPE ; BEGIN OPTIONNAME[CHECKS] := 'RANGECHECKS '; OPTIONNAME[COMPILER] := 'COMPILER '; OPTIONNAME[LINEMAP] := 'DIAGLINEMAP '; OPTIONNAME[DUMP] := 'DIAGNAMETABLE '; OPTIONNAME[ENTRY] := 'KEYEDENTRY '; OPTIONNAME[SOURCELIST] := 'SOURCE '; OPTIONNAME[OBJECTLIST] := 'OBJECT '; OPTIONNAME[PROFILE] := 'PROFILE '; OPTIONNAME[RETRO] := 'RETROTRACE '; OPTIONNAME[TRACE] := 'FORWARDTRACE '; OPTIONNAME[NOCODEGEN] := BLANKALFA16; (*-NO DIRECTIVE FOR THIS OPTION*) OPTIONNAME[CHARCODE] := 'CHARCODE '; OPTIONNAME[MARGIN] := 'RHMARGIN '; OPTIONNAME[GLOBALID] := 'GLOBALAREANAME '; OPTIONNAME[TITLE] := 'TITLE '; OPTIONNAME[NEWPAGE] := 'NEWPAGE '; OPTIONNAME[NOSUCHOPTION] := BLANKALFA16; LOCALBOOLOPTIONS := [CHECKS,ENTRY..OBJECTLIST,PROFILE..TRACE]; ALLLOCALOPTIONS := LOCALBOOLOPTIONS + [MARGIN,TITLE]; ALLGLOBALOPTIONS := [CHECKS..TITLE] - [ENTRY, NOCODEGEN, MARGIN, TITLE]; FOR OPTION := CHECKS TO NOSUCHOPTION DO BEGIN REQD[OPTION] := FALSE; LOCALLYREQD[OPTION] := FALSE; END; PARMVALUE[MARGIN] := MAXMARGIN; ICL9LPCTGIVEENVOPTIONS(OPTIONSCHOSEN, PARMVALUE[CHARCODE]); SETINTEGEROPTION(CHARCODE, PARMVALUE[CHARCODE]); FOR OPTION := CHECKS TO TRACE DO IF OPTION IN ALLGLOBALOPTIONS THEN SETBOOLEANOPTION(OPTION, OPTION IN OPTIONSCHOSEN, GLOBALLY); SETBOOLEANOPTION(ENTRY, FALSE, LOCALLY) ; REQD[NOCODEGEN] := NOCODEGEN IN OPTIONSCHOSEN; IF REQD[NOCODEGEN] THEN CODEISTOBEGENERATED:=FALSE; END (* INITOPTIONS *) ; PROCEDURE GETGLOBALIDOPTION ; (*FORWARD-DECLARED*) (* PARAM. LIST SPEC. IS :- (VAR USERDEFNAME : ALFA) *) BEGIN IF REQD[GLOBALID] THEN USERDEFNAME := USERDEFGLOBALID ELSE USERDEFNAME := BLANKALFA ; END (* GETGLOBALIDOPTION *) ; PROCEDURE GETVALIDRTOPTIONS ; (*FORWARD-DECLARED*) (* PARAM. LIST SPEC. IS :- (VAR VALIDRTOPTIONS : SETOFOPTIONS) *) BEGIN VALIDRTOPTIONS := OPTIONSCHOSEN * [CHECKS, COMPILER, LINEMAP, DUMP, PROFILE, RETRO, TRACE]; END (* GETVALIDRTOPTIONS *) ; (* ---------------- THE SOURCE HANDLER ------------------ *) PROCEDURE ANALYSEDIRECTIVE ; FORWARD ; PROCEDURE ENDPROGRAMLISTING; FORWARD; PROCEDURE ENDLISTING; FORWARD; PROCEDURE READNEXTLINE ; VAR RAWSTATUS : EXTERNSOURCESTATUS; GOTSIGCHAR : BOOLEAN; LENGTH, FIRSTSIGPOS, LASTSIGPOS : LINEPOSITION; PROCEDURE EARLYEOFERRORSTOP; BEGIN ERROR(90); ENDPROGRAMLISTING; ENDLISTING; NOTECOMPILATIONERRORCOUNT; HALT('PREMATURE END OF SOURCE TEXT'); END (*EARLYEOFERRORSTOP*); BEGIN (* READNEXTLINE *) WITH SOURCE DO BEGIN ICL9LPCTNEXTSOURCELINE (LINE, LENGTH, RAWSTATUS); (*-N.B.: DEFINITION OF TYPE FOR "LENGTH" MEANS THAT THIS*) (*CALL NEVER USES/FILLS THE LAST POSITION IN "LINE". *) IF RAWSTATUS<>BUFABSENTATEOF THEN LINENUMBER:=LINENUMBER+1; CHARNUMBER := 0; LINEOVERFLOW := (RAWSTATUS=BUFTRUNCATED); MARGINOVERFLOW := FALSE; CASE RAWSTATUS OF BUFABSENTATEOF: BEGIN STATUS := LINEISABSENT; EARLYEOFERRORSTOP; END; BUFTOBELISTEDONLY: STATUS := LINEISTOBELISTEDONLY; BUFTOBEIGNORED: STATUS := LINEISTOBEIGNORED; BUFTRUNCATED, BUFOK: BEGIN LINE[LENGTH] := '*'; (*-ANY NON-BLANK*) FIRSTSIGPOS := 0; GOTSIGCHAR := FALSE; WHILE NOT GOTSIGCHAR DO IF LINE[FIRSTSIGPOS]=BLANK THEN FIRSTSIGPOS := FIRSTSIGPOS + 1 ELSE GOTSIGCHAR := TRUE; LASTSIGPOS := LENGTH; IF FIRSTSIGPOSBLANK; IF LASTSIGPOS>=PARMVALUE[MARGIN] THEN BEGIN MARGINOVERFLOW := TRUE; OVERFLOWMAX := LASTSIGPOS; END; END; IF (FIRSTSIGPOS=LENGTH) OR (FIRSTSIGPOS>=PARMVALUE[MARGIN]) THEN STATUS := LINEISBLANK ELSE BEGIN IF LINE[0] = '%' THEN STATUS := LINEISPASCALDIRECTIVE ELSE STATUS := LINEISNORMAL; FIRSTNONBLANK := FIRSTSIGPOS; IF MARGINOVERFLOW THEN BEGIN LASTSIGPOS := PARMVALUE[MARGIN]; REPEAT LASTSIGPOS:=LASTSIGPOS-1 UNTIL LINE[LASTSIGPOS]<>BLANK; END; LASTNONBLANK := LASTSIGPOS; END; END; END (*CASE*); END (*WITH*); END (* READNEXTLINE *) ; PROCEDURE NEWLINE; BEGIN WRITELN(LISTINGP@); END (* NEWLINE *) ; PROCEDURE STARTSOURCEHEADING; FORWARD; PROCEDURE LISTTHISLINE ; CONST LONGLINEERROR = 296; ARROW = '!'; VAR I : LINEPOSITION; PROCEDURE LISTERRORS ; VAR K : 1..ERRMAX ; NEXTPRINTPOSITION,LASTARROWPOSITION : POSITIVEINTEGER ; PROCEDURE STARTERRORLINE ; BEGIN NEWLINE; WRITE(LISTINGP@, '****** ERROR ******', BAR) ; NEXTPRINTPOSITION := 0 END (* STARTERRORLINE *) ; PROCEDURE PRINTARROWAT ( POSITION : LINEPOSITION ) ; BEGIN IF POSITION < NEXTPRINTPOSITION THEN STARTERRORLINE ; WRITE(LISTINGP@, ARROW:POSITION-NEXTPRINTPOSITION+1) ; LASTARROWPOSITION := POSITION ; NEXTPRINTPOSITION := POSITION+1 END (* PRINTARROWAT *) ; PROCEDURE PRINTCODE ( CODE : INTEGER ) ; VAR WIDTH : 1..3 ; BEGIN IF CODE < 10 THEN WIDTH := 1 ELSE IF CODE < 100 THEN WIDTH := 2 ELSE WIDTH := 3 ; WRITE(LISTINGP@, CODE:WIDTH) ; NEXTPRINTPOSITION := NEXTPRINTPOSITION+WIDTH END (* PRINTCODE *) ; PROCEDURE PRINTCOMMA ; BEGIN WRITE(LISTINGP@, ',') ; NEXTPRINTPOSITION := NEXTPRINTPOSITION+1 END (* PRINTCOMMA *) ; FUNCTION ROOMFORANOTHERNUMBER : BOOLEAN; BEGIN ROOMFORANOTHERNUMBER := (NEXTPRINTPOSITION<=MAXMARGIN); END (*ROOMFORANOTHERNUMBER*); BEGIN WITH SOURCE DO BEGIN STARTERRORLINE ; WITH ERRLIST[1] DO BEGIN PRINTARROWAT(ERRORPOSITION) ; PRINTCODE(ERRORCODE) END ; FOR K := 2 TO ERRINX DO WITH ERRLIST[K] DO BEGIN IF (ERRORPOSITION=LASTARROWPOSITION) AND ROOMFORANOTHERNUMBER THEN PRINTCOMMA ELSE PRINTARROWAT(ERRORPOSITION) ; PRINTCODE(ERRORCODE) END ; IF ERROROVERFLOW THEN BEGIN STARTERRORLINE ; WRITE(LISTINGP@, 'FURTHER ERRORS FOUND IN THIS LINE HAVE BEEN OMITTED') END ; ERRINX := 0 ; ERROROVERFLOW := FALSE END END (* LISTERRORS *) ; PROCEDURE CHECKLINEOVERFLOW; BEGIN IF SOURCE.LINEOVERFLOW THEN BEGIN SOURCE.CHARNUMBER := MAXMARGIN; ERROR(LONGLINEERROR); END; END (*CHECKLINEOVERFLOW*); PROCEDURE STARTSOURCELISTLINE; BEGIN WITH SOURCE DO BEGIN IF NEWHEADINGPENDING THEN BEGIN STARTSOURCEHEADING; NEWHEADINGPENDING := FALSE; END; WRITE(LISTINGP@, LINENUMBER:5, BLANK:2, MODES:5); WITH NESTINGLEVEL DO IF LINESTART<>CURRENT THEN IF LINESTART0 THEN WRITE(LISTINGP@, BLANK:FILL); WRITE(LISTINGP@, BAR); FOR I := PARMVALUE[MARGIN] TO OVERFLOWMAX DO WRITE(LISTINGP@, LINE[I]); WRITE(LISTINGP@, BAR, '**':PAGEWIDTH-LEFTSPACE-2-(OVERFLOWMAX+1)); END; END (*LISTMARGINOVERFLOW*); PROCEDURE UPDATEDELAYEDLISTINGOPTION; BEGIN WITH DELAYEDOPTIONINFO DO CASE OPTION OF MARGIN : PARMVALUE[MARGIN] := NEWMARGIN; NEWPAGE : IF LOCALLYREQD[SOURCELIST] THEN PAGE(LISTINGP@); TITLE : BEGIN SOURCE.NEWHEADINGPENDING := TRUE; LISTINGCONTROL.SOURCETITLE := NEWTITLE; END; END (*CASE*); SOURCE.DELAYEDOPTIONPENDING := FALSE; END (*UPDATEDELAYEDLISTINGOPTION*); BEGIN IF SOURCE.DONEPREMATURELISTING THEN SOURCE.DONEPREMATURELISTING := FALSE ELSE BEGIN MAPTHISLINE; WITH SOURCE DO CASE STATUS OF LINEISABSENT, LINEISTOBEIGNORED: ; LINEISTOBELISTEDONLY: BEGIN STARTSOURCELISTLINE; FOR I := 0 TO MAXMARGIN-1 DO WRITE(LISTINGP@, LINE[I]); NEWLINE; END; LINEISBLANK, LINEISNORMAL, LINEISPASCALDIRECTIVE: BEGIN CHECKLINEOVERFLOW; IF LOCALLYREQD[SOURCELIST] OR (ERRINX>0) THEN BEGIN STARTSOURCELISTLINE; IF STATUS<>LINEISBLANK THEN BEGIN IF FIRSTNONBLANK>0 THEN WRITE(LISTINGP@, BLANK:FIRSTNONBLANK); FOR I:=FIRSTNONBLANK TO LASTNONBLANK DO WRITE(LISTINGP@, LINE[I]); END; IF MARGINOVERFLOW THEN BEGIN ASUFFIXWASIGNORED := TRUE; LISTMARGINOVERFLOW; END; IF ERRINX>0 THEN LISTERRORS; NEWLINE; END; IF DELAYEDOPTIONPENDING THEN UPDATEDELAYEDLISTINGOPTION; WITH NESTINGLEVEL DO LINESTART :=CURRENT; END; END (*CASE*); END (*ELSE*); END (* LISTTHISLINE *) ; PROCEDURE TRYTOFORCEPREMATURELISTTHISLINE ; BEGIN WITH SOURCE DO IF CHARNUMBER > LASTNONBLANK THEN BEGIN LISTTHISLINE ; DONEPREMATURELISTING := TRUE ; END ; END (* TRYTOFORCEPREMATURELISTTHISLINE *) ; PROCEDURE FIRSTCHOFNEXTLINE ; BEGIN WITH SOURCE DO BEGIN READNEXTLINE ; WHILE STATUS<>LINEISNORMAL DO BEGIN IF STATUS=LINEISPASCALDIRECTIVE THEN BEGIN CHARNUMBER := 0 ; CH := BLANK ; ANALYSEDIRECTIVE; END ; LISTTHISLINE ; READNEXTLINE END ; CHARNUMBER := FIRSTNONBLANK ; CH := LINE[CHARNUMBER] END END (* FIRSTCHOFNEXTLINE *) ; FUNCTION ATENDOFLINE : BOOLEAN; BEGIN WITH SOURCE DO ATENDOFLINE := (CHARNUMBER>LASTNONBLANK); END (* ATENDOFLINE *) ; PROCEDURE NEXTCH ; BEGIN WITH SOURCE DO IF CHARNUMBER >= LASTNONBLANK THEN IF CHARNUMBER = LASTNONBLANK THEN BEGIN CHARNUMBER := CHARNUMBER+1 ; CH := BLANK ; END ELSE IF LINEADVANCEALLOWED THEN BEGIN LISTTHISLINE ; FIRSTCHOFNEXTLINE END ELSE CH := '%' (*OR ANY (OTHERSY,NOTOP) CHARACTER*) ELSE BEGIN CHARNUMBER := CHARNUMBER+1 ; CH := LINE[CHARNUMBER] END END (* NEXTCH *) ; PROCEDURE PREVCH; BEGIN WITH SOURCE DO BEGIN CHARNUMBER := CHARNUMBER - 1; CH := LINE[CHARNUMBER]; END; END (* PREVCH *) ; PROCEDURE FORBIDLINEADVANCE; BEGIN LINEADVANCEALLOWED := FALSE; END (*FORBIDLINEADVANCE*); PROCEDURE ALLOWLINEADVANCE; BEGIN LINEADVANCEALLOWED := TRUE; END (*ALLOWLINEADVANCE*); PROCEDURE ERROR; (*FORWARD-DECLARED*) PROCEDURE NOTEOCCURRENCEOF (ERROR : INTEGER); VAR BASE : 0..ERRSETSIZE; BEGIN BASE := ERROR DIV (ERRSETMAX+1); ERRORSET[BASE] := ERRORSET[BASE] + [ERROR MOD (ERRSETMAX+1)]; END (*NOTEOCCURENCEOF*) ; BEGIN (*ERROR*) ERRORCOUNT := ERRORCOUNT + 1; CODEISTOBEGENERATED := FALSE; BADGENERATEDCODE := TRUE; WITH SOURCE DO IF ERRINX=ERRMAX THEN BEGIN NOTEOCCURRENCEOF(255); ERROROVERFLOW := TRUE; END ELSE BEGIN NOTEOCCURRENCEOF(CODE); ERRINX := ERRINX + 1; WITH ERRLIST[ERRINX] DO BEGIN ERRORCODE := CODE; ERRORPOSITION := CHARNUMBER; END; END; END (*ERROR*) ; PROCEDURE STARTSOURCEHEADING; (*FORWARD-DECLARED*) BEGIN WITH LISTINGCONTROL DO BEGIN STATUS := SOURCELS; ICL9LPCTUPDATELISTHEADING(SOURCEHEADING, SOURCETITLE); END; END (*STARTSOURCEHEADING*); PROCEDURE STARTOBJECTHEADING (CLASS : BLOCKIDCLASS; NAME : ALFA); VAR KIND : LISTPAGEHEADINGKIND; BEGIN LISTINGCONTROL.STATUS := OBJECTLS; CASE CLASS OF PROC: KIND := PROCOBJECTHEADING; FUNC: KIND := FUNCOBJECTHEADING; PROG: KIND := PROGOBJECTHEADING; END (*CASE*); ICL9LPCTUPDATELISTHEADING(KIND,NAME); END (*SWITCHTOOBJECTLISTHEADING*); PROCEDURE STARTSUMMARYHEADING (MINLINECOUNT : POSITIVEINTEGER; TRYFORCURRENTPAGE : BOOLEAN); BEGIN LISTINGCONTROL.STATUS := SUMMARYLS; ICL9LPCTSUMMARYHEADING (MINLINECOUNT, NOT TRYFORCURRENTPAGE); END (*STARTSUMMARYHEADING*); PROCEDURE INCREMENTNESTINGLEVEL; BEGIN WITH NESTINGLEVEL DO IF CURRENT < 99 THEN CURRENT:=CURRENT+1; END (* INCREMENTNESTINGLEVEL *); PROCEDURE DECREMENTNESTINGLEVEL; BEGIN WITH NESTINGLEVEL DO IF CURRENT > 1 THEN CURRENT:=CURRENT-1; END (* DECREMENTNESTINGLEVEL *); PROCEDURE INITLISTING ; VAR I : 0..ERRSETSIZE ; BEGIN (* INITLISTING *) ICL9LPCTGETLISTFILEPTR(LISTINGP); WITH LISTINGCONTROL DO BEGIN STATUS := LISTINGYETTOSTART; SOURCETITLE := BLANKALFA; END; ERRORCOUNT := 0 ; WITH NESTINGLEVEL DO BEGIN CURRENT := 1; LINESTART := 1 END; FOR I := 0 TO ERRSETSIZE DO ERRORSET[I] := []; ALLOWLINEADVANCE; WITH SOURCE DO BEGIN LINENUMBER := 0 ; DONEPREMATURELISTING := FALSE ; NEWHEADINGPENDING := TRUE; DELAYEDOPTIONPENDING := FALSE; ERRINX := 0 ; ERROROVERFLOW := FALSE ; ASUFFIXWASIGNORED := FALSE; ATHEADOFTEXT := TRUE ; FIRSTCHOFNEXTLINE ; ATHEADOFTEXT := FALSE END; END (* INITLISTING *) ; PROCEDURE BLKENDLIST ( BLKID : IDENTRY ) ; BEGIN IF LOCALLYREQD[OBJECTLIST] AND CODEISTOBEGENERATED THEN BEGIN TRYTOFORCEPREMATURELISTTHISLINE ; WITH BLKID@ DO STARTOBJECTHEADING(KLASS,NAME); LISTOBJCODEBLOCK ; SOURCE.NEWHEADINGPENDING := TRUE; END END (* BLKENDLIST *) ; PROCEDURE PRINTERRORSUMMARY ; VAR BASE : 0..ERRSETSIZE ; OFFSET : 0..ERRSETMAX ; ERROR : INTEGER ; EMTEXT : EMTBUF ; BEGIN WRITE (LISTINGP@, ' ERROR SUMMARY:-') ; NEWLINE ; FOR BASE := 0 TO ERRSETSIZE DO FOR OFFSET := 0 TO ERRSETMAX DO IF OFFSET IN ERRORSET [BASE] THEN BEGIN ERROR := BASE*(ERRSETMAX+1) + OFFSET ; WRITE (LISTINGP@, ERROR:4, ' : ') ; ICL9LPET (ERROR, EMTEXT) ; WRITE (LISTINGP@, EMTEXT) ; NEWLINE END ; NEWLINE ; END ; (*PRINTERRORSUMMARY *) PROCEDURE ENDPROGRAMLISTING ; (*FORWARD-DECLARED*) BEGIN LISTTHISLINE; END (* ENDPROGRAMLISTING *) ; PROCEDURE ENDLISTING ; (*FORWARD-DECLARED*) VAR MINLINESREQUIRED : POSITIVEINTEGER; NEEDOBJDETAILS : BOOLEAN; PROCEDURE PRINTTABLESIZES; VAR TOTALSIZE : INTEGER ; COMMAREQD : BOOLEAN ; BEGIN TOTALSIZE := STDAREASIZES[DIAGMAPAREA] + STDAREASIZES[DIAGOBJECTAREA] + STDAREASIZES[DIAGTOKENAREA] ; WRITE(LISTINGP@, 'DIAGNOSTIC TABLE SIZE = ':25, TOTALSIZE:6, ' BYTES') ; IF TOTALSIZE>0 THEN BEGIN WRITE(LISTINGP@, ' (') ; COMMAREQD := FALSE ; IF STDAREASIZES[DIAGMAPAREA] > 0 THEN BEGIN WRITE(LISTINGP@, 'LINEMAP=',STDAREASIZES[DIAGMAPAREA]:1) ; COMMAREQD := TRUE ; END ; IF STDAREASIZES[DIAGOBJECTAREA] > 0 THEN BEGIN IF COMMAREQD THEN WRITE(LISTINGP@, ', ') ; WRITE(LISTINGP@, 'NAMETABLE=',STDAREASIZES[DIAGOBJECTAREA]:1) ; COMMAREQD := TRUE ; END ; IF STDAREASIZES[DIAGTOKENAREA] > 0 THEN BEGIN IF COMMAREQD THEN WRITE(LISTINGP@, ', ') ; WRITE(LISTINGP@, 'FLOWANALYSES=',STDAREASIZES[DIAGTOKENAREA]:1) ; END ; WRITELN(LISTINGP@, ')') ; END ELSE WRITELN(LISTINGP@); END (* PRINTTABLESIZES *) ; BEGIN (* ENDLISTING *) NEEDOBJDETAILS := (ERRORCOUNT=0) AND NOT REQD[NOCODEGEN]; IF NEEDOBJDETAILS THEN MINLINESREQUIRED := 11 ELSE IF ERRORCOUNT=0 THEN MINLINESREQUIRED := 4 ELSE MINLINESREQUIRED := 7 ; STARTSUMMARYHEADING (MINLINESREQUIRED, LISTINGCONTROL.STATUS<>OBJECTLS); WRITE(LISTINGP@, 'COMPILATION COMPLETE : ':25); IF ERRORCOUNT = 0 THEN WRITE(LISTINGP@, 'NO') ELSE WRITE(LISTINGP@, ERRORCOUNT:2); WRITE(LISTINGP@, ' ERROR(S) REPORTED'); NEWLINE; NEWLINE; IF NEEDOBJDETAILS THEN BEGIN WRITE(LISTINGP@, 'GLOBAL SIZE = ':25, GLOBALSIZE:6, ' BYTES'); IF REQD[GLOBALID] THEN WRITELN(LISTINGP@, ', GLOBALID = ':13, '''', USERDEFGLOBALID, '''') ELSE NEWLINE; WRITELN(LISTINGP@, 'CODE SIZE = ':25, STDAREASIZES[CODEAREA]:6, ' BYTES'); WRITELN(LISTINGP@, 'PLT SIZE = ':25, STDAREASIZES[PLTAREA]:6, ' BYTES'); PRINTTABLESIZES; PRINTOPTIONS; END ELSE IF ERRORCOUNT<>0 THEN PRINTERRORSUMMARY; WRITE(LISTINGP@, 'SOURCE PROGRAM = ':25, SOURCE.LINENUMBER:6, ' LINES'); IF ASUFFIXWASIGNORED THEN BEGIN WRITE(LISTINGP@, ' ** THE SOURCE TEXT DELIMITED BY ', BAR, '...', BAR, ' IS PAST THE MARGIN AND HAS BEEN IGNORED **'); END; NEWLINE; ENDCLOCK := CLOCK; WRITE(LISTINGP@, 'OCP TIME FOR COMPILER = ':25, ENDCLOCK-STARTCLOCK:6, ' MILLISECONDS'); NEWLINE; END (* ENDLISTING *) ; (****************** DIRECTIVE ANALYSIS ***************) PROCEDURE READSYMBOL; FORWARD; PROCEDURE ANALYSEDIRECTIVE ; (*FORWARD-DECLARED*) CONST UNIMPLEMENTEDDIRECTIVE = 297; MISPLACEDDIRECTIVE = 298; INVALIDDIRECTIVE = 299; VAR OPTION : OPTIONTYPE; GLOBALSYNTAX, GLOBAL : BOOLEAN; PROCEDURE SETOPTIONVALUE (EXTENT : OPTIONSCOPE); VAR POSITIVE, NEGATIVE : ALFA; CHARSET : CHARCODETYPE; BEGIN (*SETOPTIONVALUE*) CASE EXTENT OF LOCALLY: BEGIN POSITIVE := 'ON '; NEGATIVE := 'OFF '; END; GLOBALLY: BEGIN POSITIVE := 'YES '; NEGATIVE := 'NO '; END; END (*CASE*) ; CASE OPTION OF CHECKS, COMPILER, LINEMAP, DUMP, ENTRY, SOURCELIST, OBJECTLIST, PROFILE, RETRO, TRACE: BEGIN IF SYMBOL<>IDENT THEN ERROR(INVALIDDIRECTIVE) ELSE IF SPELLING=POSITIVE THEN SETBOOLEANOPTION(OPTION, TRUE, EXTENT) ELSE IF SPELLING=NEGATIVE THEN SETBOOLEANOPTION(OPTION, FALSE, EXTENT) ELSE ERROR(INVALIDDIRECTIVE); END; NOCODEGEN: (*-SHOULD NEVER GET HERE*); MARGIN (*, RETROMAX, TRACEMIN, TRACEMAX *): BEGIN IF SYMBOL=INTCONST THEN IF CONSTANT.IVAL1>0 THEN SETINTEGEROPTION(MARGIN, CONSTANT.IVAL1) ELSE ERROR(INVALIDDIRECTIVE) ELSE ERROR(INVALIDDIRECTIVE); END; CHARCODE: BEGIN IF SYMBOL<>IDENT THEN CHARSET := CCINVALID ELSE IF SPELLING='EBCDIC ' THEN CHARSET := CCEBCDIC ELSE IF SPELLING='ISO ' THEN CHARSET := CCISO ELSE IF SPELLING='ICL1900 ' THEN CHARSET := CCICL1900 ELSE CHARSET := CCINVALID; IF CHARSET=CCINVALID THEN ERROR(INVALIDDIRECTIVE) ELSE SETINTEGEROPTION(CHARCODE, ORD(CHARSET)); END; GLOBALID, TITLE: BEGIN IF SYMBOL=STRINGCONST THEN SETSTRINGOPTION(OPTION) ELSE ERROR(INVALIDDIRECTIVE); END; NEWPAGE: INITDELAYEDLISTINGOPTION(NEWPAGE); NOSUCHOPTION: ERROR(INVALIDDIRECTIVE); END (*CASE*); END (*SETOPTIONVALUE*); BEGIN (*ANALYSEDIRECTIVE*) FORBIDLINEADVANCE; READSYMBOL; IF SYMBOL<>IDENT THEN ERROR(INVALIDDIRECTIVE) ELSE BEGIN IDENTIFYOPTION(SPELLING, OPTION); READSYMBOL; GLOBALSYNTAX := (SYMBOL=RELOP) AND (OPERATOR=EQOP); IF GLOBALSYNTAX THEN READSYMBOL; GLOBAL := GLOBALSYNTAX AND (OPTION IN ALLGLOBALOPTIONS); IF GLOBAL AND SOURCE.ATHEADOFTEXT THEN SETOPTIONVALUE(GLOBALLY) ELSE IF GLOBAL THEN ERROR(MISPLACEDDIRECTIVE) ELSE IF GLOBALSYNTAX THEN ERROR(INVALIDDIRECTIVE) (*SUPERFLUOUS "=" ?*) ELSE IF OPTION IN ALLLOCALOPTIONS THEN SETOPTIONVALUE(LOCALLY) ELSE IF OPTION=NEWPAGE THEN SETOPTIONVALUE(LOCALLY) ELSE ERROR(INVALIDDIRECTIVE) (*MISSING "=" ?*); END; ALLOWLINEADVANCE; END (*ANALYSEDIRECTIVE*); (* ****************************************************************** *) (*---- T H E L E X I C A L A N A L Y S E R ----*) (* ------------------------------------- *) PROCEDURE INITSYMBOL ; VAR I : CHAR ; J : 1..NOWORDSYMBOLS ; BEGIN (* INITSYMBOL *) NEW(STRINGBASE) ; FOR I:=CHR(ORDSMALLESTCHAR) TO CHR(ORDLARGESTCHAR) DO WITH ONECHARSYMBOLS[I] DO BEGIN SYMBOLVALUE := OTHERSY ; OPVALUE := NOTOP END ; ONECHARSYMBOLS['A'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['B'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['C'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['D'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['E'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['F'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['G'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['H'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['I'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['J'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['K'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['L'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['M'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['N'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['O'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['P'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['Q'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['R'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['S'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['T'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['U'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['V'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['W'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['X'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['Y'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['Z'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['a'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['b'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['c'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['d'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['e'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['f'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['g'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['h'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['i'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['j'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['k'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['l'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['m'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['n'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['o'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['p'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['q'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['r'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['s'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['t'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['u'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['v'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['w'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['x'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['y'].SYMBOLVALUE := IDENT ; ONECHARSYMBOLS['z'].SYMBOLVALUE := IDENT ; FOR I:='0' TO '9' DO ONECHARSYMBOLS[I].SYMBOLVALUE := DIGIT ; ONECHARSYMBOLS[','].SYMBOLVALUE := COMMA ; ONECHARSYMBOLS[':'].SYMBOLVALUE := COLON ; ONECHARSYMBOLS[';'].SYMBOLVALUE := SEMICOLON ; ONECHARSYMBOLS['.'].SYMBOLVALUE := PERIOD ; ONECHARSYMBOLS['('].SYMBOLVALUE := LEFTPARENT ; ONECHARSYMBOLS[')'].SYMBOLVALUE := RIGHTPARENT ; ONECHARSYMBOLS['['].SYMBOLVALUE := LEFTBRACKET ; ONECHARSYMBOLS[']'].SYMBOLVALUE := RIGHTBRACKET ; ONECHARSYMBOLS['{'].SYMBOLVALUE := LEFTCURLYBRACKET ; ONECHARSYMBOLS['}'].SYMBOLVALUE := RIGHTCURLYBRACKET ; ONECHARSYMBOLS[''''].SYMBOLVALUE := QUOTE ; ONECHARSYMBOLS['@'].SYMBOLVALUE := ARROW ; ONECHARSYMBOLS['^'].SYMBOLVALUE := ARROW ; WITH ONECHARSYMBOLS['<'] DO BEGIN SYMBOLVALUE := RELOP ; OPVALUE := LTOP END ; WITH ONECHARSYMBOLS['='] DO BEGIN SYMBOLVALUE := RELOP ; OPVALUE := EQOP END ; WITH ONECHARSYMBOLS['>'] DO BEGIN SYMBOLVALUE := RELOP ; OPVALUE := GTOP END ; WITH ONECHARSYMBOLS['+'] DO BEGIN SYMBOLVALUE := ADDOP ; OPVALUE := PLUS END ; WITH ONECHARSYMBOLS['-'] DO BEGIN SYMBOLVALUE := ADDOP ; OPVALUE := MINUS END ; WITH ONECHARSYMBOLS['*'] DO BEGIN SYMBOLVALUE := MULOP ; OPVALUE := MUL END ; WITH ONECHARSYMBOLS['/'] DO BEGIN SYMBOLVALUE := MULOP ; OPVALUE := RDIV END ; FOR I := CHR(ORDSMALLESTCHAR) TO CHR(ORDLARGESTCHAR) DO FORCETOUPPERCASE [I] := I ; FORCETOUPPERCASE['a'] := 'A' ; FORCETOUPPERCASE['b'] := 'B' ; FORCETOUPPERCASE['c'] := 'C' ; FORCETOUPPERCASE['d'] := 'D' ; FORCETOUPPERCASE['e'] := 'E' ; FORCETOUPPERCASE['f'] := 'F' ; FORCETOUPPERCASE['g'] := 'G' ; FORCETOUPPERCASE['h'] := 'H' ; FORCETOUPPERCASE['i'] := 'I' ; FORCETOUPPERCASE['j'] := 'J' ; FORCETOUPPERCASE['k'] := 'K' ; FORCETOUPPERCASE['l'] := 'L' ; FORCETOUPPERCASE['m'] := 'M' ; FORCETOUPPERCASE['n'] := 'N' ; FORCETOUPPERCASE['o'] := 'O' ; FORCETOUPPERCASE['p'] := 'P' ; FORCETOUPPERCASE['q'] := 'Q' ; FORCETOUPPERCASE['r'] := 'R' ; FORCETOUPPERCASE['s'] := 'S' ; FORCETOUPPERCASE['t'] := 'T' ; FORCETOUPPERCASE['u'] := 'U' ; FORCETOUPPERCASE['v'] := 'V' ; FORCETOUPPERCASE['w'] := 'W' ; FORCETOUPPERCASE['x'] := 'X' ; FORCETOUPPERCASE['y'] := 'Y' ; FORCETOUPPERCASE['z'] := 'Z' ; FOR J:=1 TO NOWORDSYMBOLS DO WORDSYMBOLS[J].OPVALUE := NOTOP ; WITH WORDSYMBOLS[1] DO BEGIN A8TOALFA ('IF ', SPELLING) ; SYMBOLVALUE := IFSY END ; WITH WORDSYMBOLS[2] DO BEGIN A8TOALFA ('DO ', SPELLING) ; SYMBOLVALUE := DOSY END ; WITH WORDSYMBOLS[3] DO BEGIN A8TOALFA ('OF ', SPELLING) ; SYMBOLVALUE := OFSY END ; WITH WORDSYMBOLS[4] DO BEGIN A8TOALFA ('TO ', SPELLING) ; SYMBOLVALUE := TOSY END ; WITH WORDSYMBOLS[5] DO BEGIN A8TOALFA ('IN ', SPELLING) ; SYMBOLVALUE := RELOP ; OPVALUE := INOP END ; WITH WORDSYMBOLS[6] DO BEGIN A8TOALFA ('OR ', SPELLING) ; SYMBOLVALUE := ADDOP ; OPVALUE := OROP END ; WITH WORDSYMBOLS[7] DO BEGIN A8TOALFA ('END ', SPELLING) ; SYMBOLVALUE := ENDSY END ; WITH WORDSYMBOLS[8] DO BEGIN A8TOALFA ('FOR ', SPELLING) ; SYMBOLVALUE := FORSY END ; WITH WORDSYMBOLS[9] DO BEGIN A8TOALFA ('VAR ', SPELLING) ; SYMBOLVALUE := VARSY END ; WITH WORDSYMBOLS[10] DO BEGIN A8TOALFA ('DIV ', SPELLING) ; SYMBOLVALUE := MULOP ; OPVALUE := IDIV END ; WITH WORDSYMBOLS[11] DO BEGIN A8TOALFA ('MOD ', SPELLING) ; SYMBOLVALUE := MULOP ; OPVALUE := IMOD END ; WITH WORDSYMBOLS[12] DO BEGIN A8TOALFA ('SET ', SPELLING) ; SYMBOLVALUE := SETSY END ; WITH WORDSYMBOLS[13] DO BEGIN A8TOALFA ('AND ', SPELLING) ; SYMBOLVALUE := MULOP ; OPVALUE := ANDOP END ; WITH WORDSYMBOLS[14] DO BEGIN A8TOALFA ('NOT ', SPELLING) ; SYMBOLVALUE := NOTSY ; OPVALUE := NEOP END ; WITH WORDSYMBOLS[15] DO BEGIN A8TOALFA ('THEN ', SPELLING) ; SYMBOLVALUE := THENSY END ; WITH WORDSYMBOLS[16] DO BEGIN A8TOALFA ('ELSE ', SPELLING) ; SYMBOLVALUE := ELSESY END ; WITH WORDSYMBOLS[17] DO BEGIN A8TOALFA ('WITH ', SPELLING) ; SYMBOLVALUE := WITHSY END ; WITH WORDSYMBOLS[18] DO BEGIN A8TOALFA ('GOTO ', SPELLING) ; SYMBOLVALUE := GOTOSY END ; WITH WORDSYMBOLS[19] DO BEGIN A8TOALFA ('CASE ', SPELLING) ; SYMBOLVALUE := CASESY END ; WITH WORDSYMBOLS[20] DO BEGIN A8TOALFA ('TYPE ', SPELLING) ; SYMBOLVALUE := TYPESY END ; WITH WORDSYMBOLS[21] DO BEGIN A8TOALFA ('FILE ', SPELLING) ; SYMBOLVALUE := FILESY END ; WITH WORDSYMBOLS[22] DO BEGIN A8TOALFA ('BEGIN ', SPELLING) ; SYMBOLVALUE := BEGINSY END ; WITH WORDSYMBOLS[23] DO BEGIN A8TOALFA ('UNTIL ', SPELLING) ; SYMBOLVALUE := UNTILSY END ; WITH WORDSYMBOLS[24] DO BEGIN A8TOALFA ('WHILE ', SPELLING) ; SYMBOLVALUE := WHILESY END ; WITH WORDSYMBOLS[25] DO BEGIN A8TOALFA ('ARRAY ', SPELLING) ; SYMBOLVALUE := ARRAYSY END ; WITH WORDSYMBOLS[26] DO BEGIN A8TOALFA ('CONST ', SPELLING) ; SYMBOLVALUE := CONSTSY END ; WITH WORDSYMBOLS[27] DO BEGIN A8TOALFA ('LABEL ', SPELLING) ; SYMBOLVALUE := LABELSY END ; WITH WORDSYMBOLS[28] DO BEGIN A8TOALFA ('REPEAT ', SPELLING) ; SYMBOLVALUE := REPEATSY END ; WITH WORDSYMBOLS[29] DO BEGIN A8TOALFA ('RECORD ', SPELLING) ; SYMBOLVALUE := RECORDSY END ; WITH WORDSYMBOLS[30] DO BEGIN A8TOALFA ('DOWNTO ', SPELLING) ; SYMBOLVALUE := DOWNTOSY ; END ; WITH WORDSYMBOLS[31] DO BEGIN A8TOALFA ('PACKED ', SPELLING) ; SYMBOLVALUE := PACKEDSY END ; WITH WORDSYMBOLS[32] DO BEGIN A8TOALFA ('PROGRAM ', SPELLING) ; SYMBOLVALUE := PROGRAMSY END ; WITH WORDSYMBOLS[33] DO BEGIN A8TOALFA ('FUNCTION', SPELLING) ; SYMBOLVALUE := FUNCSY END ; WITH WORDSYMBOLS[34] DO BEGIN A8TOALFA ('PROCEDUR', SPELLING) ; SPELLING[9] := 'E' ; SYMBOLVALUE := PROCSY END ; LASTOFLENGTH[0] := 0 ; LASTOFLENGTH[1] := 0 ; LASTOFLENGTH[2] := 6 ; LASTOFLENGTH[3] := 14 ; LASTOFLENGTH[4] := 21 ; LASTOFLENGTH[5] := 27 ; LASTOFLENGTH[6] := 31 ; LASTOFLENGTH[7] := 32 ; LASTOFLENGTH[8] := 33 ; LASTOFLENGTH[9] := 34 ; END (* INITSYMBOL *) ; PROCEDURE READSYMBOL ; (*FORWARD-DECLARED*) (* THIS PROCEDURE READS THE NEXT BASIC SYMBOL OF THE SOURCE PROGRAM AND RETURNS ITS DESCRIPTION IN THE GLOBAL VARIABLES SYMBOL, OPERATOR, SPELLING AND CONSTANT *) LABEL 1, 2, 3 ; VAR K : 0..ALFALENGTH ; PACKEDIDEN : ALFA ; LASTWASQ,STRINGEND,SFACNEG : BOOLEAN ; I : 0..CHARSINWORD ; N : 0..ALFALENGTH ; LGTH : LINEPOSITION ; LASTP,TAILP,HEADP : STRINGP ; LICH : ALFAWORD; L : 1..NOWORDSYMBOLS ; STILLINTEGER,NEGATIVE : BOOLEAN ; DIGITS : ARRAY [1..SIGMAX] OF 0..9 ; SIGNIFICANT,SCALE,EXPONENT,LIVAL : INTEGER ; FACTOR,SCALEFACTOR,LRVAL : REAL ; SIGLIMIT : 0..SIGMAX ; J : 1..SIGMAX ; BEGIN (* READSYMBOL *) 1: WHILE (CH=' ') OR (CH=CHR(EBCDICTABCHAR)) DO NEXTCH; IF CH<=CHR(ORDLARGESTCHAR) THEN WITH ONECHARSYMBOLS[CH] DO BEGIN SYMBOL := SYMBOLVALUE ; OPERATOR := OPVALUE END ELSE BEGIN SYMBOL := OTHERSY; OPERATOR := NOTOP; END; CASE SYMBOL OF IDENT : BEGIN K := 0 ; PACKEDIDEN := BLANKALFA; REPEAT IF (K UNDERSCORECHAR) THEN BEGIN K := K+1 ; PACKEDIDEN [K] := FORCETOUPPERCASE [CH] ; END ; NEXTCH UNTIL (ONECHARSYMBOLS[CH].SYMBOLVALUE <> IDENT) AND (ONECHARSYMBOLS[CH].SYMBOLVALUE <> DIGIT) AND (CH <> UNDERSCORECHAR) ; IF K <= MAXWORDSYMLEN THEN FOR L := LASTOFLENGTH[K-1]+1 TO LASTOFLENGTH[K] DO WITH WORDSYMBOLS[L] DO IF SPELLING=PACKEDIDEN THEN BEGIN SYMBOL := SYMBOLVALUE ; OPERATOR := OPVALUE ; GOTO 2 END ; SPELLING := PACKEDIDEN ; 2: END ; DIGIT : BEGIN STILLINTEGER := TRUE ; SIGNIFICANT := 0 ; SCALE := 0 ; (* IGNORE LEADING ZEROES *) WHILE CH='0' DO NEXTCH ; WHILE (CH>='0') AND (CH<='9') DO BEGIN SIGNIFICANT:=SIGNIFICANT+1 ; IF SIGNIFICANT <= SIGMAX THEN DIGITS[SIGNIFICANT] := ORD(CH) - ORD('0') ; NEXTCH END ; BEGIN IF CH='.' THEN BEGIN NEXTCH ; IF CH='.' THEN PREVCH ELSE BEGIN STILLINTEGER := FALSE ; IF (CH<'0') OR (CH>'9') THEN ERROR(201) ELSE REPEAT IF (CH<>'0') OR (SIGNIFICANT<>0) THEN BEGIN SIGNIFICANT := SIGNIFICANT+1 ; IF SIGNIFICANT <= SIGMAX THEN DIGITS[SIGNIFICANT] := ORD(CH)-ORD('0') END ; SCALE := SCALE+1 ; NEXTCH UNTIL (CH<'0') OR (CH>'9') END END ; IF (CH='E') OR (CH='e') THEN (* READ EXPONENT PART *) BEGIN STILLINTEGER := FALSE ; NEXTCH ; NEGATIVE := (CH='-') ; IF NEGATIVE OR (CH='+') THEN NEXTCH ; EXPONENT := 0 ; IF (CH<'0') OR (CH>'9') THEN ERROR(201) ELSE REPEAT EXPONENT := 10*EXPONENT+ORD(CH)-ORD('0') ; NEXTCH UNTIL (CH<'0') OR (CH>'9') ; IF NEGATIVE THEN SCALE := SCALE+EXPONENT ELSE SCALE := SCALE-EXPONENT END ; IF STILLINTEGER THEN (* INTEGER CONSTANT *) IF SIGNIFICANT > INTSIGMAX THEN STILLINTEGER := FALSE ELSE BEGIN LIVAL := 0 ; FOR J := 1 TO SIGNIFICANT DO IF (LIVAL < MAXINT DIV 10) OR (LIVAL = MAXINT DIV 10 ) AND (DIGITS[J] <= MAXINT MOD 10 ) THEN LIVAL := LIVAL*10 + DIGITS[J] ELSE BEGIN STILLINTEGER := FALSE ; GOTO 3 END ; 3: END END ; IF STILLINTEGER THEN BEGIN WITH CONSTANT DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := LIVAL END ; SYMBOL := INTCONST END ELSE (* SET UP DESCRIPTION FOR DECIMAL CONSTANT *) BEGIN LRVAL := 0 ; IF SIGNIFICANT > SIGMAX THEN BEGIN SIGLIMIT := SIGMAX ; SCALE := SCALE-(SIGNIFICANT-SIGMAX) END ELSE SIGLIMIT := SIGNIFICANT ; FOR J := 1 TO SIGLIMIT DO LRVAL := 10*LRVAL+DIGITS[J] ; IF SCALE <> 0 THEN BEGIN SFACNEG := (SCALE<0) ; SCALE := ABS(SCALE) ; FACTOR := 10 ; SCALEFACTOR := 1 ; WHILE SCALE > 0 DO IF ODD(SCALE) THEN BEGIN SCALEFACTOR := SCALEFACTOR * FACTOR ; SCALE := SCALE - 1 END ELSE BEGIN FACTOR := SQR(FACTOR) ; SCALE := SCALE DIV 2 END ; IF SFACNEG THEN LRVAL := LRVAL * SCALEFACTOR ELSE LRVAL := LRVAL / SCALEFACTOR END ; WITH CONSTANT DO BEGIN SIZE := 2 ; KIND := REALVALUE ; RVAL := LRVAL END ; SYMBOL := REALCONST END ; OPERATOR := NOTOP END ; QUOTE : (* ANALYSIS OF A CHARACTER STRING *) BEGIN OPERATOR := NOTOP ; LASTWASQ := FALSE ; STRINGEND := FALSE ; LASTP := NIL ; LGTH := 0 ; I := 0 ;LICH := ' '; NEXTCH ; REPEAT IF ATENDOFLINE THEN BEGIN ERROR(202) ; STRINGEND := TRUE END ELSE IF (CH <> '''') OR LASTWASQ THEN BEGIN IF I = CHARSINWORD THEN BEGIN NEW(TAILP) ; TAILP@.WORD := LICH ; IF LASTP = NIL THEN HEADP := TAILP ELSE LASTP@.NEXTWORD := TAILP ; LASTP := TAILP ; I := 0 ;LICH := ' '; END ; I := I+1 ; LGTH := LGTH+1 ; LASTWASQ := FALSE ; LICH[I] := CH ; NEXTCH END ELSE BEGIN LASTWASQ := TRUE ; NEXTCH ; STRINGEND := CH <> '''' END UNTIL STRINGEND ; WITH CONSTANT DO IF LGTH<=1 THEN BEGIN IF LGTH = 0 THEN ERROR(205) ; SIZE := 1 ; KIND := CHARVALUE ; CVAL := CODETABLE@[LICH[1]] ; SYMBOL := CHARCONST END ELSE BEGIN NEW(TAILP) ; WITH TAILP@ DO BEGIN WORD := LICH ; NEXTWORD := NIL END ; IF LASTP = NIL THEN HEADP := TAILP ELSE LASTP@.NEXTWORD := TAILP ; IF(LGTH MOD CHARSINWORD)=0 THEN SIZE := LGTH DIV CHARSINWORD ELSE SIZE := LGTH DIV CHARSINWORD + 1 ; KIND := STRINGVALUE ; LENGTH := LGTH ; STRING := HEADP ; SYMBOL := STRINGCONST END END ; (* ANALYSIS OF AN OPERATOR/DELIMITER *) (* 2-CHARACTER OPERATOR/DELIMITER *) COLON : BEGIN NEXTCH ; IF CH = '=' THEN BEGIN SYMBOL := BECOMES ; NEXTCH END END ; PERIOD : BEGIN NEXTCH ; IF CH = '.' THEN BEGIN SYMBOL := DOTDOTSY ; NEXTCH END END ; LEFTPARENT : BEGIN NEXTCH ; IF CH = '*' THEN BEGIN NEXTCH; REPEAT WHILE (CH<>'*') AND (CH<>'}') DO NEXTCH; IF CH='*' THEN NEXTCH; UNTIL (CH=')') OR (CH='}'); NEXTCH ; GOTO 1 END END ; LEFTCURLYBRACKET : BEGIN NEXTCH; REPEAT WHILE (CH<>'*') AND (CH<>'}') DO NEXTCH; IF CH='*' THEN NEXTCH; UNTIL (CH='}') OR (CH=')'); NEXTCH ; GOTO 1 END ; RELOP : CASE OPERATOR OF LTOP : BEGIN NEXTCH ; IF CH = '=' THEN BEGIN OPERATOR := LEOP ; NEXTCH END ELSE IF CH = '>' THEN BEGIN OPERATOR := NEOP ; NEXTCH END END ; GTOP : BEGIN NEXTCH ; IF CH = '=' THEN BEGIN OPERATOR := GEOP ; NEXTCH END END ; EQOP : NEXTCH END ; OTHERSY,SEMICOLON,RIGHTPARENT,ARROW, MULOP,ADDOP,COMMA,LEFTBRACKET,RIGHTBRACKET, RIGHTCURLYBRACKET : NEXTCH END (* CASE *) END (* INSYMBOL *) ; PROCEDURE INSYMBOL; BEGIN READSYMBOL; PRESERVETOKEN; END (* INSYMBOL *) ; (*---- SUPPORT FOR SYNTAX/SEMANTIC ANALYSER ----*) (* ------------------------------------ *) PROCEDURE STARTLIST ( VAR LIST : IDLIST ) ; BEGIN LIST.FIRSTENTRY := NIL ; LIST.LASTENTRY := NIL END (* STARTLIST *) ; PROCEDURE APPENDID ( VAR LIST : IDLIST ; VAR ID : IDENTRY ) ; BEGIN IF LIST.FIRSTENTRY = NIL THEN LIST.FIRSTENTRY := ID ELSE LIST.LASTENTRY@.NEXT := ID ; LIST.LASTENTRY := ID ; ID@.NEXT := NIL END (* APPENDID *) ; PROCEDURE APPENDLISTS ( VAR LIST1,LIST2 : IDLIST ) ; BEGIN IF LIST1.FIRSTENTRY = NIL THEN LIST1 := LIST2 ELSE IF LIST2.FIRSTENTRY <> NIL THEN BEGIN LIST1.LASTENTRY@.NEXT := LIST2.FIRSTENTRY ; LIST1.LASTENTRY := LIST2.LASTENTRY END END (* APPENDLISTS *) ; PROCEDURE INITSCOPE ; BEGIN TOP:=0 ; LEVEL:=0 ; WITH DISPLAY[0] DO BEGIN IDSCOPE := NIL ; SCOPE := BLOC ; TYPECHAIN := NIL ; FIRSTLABEL := NIL END END (* INITSCOPE *) ; PROCEDURE OPENSCOPE ( KIND : SCOPEKIND ) ; BEGIN IF TOP < DISPLIMIT THEN BEGIN TOP := TOP+1 ; WITH DISPLAY[TOP] DO BEGIN IDSCOPE := NIL ; SCOPE := KIND ; IF KIND = BLOC THEN BEGIN TYPECHAIN := NIL ; FIRSTLABEL := NIL ; LEVEL := TOP ; OPENNAMESPACE ; END ELSE FIELDSPACKED := FALSE END END ELSE BEGIN ERROR(250) END END (* OPENSCOPE *) ; PROCEDURE SAVESCOPE ( VAR SCOPE : SCOPECOPY ) ; BEGIN NEW(SCOPE) ; SCOPE @ := DISPLAY[TOP] ; TOP := TOP - 1 ; LEVEL := LEVEL - 1 END (* SAVESCOPE *) ; PROCEDURE RESTORESCOPE ( SCOPE : SCOPECOPY ) ; BEGIN TOP := TOP + 1 ; LEVEL := LEVEL + 1 ; DISPLAY[TOP] := SCOPE @ ; DISPOSE(SCOPE) END (* RESTORESCOPE *) ; PROCEDURE CLOSESCOPE ; BEGIN IF DISPLAY[TOP].SCOPE = BLOC THEN BEGIN CLOSENAMESPACE ; LEVEL := LEVEL-1 ; END ; TOP := TOP-1 END (* CLOSESCOPE *) ; PROCEDURE DISPOSESCOPE ; PROCEDURE DISPOSEIDS ( ROOT : IDENTRY ) ; VAR THISFORMAL,NEXTFORMAL : FORMALENTRY ; BEGIN IF ROOT <> NIL THEN WITH ROOT@ DO BEGIN DISPOSEIDS (LEFTLINK) ; DISPOSEIDS (RIGHTLINK) ; CASE KLASS OF TYPES : DISPOSE(ROOT,TYPES) ; CONSTS : DISPOSE(ROOT,CONSTS) ; VARS : DISPOSE(ROOT,VARS) ; FIELD : DISPOSE(ROOT,FIELD) ; PROC, FUNC : IF PFKIND = ACTUAL THEN BEGIN IF FORWARD THEN ERROR(174) ; NEXTFORMAL := FORMALS ; WHILE NEXTFORMAL <> NIL DO BEGIN THISFORMAL := NEXTFORMAL ; NEXTFORMAL := THISFORMAL@.NEXT ; DISPOSE(THISFORMAL) END ; DISPOSE(ROOT,PROC) END ELSE DISPOSE(ROOT,PROC) END END END (* DISPOSEIDS *) ; PROCEDURE DISPOSETYPES ( FIRSTTYPE : TYPENTRY ) ; VAR THISTYPE,NEXTTYPE : TYPENTRY ; BEGIN NEXTTYPE := FIRSTTYPE ; WHILE NEXTTYPE <> NIL DO BEGIN THISTYPE := NEXTTYPE ; NEXTTYPE := THISTYPE@.NEXT ; CASE THISTYPE@.FORM OF SCALARS : DISPOSE(THISTYPE,SCALARS) ; SUBRANGES : DISPOSE(THISTYPE,SUBRANGES) ; POINTERS : DISPOSE(THISTYPE,POINTERS) ; SETS : DISPOSE(THISTYPE,SETS) ; ARRAYS : DISPOSE(THISTYPE,ARRAYS) ; RECORDS : BEGIN DISPOSEIDS(THISTYPE@.FIELDSCOPE) ; DISPOSE(THISTYPE,RECORDS) END ; FILES : DISPOSE(THISTYPE,FILES) ; VARIANTPART : DISPOSE(THISTYPE,VARIANTPART) ; VARIANT : DISPOSE(THISTYPE,VARIANT) END END END (* DISPOSETYPES *) ; PROCEDURE DISPOSELABELS ( STARTLABEL : LABELENTRY ) ; VAR NEXTLAB,THISLAB : LABELENTRY ; BEGIN NEXTLAB := STARTLABEL ; WHILE NEXTLAB <> NIL DO BEGIN THISLAB := NEXTLAB ; IF NOT THISLAB@.DEFINED THEN ERROR(168) ; NEXTLAB := THISLAB@.NEXTLABEL ; DISPOSE(THISLAB) END END (* DISPOSELABELS *) ; BEGIN (* DISPOSESCOPE *) WITH DISPLAY[LEVEL] DO BEGIN DISPOSEIDS(IDSCOPE) ; DISPOSETYPES(TYPECHAIN) ; DISPOSELABELS(FIRSTLABEL) END END (* DISPOSESCOPE *) ; PROCEDURE NEWTYPE ( VAR ENTRY : TYPENTRY ; FORMNEEDED : TYPEFORM ) ; VAR NEWENTRY : TYPENTRY ; BEGIN (* NEWTYPE *) CASE FORMNEEDED OF SCALARS : BEGIN NEW(NEWENTRY,SCALARS,DECLARED) ; WITH NEWENTRY@ DO BEGIN FORM := SCALARS ; SCALARKIND := DECLARED ; FIRSTCONST := NIL END END ; SUBRANGES : BEGIN NEW(NEWENTRY,SUBRANGES) ; WITH NEWENTRY@ DO BEGIN FORM := SUBRANGES ; RANGETYPE := NIL ; MIN := 0 ; MAX := 1 END END ; POINTERS : BEGIN NEW(NEWENTRY,POINTERS) ; WITH NEWENTRY@ DO BEGIN FORM := POINTERS ; DOMAINTYPE := NIL END END ; SETS : BEGIN NEW(NEWENTRY,SETS) ; WITH NEWENTRY@ DO BEGIN FORM := SETS ; PACKEDSET := FALSE ; BASETYPE := NIL END END ; ARRAYS : BEGIN NEW(NEWENTRY,ARRAYS) ; WITH NEWENTRY@ DO BEGIN FORM := ARRAYS ; AELTYPE := NIL ; INXTYPE := NIL ; PACKEDARRAY := FALSE END END ; RECORDS : BEGIN NEW(NEWENTRY,RECORDS) ; WITH NEWENTRY@ DO BEGIN FORM := RECORDS ; PACKEDRECORD := FALSE ; FIELDSCOPE := NIL ; NONVARPART := NIL ; VARPART := NIL END END ; FILES : BEGIN NEW(NEWENTRY,FILES) ; WITH NEWENTRY@ DO BEGIN FORM := FILES ; PACKEDFILE := FALSE ; TEXTFILE := FALSE ; FELTYPE := NIL END END ; VARIANTPART : BEGIN NEW(NEWENTRY,VARIANTPART) ; WITH NEWENTRY@ DO BEGIN FORM := VARIANTPART ; TAGFIELD := NIL ; TAGTYPE := NIL ; FIRSTVARIANT := NIL END END ; VARIANT : BEGIN NEW(NEWENTRY,VARIANT) ; WITH NEWENTRY@ DO BEGIN FORM := VARIANT ; FSTVARFIELD := NIL ; NEXTVARIANT := NIL ; SUBVARPART := NIL ; WITH VARIANTVALUE DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := 0 END END END END ; NEWENTRY@.REPRESENTATION := DEFAULTREPRESENTATION ; WITH DISPLAY[LEVEL] DO BEGIN NEWENTRY@.NEXT := TYPECHAIN ; TYPECHAIN := NEWENTRY END ; TSERIALISE(NEWENTRY); ENTRY := NEWENTRY END (* NEWTYPE *) ; PROCEDURE NEWID ( VAR ENTRY : IDENTRY ; CLASSNEEDED : IDCLASS ) ; VAR NEWENTRY,THISENTRY,LASTENTRY : IDENTRY ; LEFTTAKEN : BOOLEAN ; BEGIN (* NEWID *) (* CREATE NEW ENTRY OF APPROPRIATE CLASS *) CASE CLASSNEEDED OF TYPES : NEW(NEWENTRY,TYPES) ; CONSTS: NEW(NEWENTRY,CONSTS) ; VARS : NEW(NEWENTRY,VARS) ; FIELD : NEW(NEWENTRY,FIELD) ; PROC : NEW(NEWENTRY,PROC,DECLARED) ; FUNC : NEW(NEWENTRY,FUNC,DECLARED) END ; (* SET NAME, KLASS, AND DEFAULT ATTRIBUTES *) WITH NEWENTRY@ DO BEGIN NAME := SPELLING ; IDTYPE := NIL ; LEFTLINK := NIL ; RIGHTLINK := NIL ; NEXT := NIL ; KLASS := CLASSNEEDED ; CASE KLASS OF TYPES : ; CONSTS: WITH VALUES DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := 0 END ; VARS : BEGIN VARPARAM := FALSE ; VARADDRESS := DEFAULTADDRESS END ; FIELD : WITH OFFSET DO BEGIN BYTEOFFSET := 0 ; BYTESIZE := 0 END ; PROC, FUNC : BEGIN PFDECKIND := DECLARED ; PFKIND := ACTUAL ; FORMALS := NIL ; EXPECTPROCSEQUENCE(CODEBODY) ; RESULT := DEFAULTADDRESS END END END ; (* ENTER IN CURRENT SCOPE *) THISENTRY := DISPLAY[TOP].IDSCOPE ; IF THISENTRY = NIL THEN DISPLAY[TOP].IDSCOPE := NEWENTRY ELSE BEGIN REPEAT LASTENTRY := THISENTRY ; IF THISENTRY@.NAME = SPELLING THEN (* NAME CONFLICT,FOLLOW RIGHT LINK *) BEGIN ERROR(101) ; THISENTRY := THISENTRY@.RIGHTLINK ; LEFTTAKEN := FALSE END ELSE IF THISENTRY@.NAME < SPELLING THEN BEGIN THISENTRY := THISENTRY@.RIGHTLINK ; LEFTTAKEN := FALSE END ELSE BEGIN THISENTRY := THISENTRY@.LEFTLINK ; LEFTTAKEN := TRUE END UNTIL THISENTRY = NIL ; IF LEFTTAKEN THEN LASTENTRY@.LEFTLINK := NEWENTRY ELSE LASTENTRY@.RIGHTLINK := NEWENTRY END ; ENTRY := NEWENTRY END (* NEWID *) ; PROCEDURE SEARCHLOCALID (FIRSTENTRY:IDENTRY ; VAR ENTRY : IDENTRY ) ; LABEL 1 ; BEGIN (* SEARCHLOCALID *) WHILE FIRSTENTRY <> NIL DO IF FIRSTENTRY@.NAME = SPELLING THEN GOTO 1 ELSE IF FIRSTENTRY@.NAME < SPELLING THEN FIRSTENTRY := FIRSTENTRY@.RIGHTLINK ELSE FIRSTENTRY := FIRSTENTRY@.LEFTLINK ; 1: ENTRY := FIRSTENTRY END (* SEARCHLOCALID *) ; PROCEDURE SEARCHID ( ALLOWABLECLASSES : SETOFIDCLASS ; VAR ENTRY : IDENTRY ) ; LABEL 1 ; VAR THISENTRY,LASTENTRY,NEWENTRY : IDENTRY ; MISUSED,LEFTTAKEN : BOOLEAN ; INDEX,TTOP : DISPRANGE ; LCLASS : IDCLASS ; FUNCTION STRONGESTOF ( CLASSES : SETOFIDCLASS ) : IDCLASS ; VAR LCLASS : IDCLASS ; BEGIN LCLASS := TYPES ; WHILE NOT(LCLASS IN CLASSES) DO LCLASS := SUCC(LCLASS) ; STRONGESTOF := LCLASS END (* STRONGESTOF *) ; BEGIN (* SEARCHID *) MISUSED := FALSE ; FOR INDEX := TOP DOWNTO 0 DO BEGIN THISENTRY := DISPLAY[INDEX].IDSCOPE ; WHILE THISENTRY <> NIL DO IF THISENTRY@.NAME = SPELLING THEN IF THISENTRY@.KLASS IN ALLOWABLECLASSES THEN BEGIN LEVELFOUND := INDEX ; GOTO 1 END ELSE BEGIN MISUSED := TRUE ; THISENTRY := THISENTRY@.RIGHTLINK END ELSE IF THISENTRY@.NAME < SPELLING THEN THISENTRY := THISENTRY@.RIGHTLINK ELSE THISENTRY := THISENTRY@.LEFTLINK ; IF MISUSED THEN BEGIN (* IDENTIFIER(S) WITH CORRECT SPELLING BUT WRONG CLASS - SET DEFAULTENTRY FOR MISUSED IDENTIFIER AND JUMP OUT *) ERROR(103) ; LEVELFOUND := LEVEL ; THISENTRY := DEFAULTENTRY[STRONGESTOF(ALLOWABLECLASSES)] ; GOTO 1 END END (* FOR *) ; (* TABLE EXHAUSTED - IDENTIFIER NOT FOUND. CREATE AN ENTRY FOR THE UNDECLARED IDENTIFIER, OF APPROPRIATE CLASS *) ERROR(104) ; TTOP := TOP ; TOP := LEVEL ; NEWID(THISENTRY,STRONGESTOF(ALLOWABLECLASSES)) ; TOP := TTOP ; LEVELFOUND := LEVEL ; 1: ENTRY := THISENTRY END (* SEARCHID *) ; PROCEDURE NEWLABEL ( VAR ENTRY : LABELENTRY ) ; LABEL 1 ; VAR NEWENTRY,THISENTRY : LABELENTRY ; NEWLABEL : INTEGER ; BEGIN (* NEWLABEL *) NEW(NEWENTRY) ; WITH NEWENTRY@ DO BEGIN LABELVALUE := CONSTANT.IVAL1 ; NEXTLABEL := NIL ; EXPECTCODESEQUENCE(LABELLEDCODE) ; DEFINED := FALSE END ; WITH DISPLAY[TOP] DO BEGIN THISENTRY := FIRSTLABEL ; NEWLABEL := NEWENTRY@.LABELVALUE ; WHILE THISENTRY <> NIL DO IF THISENTRY@.LABELVALUE = NEWLABEL THEN BEGIN ERROR(166) ; GOTO 1 END ELSE THISENTRY := THISENTRY@.NEXTLABEL ; NEWENTRY@.NEXTLABEL := FIRSTLABEL ; FIRSTLABEL := NEWENTRY END ; 1: ENTRY := NEWENTRY END (* NEWLABEL *) ; PROCEDURE SEARCHLABEL ( VAR ENTRY : LABELENTRY ) ; LABEL 1 ; VAR INDEX,TTOP : DISPRANGE ; THISENTRY : LABELENTRY ; BEGIN (* SEARCHLABEL *) INDEX := LEVEL ; REPEAT THISENTRY := DISPLAY[INDEX].FIRSTLABEL ; WHILE THISENTRY <> NIL DO IF THISENTRY@.LABELVALUE = CONSTANT.IVAL1 THEN BEGIN LEVELFOUND := INDEX ; GOTO 1 END ELSE THISENTRY := THISENTRY@.NEXTLABEL ; INDEX := INDEX-1 UNTIL INDEX = 0 ; (* LABEL NOT FOUND - REPORT ERROR AND CREATE AN ENTRY FOR THE UNDECLARED LABEL *) ERROR(167) ; TTOP := TOP ; TOP := LEVEL ; NEWLABEL(THISENTRY) ; TOP := TTOP ; LEVELFOUND := LEVEL ; 1: ENTRY := THISENTRY END (* SEARCHLABEL *) ; (* ---------------------- THE SYNTAX ANALYSER ----------------------- *) PROCEDURE INITSYNTAXANALYSER ; VAR I : SYMBOLTYPE ; BEGIN FOR I := IDENT TO OTHERSY DO MISSINGCODEFOR[I] := 0 ; MISSINGCODEFOR[IDENT] := 2 ; MISSINGCODEFOR[LEFTPARENT] := 9 ; MISSINGCODEFOR[RIGHTPARENT] := 4 ; MISSINGCODEFOR[LEFTBRACKET] := 11 ; MISSINGCODEFOR[RIGHTBRACKET] := 12 ; MISSINGCODEFOR[COMMA] := 20 ; MISSINGCODEFOR[SEMICOLON] := 14 ; MISSINGCODEFOR[COLON] := 5 ; MISSINGCODEFOR[ENDSY] := 13 ; MISSINGCODEFOR[OFSY] := 8 ; MISSINGCODEFOR[DOSY] := 54 ; MISSINGCODEFOR[THENSY] := 52 ; A8TOALFA ('GET ', STDPFNAMES[GETP] ) ; A8TOALFA ('PUT ', STDPFNAMES[PUTP] ) ; A8TOALFA ('RESET ', STDPFNAMES[RESETP] ) ; A8TOALFA ('REWRITE ', STDPFNAMES[REWRITEP]) ; A8TOALFA ('READ ', STDPFNAMES[READP] ) ; A8TOALFA ('WRITE ', STDPFNAMES[WRITEP] ) ; A8TOALFA ('READLN ', STDPFNAMES[READLNP] ) ; A8TOALFA ('WRITELN ', STDPFNAMES[WRITELNP]) ; A8TOALFA ('PAGE ', STDPFNAMES[PAGEP] ) ; STDPFNAMES [DATEANDTIMEP] := 'DATEANDTIME ' ; A8TOALFA ('HALT ', STDPFNAMES[HALTP] ) ; A8TOALFA ('NEW ', STDPFNAMES[NEWP] ) ; A8TOALFA ('DISPOSE ', STDPFNAMES[DISPOSEP]) ; STDPFNAMES [STOREBYTEATP] := 'STOREBYTEAT ' ; STDPFNAMES [STOREWORDATP] := 'STOREWORDAT ' ; A8TOALFA ('PACK ', STDPFNAMES[PACKP] ) ; A8TOALFA ('UNPACK ', STDPFNAMES[UNPACKP] ) ; A8TOALFA ('ABS ', STDPFNAMES[ABSF] ) ; A8TOALFA ('SQR ', STDPFNAMES[SQRF] ) ; A8TOALFA ('ODD ', STDPFNAMES[ODDF] ) ; A8TOALFA ('SUCC ', STDPFNAMES[SUCCF] ) ; A8TOALFA ('PRED ', STDPFNAMES[PREDF] ) ; A8TOALFA ('ORD ', STDPFNAMES[ORDF] ) ; A8TOALFA ('CHR ', STDPFNAMES[CHRF] ) ; A8TOALFA ('TRUNC ', STDPFNAMES[TRUNCF] ) ; A8TOALFA ('ROUND ', STDPFNAMES[ROUNDF] ) ; A8TOALFA ('SIN ', STDPFNAMES[SINF] ) ; A8TOALFA ('COS ', STDPFNAMES[COSF] ) ; A8TOALFA ('EXP ', STDPFNAMES[EXPF] ) ; A8TOALFA ('LN ', STDPFNAMES[LNF] ) ; A8TOALFA ('SQRT ', STDPFNAMES[SQRTF] ) ; A8TOALFA ('ARCTAN ', STDPFNAMES[ARCTANF] ) ; A8TOALFA ('ADDRESSO', STDPFNAMES[ADDRESSF]) ; STDPFNAMES [ADDRESSF] [9] := 'F' ; A8TOALFA ('ORX ', STDPFNAMES[ORF] ) ; A8TOALFA ('ANDX ', STDPFNAMES[ANDF] ) ; A8TOALFA ('NEQX ', STDPFNAMES[NEQF] ) ; A8TOALFA ('USHX ', STDPFNAMES[USHF] ) ; A8TOALFA ('ROTX ', STDPFNAMES[ROTF] ) ; A8TOALFA ('ISHX ', STDPFNAMES[ISHF] ) ; A8TOALFA ('CLOCK ', STDPFNAMES[CLOCKF] ) ; A8TOALFA ('BYTEAT ', STDPFNAMES[BYTEATF] ) ; A8TOALFA ('WORDAT ', STDPFNAMES[WORDATF] ) ; STDPFNAMES [BYTESIZEOFF] := 'BYTESIZEOF ' ; A8TOALFA ('EOF ', STDPFNAMES[EOFF] ) ; A8TOALFA ('EOLN ', STDPFNAMES[EOLNF] ) ; WITH EMPTYSET DO BEGIN SIZE := 2 ; KIND := SETVALUE ; SVAL := [] END ; WITH LINEFEED DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := THROWLINE END ; WITH PAGETHROW DO BEGIN SIZE := 1 ; KIND := INTVALUE ; IVAL1 := THROWPAGE END END (* INITSYNTAXANALYSER *) ; PROCEDURE ACCEPT ( SYMBOLEXPECTED : SYMBOLTYPE ) ; BEGIN IF SYMBOL = SYMBOLEXPECTED THEN INSYMBOL ELSE ERROR(MISSINGCODEFOR[SYMBOLEXPECTED]) END (* ACCEPT *) ; PROCEDURE SKIP (RELEVANTSYMBOLS : SETOFSYMBOLS) ; BEGIN WHILE NOT (SYMBOL IN RELEVANTSYMBOLS) DO INSYMBOL END (* SKIP *) ; PROCEDURE CHECKCONTEXT ( CONTEXTEXPECTED : SETOFSYMBOLS ) ; BEGIN IF NOT (SYMBOL IN CONTEXTEXPECTED ) THEN BEGIN ERROR(6) ; SKIP(CONTEXTEXPECTED) END END (* CHECKCONTEXT *) ; PROCEDURE CHECKNEXTORCONTEXT ( SYMBOLSEXPECTED,DEFAULTCONTEXT : SETOFSYMBOLS) ; BEGIN IF NOT ( SYMBOL IN SYMBOLSEXPECTED ) THEN BEGIN ERROR(6) ; SKIP(SYMBOLSEXPECTED + DEFAULTCONTEXT) END END (* CHECKNEXTORCONTEXT *) ; PROCEDURE PROGRAMME ; TYPE FILENTRY = @ FILEREC ; FILEREC = RECORD NAME : ALFA ; FILEID : IDENTRY ; NEXT : FILENTRY ; CASE PERMANENT : BOOLEAN OF TRUE : ( UNIT : POSITIVEINTEGER ) END ; VAR PROGID : IDENTRY; PERMAFILES : FILENTRY ; UNITNUMBER : POSITIVEINTEGER ; PROCEDURE MAKEPROGENTRY (PROGNAME : ALFA); BEGIN NEW(PROGID, PROG); PROGID@.NAME := PROGNAME; PROGID@.KLASS := PROG; ISERIALISE(PROGID); OPENPROGRAM(PROGNAME); END (* MAKEPROGENTRY *) ; PROCEDURE NEWPERMAFILE ( FILENAME : ALFA ) ; VAR ENTRY : FILENTRY ; BEGIN NEW(ENTRY,TRUE) ; WITH ENTRY@ DO BEGIN NAME := FILENAME ; FILEID := NIL ; PERMANENT := TRUE ; UNIT := UNITNUMBER ; NEXT := PERMAFILES END ; UNITNUMBER := UNITNUMBER + 1 ; PERMAFILES := ENTRY END (* NEWPERMAFILE *) ; PROCEDURE BUILTINFILES ; VAR THISFILE : FILENTRY ; BEGIN INPUTFILE := NIL ; OUTPUTFILE := NIL ; THISFILE := PERMAFILES ; WHILE THISFILE <> NIL DO WITH THISFILE@ DO BEGIN IF NAME = 'INPUT ' THEN BEGIN SPELLING := NAME ; NEWID(INPUTFILE,VARS) ; ISERIALISE(INPUTFILE); INPUTFILE@.IDTYPE := TEXTTYPE ; SETADDRESSFOR(INPUTFILE) ; FILEID := INPUTFILE END ELSE IF NAME = 'OUTPUT ' THEN BEGIN SPELLING := NAME ; NEWID(OUTPUTFILE,VARS) ; ISERIALISE(OUTPUTFILE); OUTPUTFILE@.IDTYPE := TEXTTYPE ; SETADDRESSFOR(OUTPUTFILE) ; FILEID := OUTPUTFILE END ; THISFILE := NEXT END END (* BUILTINFILES*) ; PROCEDURE DEFAULTFILES ; BEGIN NEWPERMAFILE('INPUT ') ; NEWPERMAFILE('OUTPUT ') ; END ; PROCEDURE BLOCK (BLOCKCONTEXT : SETOFSYMBOLS ; BLOCKFOLLOWER : SYMBOLTYPE ; BLOCKIDENTRY : IDENTRY ) ; TYPE DLISTENTRY = @ DOMAINS ; DOMAINS = RECORD NAME : ALFA ; POINTERTYPE : TYPENTRY ; NEXTDOMAIN : DLISTENTRY END ; VAR SUBBLOCKCONTEXT : SETOFSYMBOLS ; DOMAINLIST : DLISTENTRY ; ALLTYPESDEFINED : BOOLEAN ; NEXTLOCALID : IDENTRY ; LOCALIDLIST : IDLIST ; NEXTFORMAL : IDENTRY ; SCRATCHFILES : FILENTRY ; PROCEDURE NEWFILE( ID : IDENTRY ) ; LABEL 1 ; VAR ENTRY : FILENTRY ; BEGIN IF LEVEL = GLOBALLEVEL THEN BEGIN ENTRY := PERMAFILES ; WHILE ENTRY <> NIL DO IF ENTRY@.NAME = ID@.NAME THEN BEGIN IF ENTRY@.FILEID = NIL THEN ENTRY@.FILEID := ID ELSE ERROR(101) ; GOTO 1 END ELSE ENTRY := ENTRY@.NEXT END ; NEW(ENTRY,FALSE) ; WITH ENTRY@ DO BEGIN NAME := ID@.NAME ; NEXT := SCRATCHFILES ; FILEID := ID ; PERMANENT := FALSE END ; SCRATCHFILES := ENTRY ; 1: END ; PROCEDURE OPENFILES( FIRSTFILE : FILENTRY ) ; VAR THISFILE : FILENTRY ; UNITNUMBER : POSITIVEINTEGER ; BEGIN THISFILE := FIRSTFILE ; WHILE THISFILE <> NIL DO WITH THISFILE@ DO BEGIN IF PERMANENT THEN UNITNUMBER := UNIT ELSE UNITNUMBER := 0 ; IF FILEID = NIL THEN ERROR(177) ELSE WITH FILEID@, IDTYPE@ DO IF FELTYPE <> NIL THEN BEGIN STACKREFERENCE(FALSE,VARADDRESS, REPRESENTATION ) ; FILEOPEN(FELTYPE@.REPRESENTATION, PACKEDFILE,TEXTFILE, PERMANENT,NAME, UNITNUMBER ) ; END ; THISFILE := NEXT END END (* OPENFILES *) ; PROCEDURE CLOSEFILES(FIRSTFILE : FILENTRY ) ; VAR THISFILE, NEXTFILE : FILENTRY ; BEGIN THISFILE := FIRSTFILE ; WHILE THISFILE <> NIL DO WITH THISFILE@ DO BEGIN IF FILEID <> NIL THEN WITH FILEID@, IDTYPE@ DO IF FELTYPE <> NIL THEN BEGIN STACKREFERENCE(FALSE,VARADDRESS, REPRESENTATION ) ; FILECLOSE(TEXTFILE) END ; NEXTFILE := NEXT ; THISFILE := NEXTFILE END END (* CLOSEFILES *) ; FUNCTION COMPTYPES (TYPE1,TYPE2 : TYPENTRY) : BOOLEAN ; (* DECIDES WHETHER TYPES POINTED AT BY TYPE1 AND TYPE2 ARE COMPATIBLE *) FUNCTION EQUIVALENT ( TYPE1,TYPE2 : TYPENTRY ; AREPACKED : BOOLEAN ) : BOOLEAN ; (* DECIDES WHETHER (DISCINCT) TYPES POINTED AT BY TYPE1 AND TYPE2 ARE EQUIVALENT. AREPACKED INDICATES WHETHER TYPES HAVE OCCURRED AS SUB-TYPES WITHIN A PACKED STRUCTURE TYPE, IN WHICH CASE SUB RANGE BOUNDS MUST BE IDENTICAL *) VAR STILLEQUIVALENT : BOOLEAN ; CONST1,CONST2 : IDENTRY ; FUNCTION COMPSUBTYPES ( TYPE1,TYPE2 : TYPENTRY ; AREPACKED : BOOLEAN ) : BOOLEAN ; BEGIN IF TYPE1 = TYPE2 THEN COMPSUBTYPES := TRUE ELSE IF (TYPE1=NIL) OR (TYPE2=NIL) THEN COMPSUBTYPES := TRUE ELSE COMPSUBTYPES := EQUIVALENT(TYPE1,TYPE2, AREPACKED) END (* COMPSUBTYPES *) ; FUNCTION EQUALBOUNDS ( TYPE1,TYPE2 : TYPENTRY ) : BOOLEAN ; VAR MIN1,MAX1,MIN2,MAX2 : INTEGER ; BEGIN GETBOUNDS(TYPE1,MIN1,MAX1) ; GETBOUNDS(TYPE2,MIN2,MAX2) ; EQUALBOUNDS := (MIN1=MIN2) AND (MAX1=MAX2) END (* EQUALBOUNDS *) ; BEGIN (* EQUIVALENT *) IF TYPE1@.FORM = TYPE2@.FORM THEN CASE TYPE1@.FORM OF SCALARS : IF (TYPE1@.SCALARKIND = STANDARD) OR (TYPE2@.SCALARKIND = STANDARD) THEN EQUIVALENT := FALSE ELSE BEGIN CONST1 := TYPE1@.FIRSTCONST ; CONST2 := TYPE2@.FIRSTCONST ; STILLEQUIVALENT := TRUE ; WHILE STILLEQUIVALENT AND (CONST1<>NIL) AND (CONST2<>NIL) DO BEGIN STILLEQUIVALENT := CONST1@.NAME=CONST2@.NAME; CONST1 := CONST1@.NEXT ; CONST2 := CONST2@.NEXT END ; EQUIVALENT := STILLEQUIVALENT AND (CONST1=CONST2) END ; SUBRANGES : BEGIN STILLEQUIVALENT := COMPTYPES(TYPE1@.RANGETYPE, TYPE2@.RANGETYPE) ; IF STILLEQUIVALENT AND AREPACKED THEN IF TYPE1@.RANGETYPE <> REALTYPE THEN STILLEQUIVALENT:=EQUALBOUNDS(TYPE1,TYPE2); EQUIVALENT := STILLEQUIVALENT END ; POINTERS : EQUIVALENT := COMPTYPES(TYPE1@.DOMAINTYPE, TYPE2@.DOMAINTYPE) ; SETS : EQUIVALENT := (TYPE1@.PACKEDSET=TYPE2@.PACKEDSET) AND COMPSUBTYPES(TYPE1@.BASETYPE, TYPE2@.BASETYPE, TYPE1@.PACKEDSET) ; ARRAYS : EQUIVALENT := (TYPE1@.PACKEDARRAY = TYPE2@.PACKEDARRAY) AND COMPTYPES(TYPE1@.INXTYPE, TYPE2@.INXTYPE) AND EQUALBOUNDS(TYPE1@.INXTYPE, TYPE2@.INXTYPE) AND COMPSUBTYPES(TYPE1@.AELTYPE, TYPE2@.AELTYPE, TYPE1@.PACKEDARRAY); RECORDS : EQUIVALENT := FALSE ; FILES : EQUIVALENT := (TYPE1@.PACKEDFILE=TYPE2@.PACKEDFILE) AND COMPSUBTYPES(TYPE1@.FELTYPE, TYPE2@.FELTYPE, TYPE1@.PACKEDFILE) ; END ELSE (* TYPE1@.FORM <> TYPE2@.FORM *) BEGIN IF TYPE1@.FORM = SUBRANGES THEN STILLEQUIVALENT := COMPTYPES(TYPE1@.RANGETYPE,TYPE2) ELSE IF TYPE2@.FORM = SUBRANGES THEN STILLEQUIVALENT := COMPTYPES(TYPE1,TYPE2@.RANGETYPE) ELSE STILLEQUIVALENT := FALSE ; IF STILLEQUIVALENT AND AREPACKED AND (TYPE1<>REALTYPE) AND (TYPE2<>REALTYPE) THEN STILLEQUIVALENT := EQUALBOUNDS(TYPE1,TYPE2) ; EQUIVALENT := STILLEQUIVALENT END END (* EQUIVALENT *) ; BEGIN (* COMPTYPES *) ; IF TYPE1 = TYPE2 THEN COMPTYPES := TRUE ELSE IF (TYPE1=NIL) OR (TYPE2=NIL) THEN COMPTYPES := TRUE ELSE COMPTYPES := EQUIVALENT(TYPE1,TYPE2,FALSE) END (* COMPTYPES *) ; FUNCTION STRING ( STRGTYPE : TYPENTRY ) : BOOLEAN ; BEGIN (* STRING *) STRING := FALSE ; IF STRGTYPE <> NIL THEN WITH STRGTYPE@ DO IF FORM = ARRAYS THEN IF COMPTYPES(AELTYPE,CHARTYPE) THEN STRING := PACKEDARRAY END (* STRING *) ; PROCEDURE STRINGTYPE( VAR STRINGENTRY : TYPENTRY ) ; VAR INDEXTYPE,ARRAYTYPE : TYPENTRY ; BEGIN (* STRINGTYPE *) IF CONSTANT.LENGTH = ALFALENGTH THEN STRINGENTRY := ALFATYPE ELSE IF CONSTANT.LENGTH = ALFA8LENGTH THEN STRINGENTRY := ALFA8TYPE ELSE BEGIN NEWTYPE(INDEXTYPE,SUBRANGES) ; WITH INDEXTYPE@ DO BEGIN RANGETYPE := INTTYPE ; MIN := 1 ; MAX := CONSTANT.LENGTH ; END ; SETREPRESENTATIONFOR(INDEXTYPE) ; NEWTYPE(ARRAYTYPE,ARRAYS) ; WITH ARRAYTYPE@ DO BEGIN AELTYPE := CHARTYPE ; INXTYPE := INDEXTYPE ; PACKEDARRAY := TRUE ; END ; SETREPRESENTATIONFOR(ARRAYTYPE) ; STRINGENTRY := ARRAYTYPE END END (* STRINGTYPE *) ; PROCEDURE INCONSTANT( CONTEXT : SETOFSYMBOLS ; VAR CONSTYPENTRY : TYPENTRY ; VAR CONSTVALU : VALU ) ; VAR TYPECONST : TYPENTRY ; IDCONST : IDENTRY ; SIGN : (NONE,POSITIVE,NEGATIVE) ; BEGIN (* INCONSTANT *) TYPECONST := NIL ; WITH CONSTVALU DO BEGIN SIZE := 1 ; IVAL1 := 0 END ; CHECKNEXTORCONTEXT(CONSTBEGSYS,CONTEXT) ; IF SYMBOL IN CONSTBEGSYS THEN BEGIN IF SYMBOL = CHARCONST THEN BEGIN TYPECONST := CHARTYPE ; CONSTVALU := CONSTANT ; INSYMBOL END ELSE IF SYMBOL = STRINGCONST THEN BEGIN STRINGTYPE(TYPECONST) ; CONSTVALU := CONSTANT ; INSYMBOL END ELSE BEGIN SIGN := NONE ; IF (SYMBOL=ADDOP)AND(OPERATOR IN [PLUS,MINUS]) THEN BEGIN IF OPERATOR = PLUS THEN SIGN := POSITIVE ELSE SIGN := NEGATIVE ; INSYMBOL END ; IF SYMBOL = IDENT THEN BEGIN SEARCHID([CONSTS],IDCONST) ; WITH IDCONST@ DO BEGIN TYPECONST := IDTYPE ; CONSTVALU := VALUES END ; IF SIGN <> NONE THEN IF TYPECONST = INTTYPE THEN BEGIN IF SIGN = NEGATIVE THEN CONSTVALU.IVAL1 := -CONSTVALU.IVAL1 END ELSE IF TYPECONST = REALTYPE THEN BEGIN IF SIGN = NEGATIVE THEN CONSTVALU.RVAL := -CONSTVALU.RVAL END ELSE ERROR(105) ; INSYMBOL END ELSE IF SYMBOL = INTCONST THEN BEGIN TYPECONST := INTTYPE ; CONSTVALU := CONSTANT ; IF SIGN = NEGATIVE THEN CONSTVALU.IVAL1 :=-CONSTVALU.IVAL1 ; INSYMBOL END ELSE IF SYMBOL = REALCONST THEN BEGIN TYPECONST := REALTYPE ; CONSTVALU := CONSTANT ; IF SIGN = NEGATIVE THEN CONSTVALU.RVAL := -CONSTVALU.RVAL ; INSYMBOL END ELSE BEGIN ERROR(106) ; SKIP(CONTEXT) END END ; CHECKCONTEXT(CONTEXT) END ; CONSTYPENTRY := TYPECONST END (* INCONSTANT *) ; PROCEDURE TYP ( TYPECONTEXT : SETOFSYMBOLS ; VAR TYPEFOUND : TYPENTRY ) ; LABEL 9 ; VAR ELEMENTTYPE, DIMENSION,LASTDIMENSION,INDEXTYPE, LVARPART : TYPENTRY ; DOMAINENTRY : DLISTENTRY ; DOMAINID,LNONVARPART : IDENTRY ; PACKFLAG : BOOLEAN ; PROCEDURE SIMPLETYPE ( SIMTYPCONTEXT : SETOFSYMBOLS ; VAR SIMTYPENTRY : TYPENTRY ) ; VAR FIRSTENTRY,WORKENTRY : TYPENTRY ; FIRSTIDENTRY : IDENTRY ; TTOP : DISPRANGE ; WORKVALU : VALU ; CONSTLIST : IDLIST ; CONSTVAL : INTEGER ; PROCEDURE SUBRNGE ( FIRSTYPE : TYPENTRY ; FIRSTVALU : INTEGER ) ; BEGIN (* SUBRNGE *) NEWTYPE(FIRSTENTRY,SUBRANGES) ; WITH FIRSTENTRY@ DO BEGIN RANGETYPE := FIRSTYPE ; MIN := FIRSTVALU END ; ACCEPT(DOTDOTSY) ; INCONSTANT(SIMTYPCONTEXT,WORKENTRY,WORKVALU) ; WITH FIRSTENTRY@ DO BEGIN MAX := WORKVALU.IVAL1 ; IF NOT(COMPTYPES(FIRSTYPE,WORKENTRY)) THEN ERROR(107) ELSE IF FIRSTYPE = REALTYPE THEN BEGIN ERROR(175) ; RANGETYPE := NIL END ELSE IF STRING(FIRSTYPE) THEN BEGIN ERROR(148) ; RANGETYPE := NIL END ELSE IF MIN > MAX THEN BEGIN ERROR(102) ; MIN := MAX END END ; SETREPRESENTATIONFOR(FIRSTENTRY) END (* SUBRNGE *) ; BEGIN (* SIMPLETYPE *) CHECKNEXTORCONTEXT(SIMPTYPEBEGSYS,SIMTYPCONTEXT) ; IF SYMBOL IN SIMPTYPEBEGSYS THEN BEGIN IF SYMBOL = LEFTPARENT THEN BEGIN TTOP := TOP ; TOP := LEVEL ; NEWTYPE(FIRSTENTRY,SCALARS) ; STARTLIST(CONSTLIST) ; CONSTVAL := 0 ; REPEAT INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN NEWID(FIRSTIDENTRY,CONSTS) ; ISERIALISE(FIRSTIDENTRY); (*ENUMERATION CONSTANT*) WITH FIRSTIDENTRY@ DO BEGIN IDTYPE := FIRSTENTRY ; VALUES.IVAL1 := CONSTVAL ; VALUES.SIZE:=1; CONSTVAL := CONSTVAL + 1 END ; APPENDID(CONSTLIST,FIRSTIDENTRY) ; INSYMBOL END ELSE ERROR(2) ; CHECKCONTEXT(SIMTYPCONTEXT+[COMMA,RIGHTPARENT]) UNTIL SYMBOL <> COMMA ; WITH FIRSTENTRY@ DO BEGIN FIRSTCONST := CONSTLIST.FIRSTENTRY ; END ; SETREPRESENTATIONFOR(FIRSTENTRY) ; TOP := TTOP ; ACCEPT(RIGHTPARENT) END (* SYMBOL = LEFTPARENT *) ELSE IF SYMBOL = IDENT THEN BEGIN SEARCHID([TYPES,CONSTS],FIRSTIDENTRY) ; INSYMBOL ; WITH FIRSTIDENTRY@ DO IF KLASS = CONSTS THEN SUBRNGE(IDTYPE,VALUES.IVAL1) ELSE FIRSTENTRY := IDTYPE END ELSE BEGIN INCONSTANT(SIMTYPCONTEXT + [DOTDOTSY], WORKENTRY,WORKVALU ) ; SUBRNGE(WORKENTRY,WORKVALU.IVAL1) END ; SIMTYPENTRY := FIRSTENTRY ; CHECKCONTEXT(SIMTYPCONTEXT) END ELSE SIMTYPENTRY := NIL END (* SIMPLETYPE *) ; PROCEDURE FIELDLIST ( FIELDCONTEXT : SETOFSYMBOLS ; VAR NONVARPART : IDENTRY ; VAR VARPART : TYPENTRY ) ; LABEL 9, 19, 29 ; VAR FIELDENTRY,FIRSTSUBFIELD : IDENTRY ; FIELDS,FIELDSOFONETYPE : IDLIST ; FIELDTYPE,TAGTYPE,LABELTYPE, VARIANTENTRY,LASTVARIANT,LASTDISTINCTVARIANT, SUBVARIANTPART : TYPENTRY ; LABELVALUE : VALU ; PROCEDURE TAGFIELDANDITSTYPE (VAR TAGIDENTRY : IDENTRY ; VAR TAGTYPENTRY : TYPENTRY) ; VAR TAGID, TAGTYPEID : IDENTRY ; TAGTYPE : TYPENTRY ; HOLDSPELLING : ALFA ; PROCEDURE GIVEUPONIDENT ; BEGIN ERROR (2) ; SKIP (FIELDCONTEXT + [OFSY, LEFTPARENT]) ; END (* GIVEUPONIDENT *) ; FUNCTION INVALIDTAGTYPE (TAGTYPE : TYPENTRY) : BOOLEAN ; BEGIN INVALIDTAGTYPE := TRUE ; IF TAGTYPE@.FORM <= SUBRANGES THEN IF COMPTYPES (TAGTYPE, REALTYPE) THEN ERROR (109) ELSE INVALIDTAGTYPE := FALSE ELSE ERROR (110) ; END (* INVALIDTAGTYPE *) ; BEGIN (* TAGFIELDANDITSTYPE *) TAGID := NIL ; TAGTYPEID := NIL ; TAGTYPE := NIL ; IF SYMBOL = IDENT THEN BEGIN HOLDSPELLING := SPELLING ; INSYMBOL ; IF SYMBOL = COLON THEN BEGIN (* NON-EMPTY TAGFIELD *) SPELLING := HOLDSPELLING ; NEWID (TAGID, FIELD) ; ISERIALISE(TAGID); (*TAG-FIELD*) INSYMBOL ; (* SKIP COLON *) IF SYMBOL = IDENT THEN BEGIN SEARCHID ([TYPES], TAGTYPEID) ; INSYMBOL ; END ELSE GIVEUPONIDENT ; END (* NON-EMPTY TAGFIELD *) ELSE BEGIN (* EMPTY TAGFIELD *) SPELLING := HOLDSPELLING ; SEARCHID ([TYPES], TAGTYPEID) ; END (* EMPTY TAGFIELD *) ; END (* SYMBOL = IDENT *) ELSE GIVEUPONIDENT ; IF TAGTYPEID <> NIL THEN BEGIN TAGTYPE := TAGTYPEID@.IDTYPE ; IF TAGTYPE <> NIL THEN IF INVALIDTAGTYPE (TAGTYPE) THEN TAGTYPE := NIL ; END ; TAGIDENTRY := TAGID ; IF TAGID <> NIL THEN TAGID@.IDTYPE := TAGTYPE ; TAGTYPENTRY := TAGTYPE ; END (* TAGFIELDANDITSTYPE *) ; BEGIN (* FIELDLIST *) CHECKCONTEXT(FIELDCONTEXT+[IDENT,CASESY]) ; STARTLIST(FIELDS) ; WHILE SYMBOL = IDENT DO BEGIN STARTLIST(FIELDSOFONETYPE) ; WHILE TRUE DO BEGIN IF SYMBOL = IDENT THEN BEGIN NEWID(FIELDENTRY,FIELD) ; ISERIALISE(FIELDENTRY); (*FIELD*) APPENDID(FIELDSOFONETYPE,FIELDENTRY) ; INSYMBOL END ELSE ERROR(2) ; CHECKNEXTORCONTEXT([COMMA,COLON],FIELDCONTEXT+ [SEMICOLON,CASESY]) ; IF SYMBOL <> COMMA THEN GOTO 9 ; INSYMBOL END ; 9: ; ACCEPT(COLON) ; TYP(FIELDCONTEXT + [CASESY,SEMICOLON],FIELDTYPE) ; FIELDENTRY := FIELDSOFONETYPE.FIRSTENTRY ; WHILE FIELDENTRY <> NIL DO WITH FIELDENTRY@ DO BEGIN IDTYPE := FIELDTYPE ; FIELDENTRY := NEXT END ; APPENDLISTS(FIELDS,FIELDSOFONETYPE) ; IF SYMBOL = SEMICOLON THEN BEGIN INSYMBOL ; CHECKNEXTORCONTEXT([IDENT,CASESY],FIELDCONTEXT) END ELSE IF SYMBOL = CASESY THEN ERROR(14) END (* WHILE SYMBOL = IDENT *) ; NONVARPART := FIELDS.FIRSTENTRY ; IF SYMBOL = CASESY THEN BEGIN NEWTYPE(VARPART,VARIANTPART) ; INSYMBOL ; TAGFIELDANDITSTYPE (FIELDENTRY, TAGTYPE) ; VARPART@.TAGFIELD := FIELDENTRY ; VARPART@.TAGTYPE := TAGTYPE ; ACCEPT(OFSY) ; LASTVARIANT := NIL ; WHILE TRUE DO BEGIN LASTDISTINCTVARIANT := LASTVARIANT ; WHILE TRUE DO BEGIN INCONSTANT(FIELDCONTEXT + [COMMA,COLON,LEFTPARENT], LABELTYPE,LABELVALUE) ; IF NOT COMPTYPES(TAGTYPE,LABELTYPE) THEN ERROR(111) ; NEWTYPE(VARIANTENTRY,VARIANT) ; WITH VARIANTENTRY@ DO BEGIN NEXTVARIANT := LASTVARIANT ; VARIANTVALUE := LABELVALUE END ; LASTVARIANT := VARIANTENTRY ; IF SYMBOL <> COMMA THEN GOTO 19 ; INSYMBOL END ; 19: ; ACCEPT(COLON) ; ACCEPT(LEFTPARENT) ; FIELDLIST(FIELDCONTEXT + [RIGHTPARENT,SEMICOLON], FIRSTSUBFIELD,SUBVARIANTPART) ; WHILE VARIANTENTRY <> LASTDISTINCTVARIANT DO WITH VARIANTENTRY@ DO BEGIN SUBVARPART := SUBVARIANTPART ; FSTVARFIELD := FIRSTSUBFIELD ; VARIANTENTRY := NEXTVARIANT END ; IF SYMBOL = RIGHTPARENT THEN BEGIN INSYMBOL ; CHECKCONTEXT(FIELDCONTEXT+[SEMICOLON]) END ELSE ERROR(4) ; IF SYMBOL <> SEMICOLON THEN GOTO 29 ; INSYMBOL END ; 29: ; VARPART@.FIRSTVARIANT := LASTVARIANT END ELSE VARPART := NIL END (* FIELDLIST *) ; BEGIN (* TYP *) CHECKNEXTORCONTEXT(TYPEBEGSYS,TYPECONTEXT) ; IF SYMBOL IN TYPEBEGSYS THEN BEGIN IF SYMBOL IN SIMPTYPEBEGSYS THEN SIMPLETYPE(TYPECONTEXT,TYPEFOUND) ELSE IF SYMBOL = ARROW THEN BEGIN NEWTYPE(TYPEFOUND,POINTERS) ; INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN IF ALLTYPESDEFINED THEN BEGIN SEARCHID([TYPES],DOMAINID) ; TYPEFOUND@.DOMAINTYPE := DOMAINID@.IDTYPE END ELSE BEGIN NEW(DOMAINENTRY) ; WITH DOMAINENTRY@ DO BEGIN NAME := SPELLING ; POINTERTYPE := TYPEFOUND ; NEXTDOMAIN := DOMAINLIST END ; DOMAINLIST := DOMAINENTRY END ; INSYMBOL END ELSE ERROR(2) ; SETREPRESENTATIONFOR(TYPEFOUND) END ELSE BEGIN IF SYMBOL = PACKEDSY THEN BEGIN PACKFLAG := TRUE ; INSYMBOL END ELSE PACKFLAG := FALSE ; CHECKNEXTORCONTEXT(TYPEDELS,TYPECONTEXT) ; IF SYMBOL IN TYPEDELS THEN CASE SYMBOL OF ARRAYSY : BEGIN INSYMBOL ; ACCEPT(LEFTBRACKET) ; LASTDIMENSION := NIL ; WHILE TRUE DO BEGIN NEWTYPE(DIMENSION,ARRAYS) ; WITH DIMENSION@ DO BEGIN AELTYPE := LASTDIMENSION ; PACKEDARRAY := PACKFLAG END ; LASTDIMENSION := DIMENSION ; SIMPLETYPE(TYPECONTEXT + [COMMA,RIGHTBRACKET,OFSY], INDEXTYPE) ; IF INDEXTYPE <> NIL THEN IF INDEXTYPE@.FORM <= SUBRANGES THEN IF COMPTYPES(INDEXTYPE,REALTYPE) THEN ERROR(109) ELSE IF INDEXTYPE=INTTYPE THEN ERROR(149) ELSE DIMENSION@.INXTYPE:=INDEXTYPE ELSE ERROR(113) ; IF SYMBOL <> COMMA THEN GOTO 9 ; INSYMBOL END ; 9: ; ACCEPT(RIGHTBRACKET) ; ACCEPT(OFSY) ; TYP(TYPECONTEXT,ELEMENTTYPE) ; REPEAT LASTDIMENSION := DIMENSION@.AELTYPE ; DIMENSION@.AELTYPE := ELEMENTTYPE ; SETREPRESENTATIONFOR(DIMENSION) ; ELEMENTTYPE := DIMENSION ; DIMENSION := LASTDIMENSION UNTIL DIMENSION = NIL ; TYPEFOUND := ELEMENTTYPE END ; RECORDSY : BEGIN INCREMENTNESTINGLEVEL; INSYMBOL ; OPENSCOPE(WITHST) ; FIELDLIST(TYPECONTEXT-[SEMICOLON]+[ENDSY], LNONVARPART,LVARPART) ; NEWTYPE(TYPEFOUND,RECORDS) ; WITH TYPEFOUND@ DO BEGIN PACKEDRECORD := PACKFLAG ; FIELDSCOPE := DISPLAY[TOP].IDSCOPE ; NONVARPART := LNONVARPART ; VARPART := LVARPART END ; CLOSESCOPE ; DECREMENTNESTINGLEVEL; ACCEPT(ENDSY) ; SETREPRESENTATIONFOR(TYPEFOUND) END ; SETSY : BEGIN INSYMBOL ; ACCEPT(OFSY) ; NEWTYPE(TYPEFOUND,SETS) ; TYPEFOUND@.PACKEDSET := PACKFLAG ; SIMPLETYPE(TYPECONTEXT,ELEMENTTYPE) ; IF ELEMENTTYPE <> NIL THEN IF ELEMENTTYPE@.FORM > SUBRANGES THEN ERROR(115) ELSE IF COMPTYPES(REALTYPE,ELEMENTTYPE) THEN ERROR(114) ELSE IF ELEMENTTYPE = INTTYPE THEN ERROR(169) ELSE BEGIN CHECKSETBASETYPE ( ELEMENTTYPE ) ; TYPEFOUND@.BASETYPE:=ELEMENTTYPE END ; SETREPRESENTATIONFOR(TYPEFOUND) END ; FILESY : BEGIN INSYMBOL ; ACCEPT(OFSY) ; TYP(TYPECONTEXT,ELEMENTTYPE) ; NEWTYPE(TYPEFOUND,FILES) ; WITH TYPEFOUND@ DO BEGIN PACKEDFILE := PACKFLAG ; TEXTFILE := PACKFLAG AND COMPTYPES(CHARTYPE, ELEMENTTYPE) ; FELTYPE := ELEMENTTYPE ; END ; SETREPRESENTATIONFOR(TYPEFOUND) END END (* CASE *) ELSE TYPEFOUND := NIL ; END ; CHECKCONTEXT(TYPECONTEXT) END ELSE TYPEFOUND := NIL END (* TYP *) ; PROCEDURE LABELDECLARATION ; VAR THISLABELENTRY : LABELENTRY ; BEGIN (* LABELDECLARATION *) REPEAT INSYMBOL ; IF SYMBOL = INTCONST THEN BEGIN NEWLABEL(THISLABELENTRY) ; INSYMBOL END ELSE ERROR(15) ; CHECKCONTEXT(SUBBLOCKCONTEXT + [COMMA,SEMICOLON]) UNTIL SYMBOL <> COMMA ; IF SYMBOL = SEMICOLON THEN BEGIN INSYMBOL ; CHECKCONTEXT(SUBBLOCKCONTEXT) END ELSE ERROR(14) END (* LABELDECLARATION *) ; PROCEDURE CONSTDECLARATION ; VAR DECONSTID : IDENTRY ; DECONSTYPE : TYPENTRY ; DECONSTVALU : VALU ; BEGIN (* CONSTDECLARATION *) INSYMBOL ; IF SYMBOL <> IDENT THEN BEGIN ERROR(2) ; SKIP(SUBBLOCKCONTEXT + [IDENT]) END ; WHILE SYMBOL = IDENT DO BEGIN NEWID(DECONSTID,CONSTS) ; INSYMBOL ; IF (SYMBOL = RELOP) AND (OPERATOR = EQOP) THEN INSYMBOL ELSE ERROR(16) ; INCONSTANT(SUBBLOCKCONTEXT + [SEMICOLON] , DECONSTYPE,DECONSTVALU ) ; APPENDID(LOCALIDLIST,DECONSTID) ; DECONSTID@.IDTYPE := DECONSTYPE ; DECONSTID@.VALUES := DECONSTVALU ; IF SYMBOL = SEMICOLON THEN BEGIN INSYMBOL ; CHECKCONTEXT(SUBBLOCKCONTEXT + [IDENT]) END ELSE ERROR(14) END ; END (* CONSTDECLARATION *) ; PROCEDURE TYPEDECLARATION ; VAR NEWTYPENTRY : TYPENTRY ; TYPIDENTRY : IDENTRY ; BEGIN (* TYPEDECLARATION *) INSYMBOL ; ALLTYPESDEFINED := FALSE ; DOMAINLIST := NIL ; IF SYMBOL <> IDENT THEN BEGIN ERROR(2) ; SKIP(SUBBLOCKCONTEXT + [IDENT]) END ; WHILE SYMBOL = IDENT DO BEGIN NEWID(TYPIDENTRY,TYPES) ; INSYMBOL ; IF (SYMBOL = RELOP) AND (OPERATOR = EQOP) THEN INSYMBOL ELSE ERROR(16) ; TYP(SUBBLOCKCONTEXT + [SEMICOLON],NEWTYPENTRY) ; APPENDID(LOCALIDLIST,TYPIDENTRY) ; TYPIDENTRY@.IDTYPE := NEWTYPENTRY ; IF SYMBOL = SEMICOLON THEN BEGIN INSYMBOL ; CHECKCONTEXT(SUBBLOCKCONTEXT + [IDENT]) END ELSE ERROR(14) END (* WHILE *) ; WHILE DOMAINLIST <> NIL DO WITH DOMAINLIST@ DO BEGIN SPELLING := NAME ; SEARCHID([TYPES],TYPIDENTRY) ; POINTERTYPE@.DOMAINTYPE := TYPIDENTRY@.IDTYPE ; DOMAINLIST := NEXTDOMAIN END END (* TYPEDECLARATION *) ; PROCEDURE VARDECLARATION ; LABEL 9 ; VAR VARIDENTRY,NEXTENTRY : IDENTRY ; VARSOFONETYPE : IDLIST ; VARTYPENTRY : TYPENTRY ; BEGIN (* VARDECLARATION *) INSYMBOL ; ALLTYPESDEFINED := TRUE ; REPEAT STARTLIST(VARSOFONETYPE) ; WHILE TRUE DO BEGIN IF SYMBOL = IDENT THEN BEGIN NEWID(VARIDENTRY,VARS) ; ISERIALISE(VARIDENTRY); (*LOCAL VARIABLE*) APPENDID(VARSOFONETYPE,VARIDENTRY) ; INSYMBOL END ELSE ERROR(2) ; CHECKNEXTORCONTEXT(SUBBLOCKCONTEXT + [VALUESY,COMMA, COLON] + TYPEDELS,[SEMICOLON]) ; IF SYMBOL <> COMMA THEN GOTO 9 ; INSYMBOL END ; 9: ; ACCEPT(COLON) ; TYP(SUBBLOCKCONTEXT + [VALUESY,SEMICOLON] + TYPEDELS, VARTYPENTRY ) ; NEXTENTRY := VARSOFONETYPE.FIRSTENTRY ; WHILE NEXTENTRY <> NIL DO WITH NEXTENTRY@ DO BEGIN IDTYPE := VARTYPENTRY ; SETADDRESSFOR(NEXTENTRY) ; IF VARTYPENTRY <> NIL THEN IF VARTYPENTRY@.FORM = FILES THEN NEWFILE(NEXTENTRY) ; NEXTENTRY := NEXT END ; APPENDLISTS(LOCALIDLIST,VARSOFONETYPE) ; IF SYMBOL = SEMICOLON THEN BEGIN INSYMBOL ; CHECKCONTEXT(SUBBLOCKCONTEXT + [VALUESY,IDENT]) END ELSE ERROR(14) UNTIL (SYMBOL <> IDENT) AND NOT (SYMBOL IN TYPEDELS) ; END (* VARDECLARATION *) ; PROCEDURE PROCDECLARATION ; VAR LSYMBOL : SYMBOLTYPE ; PFID,TYPEID : IDENTRY ; FIRSTPARAM : FORMALENTRY ; FUNCTYPE : TYPENTRY ; ALREADYDECLARED : BOOLEAN ; PROCEDURE PARAMETERLIST ( PARAMCONTEXT : SETOFSYMBOLS ; VAR PARAMS : FORMALENTRY ) ; LABEL 9 ; VAR THISPARAM,NEXTPARAM,TYPEID : IDENTRY ; PARAMLIST,PARAMSOFONEKIND : IDLIST ; FORMALLIST,THISFORMAL,LASTFORMAL : FORMALENTRY ; THISTYPE : TYPENTRY ; VARMODE : BOOLEAN ; BEGIN (* PARAMETERLIST *) STARTLIST(PARAMLIST) ; CHECKNEXTORCONTEXT(PARAMCONTEXT + [LEFTPARENT], SUBBLOCKCONTEXT) ; FORMALLIST := NIL ; IF SYMBOL = LEFTPARENT THEN BEGIN IF ALREADYDECLARED THEN ERROR(119) ; INSYMBOL ; CHECKNEXTORCONTEXT(PARAMBEGSYS,SUBBLOCKCONTEXT + [RIGHTPARENT]) ; WHILE SYMBOL IN PARAMBEGSYS DO BEGIN STARTLIST(PARAMSOFONEKIND) ; CASE SYMBOL OF PROCSY : REPEAT INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN NEWID(THISPARAM,PROC) ; THISPARAM@.PFKIND := FORMAL ; SETPARAMETERADDRESSFOR(THISPARAM) ; APPENDID(PARAMSOFONEKIND,THISPARAM) ; INSYMBOL END ELSE ERROR(2) ; CHECKCONTEXT(SUBBLOCKCONTEXT + [COMMA, SEMICOLON,RIGHTPARENT]) UNTIL SYMBOL <> COMMA ; FUNCSY : BEGIN (* FORMAL FUNCTION PARAMETERS ARE CHAINED IN A SUB-LIST UNTIL TYPE CAN BE INSERTED*) REPEAT INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN NEWID(THISPARAM,FUNC) ; THISPARAM@.PFKIND := FORMAL ; APPENDID(PARAMSOFONEKIND,THISPARAM) ; INSYMBOL END ELSE ERROR(2) ; IF NOT(SYMBOL IN SUBBLOCKCONTEXT + [COMMA,COLON]) THEN BEGIN ERROR(7) ; SKIP(SUBBLOCKCONTEXT + [COMMA,SEMICOLON,RIGHTPARENT]) END UNTIL SYMBOL <> COMMA ; IF SYMBOL = COLON THEN BEGIN INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN SEARCHID([TYPES],TYPEID) ; THISTYPE := TYPEID@.IDTYPE ; IF THISTYPE <> NIL THEN IF NOT(THISTYPE@.FORM IN [SCALARS,SUBRANGES,POINTERS]) THEN BEGIN ERROR(120) ; THISTYPE := NIL END ; NEXTPARAM :=PARAMSOFONEKIND.FIRSTENTRY; WHILE NEXTPARAM <> NIL DO BEGIN SETPARAMETERADDRESSFOR(NEXTPARAM) ; NEXTPARAM@.IDTYPE := THISTYPE ; NEXTPARAM := NEXTPARAM@.NEXT END ; INSYMBOL END ELSE ERROR(2) ; CHECKCONTEXT(SUBBLOCKCONTEXT + [SEMICOLON, RIGHTPARENT]) END ELSE ERROR(5) END ; VARSY , IDENT : BEGIN IF SYMBOL = VARSY THEN BEGIN VARMODE := TRUE ; INSYMBOL END ELSE VARMODE := FALSE ; WHILE TRUE DO BEGIN IF SYMBOL = IDENT THEN BEGIN NEWID(THISPARAM,VARS) ; ISERIALISE(THISPARAM); (*FORMAL PARAMETER*) THISPARAM@.VARPARAM := VARMODE ; APPENDID(PARAMSOFONEKIND,THISPARAM) ; INSYMBOL END ELSE ERROR(2) ; IF NOT(SYMBOL IN SUBBLOCKCONTEXT + [COMMA,COLON]) THEN BEGIN ERROR(7) ; SKIP(SUBBLOCKCONTEXT + [COMMA,SEMICOLON,RIGHTPARENT]) END ; IF SYMBOL <> COMMA THEN GOTO 9 ; INSYMBOL END ; 9: ; IF SYMBOL = COLON THEN BEGIN THISTYPE := NIL ; INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN SEARCHID([TYPES],TYPEID) ; THISTYPE := TYPEID@.IDTYPE ; INSYMBOL END ELSE ERROR(2) ; IF THISTYPE <> NIL THEN IF NOT VARMODE AND (THISTYPE@.FORM = FILES) THEN ERROR(121) ; (* FILL IN TYPE OF FORMAL VARIABLES *) NEXTPARAM := PARAMSOFONEKIND.FIRSTENTRY ; WHILE NEXTPARAM <> NIL DO BEGIN NEXTPARAM@.IDTYPE := THISTYPE ; SETPARAMETERADDRESSFOR(NEXTPARAM) ; NEXTPARAM:= NEXTPARAM@.NEXT END ; CHECKCONTEXT(SUBBLOCKCONTEXT + [SEMICOLON, RIGHTPARENT]) END (* IF SYMBOL = COLON *) ELSE ERROR(5) END END (* CASE *) ; APPENDLISTS(PARAMLIST,PARAMSOFONEKIND) ; IF SYMBOL = SEMICOLON THEN BEGIN INSYMBOL ; CHECKNEXTORCONTEXT(SUBBLOCKCONTEXT+PARAMBEGSYS, [RIGHTPARENT]) END END (* WHILE *) ; IF SYMBOL = RIGHTPARENT THEN BEGIN INSYMBOL ; CHECKCONTEXT(PARAMCONTEXT + SUBBLOCKCONTEXT) END ELSE ERROR(4) ; THISPARAM := PARAMLIST.FIRSTENTRY ; LASTFORMAL := NIL ; WHILE THISPARAM <> NIL DO BEGIN NEW(THISFORMAL) ; WITH THISFORMAL@,THISPARAM@ DO BEGIN FORMALTYPE := IDTYPE ; THISFORMAL@.KLASS := KLASS ; IF KLASS = VARS THEN FORMALISVAR := VARPARAM ; THISFORMAL@.NEXT := NIL END ; IF LASTFORMAL = NIL THEN FORMALLIST := THISFORMAL ELSE LASTFORMAL@.NEXT := THISFORMAL ; LASTFORMAL := THISFORMAL ; THISPARAM := THISPARAM@.NEXT END END (* IF SYMBOL = LEFTPARENT *) ; PARAMS := FORMALLIST END (* PARAMETERLIST *) ; BEGIN (* PROCDECLARATION *) LSYMBOL := SYMBOL ; INSYMBOL ; ALREADYDECLARED := FALSE ; IF SYMBOL = IDENT THEN BEGIN SEARCHLOCALID(DISPLAY[TOP].IDSCOPE,PFID) ; IF PFID <> NIL THEN WITH PFID@ DO IF KLASS = PROC THEN ALREADYDECLARED := FORWARD AND (LSYMBOL = PROCSY) AND (PFKIND = ACTUAL) ELSE IF KLASS = FUNC THEN ALREADYDECLARED := FORWARD AND (LSYMBOL = FUNCSY) AND (PFKIND = ACTUAL) ; INSYMBOL END ELSE BEGIN ERROR(2) ; SPELLING := '???????? ' END ; IF NOT ALREADYDECLARED THEN BEGIN IF LSYMBOL = PROCSY THEN NEWID(PFID,PROC) ELSE NEWID(PFID,FUNC) ; ISERIALISE(PFID); (*PROC+FUNC BLOCK*) APPENDID(LOCALIDLIST,PFID) ; OPENSCOPE(BLOC) ; END ELSE RESTORESCOPE(PFID@.FORMALSCOPE) ; IF LSYMBOL = PROCSY THEN BEGIN PARAMETERLIST([SEMICOLON],FIRSTPARAM) ; IF NOT ALREADYDECLARED THEN PFID@.FORMALS := FIRSTPARAM ; END ELSE BEGIN PARAMETERLIST([SEMICOLON,COLON],FIRSTPARAM) ; IF NOT ALREADYDECLARED THEN PFID@.FORMALS := FIRSTPARAM ; IF SYMBOL = COLON THEN BEGIN INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN IF ALREADYDECLARED THEN ERROR(122) ; SEARCHID([TYPES],TYPEID) ; FUNCTYPE := TYPEID@.IDTYPE ; PFID@.IDTYPE := FUNCTYPE ; SETADDRESSFOR(PFID) ; IF FUNCTYPE <> NIL THEN IF NOT(FUNCTYPE@.FORM IN [SCALARS,SUBRANGES,POINTERS]) THEN BEGIN ERROR(120) ; PFID@.IDTYPE := NIL END ; INSYMBOL END ELSE BEGIN ERROR(2) ; SKIP(SUBBLOCKCONTEXT + [SEMICOLON]) END END ELSE IF NOT ALREADYDECLARED THEN ERROR(123) END ; ACCEPT(SEMICOLON) ; IF (SYMBOL = IDENT) AND ( (SPELLING = 'FORWARD ') OR (SPELLING = 'EXTERN ') ) THEN BEGIN IF ALREADYDECLARED THEN ERROR(161) ; WITH PFID@ DO IF SPELLING = 'FORWARD ' THEN BEGIN FORWARD := TRUE ; IF LOCALLYREQD[ENTRY] AND ( LEVEL = GLOBALLEVEL + 1 ) THEN PROCISENTRYSEQUENCE(NAME,CODEBODY) ; SAVESCOPE(FORMALSCOPE) END ELSE BEGIN FORWARD := FALSE ; PROCISEXTERNALSEQUENCE(NAME,CODEBODY) ; DISPOSESCOPE ; CLOSESCOPE END ; INSYMBOL ; ACCEPT(SEMICOLON) ; CHECKCONTEXT(SUBBLOCKCONTEXT) END ELSE BEGIN WITH PFID@ DO BEGIN FORWARD := FALSE ; IF NOT ALREADYDECLARED AND LOCALLYREQD[ENTRY] AND ( LEVEL = GLOBALLEVEL+1 ) THEN PROCISENTRYSEQUENCE(NAME,CODEBODY) END ; REPEAT BLOCK(SUBBLOCKCONTEXT,SEMICOLON,PFID) ; IF SYMBOL = SEMICOLON THEN BEGIN INSYMBOL ; IF NOT(SYMBOL IN [BEGINSY,PROCSY,FUNCSY]) THEN BEGIN ERROR(6) ; SKIP(SUBBLOCKCONTEXT) END END ELSE ERROR(14) UNTIL SYMBOL IN [BEGINSY,PROCSY,FUNCSY] ; FILESCOPE(PFID); DISPOSESCOPE ; CLOSESCOPE END END (* PROCDECLARATION *) ; PROCEDURE BODY ; LABEL 1 ; VAR ENDBODY : BOOLEAN ; PROCEDURE STATEMENT ( STATCONTEXT : SETOFSYMBOLS ) ; VAR LABELFOUND : LABELENTRY ; SUBSTATCONTEXT : SETOFSYMBOLS ; FIRSTID : IDENTRY ; VARPACKED : BOOLEAN ; FOLLOWINGSTATEMENT : CODESEQUENCE ; PROCEDURE EXPRESSION (EXPCONTEXT : SETOFSYMBOLS) ; FORWARD ; PROCEDURE SELECTOR (SELECTCONTEXT : SETOFSYMBOLS; VARIDENTRY : IDENTRY ) ; VAR LOCALTYPE : TYPENTRY ; LOCALID : IDENTRY ; LOWERBOUND,UPPERBOUND : INTEGER ; BEGIN (* SELECTOR *) VARPACKED := FALSE ; WITH VARIDENTRY@ DO BEGIN LOCALTYPE := IDTYPE ; IF LOCALTYPE <> NIL THEN CASE KLASS OF VARS : STACKREFERENCE(VARPARAM,VARADDRESS, IDTYPE@.REPRESENTATION) ; FIELD : BEGIN WITHREFERENCE(DISPLAY[LEVELFOUND]. WITHBASE,OFFSET, LOCALTYPE@. REPRESENTATION) ; VARPACKED := DISPLAY[LEVELFOUND].FIELDSPACKED END ; FUNC : IF PFDECKIND = STANDARD THEN ERROR(150) ELSE IF PFKIND = FORMAL THEN ERROR(151) ELSE STACKREFERENCE(FALSE,RESULT, IDTYPE@.REPRESENTATION) END (* CASE *) ELSE STACKREFERENCE(FALSE,DEFAULTADDRESS, DEFAULTREPRESENTATION) END (* WITH *) ; IF NOT (SYMBOL IN SELECTSYMBOLS + SELECTCONTEXT) THEN BEGIN ERROR(59) ; LOCALTYPE := NIL ; SKIP(SELECTSYMBOLS + SELECTCONTEXT) END ; WHILE SYMBOL IN SELECTSYMBOLS DO BEGIN CASE SYMBOL OF LEFTBRACKET : BEGIN REPEAT IF LOCALTYPE <> NIL THEN IF LOCALTYPE@.FORM <> ARRAYS THEN BEGIN ERROR(138) ; LOCALTYPE := NIL END ; INSYMBOL ; EXPRESSION(SELECTCONTEXT + [COMMA,RIGHTBRACKET]) ; IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM > SUBRANGES THEN ERROR(113) ; IF LOCALTYPE <> NIL THEN BEGIN WITH LOCALTYPE@ DO BEGIN IF COMPTYPES(INXTYPE,EXPTYPE) THEN BEGIN IF (INXTYPE <> NIL) AND (AELTYPE <> NIL) THEN BEGIN VARPACKED := LOCALTYPE@.PACKEDARRAY ; GETBOUNDS(INXTYPE, LOWERBOUND,UPPERBOUND); INDEXEDREFERENCE(VARPACKED ,LOWERBOUND,UPPERBOUND, AELTYPE@. REPRESENTATION) END END ELSE ERROR(139) END ; LOCALTYPE := LOCALTYPE@.AELTYPE END UNTIL SYMBOL<>COMMA ; ACCEPT(RIGHTBRACKET) END ; PERIOD : BEGIN IF LOCALTYPE <> NIL THEN IF LOCALTYPE@.FORM <> RECORDS THEN BEGIN ERROR(140) ; LOCALTYPE := NIL END ELSE VARPACKED := LOCALTYPE@.PACKEDRECORD; INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN IF LOCALTYPE <> NIL THEN BEGIN SEARCHLOCALID(LOCALTYPE@.FIELDSCOPE, LOCALID ) ; IF LOCALID = NIL THEN BEGIN ERROR(152) ; LOCALTYPE := NIL END ELSE WITH LOCALID@ DO BEGIN LOCALTYPE := IDTYPE ; IF LOCALTYPE <> NIL THEN FIELDREFERENCE(OFFSET, LOCALTYPE@.REPRESENTATION) END END ; INSYMBOL END ELSE ERROR(2) END ; ARROW : BEGIN IF LOCALTYPE <> NIL THEN BEGIN WITH LOCALTYPE@ DO BEGIN IF FORM = POINTERS THEN BEGIN LOCALTYPE := DOMAINTYPE ; VARPACKED := FALSE ; IF LOCALTYPE <> NIL THEN PNTERREFERENCE(LOCALTYPE@. REPRESENTATION) END ELSE IF FORM = FILES THEN BEGIN LOCALTYPE := FELTYPE ; VARPACKED := PACKEDFILE ; IF LOCALTYPE <> NIL THEN FILEREFERENCE(VARPACKED, TEXTFILE, LOCALTYPE@.REPRESENTATION) END ELSE ERROR(141) ; END END ; INSYMBOL END END ; IF NOT (SYMBOL IN SELECTSYMBOLS + SELECTCONTEXT) THEN BEGIN ERROR(6) ; LOCALTYPE := NIL ; SKIP(SELECTSYMBOLS + SELECTCONTEXT) END END ; VARTYPE := LOCALTYPE ; END (* SELECTOR *) ; PROCEDURE CALL ( CALLCONTEXT : SETOFSYMBOLS; PFID :IDENTRY); VAR WHICHPF : STDPROCFUNCS ; PROCEDURE VARIABLE ( VARCONTEXT : SETOFSYMBOLS ) ; VAR VARID : IDENTRY ; BEGIN IF SYMBOL = IDENT THEN BEGIN SEARCHID([VARS,FIELD],VARID) ; INSYMBOL END ELSE BEGIN ERROR(2) ; VARID := DEFAULTENTRY[VARS] END ; SELECTOR(VARCONTEXT,VARID) END (* VARIABLE *) ; PROCEDURE VARORCONST (VAR VCTYPE : TYPENTRY ; VCCONTEXT : SETOFSYMBOLS) ; VAR CONSTVAL : VALU ; VCID : IDENTRY ; BEGIN VCTYPE := NIL ; IF SYMBOL IN (CONSTBEGSYS - [IDENT]) THEN INCONSTANT (VCCONTEXT, VCTYPE, CONSTVAL) ELSE IF SYMBOL = IDENT THEN BEGIN SEARCHID ([CONSTS, VARS, FIELD], VCID) ; INSYMBOL ; WITH VCID@ DO IF KLASS = CONSTS THEN VCTYPE := IDTYPE ELSE BEGIN SELECTOR (VCCONTEXT, VCID) ; VCTYPE := VARTYPE ; END; END ELSE BEGIN ERROR (3) ; SKIP (VCCONTEXT) ; END ; END (* VARORCONST *) ; PROCEDURE VARIANTLIST (STARTTYPE : TYPENTRY ; VAR REPSELECTED : TYPEREPRESENTATION) ; VAR THISVARPART, THISVARIANT, TAGVALTYPE : TYPENTRY ; REPSOFAR : TYPEREPRESENTATION ; TAGVAL : VALU ; STILLVALID, FOUNDNONEMPTYVARIANT : BOOLEAN ; BEGIN REPSOFAR := DEFAULTREPRESENTATION ; IF STARTTYPE <> NIL THEN WITH STARTTYPE@ DO BEGIN REPSOFAR := REPRESENTATION ; IF FORM = RECORDS THEN BEGIN THISVARPART := VARPART ; STILLVALID := TRUE ; WHILE SYMBOL = COMMA DO BEGIN INSYMBOL ; INCONSTANT (CALLCONTEXT + [COMMA, RIGHTPARENT], TAGVALTYPE, TAGVAL) ; IF STRING (TAGVALTYPE) OR (TAGVALTYPE = REALTYPE) THEN BEGIN ERROR (159) ; STILLVALID := FALSE ; END ELSE IF STILLVALID THEN IF THISVARPART = NIL THEN BEGIN ERROR (158) ; STILLVALID := FALSE ; END ELSE IF COMPTYPES (TAGVALTYPE, THISVARPART@.TAGTYPE) THEN BEGIN THISVARIANT := THISVARPART@.FIRSTVARIANT ; FOUNDNONEMPTYVARIANT := FALSE ; WHILE (THISVARIANT <> NIL) AND NOT FOUNDNONEMPTYVARIANT DO WITH THISVARIANT@ DO IF VARIANTVALUE.IVAL1 = TAGVAL.IVAL1 THEN BEGIN THISVARPART := SUBVARPART ; REPSOFAR := REPRESENTATION ; FOUNDNONEMPTYVARIANT := TRUE ; END ELSE THISVARIANT := NEXTVARIANT ; IF NOT FOUNDNONEMPTYVARIANT THEN BEGIN REPSOFAR := THISVARPART@.REPRESENTATION ; THISVARPART := NIL ; END ; END (* COMPTYPES TRUE *) ELSE BEGIN ERROR (116) ; STILLVALID := FALSE ; END ; END (* WHILE SYMBOL = COMMA *) ; END (* IF FORM = RECORDS *) ; END (* WITH STARTTYPE@ *) ; REPSELECTED := REPSOFAR ; END (* VARIANTLIST *) ; PROCEDURE FILEPROCEDURES ; BEGIN VARIABLE(CALLCONTEXT + [RIGHTPARENT]) ; IF VARTYPE <> NIL THEN WITH VARTYPE@ DO IF FORM = FILES THEN BEGIN IF FELTYPE <> NIL THEN FILEOPERATION(WHICHPF,PACKEDFILE, TEXTFILE, FELTYPE@.REPRESENTATION) END ELSE ERROR(116) ; END (* FILEPROCEDURES *) ; PROCEDURE SELECTINPUT ; BEGIN IF INPUTFILE = NIL THEN ERROR(178) ELSE WITH INPUTFILE@ DO STACKREFERENCE(VARPARAM,VARADDRESS, IDTYPE@.REPRESENTATION) ; SELECT(READFILE) END ; PROCEDURE SELECTOUTPUT ; BEGIN IF OUTPUTFILE = NIL THEN ERROR(178) ELSE WITH OUTPUTFILE@ DO STACKREFERENCE(VARPARAM,VARADDRESS, IDTYPE@.REPRESENTATION) ; SELECT(WRITEFILE) END ; PROCEDURE READPROCEDURE ; LABEL 1 ; VAR FILEDETERMINED : BOOLEAN ; BEGIN FILEDETERMINED := FALSE ; WHILE TRUE DO BEGIN VARIABLE(CALLCONTEXT + [COMMA,RIGHTPARENT]) ; IF VARTYPE <> NIL THEN IF COMPTYPES(VARTYPE,TEXTTYPE) THEN IF FILEDETERMINED THEN ERROR(116) ELSE SELECT(READFILE) ELSE BEGIN IF NOT FILEDETERMINED THEN SELECTINPUT ; IF COMPTYPES(VARTYPE,CHARTYPE) THEN READOPERATION(CHARKIND) ELSE IF COMPTYPES(VARTYPE,REALTYPE) THEN READOPERATION(REALKIND) ELSE IF COMPTYPES(VARTYPE,INTTYPE) THEN READOPERATION(INTKIND) ELSE ERROR(116) END ; FILEDETERMINED := TRUE ; IF SYMBOL <> COMMA THEN GOTO 1 ; INSYMBOL END ; 1: IF WHICHPF = READLNP THEN BEGIN READLAYOUT END END (* READPROCEDURE *) ; PROCEDURE WRITEPROCEDURE ; LABEL 1 ; VAR EXP1TYPE : TYPENTRY ; WRITEKIND : OUTPUTKIND ; FORMAT : FORMATKIND ; FILEDETERMINED : BOOLEAN ; BEGIN FILEDETERMINED := FALSE ; WHILE TRUE DO BEGIN EXPRESSION(CALLCONTEXT + [COMMA,COLON,RIGHTPARENT]) ; EXP1TYPE := EXPTYPE ; IF EXPTYPE <> NIL THEN IF COMPTYPES(EXP1TYPE,TEXTTYPE) THEN IF FILEDETERMINED THEN ERROR(116) ELSE SELECT(WRITEFILE) ELSE BEGIN IF NOT FILEDETERMINED THEN SELECTOUTPUT ; IF COMPTYPES(EXP1TYPE,CHARTYPE) THEN WRITEKIND := CHARKIND ELSE IF COMPTYPES(EXP1TYPE,INTTYPE) THEN WRITEKIND := INTKIND ELSE IF COMPTYPES(EXP1TYPE,REALTYPE) THEN WRITEKIND := REALKIND ELSE IF COMPTYPES(EXP1TYPE,BOOLTYPE) THEN BEGIN FIXBOOLEANCHECK ; WRITEKIND := BOOLKIND END ELSE IF STRING(EXP1TYPE) THEN WRITEKIND := STRINGKIND ELSE BEGIN ERROR(116) ; WRITEKIND := DEFAULTKIND END ; IF SYMBOL = COLON THEN BEGIN INSYMBOL ; EXPRESSION(CALLCONTEXT + [COMMA,COLON,RIGHTPARENT]); IF NOT COMPTYPES(EXPTYPE,INTTYPE) THEN ERROR(116) ; IF SYMBOL = COLON THEN BEGIN INSYMBOL ; EXPRESSION(CALLCONTEXT + [COMMA,RIGHTPARENT]) ; IF NOT COMPTYPES(EXPTYPE,INTTYPE) THEN ERROR(116) ; IF NOT COMPTYPES(EXP1TYPE,REALTYPE) THEN ERROR(124) ; FORMAT := FIXED END ELSE FORMAT := FLOATING END ELSE FORMAT := DEFAULT ; CASE WRITEKIND OF INTKIND, REALKIND, CHARKIND, BOOLKIND : WRITESCALARS(WRITEKIND,FORMAT); STRINGKIND : WRITESTRING(CARDINALITY( EXP1TYPE@.INXTYPE),FORMAT); DEFAULTKIND : END END ; FILEDETERMINED := TRUE ; IF SYMBOL <> COMMA THEN GOTO 1 ; INSYMBOL END ; 1: IF WHICHPF = WRITELNP THEN BEGIN STACKCONSTANT(LINEFEED) ; WRITELAYOUT END END (* WRITEPROCEDURE *) ; PROCEDURE PAGEPROCEDURE ; BEGIN VARIABLE(CALLCONTEXT+[RIGHTPARENT]) ; IF COMPTYPES(VARTYPE,TEXTTYPE) THEN BEGIN SELECT(WRITEFILE) ; STACKCONSTANT(PAGETHROW) ; WRITELAYOUT END ELSE ERROR(116) END ; PROCEDURE STOREATPROCEDURE ; BEGIN EXPRESSION (CALLCONTEXT + [COMMA, RIGHTPARENT]) ; IF NOT COMPTYPES (EXPTYPE, INTTYPE) THEN ERROR (116) ; ACCEPT (COMMA) ; EXPRESSION (CALLCONTEXT + [RIGHTPARENT]) ; IF NOT COMPTYPES (EXPTYPE, INTTYPE) THEN ERROR (116) ; VSSTOREOPERATION (WHICHPF) ; END (* STOREATPROCEDURE *) ; PROCEDURE PACKPROCEDURE ; VAR LOWERBOUND,UPPERBOUND : INTEGER ; FIRSTINXTYPE,FIRSTELTYPE : TYPENTRY ; BEGIN VARIABLE(CALLCONTEXT + [COMMA,RIGHTPARENT]) ; FIRSTINXTYPE := NIL ; FIRSTELTYPE := NIL ; IF VARTYPE <> NIL THEN WITH VARTYPE@ DO IF FORM = ARRAYS THEN BEGIN IF PACKEDARRAY THEN ERROR(116) ; FIRSTINXTYPE := INXTYPE ; FIRSTELTYPE := AELTYPE END ELSE ERROR(116) ; ACCEPT(COMMA) ; EXPRESSION(CALLCONTEXT + [COMMA,RIGHTPARENT]) ; IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM > SUBRANGES THEN ERROR(116) ELSE IF NOT COMPTYPES(EXPTYPE,FIRSTINXTYPE) THEN ERROR(116) ; ACCEPT(COMMA) ; VARIABLE(CALLCONTEXT + [RIGHTPARENT]) ; IF VARTYPE <> NIL THEN WITH VARTYPE@ DO IF FORM = ARRAYS THEN BEGIN IF NOT PACKEDARRAY THEN ERROR(116) ; IF NOT COMPTYPES(AELTYPE,FIRSTELTYPE) OR NOT COMPTYPES(INXTYPE,FIRSTINXTYPE) THEN ERROR(116) ELSE IF (FIRSTELTYPE <> NIL) AND (AELTYPE <> NIL) THEN BEGIN GETBOUNDS(FIRSTINXTYPE,LOWERBOUND, UPPERBOUND) ; PACKOPERATION(PACKP,LOWERBOUND, UPPERBOUND, FIRSTELTYPE@.REPRESENTATION, AELTYPE@.REPRESENTATION , CARDINALITY(INXTYPE) ) END END ELSE ERROR(116) ; END (* PACKPROCEDURE *) ; PROCEDURE UNPACKPROCEDURE ; VAR LOWERBOUND,UPPERBOUND : INTEGER ; SECONDINXTYPE,SECONDELTYPE, FIRSTINXTYPE,FIRSTELTYPE : TYPENTRY ; BEGIN VARIABLE(CALLCONTEXT + [COMMA,RIGHTPARENT]) ; FIRSTINXTYPE := NIL ; FIRSTELTYPE := NIL ; IF VARTYPE <> NIL THEN WITH VARTYPE@ DO IF FORM = ARRAYS THEN BEGIN IF NOT PACKEDARRAY THEN ERROR(116) ; FIRSTINXTYPE := INXTYPE ; FIRSTELTYPE := AELTYPE END ELSE ERROR(116) ; ACCEPT(COMMA) ; VARIABLE(CALLCONTEXT + [COMMA,RIGHTPARENT]) ; SECONDINXTYPE := NIL ; SECONDELTYPE := NIL ; IF VARTYPE <> NIL THEN WITH VARTYPE@ DO IF FORM = ARRAYS THEN BEGIN IF PACKEDARRAY THEN ERROR(116) ; IF NOT COMPTYPES(AELTYPE,FIRSTELTYPE) OR NOT COMPTYPES(INXTYPE,FIRSTINXTYPE) THEN ERROR(116) ELSE BEGIN SECONDINXTYPE := INXTYPE ; SECONDELTYPE := AELTYPE END END ELSE ERROR(116) ; ACCEPT(COMMA) ; EXPRESSION(CALLCONTEXT + [RIGHTPARENT]) ; IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM > SUBRANGES THEN ERROR(116) ELSE IF NOT COMPTYPES(EXPTYPE,SECONDINXTYPE) THEN ERROR(116) ; IF (FIRSTELTYPE<>NIL) AND (SECONDELTYPE<>NIL) THEN BEGIN GETBOUNDS(SECONDINXTYPE,LOWERBOUND,UPPERBOUND) ; PACKOPERATION(UNPACKP, LOWERBOUND,UPPERBOUND, SECONDELTYPE@.REPRESENTATION, FIRSTELTYPE@.REPRESENTATION, CARDINALITY(FIRSTINXTYPE) ) END END (* UNPACKPROCEDURE *) ; PROCEDURE HEAPPROCEDURE ; VAR REPNEEDED : TYPEREPRESENTATION ; BEGIN VARIABLE (CALLCONTEXT + [COMMA, RIGHTPARENT]) ; IF VARTYPE = NIL THEN REPNEEDED := DEFAULTREPRESENTATION ELSE WITH VARTYPE@ DO IF FORM <> POINTERS THEN BEGIN ERROR (116) ; REPNEEDED := DEFAULTREPRESENTATION ; END ELSE VARIANTLIST (DOMAINTYPE, REPNEEDED) ; HEAPOPERATION (WHICHPF, REPNEEDED) ; END (* HEAPPROCEDURE *) ; PROCEDURE DATEANDTIMEPROCEDURE ; BEGIN VARIABLE(CALLCONTEXT + [COMMA,RIGHTPARENT]); IF NOT COMPTYPES(VARTYPE,ALFA8TYPE) THEN ERROR(116) ; ACCEPT(COMMA); VARIABLE(CALLCONTEXT + [RIGHTPARENT]); IF NOT COMPTYPES(VARTYPE,ALFA8TYPE) THEN ERROR(116) ; DATEANDTIMEOPERATION END (* DATEANDTIMEPROCEDURE *) ; PROCEDURE HALTPROCEDURE ; BEGIN EXPRESSION(CALLCONTEXT + [RIGHTPARENT]) ; IF NOT STRING(EXPTYPE) THEN ERROR(116) ; CLOSEFILES(PERMAFILES) ; IF (EXPTYPE<>NIL) AND STRING(EXPTYPE) THEN HALTOPERATION(CARDINALITY(EXPTYPE@.INXTYPE)) END (* HALTPROCEDURE *) ; PROCEDURE ITEMATFUNCTION ; BEGIN EXPRESSION (CALLCONTEXT + [RIGHTPARENT]) ; IF NOT COMPTYPES (EXPTYPE, INTTYPE) THEN ERROR (125) ; VSFETCHOPERATION (WHICHPF) ; IF WHICHPF = BYTEATF THEN EXPTYPE := BYTETYPE ELSE EXPTYPE := INTTYPE ; END (* ITEMATFUNCTION *) ; PROCEDURE BYTESIZEOFFUNCTION ; VAR ITEMTYPE : TYPENTRY ; REPSPECIFIED : TYPEREPRESENTATION ; BEGIN SUSPENDCODEGENERATION ; VARORCONST (ITEMTYPE, CALLCONTEXT + [COMMA, RIGHTPARENT]) ; REINSTATECODEGENERATION ; VARIANTLIST (ITEMTYPE, REPSPECIFIED) ; BYTESIZEVALUEFOR (REPSPECIFIED) ; EXPTYPE := INTTYPE ; END (* BYTESIZEOFFUNCTION *) ; PROCEDURE CALLUSERDEFINED ; VAR PFPARAMID : IDENTRY ; FORMPARAM,ITSFORMPARAM : FORMALENTRY ; FORMTYPE : TYPENTRY ; CALLPFKIND : IDKIND ; LEVELCALLED : DISPRANGE ; REPREQUIRED : TYPEREPRESENTATION ; FUNCTION PROCORFUNCFORMAL : BOOLEAN ; BEGIN IF FORMPARAM <> NIL THEN PROCORFUNCFORMAL := FORMPARAM@.KLASS IN [PROC,FUNC] ELSE PROCORFUNCFORMAL := FALSE END (* PROCORFUNCFORMAL *) ; FUNCTION VARFORMAL : BOOLEAN ; BEGIN IF FORMPARAM <> NIL THEN VARFORMAL := FORMPARAM@.FORMALISVAR ELSE VARFORMAL := FALSE END (* VARFORMAL *) ; FUNCTION FORMALTYPEDEF : BOOLEAN ; BEGIN IF FORMPARAM <> NIL THEN FORMALTYPEDEF := FORMPARAM@.FORMALTYPE <> NIL ELSE FORMALTYPEDEF := FALSE END (* FORMALTYPEDEF *) ; BEGIN CALLPFKIND := PFID@.PFKIND ; IF CALLPFKIND = ACTUAL THEN BEGIN FORMPARAM := PFID@.FORMALS ; LEVELCALLED := LEVELFOUND ; OPENPARAMETERLIST(LEVELFOUND,PFID@.KLASS) END ELSE BEGIN FORMPARAM := NIL ; WITH PFID@ DO OPENFORMALPARAMETERLIST(FADDRESS,KLASS) END ; IF SYMBOL = LEFTPARENT THEN BEGIN REPEAT (* FOR EACH ACTUAL PARAMETER *) IF CALLPFKIND = ACTUAL THEN (* MUST BE CORRESPONDING FORMAL *) IF FORMPARAM = NIL THEN ERROR(126) ; INSYMBOL ; IF PROCORFUNCFORMAL THEN (* FORMAL IS PROCEDURE OR FUNCTION *) BEGIN IF SYMBOL <> IDENT THEN BEGIN ERROR(2) ; SKIP(CALLCONTEXT + [COMMA,RIGHTPARENT]) END ELSE BEGIN IF FORMPARAM@.KLASS = PROC THEN SEARCHID([PROC],PFPARAMID) ELSE BEGIN SEARCHID([FUNC],PFPARAMID) ; IF NOT COMPTYPES(PFPARAMID@.IDTYPE, FORMPARAM@.FORMALTYPE) THEN ERROR(128) END ; IF PFPARAMID@.PFDECKIND = STANDARD THEN ERROR(164) ELSE IF PFPARAMID@.PFKIND = ACTUAL THEN BEGIN (* ENSURE THAT A PROC/FUNC USED AS PARAMETER TO AN OTHER PROC/ FUNC HAS VALUE PARAMS ONLY *) ITSFORMPARAM:=PFPARAMID@.FORMALS ; WHILE ITSFORMPARAM <> NIL DO WITH ITSFORMPARAM@ DO BEGIN IF KLASS <> VARS THEN ERROR(170) ELSE IF FORMALISVAR THEN ERROR(170) ; ITSFORMPARAM := NEXT END ; PASSACTUAL(LEVELFOUND, PFPARAMID@.CODEBODY) END ELSE PASSFORMAL(PFPARAMID@. FADDRESS) END (* SYMBOL = IDENT *) ; INSYMBOL ; CHECKCONTEXT(CALLCONTEXT + [COMMA, RIGHTPARENT]) END (* FORMAL PROCEDURE OR FUNCTION *) ELSE IF VARFORMAL THEN (* VARIABLE PARAMETER *) BEGIN VARIABLE(CALLCONTEXT + [COMMA,RIGHTPARENT]); (* ACTUAL VARIABLE PARAMETER CANNOT BE A COMPONENT OF A PACKED STRUCTURE *) IF VARPACKED THEN ERROR(173) ; IF NOT COMPTYPES(VARTYPE, FORMPARAM@.FORMALTYPE) THEN ERROR(142) ; PASSREFERENCE END ELSE (* VALUE PARAMETER *) BEGIN EXPRESSION(CALLCONTEXT + [COMMA,RIGHTPARENT]); IF (CALLPFKIND = ACTUAL) AND (FORMPARAM <> NIL) THEN BEGIN FORMTYPE := FORMPARAM@.FORMALTYPE ; IF NOT COMPTYPES(EXPTYPE,FORMTYPE) THEN IF COMPTYPES(FORMTYPE,REALTYPE)AND COMPTYPES(EXPTYPE,INTTYPE) THEN BEGIN FLOATINTEGER(TOPOFSTACK) ; EXPTYPE := REALTYPE END ELSE ERROR(142) END ; IF FORMALTYPEDEF THEN REPREQUIRED := FORMPARAM@. FORMALTYPE@.REPRESENTATION ELSE IF EXPTYPE <> NIL THEN REPREQUIRED := EXPTYPE@. REPRESENTATION ELSE REPREQUIRED := DEFAULTREPRESENTATION ; PASSVALUE(REPREQUIRED) END (* VALUE PARAMETER *) ; IF FORMPARAM <> NIL THEN FORMPARAM := FORMPARAM@.NEXT UNTIL SYMBOL <> COMMA ; ACCEPT(RIGHTPARENT) END (* PARAMETER LIST *) ; IF CALLPFKIND = ACTUAL THEN BEGIN CLOSEPARAMETERLIST ; IF FORMPARAM <> NIL THEN ERROR(126) ; CALLACTUAL(LEVELCALLED,PFID@.CODEBODY) END ELSE BEGIN CLOSEFMALPARAMETERLIST ; CALLFORMAL(PFID@.FADDRESS) END ; IF PFID@.KLASS = FUNC THEN BEGIN IF PFID@.IDTYPE <> NIL THEN TAKERESULT(PFID@.IDTYPE@.REPRESENTATION) ; EXPTYPE := PFID@.IDTYPE END END (* CALLUSERDEFINED *) ; BEGIN (* CALL *) IF PFID@.PFDECKIND = STANDARD THEN BEGIN WHICHPF := PFID@.PFINDEX ; IF (SYMBOL=LEFTPARENT) AND (WHICHPF<>CLOCKF) THEN BEGIN INSYMBOL ; IF PFID@.KLASS = PROC THEN (* STANDARD PROCEDURES *) CASE WHICHPF OF GETP,PUTP,RESETP,REWRITEP: FILEPROCEDURES ; READLNP,READP : READPROCEDURE ; WRITELNP,WRITEP : WRITEPROCEDURE ; NEWP,DISPOSEP: HEAPPROCEDURE ; DATEANDTIMEP : DATEANDTIMEPROCEDURE ; HALTP : HALTPROCEDURE ; PAGEP : PAGEPROCEDURE ; STOREBYTEATP, STOREWORDATP : STOREATPROCEDURE ; PACKP : PACKPROCEDURE ; UNPACKP : UNPACKPROCEDURE END ELSE BEGIN (* STANDARD FUNCTIONS *) IF WHICHPF IN [ ADDRESSF,ORF ,ANDF , NEQF ,USHF ,ROTF , ISHF ] THEN IF WHICHPF = ADDRESSF THEN BEGIN VARIABLE(CALLCONTEXT+[RIGHTPARENT]) ; MONADICFUNCTION(ADDRESSF) ; EXPTYPE := INTTYPE END ELSE BEGIN EXPRESSION (CALLCONTEXT+[COMMA,RIGHTPARENT]) ; IF NOT COMPTYPES(EXPTYPE,INTTYPE) THEN ERROR(125) ; ACCEPT(COMMA) ; EXPRESSION (CALLCONTEXT+[RIGHTPARENT]) ; IF NOT COMPTYPES(EXPTYPE,INTTYPE) THEN ERROR(125) ; DYADICFUNCTION(WHICHPF) ; EXPTYPE := INTTYPE END ELSE IF WHICHPF IN [BYTEATF, WORDATF] THEN ITEMATFUNCTION ELSE IF WHICHPF = BYTESIZEOFF THEN BYTESIZEOFFUNCTION ELSE BEGIN EXPRESSION(CALLCONTEXT + [RIGHTPARENT]) ; CASE WHICHPF OF ABSF, SQRF: IF COMPTYPES(EXPTYPE,INTTYPE) THEN INTEGERFUNCTION(WHICHPF) ELSE IF COMPTYPES(EXPTYPE,REALTYPE) THEN REALFUNCTION(WHICHPF) ELSE BEGIN ERROR(125) ; EXPTYPE := INTTYPE END ; ODDF: BEGIN IF NOT COMPTYPES(EXPTYPE,INTTYPE) THEN ERROR(125) ; INTEGERFUNCTION(ODDF) ; EXPTYPE := BOOLTYPE END ; SUCCF, PREDF: BEGIN IF EXPTYPE <> NIL THEN IF NOT ( EXPTYPE@.FORM IN [SCALARS,SUBRANGES]) OR COMPTYPES(EXPTYPE,REALTYPE) THEN BEGIN ERROR(125) ; EXPTYPE := NIL END ; INTEGERFUNCTION(WHICHPF) END ; ORDF: BEGIN INTEGERFUNCTION(ORDF) ; EXPTYPE := INTTYPE END ; CHRF: BEGIN IF NOT COMPTYPES(EXPTYPE,INTTYPE) THEN ERROR(125) ; INTEGERFUNCTION(CHRF) ; EXPTYPE := CHARTYPE END ; TRUNCF, ROUNDF: BEGIN IF NOT COMPTYPES(EXPTYPE,REALTYPE) THEN ERROR(125) ; REALFUNCTION(WHICHPF) ; EXPTYPE := INTTYPE END ; SINF, COSF, EXPF, LNF, SQRTF, ARCTANF: BEGIN IF COMPTYPES(EXPTYPE,INTTYPE) THEN FLOATINTEGER(TOPOFSTACK) ELSE IF NOT COMPTYPES(EXPTYPE,REALTYPE) THEN ERROR(125) ; REALFUNCTION(WHICHPF) ; EXPTYPE := REALTYPE END ; EOFF: BEGIN IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM = FILES THEN FILEFUNCTION(EOFF) ELSE ERROR(125) ; EXPTYPE := BOOLTYPE END ; EOLNF : BEGIN IF COMPTYPES(EXPTYPE,TEXTTYPE) THEN FILEFUNCTION(EOLNF) ELSE ERROR(125) ; EXPTYPE := BOOLTYPE END ; END (* CASE *) END END (* STANDARD FUNCTIONS *) ; ACCEPT(RIGHTPARENT) END ELSE BEGIN IF WHICHPF IN [READLNP,WRITELNP,PAGEP,EOLNF,EOFF] THEN CASE WHICHPF OF READLNP : BEGIN SELECTINPUT ; READLAYOUT ; END ; WRITELNP : BEGIN SELECTOUTPUT ; STACKCONSTANT(LINEFEED) ; WRITELAYOUT END ; PAGEP : BEGIN SELECTOUTPUT ; STACKCONSTANT(PAGETHROW) ; WRITELAYOUT END ; EOLNF, EOFF : BEGIN IF INPUTFILE = NIL THEN ERROR(178) ELSE WITH INPUTFILE@ DO STACKREFERENCE(VARPARAM,VARADDRESS, IDTYPE@.REPRESENTATION) ; FILEFUNCTION(WHICHPF) ; EXPTYPE := BOOLTYPE END END (* CASE*) ELSE IF WHICHPF = CLOCKF THEN BEGIN CLOCKOPERATION; EXPTYPE := INTTYPE END ELSE ERROR(9) END END (* STANDARD PROCEDURE OR FUNCTION *) ELSE CALLUSERDEFINED END (* CALL *) ; PROCEDURE EXPRESSION ; VAR LEXPTYPE : TYPENTRY ; EXPOPERATOR : OPTYPE ; PROCEDURE SIMPLEEXPRESSION (SIMEXPCONTEXT:SETOFSYMBOLS) ; VAR SEXPTYPE : TYPENTRY ; SEXPOPERATOR : OPTYPE ; SIGNED : BOOLEAN ; PROCEDURE PLUSMINUSMUL ( FIRSTOPTYPE : TYPENTRY ; OPERATOR : OPTYPE ) ; FUNCTION FORMISSET : BOOLEAN ; BEGIN IF FIRSTOPTYPE <> NIL THEN FORMISSET := FIRSTOPTYPE@.FORM = SETS ELSE IF EXPTYPE <> NIL THEN FORMISSET := EXPTYPE@.FORM = SETS ELSE FORMISSET := FALSE END ; BEGIN IF FORMISSET THEN BEGIN IF COMPTYPES(FIRSTOPTYPE,EXPTYPE) THEN BEGIN IF EXPTYPE = NIL THEN EXPTYPE := FIRSTOPTYPE END ELSE BEGIN ERROR(137) ; EXPTYPE := UNISETTYPE END ; BINARYSETOPERATION(OPERATOR) END ELSE IF COMPTYPES(FIRSTOPTYPE,INTTYPE) AND COMPTYPES(EXPTYPE,INTTYPE) THEN BEGIN EXPTYPE := INTTYPE ; BINARYINTEGEROPERATION(OPERATOR) END ELSE BEGIN IF COMPTYPES(FIRSTOPTYPE,INTTYPE) THEN BEGIN FIRSTOPTYPE := REALTYPE ; FLOATINTEGER(NEXTTOTOP) END ; IF COMPTYPES(EXPTYPE,INTTYPE) THEN BEGIN EXPTYPE := REALTYPE ; FLOATINTEGER(TOPOFSTACK) END ; IF COMPTYPES(FIRSTOPTYPE,REALTYPE) AND COMPTYPES(EXPTYPE,REALTYPE) THEN BEGIN EXPTYPE := REALTYPE END ELSE BEGIN ERROR(134) ; EXPTYPE := INTTYPE END ; BINARYREALOPERATION(OPERATOR) END END (* PLUSMINUSMUL *) ; PROCEDURE TERM (TERMCONTEXT : SETOFSYMBOLS) ; VAR TERMTYPE : TYPENTRY ; LOPERATOR : OPTYPE ; PROCEDURE FACTOR (FACTORCONTEXT : SETOFSYMBOLS) ; LABEL 1 ; VAR LFACID : IDENTRY ; LFACTYPE,COMPEXPTYPE : TYPENTRY ; BEGIN IF NOT ( SYMBOL IN FACBEGSYS) THEN BEGIN ERROR(58) ; SKIP(FACTORCONTEXT + FACBEGSYS) ; EXPTYPE := NIL END ; REPEAT IF SYMBOL IN FACBEGSYS THEN BEGIN CASE SYMBOL OF IDENT : BEGIN SEARCHID([CONSTS,VARS,FIELD,FUNC] ,LFACID ) ; INSYMBOL ; CASE LFACID@.KLASS OF CONSTS : WITH LFACID@ DO BEGIN STACKCONSTANT(VALUES) ; EXPTYPE := IDTYPE ; END ; VARS, FIELD : BEGIN SELECTOR (FACTORCONTEXT, LFACID) ; EXPTYPE := VARTYPE END ; FUNC : CALL(FACTORCONTEXT,LFACID) END END ; INTCONST : BEGIN STACKCONSTANT(CONSTANT) ; EXPTYPE := INTTYPE ; INSYMBOL END ; REALCONST : BEGIN STACKCONSTANT(CONSTANT) ; EXPTYPE := REALTYPE ; INSYMBOL END ; CHARCONST : BEGIN STACKCONSTANT(CONSTANT) ; EXPTYPE := CHARTYPE ; INSYMBOL END ; STRINGCONST : BEGIN STACKCONSTANT(CONSTANT) ; STRINGTYPE(EXPTYPE) ; INSYMBOL END ; LEFTPARENT : BEGIN INSYMBOL ; EXPRESSION(FACTORCONTEXT + [RIGHTPARENT]) ; ACCEPT(RIGHTPARENT) END ; NOTSY : BEGIN INSYMBOL ; FACTOR(FACTORCONTEXT) ; IF COMPTYPES(EXPTYPE,BOOLTYPE) THEN NEGATEBOOLEAN ELSE BEGIN ERROR(135) ; EXPTYPE := NIL END END ; LEFTBRACKET : BEGIN INSYMBOL ; LFACTYPE := NIL ; COMPEXPTYPE := NIL ; STACKCONSTANT(EMPTYSET) ; IF SYMBOL=RIGHTBRACKET THEN BEGIN EXPTYPE := UNISETTYPE ; INSYMBOL END ELSE BEGIN WHILE TRUE DO BEGIN EXPRESSION(FACTORCONTEXT + [COMMA,DOTDOTSY,RIGHTBRACKET]); IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM > SUBRANGES THEN BEGIN ERROR(136) ; EXPTYPE := NIL END ELSE IF COMPEXPTYPE =NIL THEN BEGIN COMPEXPTYPE := EXPTYPE ; NEW(LFACTYPE, SETS) ; WITH LFACTYPE@ DO BEGIN FORM := SETS ; PACKEDSET := FALSE ; BASETYPE := COMPEXPTYPE END ; SETREPRESENTATIONFOR (LFACTYPE) END ELSE IF NOT(COMPTYPES( COMPEXPTYPE, EXPTYPE )) THEN ERROR(137) ; IF SYMBOL=DOTDOTSY THEN BEGIN TERMTYPE := EXPTYPE ; INSYMBOL ; EXPRESSION(FACTORCONTEXT + [COMMA,RIGHTBRACKET]) ; IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM >SUBRANGES THEN BEGIN ERROR(136) ; EXPTYPE := NIL END ELSE IF NOT(COMPTYPES( COMPEXPTYPE, EXPTYPE )) THEN ERROR(137) ; IF COMPEXPTYPE <> NIL THEN RANGESET(LFACTYPE@. REPRESENTATION) END ELSE BEGIN IF COMPEXPTYPE <> NIL THEN SINGLETONSET( LFACTYPE@. REPRESENTATION) END ; BINARYSETOPERATION(PLUS) ; IF SYMBOL<>COMMA THEN GOTO 1 ; INSYMBOL END ; 1: ; ACCEPT(RIGHTBRACKET) ; EXPTYPE := LFACTYPE END END END ; CHECKNEXTORCONTEXT(FACTORCONTEXT, FACBEGSYS) END UNTIL SYMBOL IN FACTORCONTEXT END (* FACTOR *) ; BEGIN (* TERM *) FACTOR(TERMCONTEXT + [MULOP]) ; IF (SYMBOL=MULOP) AND (OPERATOR=ANDOP) THEN BINARYBOOLEANOPERATION(ANDOP,TRUE) ; WHILE SYMBOL=MULOP DO BEGIN TERMTYPE := EXPTYPE ; LOPERATOR := OPERATOR; INSYMBOL ; FACTOR(TERMCONTEXT + [MULOP]) ; CASE LOPERATOR OF MUL : PLUSMINUSMUL(TERMTYPE,MUL) ; RDIV : BEGIN IF COMPTYPES(TERMTYPE,INTTYPE) THEN BEGIN FLOATINTEGER(NEXTTOTOP) ; TERMTYPE := REALTYPE ; END ; IF COMPTYPES(EXPTYPE,INTTYPE) THEN BEGIN FLOATINTEGER(TOPOFSTACK) ; EXPTYPE := REALTYPE ; END ; IF COMPTYPES(TERMTYPE,REALTYPE) AND COMPTYPES(EXPTYPE,REALTYPE) THEN ELSE ERROR(134) ; EXPTYPE := REALTYPE ; BINARYREALOPERATION(RDIV) END ; IDIV , IMOD : BEGIN IF COMPTYPES(TERMTYPE,INTTYPE) AND COMPTYPES(EXPTYPE,INTTYPE) THEN ELSE ERROR(134) ; BINARYINTEGEROPERATION(LOPERATOR) ; EXPTYPE := INTTYPE END ; ANDOP : BEGIN IF COMPTYPES(TERMTYPE,BOOLTYPE) AND COMPTYPES(EXPTYPE,BOOLTYPE) THEN ELSE ERROR(134) ; BINARYBOOLEANOPERATION(ANDOP,FALSE) ; EXPTYPE := BOOLTYPE END END (* CASE *) END END (* TERM *) ; BEGIN (* SIMPLE EXPRESSION *) SIGNED := FALSE ; IF (SYMBOL=ADDOP)AND(OPERATOR IN [PLUS,MINUS]) THEN BEGIN SIGNED := OPERATOR=MINUS ; INSYMBOL END ; TERM(SIMEXPCONTEXT + [ADDOP]) ; IF SIGNED THEN IF COMPTYPES(EXPTYPE,INTTYPE) THEN NEGATEINTEGER ELSE IF COMPTYPES(EXPTYPE,REALTYPE) THEN NEGATEREAL ELSE BEGIN ERROR(134) ; EXPTYPE := NIL END ; IF (SYMBOL = ADDOP) AND (OPERATOR = OROP) THEN BINARYBOOLEANOPERATION(OROP,TRUE) ; WHILE SYMBOL=ADDOP DO BEGIN SEXPTYPE := EXPTYPE ; SEXPOPERATOR := OPERATOR ; INSYMBOL ; TERM(SIMEXPCONTEXT + [ADDOP]) ; CASE SEXPOPERATOR OF PLUS : PLUSMINUSMUL(SEXPTYPE,PLUS) ; MINUS : PLUSMINUSMUL(SEXPTYPE,MINUS) ; OROP : BEGIN IF COMPTYPES(SEXPTYPE,BOOLTYPE) AND COMPTYPES(EXPTYPE,BOOLTYPE) THEN ELSE ERROR(134) ; BINARYBOOLEANOPERATION(OROP,FALSE) ; EXPTYPE := BOOLTYPE END END (* CASE *) END END (* SIMPLE EXPRESSION *) ; BEGIN (* EXPRESSION *) SIMPLEEXPRESSION(EXPCONTEXT + [RELOP]) ; IF SYMBOL=RELOP THEN BEGIN FIXBOOLEANCHECK ; LEXPTYPE := EXPTYPE ; EXPOPERATOR := OPERATOR ; INSYMBOL ; SIMPLEEXPRESSION(EXPCONTEXT) ; IF EXPOPERATOR = INOP THEN BEGIN IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM = SETS THEN IF COMPTYPES(LEXPTYPE,EXPTYPE@.BASETYPE) THEN SETCOMPARISON(INOP) ELSE ERROR(129) ELSE ERROR(130) END ELSE IF LEXPTYPE <> NIL THEN BEGIN IF NOT(COMPTYPES(LEXPTYPE,EXPTYPE)) THEN IF COMPTYPES(LEXPTYPE,INTTYPE) THEN BEGIN FLOATINTEGER(NEXTTOTOP) ; LEXPTYPE := REALTYPE END ELSE IF COMPTYPES(EXPTYPE,INTTYPE) THEN BEGIN FLOATINTEGER(TOPOFSTACK) ; EXPTYPE := REALTYPE END ; IF COMPTYPES(LEXPTYPE,EXPTYPE) THEN BEGIN CASE LEXPTYPE@.FORM OF SCALARS, SUBRANGES : IF COMPTYPES(LEXPTYPE,REALTYPE) THEN REALCOMPARISON(EXPOPERATOR) ELSE INTEGERCOMPARISON(EXPOPERATOR) ; POINTERS : IF EXPOPERATOR IN [LTOP,LEOP,GTOP, GEOP] THEN ERROR(131) ELSE INTEGERCOMPARISON(EXPOPERATOR) ; SETS : IF EXPOPERATOR IN [LTOP,GTOP] THEN ERROR(132) ELSE SETCOMPARISON(EXPOPERATOR) ; ARRAYS : IF NOT(STRING(EXPTYPE)) THEN ERROR(133) ELSE STRNGCOMPARISON( CARDINALITY( EXPTYPE@.INXTYPE), EXPOPERATOR) ; RECORDS, FILES : ERROR(133) END ; END ELSE ERROR(129) END ; EXPTYPE := BOOLTYPE ; END END (* EXPRESSION *) ; PROCEDURE ASSIGNMENT ( VARID : IDENTRY ) ; VAR LVARTYPE : TYPENTRY ; BEGIN (* ASSIGNMENT *) SELECTOR(SUBSTATCONTEXT + [BECOMES],VARID) ; LVARTYPE := VARTYPE ; IF SYMBOL = BECOMES THEN BEGIN INSYMBOL ; EXPRESSION(SUBSTATCONTEXT) ; IF (LVARTYPE<>NIL) AND (EXPTYPE<>NIL) THEN BEGIN IF COMPTYPES(LVARTYPE,REALTYPE) AND COMPTYPES(EXPTYPE,INTTYPE) THEN BEGIN FLOATINTEGER(TOPOFSTACK) ; EXPTYPE := REALTYPE END ; IF COMPTYPES(LVARTYPE,EXPTYPE) THEN CASE LVARTYPE@.FORM OF SCALARS , SUBRANGES , POINTERS , SETS , ARRAYS , RECORDS : ASSIGN ; FILES : ERROR(146) END ELSE ERROR(129) END END ELSE ERROR(51) END (* ASSIGNMENT *) ; PROCEDURE COMPOUNDSTATEMENT ; BEGIN (* COMPOUNDSTATEMENT *) REPEAT INSYMBOL ; STATEMENT(STATCONTEXT + [SEMICOLON,ENDSY]) UNTIL SYMBOL <> SEMICOLON ; DECREMENTNESTINGLEVEL; ACCEPT(ENDSY) END (* COMPOUNDSTATEMENT *) ; PROCEDURE IFSTATEMENT ; VAR FORFALSEACTION : CODESEQUENCE ; BEGIN (* IFSTATEMENT *) INSYMBOL ; EXPRESSION(SUBSTATCONTEXT + [THENSY]) ; IF NOT COMPTYPES(EXPTYPE,BOOLTYPE) THEN ERROR(144) ; EXPECTCODESEQUENCE(FORFALSEACTION) ; JUMPONFALSE(FORFALSEACTION) ; ACCEPT(THENSY) ; STATEMENT(STATCONTEXT + [ELSESY]) ; IF SYMBOL = ELSESY THEN BEGIN JUMP(FOLLOWINGSTATEMENT) ; NEXTISCODESEQUENCE(FORFALSEACTION) ; INSYMBOL ; STATEMENT(STATCONTEXT) ; END ELSE NEXTISCODESEQUENCE(FORFALSEACTION) END (* IFSTATEMENT *) ; PROCEDURE CASESTATEMENT ; LABEL 1, 9, 29 ; VAR CASETYPE,LABELTYPE : TYPENTRY ; LABELVALUE : VALU ; FIRSTCASE,LASTCASE, THISCASE,NEWCASE : CASENTRY ; SWITCHCODE : CODESEQUENCE ; BEGIN (* CASESTATEMENT *) INSYMBOL ; EXPRESSION(SUBSTATCONTEXT + [OFSY,COMMA,COLON]) ; CASETYPE := EXPTYPE ; IF CASETYPE <> NIL THEN IF (CASETYPE@.FORM>SUBRANGES) OR COMPTYPES(CASETYPE,REALTYPE) THEN BEGIN ERROR(144) ; CASETYPE := NIL END ; EXPECTCODESEQUENCE(SWITCHCODE) ; OPENCASE(SWITCHCODE) ; ACCEPT(OFSY) ; FIRSTCASE := NIL ; LASTCASE := NIL ; REPEAT WHILE TRUE DO BEGIN INCONSTANT(SUBSTATCONTEXT + [COMMA,COLON], LABELTYPE,LABELVALUE) ; IF LABELTYPE <> NIL THEN IF COMPTYPES(LABELTYPE,CASETYPE) THEN BEGIN THISCASE := FIRSTCASE ; LASTCASE := NIL ; WHILE THISCASE <> NIL DO BEGIN IF THISCASE@.CASEVALUE >= LABELVALUE.IVAL1 THEN BEGIN IF THISCASE@.CASEVALUE = LABELVALUE.IVAL1 THEN ERROR(156); GOTO 1 END ; LASTCASE := THISCASE ; THISCASE := THISCASE@.NEXTCASE END ; 1: NEW(NEWCASE) ; WITH NEWCASE@ DO BEGIN CASEVALUE := LABELVALUE.IVAL1 ; STARTCODESEQUENCE(CASELIMB) ; NEXTCASE := THISCASE END ; IF LASTCASE = NIL THEN FIRSTCASE := NEWCASE ELSE LASTCASE@.NEXTCASE := NEWCASE END ELSE ERROR(147) ; IF SYMBOL <> COMMA THEN GOTO 9 ; INSYMBOL END ; 9: ; ACCEPT(COLON) ; STATEMENT(STATCONTEXT + [SEMICOLON]) ; JUMP(FOLLOWINGSTATEMENT) ; IF SYMBOL = SEMICOLON THEN INSYMBOL ELSE IF SYMBOL <> ENDSY THEN BEGIN IF SYMBOL IN STATCONTEXT THEN BEGIN ERROR(13) ; GOTO 29 END ; ERROR(14) END UNTIL SYMBOL = ENDSY ; DECREMENTNESTINGLEVEL; NEXTISCODESEQUENCE(SWITCHCODE) ; CLOSECASE(FIRSTCASE) ; NEWCASE := FIRSTCASE ; WHILE NEWCASE <> NIL DO BEGIN THISCASE := NEWCASE ; NEWCASE := THISCASE@.NEXTCASE ; DISPOSE(THISCASE) END ; INSYMBOL ; 29: END (* CASESTATEMENT *) ; PROCEDURE WHILESTATEMENT ; VAR TOTESTCONDITION : CODESEQUENCE ; BEGIN (* WHILESTATEMENT *) STARTCODESEQUENCE(TOTESTCONDITION) ; INSYMBOL ; EXPRESSION(SUBSTATCONTEXT + [DOSY]) ; IF NOT COMPTYPES(EXPTYPE,BOOLTYPE) THEN ERROR(144) ; JUMPONFALSE(FOLLOWINGSTATEMENT) ; ACCEPT(DOSY) ; STATEMENT(STATCONTEXT) ; JUMP(TOTESTCONDITION) ; END (* WHILESTATEMENT *) ; PROCEDURE REPEATSTATEMENT ; VAR THISSTATEMENT : CODESEQUENCE ; BEGIN (* REPEATSTATEMENT *) STARTCODESEQUENCE(THISSTATEMENT) ; REPEAT INSYMBOL ; STATEMENT(STATCONTEXT + [SEMICOLON,UNTILSY]) ; UNTIL SYMBOL <> SEMICOLON ; IF SYMBOL = UNTILSY THEN BEGIN INSYMBOL ; EXPRESSION(SUBSTATCONTEXT) ; IF NOT COMPTYPES(EXPTYPE,BOOLTYPE) THEN ERROR(144) ; JUMPONFALSE(THISSTATEMENT) ; END ELSE ERROR(53); DECREMENTNESTINGLEVEL; END (* REPEATSTATEMENT *) ; PROCEDURE FORSTATEMENT ; VAR LVARID : IDENTRY ; LVARTYPE : TYPENTRY ; INCREASING : BOOLEAN ; STARTOFLOOP : CODESEQUENCE ; BEGIN (* FORSTATEMENT *) INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN SEARCHID([VARS],LVARID) ; LVARTYPE := LVARID@.IDTYPE ; IF NOT (LEVELFOUND IN [1,LEVEL]) THEN ERROR(155) ; IF LVARTYPE <> NIL THEN IF (LVARTYPE@.FORM > SUBRANGES) OR COMPTYPES(LVARTYPE,REALTYPE) THEN BEGIN ERROR(143) ; LVARTYPE := NIL END ELSE WITH LVARID@ DO STACKREFERENCE(VARPARAM,VARADDRESS, IDTYPE@.REPRESENTATION) ; INSYMBOL END ELSE BEGIN LVARTYPE := NIL ; ERROR(2) ; SKIP(SUBSTATCONTEXT + [BECOMES,TOSY,DOWNTOSY,DOSY]) END ; IF SYMBOL = BECOMES THEN BEGIN INSYMBOL ; EXPRESSION(SUBSTATCONTEXT + [TOSY,DOWNTOSY,DOSY]); IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM > SUBRANGES THEN ERROR(144) ELSE IF NOT COMPTYPES(LVARTYPE,EXPTYPE) THEN ERROR(145) END ELSE BEGIN ERROR(51) ; SKIP(SUBSTATCONTEXT + [TOSY,DOWNTOSY,DOSY]) END ; IF SYMBOL IN [TOSY,DOWNTOSY] THEN BEGIN FIXBOOLEANCHECK ; INCREASING := (SYMBOL = TOSY) ; INSYMBOL ; EXPRESSION(SUBSTATCONTEXT + [DOSY]) ; IF EXPTYPE <> NIL THEN IF EXPTYPE@.FORM > SUBRANGES THEN ERROR(144) ELSE IF NOT COMPTYPES(LVARTYPE,EXPTYPE) THEN ERROR(145) END ELSE BEGIN INCREASING := TRUE ; ERROR(55) ; SKIP(SUBSTATCONTEXT + [DOSY]) END ; OPENFOR(INCREASING,STARTOFLOOP,FOLLOWINGSTATEMENT) ; ACCEPT(DOSY) ; STATEMENT(STATCONTEXT) ; CLOSEFOR(INCREASING,STARTOFLOOP) END (* FORSTATEMENT *) ; PROCEDURE WITHSTATEMENT ; VAR RECORDID : IDENTRY ; BASE : STACKENTRY ; BEGIN (* WITHSTATEMENT *) INSYMBOL ; IF SYMBOL = IDENT THEN BEGIN SEARCHID([VARS,FIELD],RECORDID) ; INSYMBOL END ELSE BEGIN ERROR(2) ; RECORDID := DEFAULTENTRY[VARS] END ; SELECTOR(SUBSTATCONTEXT + [COMMA,DOSY],RECORDID) ; OPENSCOPE(WITHST) ; OPENWITH(BASE) ; IF VARTYPE <> NIL THEN IF VARTYPE@.FORM = RECORDS THEN WITH DISPLAY[TOP] DO BEGIN IDSCOPE := VARTYPE@.FIELDSCOPE ; FIELDSPACKED := VARTYPE@.PACKEDRECORD ; WITHBASE := BASE END ELSE ERROR(140) ; IF SYMBOL = COMMA THEN WITHSTATEMENT ELSE BEGIN ACCEPT(DOSY) ; STATEMENT(STATCONTEXT) END ; CLOSEWITH ; CLOSESCOPE END (* WITHSTATEMENT *) ; PROCEDURE GOTOSTATEMENT ; VAR LABELFOUND : LABELENTRY ; BEGIN (* GOTOSTATEMENT *) INSYMBOL ; IF SYMBOL = INTCONST THEN BEGIN SEARCHLABEL(LABELFOUND) ; LABELJUMP(LABELFOUND@.LABELLEDCODE,LEVELFOUND) ; INSYMBOL END ELSE ERROR(15) END (* GOTOSTATEMENT *) ; BEGIN (* STATEMENT *) SUBSTATCONTEXT := STATCONTEXT + STATBEGSYS ; IF SYMBOL = INTCONST THEN BEGIN SEARCHLABEL(LABELFOUND) ; IF LEVELFOUND <> LEVEL THEN BEGIN ERROR(176) ; NEWLABEL(LABELFOUND) END ; WITH LABELFOUND@ DO IF DEFINED THEN ERROR(165) ELSE BEGIN NEXTISCODESEQUENCE(LABELLEDCODE) ; DEFINED := TRUE END ; INSYMBOL ; ACCEPT(COLON) END ; IF NOT(SYMBOL IN SUBSTATCONTEXT + [IDENT]) THEN BEGIN ERROR(6) ; SKIP(SUBSTATCONTEXT) END ; WHILE SYMBOL IN STATBEGSYS + [IDENT] DO BEGIN OPENSTATEMENT(SOURCE.LINENUMBER,SYMBOL) ; EXPECTCODESEQUENCE(FOLLOWINGSTATEMENT) ; CASE SYMBOL OF IDENT : BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],FIRSTID) ; INSYMBOL ; IF FIRSTID@.KLASS = PROC THEN CALL(STATCONTEXT,FIRSTID) ELSE ASSIGNMENT(FIRSTID) END ; BEGINSY : BEGIN INCREMENTNESTINGLEVEL; COMPOUNDSTATEMENT ; END ; GOTOSY : GOTOSTATEMENT ; IFSY : IFSTATEMENT ; CASESY : BEGIN INCREMENTNESTINGLEVEL; CASESTATEMENT END ; WHILESY : WHILESTATEMENT ; REPEATSY : BEGIN INCREMENTNESTINGLEVEL; REPEATSTATEMENT END ; FORSY : FORSTATEMENT ; WITHSY : WITHSTATEMENT END (* CASE *) ; CLOSSTATEMENT ; NEXTISCODESEQUENCE(FOLLOWINGSTATEMENT) ; IF SYMBOL IN STATBEGSYS THEN ERROR(14) ELSE IF NOT(SYMBOL IN STATCONTEXT-BLOCKBEGSYS) THEN BEGIN ERROR(6) ; SKIP(SUBSTATCONTEXT) END END (* WHILE *) END (* STATEMENT *) ; BEGIN (* BODY *) ENDBODY := FALSE ; IF LEVEL = GLOBALLEVEL THEN BEGIN ENTERPROGRAM ; OPENFILES(PERMAFILES) END ELSE ENTERBODY(BLOCKIDENTRY) ; OPENFILES(SCRATCHFILES) ; REPEAT IF SYMBOL = BEGINSY THEN BEGIN INCREMENTNESTINGLEVEL; INSYMBOL END ; WHILE TRUE DO BEGIN STATEMENT(BLOCKCONTEXT + [SEMICOLON,ENDSY]) ; IF SYMBOL<>SEMICOLON THEN GOTO 1 ; INSYMBOL END ; 1: ; IF SYMBOL=ENDSY THEN BEGIN DECREMENTNESTINGLEVEL; INSYMBOL ; IF SYMBOL=BLOCKFOLLOWER THEN ENDBODY :=TRUE END ; IF NOT ENDBODY THEN BEGIN ERROR(6) ; SKIP(BLOCKCONTEXT + STATBEGSYS + [ENDSY]) END UNTIL ENDBODY OR (SYMBOL IN BLOCKCONTEXT) ; CLOSEFILES(SCRATCHFILES) ; IF LEVEL = GLOBALLEVEL THEN BEGIN CLOSEFILES(PERMAFILES) ; LEAVEPROGRAM END ELSE BEGIN IF (BLOCKIDENTRY@.KLASS=FUNC) AND (BLOCKIDENTRY@.IDTYPE <> NIL) THEN LEAVERESULT(BLOCKIDENTRY@.RESULT, BLOCKIDENTRY@.IDTYPE@.REPRESENTATION) ; LEAVEBODY(BLOCKIDENTRY) END ; END (* BODY *) ; BEGIN (* BLOCK *) SCRATCHFILES := NIL ; SUBBLOCKCONTEXT := BLOCKBEGSYS + STATBEGSYS - [CASESY] ; STARTLIST(LOCALIDLIST) ; REPEAT IF SYMBOL=LABELSY THEN LABELDECLARATION ; IF SYMBOL=CONSTSY THEN CONSTDECLARATION ; IF SYMBOL=TYPESY THEN TYPEDECLARATION ; IF SYMBOL=VARSY THEN VARDECLARATION ; WHILE SYMBOL IN [PROCSY,FUNCSY] DO PROCDECLARATION ; IF SYMBOL<>BEGINSY THEN IF SYMBOL IN BLOCKBEGSYS THEN ERROR(21) ELSE IF SYMBOL IN STATBEGSYS THEN ERROR(17) ELSE BEGIN ERROR(18) ; SKIP(SUBBLOCKCONTEXT) END UNTIL SYMBOL IN STATBEGSYS ; MAPTHISBLOCK(BLOCKIDENTRY); BODY ; BLKENDLIST ( BLOCKIDENTRY ) ; END (* BLOCK *) ; BEGIN (* PROGRAMME *) UNITNUMBER := 1 ; PERMAFILES := NIL ; CHECKNEXTORCONTEXT ([PROGRAMSY], BLOCKBEGSYS); IF SYMBOL = PROGRAMSY THEN BEGIN INSYMBOL ; IF SYMBOL = IDENT THEN MAKEPROGENTRY(SPELLING) ; ACCEPT(IDENT) ; IF SYMBOL = LEFTPARENT THEN BEGIN REPEAT INSYMBOL ; IF SYMBOL = IDENT THEN NEWPERMAFILE(SPELLING) ; ACCEPT(IDENT) ; CHECKNEXTORCONTEXT([COMMA,RIGHTPARENT], [SEMICOLON]+BLOCKBEGSYS) UNTIL SYMBOL <> COMMA ; ACCEPT(RIGHTPARENT) END ; ACCEPT(SEMICOLON) END; OPENSCOPE(BLOC) ; BUILTINFILES ; REPEAT BLOCK(BLOCKBEGSYS,PERIOD,PROGID) UNTIL SYMBOL = PERIOD ; FILESCOPE(PROGID); (* PROGRAM BLOCK *) DISPOSESCOPE ; CLOSESCOPE ; CLOSEPROGRAM END (* PROGRAMME *) ; PROCEDURE INITSETSOFSYMBOLS ; BEGIN BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY, BEGINSY] ; CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,CHARCONST,STRINGCONST, IDENT] ; SIMPTYPEBEGSYS := CONSTBEGSYS + [LEFTPARENT] ; TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY] ; TYPEBEGSYS := SIMPTYPEBEGSYS + TYPEDELS + [ARROW,PACKEDSY] ; STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY, CASESY] ; FACBEGSYS := [INTCONST,REALCONST,CHARCONST,STRINGCONST,IDENT, LEFTPARENT,LEFTBRACKET,NOTSY] ; SELECTSYMBOLS := [ARROW,PERIOD,LEFTBRACKET ] ; PARAMBEGSYS:= [PROCSY,FUNCSY,VARSY,IDENT] ; END (* INITSETSOFSYMBOLS *) ; PROCEDURE INITSEMANTICTABLES ; PROCEDURE STDTYPENTRIES ; VAR ENTRY : TYPENTRY ; BEGIN (* STDTYPENTRIES *) NEW(INTTYPE,SCALARS,STANDARD) ; WITH INTTYPE@ DO BEGIN REPRESENTATION := INTEGERREPRESENTATION ; FORM := SCALARS ; SCALARKIND := STANDARD ; END ; NEW(BYTETYPE,SUBRANGES) ; WITH BYTETYPE@ DO BEGIN REPRESENTATION := BYTEREPRESENTATION ; FORM := SUBRANGES ; RANGETYPE := INTTYPE ; MIN := 0 ; MAX := MAXINTFORBYTE ; END ; NEW(REALTYPE,SCALARS,STANDARD) ; WITH REALTYPE@ DO BEGIN REPRESENTATION := REALREPRESENTATION ; FORM := SCALARS ; SCALARKIND := STANDARD ; END ; NEW(CHARTYPE,SCALARS,STANDARD) ; WITH CHARTYPE@ DO BEGIN REPRESENTATION := CHARREPRESENTATION ; FORM := SCALARS ; SCALARKIND := STANDARD ; END ; NEW(BOOLTYPE,SCALARS,DECLARED) ; WITH BOOLTYPE@ DO BEGIN REPRESENTATION := BOOLEANREPRESENTATION ; FORM := SCALARS ; SCALARKIND := DECLARED ; END ; NEW(NILTYPE,POINTERS) ; WITH NILTYPE@ DO BEGIN REPRESENTATION := POINTERREPRESENTATION ; FORM := POINTERS ; DOMAINTYPE := NIL END ; NEW(LAYOUTTYPE,SCALARS,DECLARED) ; WITH LAYOUTTYPE@ DO BEGIN REPRESENTATION := LAYOUTREPRESENTATION ; FORM := SCALARS ; SCALARKIND := DECLARED END ; NEW(UNISETTYPE,SETS) ; WITH UNISETTYPE@ DO BEGIN FORM := SETS ; PACKEDSET := FALSE ; BASETYPE := NIL END ; SETREPRESENTATIONFOR(UNISETTYPE) ; NEW(TEXTTYPE,FILES) ; WITH TEXTTYPE@ DO BEGIN FORM := FILES ; PACKEDFILE := TRUE ; TEXTFILE := TRUE ; FELTYPE := CHARTYPE END ; SETREPRESENTATIONFOR(TEXTTYPE) ; NEW(ENTRY,SUBRANGES) ; WITH ENTRY@ DO BEGIN FORM := SUBRANGES ; RANGETYPE := INTTYPE ; MIN := 1 ; MAX := ALFALENGTH END ; SETREPRESENTATIONFOR(ENTRY) ; NEW(ALFATYPE,ARRAYS) ; WITH ALFATYPE@ DO BEGIN FORM := ARRAYS ; AELTYPE := CHARTYPE ; PACKEDARRAY := TRUE ; INXTYPE := ENTRY END ; SETREPRESENTATIONFOR(ALFATYPE) ; NEW(ENTRY,SUBRANGES) ; WITH ENTRY@ DO BEGIN FORM := SUBRANGES ; RANGETYPE := INTTYPE ; MIN := 1 ; MAX := ALFA8LENGTH END ; SETREPRESENTATIONFOR(ENTRY) ; NEW(ALFA8TYPE,ARRAYS) ; WITH ALFA8TYPE@ DO BEGIN FORM := ARRAYS ; AELTYPE := CHARTYPE ; PACKEDARRAY := TRUE ; INXTYPE := ENTRY END ; SETREPRESENTATIONFOR(ALFA8TYPE) ; END (* STDTYPENTRIES *) ; PROCEDURE STDIDENTRIES ; VAR ENTRY,LASTENTRY : IDENTRY ; PFNAME : STDPROCFUNCS ; BEGIN (* STDIDENTRIES *) A8TOALFA ('INTEGER ', SPELLING) ; NEWID(ENTRY,TYPES) ; ENTRY@.IDTYPE := INTTYPE ; A8TOALFA ('REAL ', SPELLING) ; NEWID(ENTRY,TYPES) ; ENTRY@.IDTYPE := REALTYPE ; A8TOALFA ('CHAR ', SPELLING) ; NEWID(ENTRY,TYPES) ; ENTRY@.IDTYPE := CHARTYPE ; A8TOALFA ('BOOLEAN ', SPELLING) ; NEWID(ENTRY,TYPES) ; ENTRY@.IDTYPE := BOOLTYPE ; A8TOALFA ('TEXT ', SPELLING) ; NEWID(ENTRY,TYPES) ; ENTRY@.IDTYPE := TEXTTYPE ; A8TOALFA ('ALFA ', SPELLING) ; NEWID(ENTRY,TYPES) ; ENTRY@.IDTYPE := ALFATYPE ; A8TOALFA ('ALFA8 ', SPELLING) ; NEWID(ENTRY,TYPES) ; ENTRY@.IDTYPE := ALFA8TYPE ; A8TOALFA ('MAXINT ', SPELLING) ; NEWID(ENTRY,CONSTS) ; WITH ENTRY@ DO BEGIN IDTYPE := INTTYPE ; VALUES.IVAL1 := MAXINT END ; A8TOALFA ('NIL ', SPELLING) ; NEWID(ENTRY,CONSTS) ; WITH ENTRY@ DO BEGIN IDTYPE := NILTYPE ; VALUES.IVAL1 := NILVALUE END ; A8TOALFA ('TRUE ', SPELLING) ; NEWID(ENTRY,CONSTS) ; WITH ENTRY@ DO BEGIN IDTYPE := BOOLTYPE ; VALUES.IVAL1 := 1 END ; LASTENTRY := ENTRY ; A8TOALFA ('FALSE ', SPELLING) ; NEWID(ENTRY,CONSTS) ; WITH ENTRY@ DO BEGIN IDTYPE := BOOLTYPE ; NEXT := LASTENTRY END ; BOOLTYPE@.FIRSTCONST := ENTRY ; A8TOALFA ('EOL ', SPELLING) ; NEWID(ENTRY,CONSTS) ; ENTRY@.IDTYPE := LAYOUTTYPE ; LAYOUTTYPE@.FIRSTCONST := ENTRY ; FOR PFNAME := GETP TO UNPACKP DO BEGIN SPELLING := STDPFNAMES[PFNAME] ; NEWID(ENTRY,PROC) ; WITH ENTRY@ DO BEGIN PFDECKIND := STANDARD ; PFINDEX := PFNAME END END ; FOR PFNAME := ABSF TO EOLNF DO BEGIN SPELLING := STDPFNAMES[PFNAME] ; NEWID(ENTRY,FUNC) ; WITH ENTRY@ DO BEGIN IDTYPE := INTTYPE ; PFDECKIND := STANDARD ; PFINDEX := PFNAME END END END (* STDIDENTRIES *) ; PROCEDURE ENTERDEFAULTS ; VAR LCLASS : IDCLASS ; BEGIN (* ENTERDEFAULTS *) A8TOALFA ('DEFAULT0', SPELLING) ; FOR LCLASS := TYPES TO FUNC DO BEGIN SPELLING[ALFA8LENGTH] := CHR(ORD(LCLASS)) ; NEWID(DEFAULTENTRY[LCLASS],LCLASS) END END (* ENTERDEFAULTS *) ; BEGIN (* INITSEMANTICTABLES *) INITSCOPE ; STDTYPENTRIES ; STDIDENTRIES ; FILESTDTYPES; ENTERDEFAULTS END (* INITSEMANTICTABLES *) ; BEGIN STARTCLOCK := CLOCK; INITCODEGENERATION; INITSYMBOL; INITOPTIONS; INITOBJECTMODULEGEN; INITDIAGNOSTICS; INITLISTING; INITSYNTAXANALYSER; INITSETSOFSYMBOLS; INITSEMANTICTABLES; INSYMBOL; PROGRAMME; ENDPROGRAMLISTING; ENDDIAGNOSTICS; ENDOBJECTMODULEGEN; ENDLISTING; NOTECOMPILATIONERRORCOUNT; END .