(*$A+,U+,L'COMPILER FOR PASCAL-6000.' *) COMP 2 COMP 3 COMP 4 (********************************************************************* COMP 5 * * COMP 6 * * COMP 7 * COMPILER FOR PASCAL-6000 * COMP 8 * ************************ * COMP 9 * * COMP 10 * * COMP 11 * (FOR CDC 6000/7000, CYBER 70,170,700,800 SERIES COMPUTER SYSTEMS) * COMP 12 * * COMP 13 * * COMP 14 * AUTHOR: URS AMMANN * COMP 15 * INSTITUT FUER INFORMATIK * COMP 16 * EIDG. TECHNISCHE HOCHSCHULE * COMP 17 * CH-8092 ZUERICH * COMP 18 * SWITZERLAND * COMP 19 * * COMP 20 * RELEASE 1 - URS AMMANN. * COMP 21 * 1974 MAY ORIGINAL RELEASE IMPLEMENTING THE REVISED PASCAL * COMP 22 * REPORT. KNOWN AS PASCAL 6000-3.4. GENERATE * COMP 23 * RELOCATABLE CODE; REMEMBER REGISTERS. * COMP 24 * UPDATES 1-10 - URS AMMANN. * COMP 25 * 1974-1975 CORRECT ERRORS. * COMP 26 * * COMP 27 * RELEASE 2 - URS AMMANN AND JOHN P. STRAIT. * COMP 28 * 1976 MAR IMPROVE PERFORMANCE; PROVIDE DIAGNOSTIC SUMMARY * COMP 29 * UPDATES 1-2 - URS AMMANN. * COMP 30 * 1976 CORRECT ERRORS. * COMP 31 * * COMP 32 * MAINTENANCE ASSUMED BY ANDY MICKEL AND JOHN P. STRAIT * COMP 33 * 1977 JAN UNIVERSITY COMPUTER CENTER * COMP 34 * UNIVERSITY OF MINNESOTA * COMP 35 * * COMP 36 * RELEASE 3 - JOHN P. STRAIT. * COMP 37 * 1979 JAN IMPLEMENT CHANGES WHICH WILL BECOME STANDARD: * COMP 38 * NEW TYPE-COMPATIBILITY RULES, ETC. IMPROVE * COMP 39 * RUN-TIME CHECKS, USABILITY; CORRECT ERRORS. * COMP 40 * UPDATES 1-4 - JOHN P. STRAIT, ANDY MICKEL, RICK L. MARCUS, * COMP 41 * AND DANIEL E. GERMANN. * COMP 42 * 1979-1982 CORRECT ERRORS. * COMP 43 * * COMP 44 * RELEASE 4 - DAVE BIANCHI, DANIEL E. GERMANN, * COMP 45 * ANDY MICKEL, AND JIM MINER. * COMP 46 * 1984 JUN IMPLEMENT CHANGES FOR ISO 7185 PASCAL STANDARD, * COMP 47 * DYNAMIC MEMORY MANAGEMENT, OPTIMIZATIONS, * COMP 48 * AND STANDARD CONTROL STATEMENT; CORRECT ERRORS. * COMP 49 * WORK SUPPORTED IN PART BY CONTROL DATA GRANTS. * COMP 50 * * COMP 51 * * COMP 52 * THIS COMPILER IS THE PROPERTY OF THE INSTITUT FUER INFORMATIK, * COMP 53 * E.T.H., ZUERICH, SWITZERLAND. CONTROL DATA CORPORATION HAS THE * COMP 54 * NON-EXCLUSIVE RIGHT TO DISTRIBUTE IT. * COMP 55 * * COMP 56 *********************************************************************) COMP 57 (*$L'MODIFICATION HISTORY.'*) COMP 58 COMP 59 HCOMP 1 (* PASCAL-6000 MODIFICATION HISTORY. HCOMP 2 * HCOMP 3 * CHANGE PREDECLARED FUNCTION "OFFSET" TO "RELVALUE". V410C01 6 * CORRECT MISTAKE IN FOR STATEMENT RANGE CHECKING FOR CONSTANTS. V41FC02 6 * FIX PROBLEM WITH COMPILER COMMAND PROCESSING. V41FC01 7 * FIX BUG WHERE "/L+" ON CONTROL STATEMENT TURNS OFF LISTING. V41EC08 5 * AVOID TRASHING FUNCTION RESULT. V41EC02 7 * CREATE PMD FILE AS "OUTPUT" IF OUTPUT NOT USED AND (PMD <> PMDNONE). V41DC06 10 * CHANGE CONTROL STATEMENT PROCESSING. V41DC05 191 * ADD NEW PREDECLARED ORDINAL FUNCTION OFFSET. V41CC21 8 * ADD RANGE CHECKS TO CHR, SUCC, AND PRED. V41CC21 9 * CHANGE CHECKS FOR FORWARD DECLARATIONS AND UNDECLARED PROG PARAMS. V41CC20 10 * ALLOW UNDERSCORE CHARACTERS IN IDENTIFIERS. V41CC18 10 * FIX BUG IN STRINGPARAM TO HANDLE PACKED STRINGS. V41CC15 6 * DETECT AND ABORT ON EMPTY INPUT FILE. V41CC12 5 * DISALLOW STRING-COMPARE PROCESSING OF CONFORMANT ARRAY PARAMS. V41CC11 7 * FIX PROBLEM WHERE MULTI-DIMENSIONAL ARRAYS ARE NOT HANDLED CORRECTLY. V41CC08 6 * 1. REWORK DATA STRUCTURE FOR RECORD TYPES. V41CC07 17 * 2. PROVIDE FOR OTHERWISE CLAUSE IN VARIANT-PART OF VARIANT RECORDS. V41CC07 18 * 3. PROVIDE FOR SUBRANGES IN CASE STATEMENTS AND VARIANT RECORDS. V41CC07 19 * USE SYMBOLIC EFET OFFSETS AND BIT POSITIONS IN COMPILER. V41CC04 7 * CALL "CLOSE" INSTEAD OF "CLOSEB" AND "CLOSET". V41BC01 7 * CORRECT ERROR IN ERROR-RECOVERY IN PROCEDURE PAGE. V41AC21 5 * ADD LANGUAGE DIALECT SELECTION PARAMETER. V41AC20 8 * SPLIT NONSTANDARD TYPE AND NAME DEFINITIONS INTO TWO PROCEDURES. V41AC19 5 * PREVENT INVALID USE OF FUNCTION IDENTIFIER IN ITS OWN BLOCK. V41AC18 6 * ENSURE THAT THE FIRST OPERAND OF THE IN OPERATOR HAS AN ORDINAL TYPE. V41AC17 6 * ALLOW CONFORMANT ARRAYS AS PARAMETERS TO PACK AND UNPACK. V41AC16 11 * ENFORCE CORRECT TYPE AND BOUNDS CHECK OF THIRD PARAMETER TO UNPACK. V41AC16 12 * INSTALL PREDECLARED PROCEDURES GETFILE AND PUTFILE, AND FUNCTION EOI. V41AC15 7 * FIX ERROR IN FIXFIELDALLOCATION -- ADJUST ADDRESS OF TAG FIELDS. V41AC13 6 * ENSURE PACKED ARRAY [1..N] OF CHAR IS A STRING TYPE ONLY IF N > 1. V41AC11 7 * CONVERT AN IF-STATEMENT TO AN ASSIGNMENT-STATEMENT. V41AC11 8 * ELIMINATE UNNECESSARY SPECIAL CASE IN GOTO STATEMENT. V41AC10 5 * ELIMINATE UNNECESSARY RUN-TIME TEST. V41AC09 5 * AVOID UNNECESSARY SHIFT DURING STORE INTO PACKED VARIABLE. V41AC08 9 * RENAME "ROTATEX" TO "UNROTATEX"; ADD "GENROTATE" AND "ROTATEX". V41AC08 10 * INTRODUCE CONSTANT FOR EXTERNAL LABEL COUNT LIMIT. V41AC03 5 * ENFORCE EXTERNAL FILE COUNT LIMIT. V41AC02 6 *) HCOMP 4 (*$L'COMPILER OPTION SETTINGS.'*) COMP 60 COMP 61 COMP 62 (*$B2 USE 401B WORD BUFFERS *) COMP 63 (*$E- COMPILE WITH DEFAULT ENTRY POINTS. *) COMP 64 (*$MB6000B ALLOW ENOUGH SPACE TO COMPILE SMALL PROGRAMS *) COMP 65 (*$MD+ ALLOW MEMORY DECREASE *) COMP 66 (*$MD5000B MINIMUM MEMORY DECREASE IS 5000B WORDS *) COMP 67 (*$MF377777B MAXIMUM ALLOWABLE FIELD LENGTH IS 377777B WORDS *) COMP 68 (*$MI+ ALLOW MEMORY INCREASE *) COMP 69 (*$MI2000B MINIMUM MEMORY INCREASE IS 2000B WORDS *) COMP 70 (*$MR+ PERFORM INITIAL REDUCE TO (LOAD FL + INITIAL SPACE) *) COMP 71 (*$MS2000B INITIAL STACK CHUNK IS 2000B WORDS. *) COMP 72 (*$MX1000B MINIMUM STACK EXTENSION IS 1000B WORDS. *) COMP 73 (*$P0 COMPILE WITH ABSOLUTELY NO PMD INFO *) COMP 74 (*$PL0 SET OUTPUT PRINT LIMIT TO MAXINT. *) COMP 75 (*$T- COMPILE WITHOUT RUNTIME TESTS *) COMP 76 (*$X5 PASS UP TO FIVE PARAMETERS IN X-REGISTERS *) COMP 77 COMP 78 COMP 79 PROGRAM PASCALCOMPILER; V41DC05 192 COMP 81 (* COMP 82 * COPYRIGHT (C) E.T.H. ZUERICH AND UNIV. OF MINNESOTA. COMP 83 * 1974, 1975, 1976, 1977, 1978, 1979, 1980, 1981, 1982. COMP 84 *) COMP 85 COMP 86 COMP 87 LABEL 13; (*EXIT IF EOF ENCOUNTERED*) COMP 88 (*$L'GLOBAL CONSTANT DECLARATIONS.' *) COMP 89 COMP 90 COMP 91 CONST COMP 92 COPYRIGHT = 'COPYRIGHT (C) E.T.H. ZUERICH AND UNIV. OF MINNESOTA.'; COMP 93 COPYRIGHT2 = '1974,1975,1976,1977,1978,1979,1980,1981,1982.'; COMP 94 ERRMAX = 360; (* MAXIMUM ERROR MESSAGE *) COMP 95 MAXERRPERLINE = 10; (* MAX ERRORS REPORTED PER LINE *) COMP 96 DISPLIMIT = 20; COMP 97 MAXLEVEL = 10; COMP 98 MAXADDR = 377777B; COMP 99 ICMAX = 32768; (* MAX WORDS IN CODE SEGMENT FOR A BLOCK. *) COMP 100 (* LIMITS: FIELDS IN BLOCK & PMD HEADER WORDS *) COMP 101 MAXLABEL = 9999; COMP 102 MAXEXTLABCNT = 36; (* LIMIT: EXTERNAL NAMES "PASCL.A".."PASCL.9" *) V41AC03 6 MAXFILES = 50; (* LIMIT: MAX EXTERNAL FILES ALLOWED *) V41AC02 7 MAXCSPNAME = 14; (* MAX CONTROL STATEMENT NAME LIST *) V41DC05 193 MAXPARAMS = 1023; (* LIMIT: PARAMS FIELD OF BLOCK HEADER WORD *) COMP 103 MAXPARAMSINREGS = 5; (* MAXIMUM X OPTION *) COMP 104 SCOPEMAX = MAXADDR; COMP 105 RESWORDS = 38; COMP 106 TWOTO17 = 400000B; COMP 107 CODEMAX = 150; COMP 108 RCODEMAX = 10 (* CODEMAX DIV 15 *); COMP 109 IDNAMEEXTLEN = 7; COMP 110 MAXLINELEN = 150; COMP 111 MAXTITLE = 40; COMP 112 OSNAME = '*OS*NAME* '; COMP 113 SITENAME = '*** SITE NAME *** '; COMP 114 (* LOCAL SITE NAME (MAXTITLE CHARACTERS LONG) *) COMP 115 BLANKTITLE = ' '; COMP 116 COMP 117 COMP 118 COMP 119 COMP 120 (* CTEXT COMSPAS - PASCAL-6000 RUN TIME EQUIVALENCES. COMSPAS 2 BASE DECIMAL COMSPAS 3 *COMMENT COPYRIGHT (C) UNIVERSITY OF MINNESOTA - 1978. COMSPAS 4 COMSPAS 5 COMSPAS 6 COMSPAS 7 COMSPAS 8 ** COMSPAS - PASCAL-6000 RUN TIME EQUIVALENCES. COMSPAS 9 * J. P. STRAIT. 77/08/24. COMSPAS 10 COMSPAS 11 COMSPAS 12 COMSPAS 13 HCOMSPA 1 ** PASCAL-6000 MODIFICATION HISTORY. HCOMSPA 2 * HCOMSPA 3 * PASCAL-6000 VERSION 4.1.0. V410C 1 * PASCAL-6000 VERSION 4.1.F. V41FC 1 * RENAME SYMBOL *ETERMINL* TO *ECONNECT*. V41EC01 1 * PASCAL-6000 VERSION 4.1.E. V41EC 1 * CHANGE VALUE OF CONSTANT *ERT*. V41DC09 1 * PASCAL-6000 VERSION 4.1.D. V41DC 1 * ADD ASCII AND DISPLAY CODE CHARACTER SET CONSTANTS. V41CC16 1 * RENAME EFET SYMBOLS: CHEFET -> TXTEFET; CHEFETSZ -> TXEFETSZ; V41CC02 1 * EFETSZ -> BNEFETSZ; CHEFITSZ -> TXEFITSZ; EFITSZ -> BNEFITSZ. V41CC02 2 * PASCAL-6000 VERSION 4.1.C. V41CC 1 * PASCAL-6000 VERSION 4.1.B. V41BC 1 * DEFINE SCOPE2 RECORD MANAGER ERROR ORDINALS. V41AC06 1 * KLUDGE: DEFINE SYMBOL *TXTEFET*. V41AC04 1 * INTRODUCE SYMBOLS *NOS1* AND *NOS2*; REMOVE SYMBOL *NOS*. V41AC01 1 * PASCAL-6000 VERSION 4.1.A. V41AC 1 * HCOMSPA 4 HCOMSPA 5 HCOMSPA 6 HCOMSPA 7 COMSPAS 14 ** COMSPAS DEFINES CONSTANTS USED THROUGHOUT THE COMSPAS 15 * PASCAL-6000 SYSTEM. THIS DECK IS CONSTRUCTED SO THAT IT COMSPAS 16 * MAY BE CALLED INTO EITHER A PASCAL OR COMPASS PROGRAM. COMSPAS 17 * *) COMSPAS 18 COMSPAS 19 COMSPAS 20 COMSPAS 21 (* COMSPAS 22 ** PASCAL-6000 RELEASE, VERSION, LEVEL. COMSPAS 23 * COMSPAS 24 * THE LEVEL NUMBER IS FOR USE BY LOCAL MAINTAINERS. COMSPAS 25 * *) COMSPAS 26 COMSPAS 27 COMSPAS 28 RELNUM = 37B ; (* RELEASE NUMBER = ORD('4') *) COMSPAS 29 VERNUM = 34B ; (* VERSION NUMBER = ORD('1') *) V41AC 2 LEVNUM = 33B ; (* VERSION NUMBER = ORD('F') *) V410C 2 ASCFLAG = 55B ; (* FULL-ASCII FLAG, OFF = ORD(' ') *) COMSPAS 32 LVERNUM = 33B ; (* LIBRARY VERSION NUMBER = ORD('0') *) COMSPAS 33 LLEVNUM = 33B ; (* LIBRARY LEVEL NUMBER = ORD('0') *) COMSPAS 34 COMSPAS 35 COMSPAS 36 COMSPAS 37 (* COMSPAS 38 ** DEFINE THE TARGET OPERATING SYSTEM. *) COMSPAS 39 COMSPAS 40 COMSPAS 41 KRONOS = 0 ; COMSPAS 42 NOS1 = 0 ; V41AC01 2 NOS2 = 0 ; V41AC01 3 NOSBE = 0 ; COMSPAS 44 SCOPE2 = 0 ; COMSPAS 45 SCOPE34 = 0 ; COMSPAS 46 COMSPAS 47 COMSPAS 48 COMSPAS 49 (* COMSPAS 50 ** DEFINE THE OPERATING SYSTEM ORDINALS. *) COMSPAS 51 COMSPAS 52 COMSPAS 53 XKRONOS = 1 ; COMSPAS 54 XNOS1 = 2 ; V41AC01 4 XNOS2 = 3 ; V41AC01 5 XNOSBE = 4 ; V41AC01 6 XSCOPE2 = 5 ; V41AC01 7 XSCOPE34 = 6 ; V41AC01 8 COMSPAS 59 COMSPAS 60 COMSPAS 61 (* COMSPAS 62 ** GENERAL CONSTANTS. *) COMSPAS 63 COMSPAS 64 COMSPAS 65 MARKLIM = 31 ; (* MAXIMUM MARK LEVEL *) COMSPAS 66 NILP = 377777B ; (* NIL POINTER *) COMSPAS 67 PFLC = 1 ; (* FIRST LOCATION IN ACTIVATION RECORDS *) COMSPAS 68 MPLC = PFLC ; (* FIRST LOCATION IN PROGRAM ACTIVATION *) COMSPAS 69 ARPS = 1 ; (* ACTIVATION-RECORD PREFIX SIZE *) COMSPAS 70 PMDSPACE = 120B ; (* SIZE OF STACK CHUNK FOR PMD *) COMSPAS 71 COMSPAS 72 COMSPAS 73 COMSPAS 74 (* COMSPAS 75 ** DATA SIZE CONSTANTS. *) COMSPAS 76 COMSPAS 77 COMSPAS 78 WORDSIZE = 60 ; (* NUMBER OF BITS IN ONE WORD *) COMSPAS 79 COMSPAS 82 (* V41CC16 2 * ASCII CHARACTER SET CONSTANTS. *) V41CC16 3 V41CC16 4 ASCHARSZ = 7 ; (* NUMBER OF BITS IN ASCII CHAR *) V41CC16 5 ASALFALN = 8 ; (* NUMBER OF ASCII CHARS IN WORD *) V41CC16 6 ASMINCH = 0 ; (* MINIMAL ORDINAL VALUE OF ASCII CHAR *) V41CC16 7 ASMAXCH = 127 ; (* MAXIMUM ORDINAL VALUE OF ASCII CHAR *) V41CC16 8 ASSPACE = 32 ; (* ASCII ORDINAL FOR ' ' *) V41CC16 9 ASONE = 49 ; (* ASCII ORDINAL FOR '1' *) V41CC16 10 V41CC16 11 (* V41CC16 12 * DISPLAY CODE CHARACTER SET CONSTANTS. *) V41CC16 13 V41CC16 14 DCCHARSZ = 6 ; (* NUMBER OF BITS IN DISPLAY CODE CHAR *) V41CC16 15 DCALFALN = 10 ; (* NUMBER OF DISPLAY CODE CHARS IN WORD *) V41CC16 16 DCMINCH = 0 ; (* MINIMUM VALUE OF DISPLAY CODE CHAR *) V41CC16 17 DCMAXCH = 63 ; (* MAXIMUM VALUE OF DISPLAY CODE CHAR *) V41CC16 18 DCSPACE = 45 ; (* DISPLAY CODE ORDINAL FOR ' ' *) V41CC16 19 DCONE = 28 ; (* DISPLAY CODE ORDINAL FOR '1' *) V41CC16 20 V41CC16 21 (* V41CC16 22 * CURRENT CHARACTER SET CONSTANTS. *) V41CC16 23 V41CC16 24 CHARSIZE = DCCHARSZ ; (* NUMBER OF BITS TO HOLD ONE CHAR *) V41CC16 25 ALFALENG = DCALFALN ; (* NUMBER OF CHARACTERS IN A WORD *) V41CC16 26 MINORDCH = DCMINCH ; (* MINIMUM ORDINAL VALUE OF A CHAR *) V41CC16 27 MAXORDCH = DCMAXCH ; (* MAXIMUM ORDINAL VALUE OF A CHAR *) V41CC16 28 CHSPACE = DCSPACE ; (* ORDINAL VALUE OF ' ' *) V41CC16 29 CHONE = DCONE ; (* ORDINAL VALUE OF '1' *) V41CC16 30 COMSPAS 85 COMSPAS 86 COMSPAS 87 (* COMSPAS 88 ** FET LENGTH CONSTANTS. *) COMSPAS 89 COMSPAS 90 COMSPAS 91 BINEFET = 1 ; (* RELATIVE ADDRESS OF WORD FILE EFET *) COMSPAS 92 TXTEFET = 13 ; (* RELATIVE ADDRESS OF TEXT FILE EFET *) V41CC02 3 TXEFETSZ = 28 ; (* TEXT EFET SIZE = TXTEFET + 1 + FETSZ *) V41CC02 4 BNEFETSZ = 16 ; (* WORD EFET SIZE = BINEFET + 1 + FETSZ *) V41CC02 5 FETSZ = 14 ; (* FET LENGTH *) COMSPAS 96 COMSPAS 97 COMSPAS 98 COMSPAS 99 (* COMSPAS 100 ** FIT LENGTH CONSTANTS. *) COMSPAS 101 COMSPAS 102 COMSPAS 103 TXEFITSZ = 32 ; (* TEXT EFET SIZE *) V41CC02 6 BNEFITSZ = 20 ; (* WORD EFET SIZE *) V41CC02 7 FITSZ = 16 ; (* FIT SIZE 7000 RM *) COMSPAS 106 COMSPAS 107 COMSPAS 108 COMSPAS 109 (* COMSPAS 110 ** EFET INDICES. COMSPAS 111 * COMSPAS 112 * THESE VALUES FORM OFFSETS FOR LOCATING THE VARIOUS COMSPAS 113 * FIELDS IN THE EFET. COMSPAS 114 * *) COMSPAS 115 COMSPAS 116 COMSPAS 117 EFETLCNT = -13 ; (* LINE COUNTER FOR TEXTFILES *) COMSPAS 118 EFETCBUF = -12 ; (* FWA OF 10-CHAR BUFFER *) COMSPAS 119 EFETSNTL = -2 ; (* END-OF-BUFFER SENTINEL *) COMSPAS 120 EFETPTR = -1 ; (* POINTER TO CURRENT ELEMENT *) COMSPAS 121 EFET = 0 ; (* ANCHOR FOR ALL OFFSETS *) COMSPAS 122 EFETFET = 1 ; (* FIRST WORD OF FET *) COMSPAS 123 EFETFRST = 2 ; (* FWA OF CIRCULAR BUFFER *) COMSPAS 124 EFETIN = 3 ; (* NEXT WORD TO PUT DATA INTO BUFFER *) COMSPAS 125 EFETOUT = 4 ; (* NEXT WORD TO GET DATA OUT OF BUFFER *) COMSPAS 126 EFETLIM = 5 ; (* LWA+1 OF CIRCULAR BUFFER *) COMSPAS 127 COMSPAS 128 COMSPAS 129 COMSPAS 130 (* COMSPAS 131 ** EFIT INDICES. *) COMSPAS 132 COMSPAS 133 COMSPAS 134 EFITBUF = 1 ; (* WSA BUFFER DESCRIPTOR *) COMSPAS 135 EFITOUT = 2 ; (* OUT POINTER *) COMSPAS 136 EFITIN = 2 ; (* IN POINTER *) COMSPAS 137 EFITFIT = 3 ; (* FIT *) COMSPAS 138 COMSPAS 139 COMSPAS 140 COMSPAS 141 (* COMSPAS 142 ** BIT-FIELD DEFINITIONS. COMSPAS 143 * COMSPAS 144 * THE VALUE OF EACH ENTRY IS THE BIT POSITION OF THAT FIELD COMSPAS 145 * IN THE WORD. FOR MULTIPLE-BIT FIELDS, THE COORDINATE OF COMSPAS 146 * THE RIGHTMOST BIT IS GIVEN. COMSPAS 147 * *) COMSPAS 148 COMSPAS 149 (* COMSPAS 150 * BIT-FIELDS IN EFET+EFETPTR. *) COMSPAS 151 COMSPAS 152 PEOLN = 59 ; (* EOLN FLAG FOR TEXTFILES *) COMSPAS 153 PREWRITE = 58 ; (* EQUIVALENT TO REWRITE IN EFET WORD *) COMSPAS 154 PPOINTER = 0 ; (* POINTER INTO CHARBUFF OR CIRC. BUFF *) COMSPAS 155 COMSPAS 156 (* COMSPAS 157 * BIT-FIELDS IN EFET. *) COMSPAS 158 COMSPAS 159 EEOSF = 59 ; (* EOS/EOF FLAG FOR SEG/NON-SEG. FILES *) COMSPAS 160 EEOF = 58 ; (* EOF FLAG *) COMSPAS 161 ESEGMENT = 57 ; (* SEGMENTED FILE *) COMSPAS 162 EREWRITE = 56 ; (* REWRITE FLAG FOR ALL FILES *) COMSPAS 163 ETEXT = 55 ; (* TEXT FILE *) COMSPAS 164 ETERMFIL = 54 ; (* TERMINAL FILE ('/' ON HEADER) *) COMSPAS 165 EPERSIST = 53 ; (* PERSISTENT FILE *) COMSPAS 166 ECONNECT = 52 ; (* FILE CONNECTED TO TERMINAL *) V41EC01 2 EPROGPAR = 51 ; (* PROGRAM PARAMETER *) COMSPAS 168 EDISPC = 51 ; (* DISPOSITION CODE (ALL OF ABOVE BITS) *) V41CC02 8 EDISPCW = 9 ; (* NUMBER OF BITS IN DISPOSITION CODE *) V41CC02 9 V41CC02 10 ELRL = 0 ; (* LOGICAL RECORD LENGTH *) COMSPAS 169 V41CC16 31 EDCCHS = 18 ; (* INDEX INTO DISPLAY CODE BUFFER (DCB) *) V41CC16 32 EDCCHSW = 18 ; (* WIDTH OF EDCCHS FIELD *) V41CC16 33 COMSPAS 170 EWSALEN = 18 ; (* ACTUAL LENGTH OF WSA *) COMSPAS 171 ERT = 36 ; (* RECORD TYPE *) V41DC09 2 ERTW = 6 ; (* NUMBER OF BITS IN RECORD TYPE *) V41CC02 11 COMSPAS 173 (* COMSPAS 174 * BIT-FIELDS IN EFET+EFITBUF. *) COMSPAS 175 COMSPAS 176 BUFEND = 0 ; (* LWA CURRENT RECORD *) COMSPAS 177 BUFADDR = 18 ; (* FWA WSA *) COMSPAS 178 BUFLEN = 36 ; (* USEABLE LENGTH OF WSA *) COMSPAS 179 COMSPAS 180 (* COMSPAS 181 * SCOPE2 RECORD MANAGER FIT VALUES. *) COMSPAS 182 COMSPAS 183 FPEOI = 64 ; (* END OF INFORMATION *) COMSPAS 184 FPEOP = 32 ; (* END OF PARTITION *) COMSPAS 185 FPEOS = 16 ; (* END OF SECTION *) COMSPAS 186 FPEOR = 8 ; (* END OF RECORD *) COMSPAS 187 FPBOI = 2 ; (* BEGIN OF INFORMATION *) COMSPAS 188 COMSPAS 189 (* COMSPAS 190 * SCOPE2 RECORD MANAGER RECORD TYPES. *) COMSPAS 191 COMSPAS 192 RTW = 0 ; (* CONTROL WORD *) COMSPAS 193 RTF = 1 ; (* FIXED LENGTH *) COMSPAS 194 RTZ = 3 ; (* ZERO BYTE TERMINATOR *) COMSPAS 195 RTU = 7 ; (* UNDEFINED RECORDS *) COMSPAS 196 RTS = 8 ; (* SYSTEM LOGICAL *) COMSPAS 197 COMSPAS 198 COMSPAS 199 COMSPAS 200 (* COMSPAS 201 ** P.GLOBL - TABLE OF GLOBAL VARIABLES. COMSPAS 202 * COMSPAS 203 * THIS TABLE INCLUDES RUN TIME SYSTEM VARIABLES THAT ARE COMSPAS 204 * MAINTAINED ACROSS THE ENTIRE EXECUTION OF A PASCAL PROGRAM. COMSPAS 205 * IN OTHER WORDS, THEY ARE GLOBAL WITH RESPECT TO THE USER COMSPAS 206 * PROGRAM. THESE VALUES ARE USED AS INDICES INTO THE COMSPAS 207 * TABLE NAMED *P.GLOBL*. COMSPAS 208 * *) COMSPAS 209 COMSPAS 210 COMSPAS 211 TGVRPMDS = 1 ; (* PMD STACK CHUNK; ZERO IF PMD DISABLED *) COMSPAS 212 (* 30/LWA+1, 30/FWA, IF PMD ENABLED *) COMSPAS 213 TGVRKEY = 2 ; (* KEY FOR POINTER CHECKS *) COMSPAS 214 TGVRFORT = 3 ; (* FORTRAN CALL FLAG *) COMSPAS 215 (* 1/FTNFLAG, 41/, 18/LINENUM *) COMSPAS 216 TGVRPTRS = 4 ; (* FOR SAVING GLOBAL POINTERS *) COMSPAS 217 (* 6/0, 18/B4, 18/B5, 18/B6 *) COMSPAS 218 COMSPAS 219 COMSPAS 220 COMSPAS 221 (* COMSPAS 222 ** P.PIT - PROGRAM INFORMATION TABLE. COMSPAS 223 * COMSPAS 224 * THIS TABLE, WHICH RESIDES IN THE CODE SPACE OF THE MAIN COMSPAS 225 * PROGRAM, IS USED TO PASS PARAMETERS FROM THE COMPILER TO THE COMSPAS 226 * RUN-TIME SYSTEM. THESE CONSTANTS ARE USED AS INDICES INTO COMSPAS 227 * THE TABLE NAMED "P.PIT". COMSPAS 228 * *) COMSPAS 229 COMSPAS 230 COMSPAS 231 PITVERS = 1 ; (* PASCAL-6000 VERSION INFORMATION *) COMSPAS 232 PITMAIN = 2 ; (* MAIN-PROGRAM BHW AND ACTIVATION *) COMSPAS 233 PITFLAG = 3 ; (* PROGRAM DESCRIPTION FLAGS *) COMSPAS 234 PITPMD = 4 ; (* ADDRESS OF PASCPMD *) COMSPAS 235 PITOUTP = 4 ; (* ADDRESS OF OUTPUT EFET *) COMSPAS 236 PITIDS = 5 ; (* INITIAL DYN. SPACE, INITIAL REDUCE *) COMSPAS 237 PITMFL = 5 ; (* MAXIMUM SIZE OF DYNAMIC MEMORY *) COMSPAS 238 PITSCS = 6 ; (* STACK-CHUNK CONTROLS *) COMSPAS 239 PITMCS = 7 ; (* MEMORY MANAGER CONTROLS *) COMSPAS 240 COMSPAS 241 COMSPAS 242 COMSPAS 243 (* COMSPAS 244 ** P.TERA - TABLE OF ERROR RECOVERY ADDRESSES. COMSPAS 245 * COMSPAS 246 * THESE VALUES ARE INDICES INTO P.TERA, THE TABLE OF ERROR COMSPAS 247 * RECOVERY ADDRESSES. COMSPAS 248 * *) COMSPAS 249 COMSPAS 250 COMSPAS 251 ASSERR = 0 ; (* VALUE OUT OF RANGE *) COMSPAS 252 INXERR = 1 ; (* INDEX OR CASE EXPR OUT OF RANGE *) COMSPAS 253 DIVERR = 2 ; (* DIVISION BY ZERO *) COMSPAS 254 ICNERR = 3 ; (* INCONSISTENT NODE REFERENCE *) COMSPAS 255 OVLERR = 4 ; (* INTEGER OVERFLOW *) COMSPAS 256 PTRERR = 5 ; (* INCORRECT POINTER REFERENCE *) COMSPAS 257 MODERR = 6 ; (* MOD BY NON-POSITIVE MODULO *) COMSPAS 258 EOLERR = 7 ; (* TRIED TO CHECK EOLN WHILE AT EOS/EOF *) COMSPAS 259 ISMERR = 8 ; (* MEMORY REQUIRED EXCEEDS SPECIFIED MFL *) COMSPAS 260 COMSPAS 261 COMSPAS 262 COMSPAS 263 (* COMSPAS 264 ** P.TMEM - TABLE OF MEMORY MANAGER VARIABLES. COMSPAS 265 * COMSPAS 266 * THIS TABLE CONTAINS THE VARIABLES USED BY THE PASCAL-6000 COMSPAS 267 * MEMORY MANAGER (PMM). THESE CONSTANTS ARE USED AS INDICES COMSPAS 268 * INTO THE TABLE NAMED "P.TMEM". COMSPAS 269 * *) COMSPAS 270 COMSPAS 271 COMSPAS 272 MEMFL = 1 ; (* CURRENT FIELD LENGTH *) COMSPAS 273 MEMFF = 2 ; (* ADDRESS OF FIRST FREE NODE *) COMSPAS 274 MEMLF = 3 ; (* ADDRESS OF LAST FREE NODE *) COMSPAS 275 MEMHLF = 4 ; (* HIGHEST ADDRESS OF LAST FREE NODE *) COMSPAS 276 MEMHFL = 5 ; (* HIGHEST FL USED BY MEMORY MANAGER *) COMSPAS 277 COMSPAS 278 COMSPAS 279 COMSPAS 280 (* COMSPAS 281 ** TIOE - TABLE OF INPUT/OUTPUT ERRORS. COMSPAS 282 * COMSPAS 283 * THESE VALUES ARE USED AS INDICES INTO THE TABLE NAMED COMSPAS 284 * *TIOE*. COMSPAS 285 * *) COMSPAS 286 COMSPAS 287 COMSPAS 288 IOEA = 0 ; (* LINELIMIT EXCEEDED ON XXXXXXX.*) COMSPAS 289 IOEB = 1 ; (* TRIED TO READ XXXXXXX PAST EOS/EOF.*) COMSPAS 290 IOEC = 2 ; (* TRIED TO WRITE XXXXXX WITHOUT REWRITE.*) COMSPAS 291 IOED = 3 ; (* BUFFER TOO SMALL ON XXXXXXX.*) COMSPAS 292 IOEE = 4 ; (* NON-DIGIT FOUND WHILE READING XXXXXXX.*) COMSPAS 293 IOEF = 5 ; (* VALUE TOO LARGE WHILE READING XXXXXXX.*) COMSPAS 294 IOEG = 6 ; (* TRIED TO READ XXXXXXX WITHOUT RESET.*) COMSPAS 295 IOEH = 7 ; (* UNDEFINED VALUE TO WRITE ON XXXXXXX. *) COMSPAS 296 V41AC06 2 (* V41AC06 3 ** SCOPE2 RECORD MANAGER ERRORS. *) V41AC06 4 V41AC06 5 RMIOEA = 0 ; (* RECORD MAN ERROR ON FILE XXXXXXX. *) V41AC06 6 RMIOEB = 1 ; (* BUFFER TOO SMALL ON XXXXXXX. *) V41AC06 7 RMIOEC = 2 ; (* FILE XXXXXXX MUST BE FO=SQ,RT=W,S,Z,U.*) V41AC06 8 RMIOED = 3 ; (* FILE CARD SPECIFIES MRL>PASCAL BUFFER.*) V41AC06 9 RMIOEE = 4 ; (* INVALID RT FOR SKIP ON XXXXXXX. *) V41AC06 10 RMIOEH = 5 ; (* ZERO SKIP COUNT ON XXXXXXX. *) V41AC06 11 COMSPAS 297 COMSPAS 298 COMSPAS 299 (* COMSPAS 300 ** TYPE CODES FOR POST-MORTEM DUMP. COMSPAS 301 *) COMSPAS 302 COMSPAS 303 PMDINT = 1 ; (* INTEGER *) COMSPAS 304 PMDREAL = 2 ; (* REAL *) COMSPAS 305 PMDCHAR = 3 ; (* CHAR *) COMSPAS 306 PMDBOOL = 4 ; (* BOOLEAN *) COMSPAS 307 PMDENUM = 5 ; (* ENUMERATED TYPE *) COMSPAS 308 PMDALFA = 6 ; (* ALFA *) COMSPAS 309 PMDUPTR = 7 ; (* UNCHECKED POINTER *) COMSPAS 310 PMDCPTR = 8 ; (* CHECKED POINTER *) COMSPAS 311 COMSPAS 312 COMSPAS 313 (* COMSPAS 314 BASE * COMSPAS 315 ENDX *) COMSPAS 316 (*$L'GLOBAL TYPE DECLARATIONS.' *) COMP 122 COMP 123 COMP 124 TYPE (*DESCRIBING:*) COMP 125 (*************) COMP 126 COMP 127 COMP 128 (*BASIC SYMBOLS*) COMP 129 (***************) COMP 130 COMP 131 SYMBOL = (IDENT,INTCONST,REALCONST,CHARCONST,STRINGCONST,NOTSY,NILSY, COMP 132 MULOP,ADDOP,RELOP,LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON, COMP 133 PERIOD,ARROW,COLON,BECOMES,DOTDOT,LABELSY,CONSTSY,TYPESY,VARSY, COMP 134 FUNCTIONSY,PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY, COMP 135 BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY, COMP 136 GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY, COMP 137 THENSY,PROGRAMSY,SEGMENTEDSY,OTHERWISESY,VALUESY,OTHERSY); COMP 138 OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP, COMP 139 GTOP,NEOP,EQOP,INOP,NOOP); COMP 140 SETOFSYS = SET OF SYMBOL; COMP 141 COMP 142 (*CONSTANTS*) COMP 143 (***********) COMP 144 COMP 145 CODERANGE = 0..CODEMAX; COMP 146 POSRANGE = 1..4; COMP 147 ADDRRANGE = 0..MAXADDR; COMP 148 ADDRFIELD = -377777B..777777B; COMP 149 SHRTINT = -377777B..377777B; COMP 150 CSTCLASS = (INT,BOOL,REEL,PSET,STRG); COMP 151 CSP = ^ CSTHEADREC; COMP 152 LOCOFREF = ^ LOCREC; COMP 153 CTAILP = ^ CSTTAILREC; COMP 154 CSTHEADREC = PACKED RECORD NXTCSP: CSP; COMP 155 CSTP: CTAILP; COMP 156 CREF: LOCOFREF COMP 157 END; COMP 158 CSTTAILREC = RECORD NXTCSP: CTAILP; CSVAL: INTEGER END; COMP 159 ERRINDEX = 1 .. ERRMAX; COMP 160 ERLISTT = PACKED ARRAY [ERRINDEX] OF BOOLEAN; COMP 161 COMP 162 VALU = RECORD CASE CSTCLASS OF COMP 163 INT: (IVAL: INTEGER); COMP 164 BOOL: (BVAL: BOOLEAN); COMP 165 REEL: (RVAL: REAL); COMP 166 PSET: (PVAL: SET OF 0..58); (*IMPL. DEPENDANT RANGE*) COMP 167 STRG: (VALP: CTAILP) COMP 168 END; COMP 169 COMP 170 (*DATA STRUCTURES*) COMP 171 (*****************) COMP 172 COMP 173 LEVRANGE = 0..MAXLEVEL; COMP 174 BITRANGE = 0..59 (*=WORDSIZE-1*); COMP 175 SHIFTRANGE = -59..59; V41AC08 11 EPWRANGE = 1..60 (*=WORDSIZE*); COMP 176 STRUCTFORM = (* BASIC STRUCTURE FORMS. ORDERING OF THESE CONSTANTS COMP 177 IS CRITICAL TO SEMANTIC ANALYSIS IN THE COMPILER. *) COMP 178 (SCALAR,SUBRANGE,REALS,POINTER,POWER,ARRAYS,RECORDS,FILES, COMP 179 FIELDLISTS,VARIANTPART,BOUNDDESC); V41CC07 20 DECLKIND = (PREDECLARED,USERDECLARED); COMP 181 WBSIZE = PACKED RECORD WORDS: ADDRRANGE; COMP 182 BITS: BITRANGE COMP 183 END; COMP 184 CCP = ^ CASECONSTREC; V41CC07 21 STP = ^ STRUCTREC; COMP 185 CTP = ^ IDENTREC; COMP 186 COMP 187 CASECONSTREC = PACKED RECORD V41CC07 22 CCMAX,CCMIN: INTEGER; V41CC07 23 NEXTCC,THREAD: CCP; V41CC07 24 CASE BOOLEAN OF V41CC07 25 TRUE: (CCVAR: STP); V41CC07 26 FALSE: (CCADDR: ADDRRANGE) V41CC07 27 END; V41CC07 28 V41CC07 29 STRUCTREC = PACKED RECORD COMP 188 FTYPE: BOOLEAN; COMP 189 SIZE: WBSIZE; COMP 190 CASE FORM: STRUCTFORM OF COMP 191 SCALAR: (CASE SCALKIND: DECLKIND OF COMP 192 PREDECLARED: (); COMP 193 USERDECLARED: (FCONST: CTP)); COMP 194 SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU); COMP 195 REALS: (); COMP 196 POINTER: (ELTYPE: STP; DBG: BOOLEAN); COMP 197 POWER: (PCKDSET: SET OF (UNPCKD, PCKD); ELSET: STP); COMP 198 ARRAYS: (AELTYPE,INXTYPE: STP; COMP 199 CONFORMANT: BOOLEAN; DESCADDR: ADDRRANGE; COMP 200 CASE PCKDARR: BOOLEAN OF COMP 201 FALSE: (); COMP 202 TRUE: (CASE PARTWORDELS: BOOLEAN OF COMP 203 FALSE: (); COMP 204 TRUE: (ELSPERWORD: 2..60))); COMP 205 RECORDS: (PCKDREC: BOOLEAN; FIELDIDTREE: CTP; V41CC07 30 FIELDLST: STP); V41CC07 31 FILES: (PCKDFIL,TEXTFILE,SEGFILE: BOOLEAN; COMP 208 BSIZE : ADDRRANGE; COMP 209 BASEFILE: STP; COMP 210 FILTYPE: STP); COMP 211 FIELDLISTS: (FIXEDPART: CTP; VARPART,NXTFLDLST: STP); V41CC07 32 VARIANTPART: (TAGFIELDID: CTP; TAGVALUELIST: CCP; V41CC07 33 TAGTYPE,VARIANTLIST,COMPLETER: STP); V41CC07 34 BOUNDDESC:(BOUNDTYPE: STP; LOWBOUND,HIGHBOUND: CTP) COMP 215 END; COMP 216 COMP 217 EXTIDP = ^ EXTID; COMP 218 EXTREFP = ^ EXTREF; COMP 219 EXTREF = PACKED RECORD LOC: 0..7777777777B; LINK: EXTREFP END; COMP 220 EXTID = PACKED RECORD COMP 221 EXID: ALFA; L,R: EXTIDP; REF: EXTREFP COMP 222 END; COMP 223 COMP 224 (*NAMES*) COMP 225 (*******) COMP 226 COMP 227 KEYWORD = (* STANDARD AND PRE-DEFINED IDENTIFIERS AND DIRECTIVES *) COMP 228 (* PROCEDURES: *) COMP 229 (GETKW,PUTKW,RESETKW,REWRITEKW,READKW,READLNKW,WRITEKW, COMP 230 WRITELNKW,PAGEKW,PACKKW,UNPACKKW,NEWKW,DISPOSEKW, COMP 231 (* FUNCTIONS: *) COMP 232 EOFKW,EOLNKW,ODDKW,ROUNDKW,TRUNCKW,ABSKW,SQRKW,ORDKW, COMP 233 CHRKW,PREDKW,SUCCKW,SINKW,COSKW,ARCTANKW,EXPKW,SQRTKW,LNKW, COMP 234 (* ADDITIONAL, PRE-DEFINED PROCEDURES: *) COMP 235 GETSEGKW,PUTSEGKW,GETFILEKW,PUTFILEKW, V41AC15 8 MNEWKW,MARKKW,RELEASEKW, COMP 237 MESSAGEKW,TIMEKW,DATEKW,HALTKW, COMP 238 (* ADDITIONAL, PRE-DEFINED FUNCTIONS: *) COMP 239 EOSKW,EOIKW, V41AC15 9 UNDEFINEDKW,EXPOKW,CARDKW,CLOCKKW, V41AC15 10 RELVALUEKW, V410C01 7 (* CONSTANTS: *) COMP 241 FALSEKW,TRUEKW,MAXINTKW, COMP 242 (* ADDITIONAL, PRE-DEFINED CONSTANTS: *) COMP 243 COLKW,PERKW, COMP 244 (* TYPES: *) COMP 245 INTEGERKW,REALKW,CHARKW,BOOLEANKW,TEXTKW, COMP 246 (* ADDITIONAL, PRE-DEFINED TYPES: *) COMP 247 ALFAKW,MARKERKW, COMP 248 (* VARIABLES: *) COMP 249 INPUTKW,OUTPUTKW, COMP 250 (* COMPILER DIRECTIVES: *) COMP 251 FORWARDKW,EXTERNALKW,FORTRANKW); COMP 252 IDCLASS = (TYPES,KONST,VARS,BOUNDID, COMP 253 FIELD,TAGFIELD,PROC,FUNC,UNKNOWNID); COMP 254 SETOFIDS = SET OF IDCLASS; COMP 255 IDKIND = (ACTUAL,FORMAL); COMP 256 ORDERING = (LESSTHAN,EQUALTO,GREATERTHAN); COMP 257 PFDECLCLASS = (DECL,FORWDECL,FORWDECLERR,EXTDECL,FTNDECL); V41CC20 11 ACCESSKIND = (DRCT,INDRCT,INXD); COMP 259 DRCTINDRCT = DRCT..INDRCT; COMP 260 SCOPERANGE = 0..SCOPEMAX; COMP 261 COMP 262 IDSEGMENT = ^ IDNAMEEXT; COMP 263 IDNAME = RECORD COMP 264 TEN: ALFA; COMP 265 EXT: IDSEGMENT COMP 266 END; COMP 267 IDNAMEEXT = PACKED RECORD COMP 268 SEVEN: PACKED ARRAY [1..IDNAMEEXTLEN] OF CHAR; COMP 269 EXTRA: IDSEGMENT COMP 270 END; COMP 271 IDENTREC = PACKED RECORD COMP 272 NAME: IDNAME; LLINK: CTP; RLINK: CTP; COMP 273 IDTYPE: STP; NEXT: CTP; COMP 274 LASTUSESCOPE: SCOPERANGE; COMP 275 CASE KLASS: IDCLASS OF COMP 276 KONST: (VALUES: VALU); COMP 277 TYPES: (); COMP 278 VARS: (VKIND: IDKIND; VARPARAM: BOOLEAN; COMP 279 VACCESS: DRCTINDRCT; VLEV: LEVRANGE; COMP 280 VADDR: ADDRRANGE; VINIT: BOOLEAN; COMP 281 FIRSTINPARMGROUP,CONFORMNT, COMP 282 THREAT,CONTROLVAR: BOOLEAN); COMP 283 BOUNDID:(BLEV: LEVRANGE; BADDR: ADDRRANGE); COMP 284 TAGFIELD, COMP 285 FIELD: (FLDADDR: ADDRRANGE; COMP 286 CASE PCKDFLD: BOOLEAN OF COMP 287 FALSE: (); COMP 288 TRUE: (BITADDR: BITRANGE)); COMP 289 PROC, COMP 290 FUNC: (CASE PFDECKIND: DECLKIND OF COMP 291 PREDECLARED: (KEY: KEYWORD); COMP 292 USERDECLARED: (PFLEV: LEVRANGE; COMP 293 PFXOPT: 0..MAXPARAMSINREGS; COMP 294 PARAMLIST: CTP; COMP 295 CASE PFKIND: IDKIND OF COMP 296 ACTUAL: (PFDECL: PFDECLCLASS; COMP 297 FIRSTVAR: ADDRRANGE; COMP 298 EPT: ALFA); COMP 299 FORMAL: (PFADDR: ADDRRANGE))); COMP 300 UNKNOWNID: () COMP 301 END; COMP 302 COMP 303 EXTFILEP = ^ FILEREC; COMP 304 FILEREC = PACKED RECORD COMP 305 FILENAME: ALFA; COMP 306 FILECP: CTP; COMP 307 NXTP: EXTFILEP; COMP 308 TERMINAL: BOOLEAN; COMP 309 SYSLOC: 1..63B V41DC06 11 END; COMP 311 COMP 312 DISPRANGE = -1 .. DISPLIMIT; COMP 313 WHERE = (BLCK,DREC,PFPAR,WREC); COMP 314 COMP 315 COMP 316 (*LABELS*) COMP 317 (********) COMP 318 COMP 319 LBP = ^LABREC; COMP 320 LABREC = PACKED RECORD COMP 321 LABVAL: INTEGER; EPT: ALFA; COMP 322 NEXTLAB: LBP; LABLEV: LEVRANGE; COMP 323 ACCESSIBLE: BOOLEAN; LABSTMTLEVEL: ADDRRANGE; COMP 324 CASE DEFINED: BOOLEAN OF COMP 325 TRUE: (LABADDR: ADDRRANGE); COMP 326 FALSE: (FSTOCC: LOCOFREF) COMP 327 END; COMP 328 COMP 329 COMP 330 (*FILES:*) COMP 331 (********) COMP 332 COMP 333 SEGTEXT = SEGMENTED TEXT; COMP 334 LGOFILE = SEGMENTED FILE OF INTEGER; COMP 335 COMP 336 COMP 337 (*FOR CODE GENERATION*) COMP 338 (*********************) COMP 339 COMP 340 OPCODE = (PS,RJ,JP,TESTX,EQ,NE,GE,LT,BXX,BXXTX,BXXPX,BXXMX,BXCX, COMP 341 BXXTCX,BXXPCX,BXXMCX,LXJK,AXJK,LXBX,AXBX,NXBX,ZXBX,UXBX,PXBX, COMP 342 FXXPX,FXXMX,DXXPX,DXXMX,RXXPX,RXXMX,IXXPX,IXXMX,FXXTX,RXXTX, COMP 343 DXXTX,MXJK,FXXDX,RXXDX,NO,CXX,SAAPK,SABPK,SAXPK,SAXPB,SAAPB, COMP 344 SAAMB,SABPB,SABMB,SBAPK,SBBPK,SBXPK,SBXPB,SBAPB,SBAMB,SBBPB, COMP 345 SBBMB,SXAPK,SXBPK,SXXPK,SXXPB,SXAPB,SXAMB,SXBPB,SXBMB); COMP 346 CONDITION = (ZR,NZ,PL,NG,XIR,XOR,XDF,XID); COMP 347 RELOCATION = (ABSR,UNUSEDR,PROGR,NEGPROGR,VARR,GLOBLR,TERAR,TMEMR); COMP 348 EXTERNALNAME = (* RUNTIME-SYSTEM PROCEDURE/FUNCTION EXTERNAL NAMES *) COMP 349 (GETBEX,PUTBEX,GETCEX,PUTCEX,GETCHEX,PUTCHEX,GETLNEX,PUTLNEX, COMP 350 RDIEX,RDREX,WRFEX,WRIEX,WREEX,WRCEX,WRCDEX,WRBEX,WRSEX,PAGEEX, COMP 351 RESETEX,REWRTEX,RWRTSEX,GETSEX,PUTSEX, COMP 352 GETFEX,PUTFEX,EOIEX, V41AC15 11 NEWEX,NEWDEX,DISPEX,DISPDEX,MNEWEX,MNEWDEX,MARKEX,RELEASEEX, COMP 353 CLOCKEX,TIMEEX,DATEEX,MSGEX,HALTEX, COMP 354 SINCOEX,EXPEX,SQRTEX,LNEX,ATANEX, COMP 355 (* OTHER RUNTIME-SYSTEM ENTRY POINTS *) COMP 356 PITEX, COMP 357 ACVEX,CPVEX,PEGEX,PENEX,PEXEX,SCOEX,VPEEX, COMP 358 CFVEX,DFVEX, COMP 359 ENDEX,GTOEX,INITEX,INVEX, COMP 360 EEREX, COMP 361 RPEEX,SPEEX, COMP 362 (* MEMORY MANAGER ENTRY POINTS *) COMP 363 ALMEX,LIMEX, COMP 364 (* PASCAL LIBRARY ENTRY POINTS *) COMP 365 PMDEX,MVEEX); COMP 366 COMP 367 BOOLCOL = ARRAY[BOOLEAN] OF OPCODE; COMP 368 BOOLROW = ARRAY[BOOLEAN] OF BOOLCOL; COMP 369 BOOLARRAY = ARRAY[BOOLEAN] OF BOOLROW; COMP 370 REGTYPE = (REGA,REGX); COMP 371 SETTYPE = (APK,BPK,XPK,XPB,APB,AMB,BPB,BMB); COMP 372 SETTABL = ARRAY[SETTYPE,REGTYPE] OF OPCODE; COMP 373 INCOPRANGE = SAAPK..SXBMB; COMP 374 COMP 375 COMP 376 (*TO DESCRIBE EXPRESSION CURRENTLY COMPILED*) COMP 377 (*******************************************) COMP 378 COMP 379 ATTRKIND = (CST,VARBL,COND,EXPR); COMP 380 REGKIND = (NONE,XREG); COMP 381 REGNR = 0..7; COMP 382 COMP 383 ATTR = RECORD TYPTR: STP; COMP 384 CASE KIND: ATTRKIND OF COMP 385 CST: (CVAL: VALU); COMP 386 VARBL: (WORDACC: ACCESSKIND; TAGF: BOOLEAN; COMP 387 VLEVEL: LEVRANGE; CWDISPL: SHRTINT; COMP 388 VWDISPL: REGNR; COMP 389 DCLPCKD: BOOLEAN; COMP 390 CASE PCKD: BOOLEAN OF COMP 391 FALSE: (); COMP 392 TRUE: (CBDISPL: SHRTINT; COMP 393 BITREG: REGKIND; VBDISPL: REGNR)); COMP 394 COND: (CDR: REGNR; CONDCD: ZR..NG); COMP 395 EXPR: (EXPREG: REGNR) COMP 396 END; COMP 397 COMP 398 COMP 399 (*TO DESCRIBE REGISTER STATUS*) COMP 400 (*****************************) COMP 401 COMP 402 ARGSTR = (SIMPADDR,INDADDR,UNSPECADDR); COMP 403 XRGSTR = (AVAIL,SHRTCST,LONGCST,SIMPVAR,INDVAR,OTHER); COMP 404 REMXRG = SHRTCST..INDVAR; COMP 405 COMP 406 ARGSTAT = COMP 407 PACKED RECORD CASE ACONT: ARGSTR OF COMP 408 UNSPECADDR: (); COMP 409 SIMPADDR, COMP 410 INDADDR: (ADISPL: ADDRRANGE; COMP 411 CASE ARGSTR OF COMP 412 UNSPECADDR: (); COMP 413 SIMPADDR: (ALEV: LEVRANGE); COMP 414 INDADDR: (AREG: REGNR)) COMP 415 END; COMP 416 COMP 417 XRGSTAT = COMP 418 PACKED RECORD COMP 419 CASE XCONT: XRGSTR OF COMP 420 AVAIL: (); COMP 421 SHRTCST,LONGCST, COMP 422 SIMPVAR,INDVAR, COMP 423 OTHER: COMP 424 (REFNR: 0..100; LASTREF: ADDRRANGE; COMP 425 CASE REMXRG OF COMP 426 SHRTCST: COMP 427 (CSTVAL: SHRTINT); COMP 428 LONGCST: COMP 429 (CPTR: CTAILP); COMP 430 SIMPVAR, COMP 431 INDVAR: COMP 432 (SHFTCNT: BITRANGE; COMP 433 CASE DRCTINDRCT OF COMP 434 DRCT: COMP 435 (XLEV: LEVRANGE; XADDR: ADDRRANGE; COMP 436 VPADDR: BOOLEAN); COMP 437 INDRCT: COMP 438 (XREG: REGNR; XDISPL: ADDRRANGE))) COMP 439 END; COMP 440 COMP 441 ARGSTATUS = ARRAY [REGNR] OF ARGSTAT; COMP 442 XRGSTATUS = ARRAY [REGNR] OF XRGSTAT; COMP 443 BRGSTATUS = SET OF REGNR; (* SET OF FREE B-REGISTERS *) COMP 444 COMP 445 REGMAP = RECORD COMP 446 XMAP: XRGSTATUS; AMAP: ARGSTATUS COMP 447 END; COMP 448 COMP 449 BASREGS = ARRAY [LEVRANGE] OF REGNR; COMP 450 COMP 451 COMP 452 PLACE = PACKED RECORD SIX: ADDRRANGE; COMP 453 CIX: CODERANGE; CP: POSRANGE COMP 454 END; COMP 455 COMP 456 LOCREC = PACKED RECORD NXTREF: LOCOFREF; LOC: PLACE END; COMP 457 V41DC05 194 V41DC05 195 (*CONTROL STATEMENT PROCESSING*) V41DC05 196 (******************************) V41DC05 197 V41DC05 198 DSKIND = (P6000,ANSI,ISO0,ISO1); V41DC05 199 SETOFA2Z = SET OF 'A'..'Z'; V41DC05 200 CH7 = PACKED ARRAY [1..7] OF CHAR; V41DC05 201 ARGUMENT = (* CONTROL STATEMENT ARGUMENT *) V41DC05 202 PACKED RECORD V41DC05 203 N : CH7; (* NAME *) V41DC05 204 D : 0..777777B; (* DELIMITER *) V41DC05 205 END; V41DC05 206 ARGLIST = ARRAY [1..MAXFILES] OF ARGUMENT; V41DC05 207 V41DC05 208 CSPARAMS = (IPM, LPM, BPM, EPM, DSPM, GOPM, V41DC05 209 PDPM, PSPM, PLPM, REWPM, NOPM); V41DC05 210 CSPINDEX = 0..MAXCSPNAME; V41DC05 211 CSPARAMREC = (* CONTROL STATEMENT PARAMETER RECORD *) V41DC05 212 PACKED RECORD V41DC05 213 PNAME : CH7; V41DC05 214 SETTING : CSPINDEX; (* PARAM DEFAULT AND SETTING *) V41DC05 215 ALTDEF : CSPINDEX; (* ALTERNATE DEFAULT *) V41DC05 216 ALLOWEQ : BOOLEAN; (* ALLOW EQUIVALENCED PARAM *) V41DC05 217 ALLOWNE : BOOLEAN; (* ALLOW KEYWORD ALONE *) V41DC05 218 USED : BOOLEAN; (* PARAMETER USAGE FLAG *) V41DC05 219 END; V41DC05 220 V41DC05 221 OPTIONBLOCK = V41DC05 222 RECORD V41DC05 223 SOURCEFN : CH7; (* SOURCE FILE NAME *) V41DC05 224 OUTPUTFN : CH7; (* OUTPUT (LISTING) FILE NAME *) V41DC05 225 BINARYFN : CH7; (* LGO (BINARY) FILE NAME *) V41DC05 226 ERRORFN : CH7; (* ERROR OUTPUT FILE NAME *) V41DC05 227 REWINDF : SETOFA2Z; (* FILES (ILBE) TO REWIND *) V41DC05 228 LOADANDGO : BOOLEAN; (* LOAD AND EXECUTE BINARY *) V41DC05 229 EIGHTLPI : BOOLEAN; (* EIGHT LPI PAGE DENSITY *) V41DC05 230 PAGESIZE : INTEGER; (* LISTING PAGE SIZE *) V41DC05 231 LINELIMIT : INTEGER; (* OUTPUT FILE LINE LIMIT *) V41DC05 232 DIALECT : DSKIND; (* DIALECT SELECTION *) V41DC05 233 END; V41DC05 234 V41DC05 235 PAGESIZEREC = V41DC05 236 RECORD V41DC05 237 PD : INTEGER; (* PAGE DENSITY *) V41DC05 238 PS : INTEGER; (* PAGE LENGTH *) V41DC05 239 PW : INTEGER; (* PAGE WIDTH *) V41DC05 240 END; V41DC05 241 COMP 458 COMP 459 (*MISCELLANEOUS*) COMP 460 (***************) COMP 461 COMP 462 DOUBLE = RECORD UPPER: REAL; LOWER: REAL END; COMP 463 PMDKIND = (PMDON,PMDOFF,PMDSUPPRESS,PMDNONE); COMP 464 LINEBUFFER = ARRAY[1..MAXLINELEN] OF CHAR; COMP 465 COMP 466 TITLEBUFFER = PACKED ARRAY[1..MAXTITLE] OF CHAR; COMP 467 COMP 468 LANGUAGEKIND = (ENGLISH, FRENCH, GERMAN, USERDL); COMP 469 (*$L'GLOBAL VARIABLE DECLARATIONS.' *) COMP 484 COMP 485 COMP 486 VAR COMP 487 (*RETURNED BY SOURCE PROGRAM SCANNER COMP 488 INSYMBOL: COMP 489 **********) COMP 490 COMP 491 SOURCE: SEGTEXT; (*SOURCE PROGRAM FILE*) COMP 492 SY: SYMBOL; (*LAST SYMBOL*) COMP 493 OP: OPERATOR; (*CLASSIFICATION OF LAST SYMBOL*) COMP 494 IVAL: INTEGER; (*VALUE OF LAST INTEGER CONSTANT*) COMP 495 RVAL: REAL; (*VALUE OF LAST REAL CONSTANT*) COMP 496 CONSTP: CTAILP; (*POINTER TO LAST STRING*) COMP 497 LGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*) COMP 498 ID: IDNAME; (*LAST IDENTIFIER*) COMP 499 IDSTART,IDEND, COMP 500 IDBREAK: IDSEGMENT; (*POINTERS TO ID EXTENSION*) COMP 501 EMPTYID: IDNAME; (*USED TO INITIALIZE IDS*) COMP 502 CH: CHAR; (*LAST CHARACTER*) COMP 503 COMP 504 COMP 505 (*COUNTERS:*) COMP 506 (***********) COMP 507 COMP 508 LC,IC: INTEGER; (*DATA LOCATION AND INSTR CNTER*) COMP 509 LABCNT: 0..MAXEXTLABCNT; (*NUMBER OF EXTERNAL LABELS*) V41AC03 7 EXTFILS: 0..MAXFILES; (*NUMBER OF EXTERNAL FILES*) V41AC02 8 PCNT: INTEGER; (*NUMBER OF PROCEDURES/FUNCTIONS*) COMP 512 COMP 513 COMP 514 (*SWITCHES:*) COMP 515 (***********) COMP 516 COMP 517 DP, (*DECLARATION PART*) COMP 518 TOPEXPR: BOOLEAN; (*TOP LEVEL EXPRESSION FLAG*) COMP 519 INTYPEDEFINITION: BOOLEAN; (*PARSING A TYPE DEFINTION*) COMP 520 LINENUMBERS: BOOLEAN; COMP 521 COMP 522 COMP 523 (*POINTERS:*) COMP 524 (***********) COMP 525 COMP 526 MARKERPTR, COMP 527 INTPTR,REALPTR,CHARPTR,ALFAPTR,STEXTPTR, COMP 528 BOOLPTR,NILPTR,TEXTPTR: STP; (*POINTERS TO PREDECLARED TYPES*) COMP 529 UTYPPTR,UCSTPTR,UVARPTR, COMP 530 UFLDPTR,UPRCPTR,UFCTPTR, (*POINTERS TO ENTRIES FOR UNDECL IDS*) COMP 531 INPUTPTR,OUTPUTPTR, (*ENTRIES FOR INPUT AND OUTPUT*) COMP 532 PMDFILEPTR, (*ENTRY FOR ALTERNATE PMD FILE*) V41DC06 12 FWPTR: CTP; (*HEAD OF CHAIN OF FORW TYPE IDS*) COMP 533 FSTLABP: LBP; (*HEAD OF LABEL CHAIN*) COMP 534 FEXFILP: EXTFILEP; (*HEAD OF LIST OF EXTERNAL FILES*) COMP 535 FSTCSP: CSP; (*HEAD OF CONSTANT CHAIN*) COMP 536 COMP 537 COMP 538 (*BOOKKEEPING OF DECLARATION LEVELS:*) COMP 539 (************************************) COMP 540 COMP 541 LEVEL: LEVRANGE; (*CURRENT STATIC LEVEL*) COMP 542 DISX, (*LEVEL OF LAST ID SRCHD BY SEARCHID*) COMP 543 TOP: DISPRANGE; (*TOP OF DISPLAY*) COMP 544 COMP 545 THISSCOPE, (*CURRENT SCOPE FOR ENTERID*) COMP 546 HIGHSCOPE: SCOPERANGE; (*HIGHEST SCOPE NUMBER USED*) COMP 547 COMP 548 DISPLAY: (*WHERE: MEANS:*) COMP 549 ARRAY [DISPRANGE] OF COMP 550 PACKED RECORD COMP 551 FNAME: CTP; COMP 552 CASE REGION: WHERE OF (*=BLCK: VARIABLE ID*) COMP 553 BLCK: (ASSIGNED: BOOLEAN; COMP 554 PFCP: CTP (* PROC/FUNC NAME *) ); COMP 555 DREC: (FFWPTR: CTP); (*=DREC: RECORD TYPE*) COMP 556 PFPAR: (); (*=PFPAR: PARAMETER LIST*) COMP 557 WREC: (WACC: DRCTINDRCT; (*=WREC: FIELD ID IN WITH-REC*) COMP 558 LEV: LEVRANGE; CWDSPL: ADDRRANGE; COMP 559 DCLPKD: BOOLEAN; COMP 560 CASE PKD: BOOLEAN OF COMP 561 FALSE: (); COMP 562 TRUE: (BACC: DRCTINDRCT; BDSPL: SHRTINT)) COMP 563 END; COMP 564 COMP 565 COMP 566 (*ERROR MESSAGES:*) COMP 567 (*****************) COMP 568 COMP 569 ERRINX: 0..MAXERRPERLINE; (* NR OF ACTIVE ENTRIES IN ERRLIST *) COMP 570 ERRORS: BOOLEAN; COMP 571 ERRLIST: COMP 572 ARRAY [1..MAXERRPERLINE] OF COMP 573 PACKED RECORD POS: 1..1000000; COMP 574 NMR: ERRINDEX COMP 575 END; COMP 576 ERLIST : ERLISTT; COMP 577 LANGUAGE: LANGUAGEKIND; (* D - DIAGNOSTIC LANGUAGE *) COMP 578 LANG: ARRAY [LANGUAGEKIND] OF ALFA; COMP 579 COMP 580 COMP 581 (*LISTING:*) COMP 582 (**********) COMP 583 COMP 584 LISTING: SEGTEXT; (* LISTING FILE *) V41DC05 242 LISTINGOPEN: BOOLEAN; (* TRUE IF LISTING FILE OPEN *) V41DC05 243 ERRFILE: SEGTEXT; (* ERROR FILE *) V41DC05 244 ERRFILEOPEN: BOOLEAN; (* TRUE IF ERROR FILE OPEN *) V41DC05 245 LINELENGTH,SOURCELENGTH,CHCNT: INTEGER; COMP 585 LINELC: INTEGER; COMP 586 LINENUM,LINESZ : INTEGER; COMP 587 NEXTNUM : INTEGER; COMP 588 SETLINENUM : BOOLEAN; COMP 589 TITLE,SUBTITLE: TITLEBUFFER; COMP 590 PAGE,LINESLEFT: INTEGER; COMP 591 SETTITLE,FIRSTHEADING: BOOLEAN; COMP 592 LINE: LINEBUFFER; COMP 593 V41DC05 246 V41DC05 247 (*CONTROL STATEMENT PROCESSING:*) V41DC05 248 (*******************************) V41DC05 249 V41DC05 250 OPTS: OPTIONBLOCK; V41DC05 251 CSPL: ARRAY [CSPARAMS] OF CSPARAMREC; V41DC05 252 CSPN: ARRAY [1..MAXCSPNAME] OF CH7; V41DC05 253 COMP 595 COMP 596 (*CODE GENERATION:*) COMP 597 (******************) COMP 598 COMP 599 GATTR: ATTR; COMP 600 CATTR: ATTR; COMP 601 ARGS: ARGSTATUS; XRGS: XRGSTATUS; BRGS: BRGSTATUS; COMP 602 BRG: BASREGS; COMP 603 LEVELS: SET OF LEVRANGE; COMP 604 BONUS: ARRAY [SHRTCST..INDVAR] OF INTEGER; COMP 605 EXTNAMES: ARRAY[VARR..TMEMR] OF ALFA; (* SPECIAL ENTRY POINTS *) COMP 606 PC: PLACE; RBUF,CBUF: INTEGER; COMP 607 BOOLOPCD: BOOLARRAY; COMP 608 SETINST: SETTABL; COMP 609 GENINCOPS: PACKED ARRAY [INCOPRANGE] OF OPCODE; COMP 610 EX: ARRAY[EXTERNALNAME] OF ALFA; (* PROC/FUNC EXTERNAL NAMES *) COMP 611 NOI: ARRAY[BOOLEAN] OF INTEGER; (* TABLE OF NO-OP INSTRUCTIONS *) COMP 612 PARAMREGS: ARRAY [1..MAXPARAMSINREGS] OF REGNR; COMP 613 LOADROTATEFLAG: BOOLEAN; V41AC08 12 COMP 614 COMP 615 (*CODEFILE AND TABLES FOR EXT. REFERENCES*) COMP 616 (*****************************************) COMP 617 COMP 618 LGO : LGOFILE; (* BINARY FILE *) V41DC05 254 BINARYOPEN : BOOLEAN; (* TRUE IF BINARY FILE OPEN *) V41DC05 255 COMPILERNAME : ALFA; (* 'PASCAL R.V' *) COMP 620 VALUES : ^LGOFILE; COMP 621 PROGNAME: ALFA; COMP 622 PROGBLOCK: ALFA; COMP 623 EXT, EXTROOT: EXTIDP; EXTIDX, EXTRX: INTEGER; COMP 624 ALFINT: RECORD CASE BOOLEAN OF COMP 625 FALSE: (A: ALFA); COMP 626 TRUE: (I: INTEGER) COMP 627 END; COMP 628 COMP 629 COMP 630 (*COMPILER OPTIONS*) COMP 631 (******************) COMP 632 COMP 633 ASCII,OLDASCII : BOOLEAN; (* A - ASCII CHARACTER SET *) COMP 634 BUFFSZ,OLDBUFFSZ: INTEGER; (* B - BUFFER SIZE *) COMP 635 EXTON,OLDEXTON: BOOLEAN; (* E - ENTRY POINT NAME CONTROL *) COMP 636 EPT1,EPT2: ALFA; COMP 637 (* SEE *ALTERNATE INPUT FILE* I - ALTERNATE INPUT FILE *) COMP 638 LISTON,OLDLISTON: BOOLEAN; (* L - LISTING CONTROL *) COMP 639 LCHANGED: BOOLEAN; COMP 640 (* M - MEMORY CONTROL OPTIONS *) COMP 641 INITIALSPACE,OLDINITIALSPACE: INTEGER; (* MB *) COMP 642 ALLOWDECREASE,OLDALLOWDECREASE: BOOLEAN; (* MD *) COMP 643 MINDECREASE,OLDMINDECREASE: INTEGER; (* MD *) COMP 644 MAXFL,OLDMAXFL: INTEGER; (* MF *) COMP 645 ALLOWINCREASE,OLDALLOWINCREASE: BOOLEAN; (* MI *) COMP 646 MININCREASE,OLDMININCREASE: INTEGER; (* MI *) COMP 647 INITIALREDUCE,OLDINITIALREDUCE: BOOLEAN; (* MR *) COMP 648 MSOPTION,OLDMSOPTION: INTEGER; (* MS *) COMP 649 MVOPTION,OLDMVOPTION: INTEGER; (* MV *) COMP 650 MXOPTION,OLDMXOPTION: INTEGER; (* MX *) COMP 651 MZOPTION,OLDMZOPTION: BOOLEAN; (* MZ *) COMP 652 OPTALLOWED,OLDOPTALWD: BOOLEAN; (* O - OPTIONS ALLOWED *) COMP 653 PMDOPT,OLDPMDOPT: PMDKIND; (* P - POST-MORTEM DUMP *) COMP 654 PRNTLIMIT,OLDPRNTLIMIT: INTEGER;(* PL- SET OUTPUT PRINT LIMIT *) COMP 655 QUICKMODE,OLDQUICKMODE: BOOLEAN;(* Q - QUICK GENERATED CODE *) COMP 656 STDFLAG,OLDSTDFLAG: BOOLEAN; (* S - STANDARD USAGE *) COMP 657 DEBUG,OLDDEBUG: BOOLEAN; (* T - RUN TIME TESTS *) COMP 658 MAXSRCLEN,OLDMAXSL: INTEGER; (* U - LINE WIDTH *) COMP 659 XPARMAX,OLDXPARMAX: INTEGER; (* X - PARAMETER PASSING *) COMP 660 ISSUESTAT,OLDISSUSTAT: BOOLEAN; (* Z - ISSUE STATISTICS MESSAGE *) COMP 661 COMP 662 COMP 663 (*ALTERNATE INPUT FILE*) COMP 664 (**********************) COMP 665 COMP 666 ALTFILE : TEXT; COMP 667 ALTLINENUMBERS,ALTERNATEINPUT,ALTERINGINPUT : BOOLEAN; COMP 668 COMP 669 COMP 670 (*STRUCTURED CONSTANTS:*) COMP 671 (***********************) COMP 672 COMP 673 DIGITS: SET OF '0'..'9'; COMP 674 CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS, COMP 675 STATBEGSYS,TYPEDELS,VALSPECBEGSYS,NONSTANDSYS: SETOFSYS; V41AC20 12 TENBLANKS: ALFA; COMP 677 RW: ARRAY [1..RESWORDS] OF ALFA; COMP 678 LRW: ARRAY [0..ALFALENG] OF 0..RESWORDS; COMP 679 FLRW : ARRAY[1..ALFALENG] OF SET OF 'A'..'Z'; COMP 680 RSY: ARRAY [1..RESWORDS] OF SYMBOL; COMP 681 ROP: ARRAY [1..RESWORDS] OF OPERATOR; COMP 682 SSY: ARRAY [BOOLEAN,'+'..';'] OF SYMBOL; COMP 683 SOP: ARRAY ['+'..';'] OF OPERATOR; COMP 684 KW: ARRAY[KEYWORD] OF ALFA; COMP 685 PASCL,PNAME: ALFA; COMP 686 TODAY,NOW,COMPILEDATE: ALFA; COMP 687 EFETOFFSET: ARRAY [BOOLEAN] OF ADDRRANGE; V41CC04 8 (*$L'GLOBAL VARIABLE INITIALIZATIONS.' *) COMP 688 COMP 689 COMP 690 VALUE COMP 691 (* INITIALIZE TABLES *) COMP 692 (*********************) COMP 693 COMP 694 KW=('GET ','PUT ','RESET ','REWRITE ','READ ', COMP 695 'READLN ','WRITE ','WRITELN ','PAGE ','PACK ', COMP 696 'UNPACK ','NEW ','DISPOSE ', COMP 697 'EOF ','EOLN ','ODD ','ROUND ','TRUNC ', COMP 698 'ABS ','SQR ','ORD ','CHR ','PRED ', COMP 699 'SUCC ','SIN ','COS ','ARCTAN ','EXP ', COMP 700 'SQRT ','LN ', COMP 701 'GETSEG ','PUTSEG ','GETFILE ','PUTFILE ', V41AC15 12 'MNEW ','MARK ','RELEASE ', COMP 703 'MESSAGE ','TIME ','DATE ','HALT ', COMP 704 'EOS ','EOI ', V41AC15 13 'UNDEFINED ','EXPO ','CARD ','CLOCK ', V41AC15 14 'RELVALUE ', V410C01 8 'FALSE ','TRUE ','MAXINT ', COMP 706 'COL ','PER ', COMP 707 'INTEGER ','REAL ','CHAR ','BOOLEAN ','TEXT ', COMP 708 'ALFA ','MARKER ', COMP 709 'INPUT ','OUTPUT ', COMP 710 'FORWARD ','EXTERN ','FORTRAN '); COMP 711 COMP 712 RW=('IF ','DO ','OF ','TO ','IN ', COMP 713 'OR ','END ','FOR ','VAR ','DIV ', COMP 714 'MOD ','SET ','AND ','NOT ','NIL ', COMP 715 'THEN ','ELSE ','WITH ','GOTO ','CASE ', COMP 716 'TYPE ','FILE ','BEGIN ','UNTIL ','WHILE ', COMP 717 'ARRAY ','CONST ','LABEL ','VALUE ','REPEAT ', COMP 718 'RECORD ','DOWNTO ','PACKED ','PROGRAM ','FUNCTION ', COMP 719 'PROCEDURE ','OTHERWISE ','SEGMENTED '); COMP 720 COMP 721 LRW=(0,0,6,15,22,29,33,34,35,38,38); COMP 722 COMP 723 FLRW=([], COMP 724 ['D','I','O','T'], COMP 725 ['A','D','E','F','M','N','S','V'], COMP 726 ['C','E','F','G','T','W'], COMP 727 ['A','B','C','L','U','V','W'], COMP 728 ['D','P','R'], COMP 729 ['P'], COMP 730 ['F'], COMP 731 ['O','P','S'], COMP 732 []); COMP 733 COMP 734 RSY=(IFSY,DOSY,OFSY,TOSY,RELOP,ADDOP,ENDSY,FORSY,VARSY,MULOP,MULOP, COMP 735 SETSY,MULOP,NOTSY,NILSY,THENSY,ELSESY,WITHSY,GOTOSY,CASESY, COMP 736 TYPESY,FILESY,BEGINSY,UNTILSY,WHILESY,ARRAYSY,CONSTSY,LABELSY, COMP 737 VALUESY,REPEATSY,RECORDSY,DOWNTOSY,PACKEDSY,PROGRAMSY, COMP 738 FUNCTIONSY,PROCEDURESY,OTHERWISESY,SEGMENTEDSY); COMP 739 COMP 740 ROP=(4 OF NOOP,INOP,OROP,3 OF NOOP,IDIV,IMOD,NOOP,ANDOP,25 OF NOOP); COMP 741 COMP 742 SSY=((ADDOP,ADDOP,MULOP,MULOP,LPARENT,RPARENT,OTHERSY,RELOP,OTHERSY, COMP 743 COMMA,PERIOD,OTHERSY,LBRACK,RBRACK,COLON,4 OF OTHERSY,ARROW, COMP 744 OTHERSY,RELOP,RELOP,3 OF OTHERSY,SEMICOLON), COMP 745 (ADDOP,ADDOP,MULOP,MULOP,LPARENT,RPARENT,OTHERSY,RELOP,OTHERSY, COMP 746 COMMA,PERIOD,OTHERSY,LBRACK,RBRACK,COLON,6 OF OTHERSY,RELOP, COMP 747 RELOP,ARROW,OTHERSY,ARROW,SEMICOLON)); COMP 748 COMP 749 SOP=(PLUS,MINUS,MUL,RDIV,3 OF NOOP,EQOP,13 OF NOOP,LTOP,GTOP, COMP 750 4 OF NOOP); COMP 751 COMP 752 ERLIST=(ERRMAX OF FALSE); COMP 753 COMP 754 LANG = ('ENGLISH ','FRENCH ','GERMAN ',' '); COMP 755 V41DC05 256 CSPL = ( (* CONTROL STATEMENT PARAMETERS *) V41DC05 257 (* NAME DF AD EQ NE USED *) V41DC05 258 ('I ', 1,10,TRUE, TRUE, FALSE), V41DC05 259 ('L ', 2,11,TRUE, TRUE, FALSE), V41DC05 260 ('B ', 3, 0,TRUE, TRUE, FALSE), V41DC05 261 ('E ', 4,12,TRUE, TRUE, FALSE), V41DC05 262 ('DS ', 5, 0,TRUE, FALSE,FALSE), V41DC05 263 ('GO ', 0, 0,FALSE,TRUE, FALSE), V41DC05 264 ('PD ', 6, 0,TRUE, TRUE, FALSE), V41DC05 265 ('PS ', 7, 0,TRUE, FALSE,FALSE), V41DC05 266 ('PL ', 8,13,TRUE, TRUE, FALSE), V41DC05 267 ('REW ', 9,14,TRUE, TRUE, FALSE), V41DC05 268 (' ', 0, 0,FALSE,FALSE,TRUE )); V41DC05 269 CSPN = (* CONTROL STATEMENT PARAMETER NAMES *) V41DC05 270 ('INPUT ','OUTPUT ','LGO ','OUTPUT ','P6000 ', V41DC05 271 ' ',' ','2000 ',' ','COMPILE', V41DC05 272 'LIST ','ERRS ','0 ','IB '); V41DC05 273 COMP 756 BOOLOPCD=(((BXXPX,BXXPCX),(BXXPX,BXXTX)), COMP 757 ((BXXTX,BXXTCX),(BXXTX,BXXPX))); COMP 758 COMP 759 SETINST=((SAAPK,SXAPK),(SABPK,SXBPK),(SAXPK,SXXPK),(SAXPB,SXXPB), COMP 760 (SAAPB,SXAPB),(SAAMB,SXAMB),(SABPB,SXBPB),(SABMB,SXBMB)); COMP 761 COMP 762 GENINCOPS = (SAAPB,SABPB,SAXPB,5 OF PS, COMP 763 SBAPB,SBBPB,SBXPB,5 OF PS, COMP 764 SXAPB,SXBPB,SXXPB,5 OF PS); COMP 765 COMP 766 EXTNAMES=('P.MAIN; ','P.GLOBL ','P.TERA ','P.TMEM '); COMP 767 COMP 768 EX=('P.GETB ','P.PUTB ','P.GETC ','P.PUTC ','P.GETCH ', COMP 769 'P.PUTCH ','P.GETLN ','P.PUTLN ', COMP 770 'P.RDI ','P.RDR ','P.WRF ','P.WRI ','P.WRE ', COMP 771 'P.WRC ','P.WRCD ','P.WRB ','P.WRS ','P.PAGE ', COMP 772 'P.RESET ','P.REWRT ','P.RWRTS ','P.GETS ','P.PUTS ', COMP 773 'P.GETF ','P.PUTF ','P.EOI ', V41AC15 15 'P.ALM ','P.NEWD ','P.LIM ','P.DISPD ', COMP 774 'P.MNW ','P.MND ','P.MRK ','P.RLS ', COMP 775 'P.CLOCK ','P.TIME ','P.DATE ','P.MSG ','P.HALT ', COMP 776 'P.SINCO ','P.EXP ','P.SQRT ','P.LN ','P.ATAN ', COMP 777 'P.PIT ', COMP 778 'P.ACV ','P.CPV ','P.PEG ','P.PEN ','P.PEX ', COMP 779 'P.SCO ','P.VPE ', COMP 780 'P.CFV ','P.DFV ', COMP 781 'P.END ','P.GTO ','P.INIT ','P.INV ', COMP 782 'P.EER ', COMP 783 'P.RPE ','P.SPE ', COMP 784 'P.ALM ','P.LIM ', COMP 785 'P.PMD ','P.MVE '); COMP 786 COMP 787 NOI=(61000B,46000B); (* SB0 B0+K / NO *) COMP 788 COMP 789 BONUS = (20,10,4,3); COMP 790 COMP 791 PARAMREGS = (0,1,2,3,4); COMP 792 V41AC08 13 LOADROTATEFLAG = TRUE; V41AC08 14 COMP 793 COMP 794 (* INITIALIZE STRINGS *) COMP 795 (**********************) COMP 796 COMP 797 PASCL = ALFA('P','A','S','C','L','.',4 OF COL); COMP 798 PNAME = ALFA('P','R','C',7 OF COL); COMP 799 PROGNAME = 'P.MAIN '; COMP 800 PROGBLOCK = 'P.MAIN '; COMP 801 COMPILERNAME = 'PASCAL R.V'; COMP 802 LANGUAGE = ENGLISH; COMP 803 TENBLANKS = ' '; COMP 804 TITLE = SITENAME; COMP 805 SUBTITLE = BLANKTITLE; COMP 806 COMP 807 COMP 808 (* INITIALIZE MISCELLANEOUS *) COMP 809 (****************************) COMP 810 COMP 811 FWPTR = NIL; COMP 812 FSTLABP = NIL; COMP 813 FSTCSP = NIL; COMP 814 INPUTPTR = NIL; COMP 815 OUTPUTPTR = NIL; COMP 816 PMDFILEPTR = NIL; V41DC06 13 LABCNT = 0; COMP 817 ERRORS = FALSE; COMP 818 DP = TRUE; COMP 819 TOPEXPR = TRUE; COMP 820 INTYPEDEFINITION = FALSE; COMP 821 ERRINX = 0; COMP 822 IC = 0; COMP 823 PCNT = 0; COMP 824 LC = MPLC; COMP 825 CHCNT = 0; COMP 826 LINENUM = 0; COMP 827 NEXTNUM = 0; COMP 828 VALUES = NIL; COMP 829 LISTINGOPEN = TRUE; V41EC08 6 ERRFILEOPEN = FALSE; V41DC05 275 BINARYOPEN = FALSE; V41DC05 276 PAGE = 0; COMP 830 LINESLEFT = 0; COMP 831 SETTITLE = TRUE; COMP 832 FIRSTHEADING = TRUE; COMP 833 CATTR = ATTR(NIL,CST,VALU(INT,0)); COMP 834 DISPLAY = (22 OF (NIL,BLCK,FALSE,NIL)); COMP 835 EMPTYID = (' ',NIL); COMP 836 THISSCOPE = 1; COMP 837 HIGHSCOPE = 1; COMP 838 EFETOFFSET = (BINEFET,TXTEFET); V41CC04 9 COMP 839 COMP 840 (* DEFAULT COMPILER OPTIONS *) COMP 841 (****************************) COMP 842 COMP 843 ASCII = TRUE; OLDASCII = TRUE; (* A+ *) COMP 844 BUFFSZ = 400B; OLDBUFFSZ = 400B; (* B2 *) COMP 845 EXTON = FALSE; OLDEXTON = FALSE; (* E- *) COMP 846 ALTERNATEINPUT = FALSE; ALTERINGINPUT = FALSE; (* I *) COMP 847 LISTON = TRUE; OLDLISTON = TRUE; (* L+ *) COMP 848 LCHANGED = FALSE; COMP 849 OPTALLOWED = TRUE; OLDOPTALWD = TRUE; (* O+ *) COMP 850 PMDOPT = PMDON; OLDPMDOPT = PMDON; (* P+ *) COMP 851 QUICKMODE = FALSE; OLDQUICKMODE = FALSE; (* Q- *) COMP 852 STDFLAG = FALSE; OLDSTDFLAG = FALSE; (* S- *) COMP 853 DEBUG = TRUE; OLDDEBUG = TRUE; (* T+ *) COMP 854 MAXSRCLEN = MAXLINELEN; OLDMAXSL = MAXLINELEN; (* U- *) COMP 855 XPARMAX = 4; OLDXPARMAX = 4; (* X4 *) COMP 856 ISSUESTAT = TRUE; OLDISSUSTAT = TRUE; (* Z+ *) COMP 857 COMP 858 COMP 859 (* DEFAULT MEMORY CONTROL OPTIONS *) COMP 860 (**********************************) COMP 861 COMP 862 INITIALSPACE = 0; OLDINITIALSPACE = 0; (* MB0 *) COMP 863 ALLOWDECREASE = FALSE; OLDALLOWDECREASE = FALSE; (* MD- *) COMP 864 MINDECREASE = 3000B; OLDMINDECREASE = 3000B; (* MD3000B *) COMP 865 MAXFL = MAXADDR; OLDMAXFL = MAXADDR; (* MF377777B *) COMP 866 ALLOWINCREASE = TRUE; OLDALLOWINCREASE = TRUE; (* MI+ *) COMP 867 MININCREASE = 2000B; OLDMININCREASE = 2000B; (* MI2000B *) COMP 868 INITIALREDUCE = TRUE; OLDINITIALREDUCE = TRUE; (* MR+ *) COMP 869 MSOPTION = 1000B; OLDMSOPTION = 1000B; (* MS1000B *) COMP 870 MVOPTION = 100B; OLDMVOPTION = 100B; (* MV100B *) COMP 871 MXOPTION = 400B; OLDMXOPTION = 400B; (* MX400B *) COMP 872 MZOPTION = FALSE; OLDMZOPTION = FALSE; (* MZ- *) COMP 873 COMP 874 COMP 875 (* INITIALIZE SETS *) COMP 876 (*******************) COMP 877 COMP 878 DIGITS = ['0'..'9']; COMP 879 CONSTBEGSYS = [ADDOP,INTCONST,REALCONST,CHARCONST,STRINGCONST,IDENT]; COMP 880 SIMPTYPEBEGSYS = [LPARENT,ADDOP,INTCONST,REALCONST,CHARCONST, COMP 881 STRINGCONST,IDENT]; COMP 882 TYPEBEGSYS = [ARROW,PACKEDSY,SEGMENTEDSY,ARRAYSY,RECORDSY,SETSY, COMP 883 FILESY,LPARENT,ADDOP,INTCONST,REALCONST,CHARCONST, COMP 884 STRINGCONST,IDENT]; COMP 885 TYPEDELS = [ARRAYSY,RECORDSY,SETSY,FILESY]; COMP 886 BLOCKBEGSYS = [LABELSY,CONSTSY,TYPESY,VARSY,VALUESY,PROCEDURESY, COMP 887 FUNCTIONSY,BEGINSY]; COMP 888 VALSPECBEGSYS = [ADDOP,INTCONST,REALCONST,CHARCONST,STRINGCONST,IDENT, COMP 889 NILSY,LPARENT,LBRACK]; COMP 890 SELECTSYS = [ARROW,PERIOD,LBRACK]; COMP 891 FACBEGSYS = [INTCONST,REALCONST,CHARCONST,STRINGCONST,IDENT,LPARENT, COMP 892 LBRACK,NOTSY,NILSY]; COMP 893 STATBEGSYS = [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY, COMP 894 CASESY]; COMP 895 NONSTANDSYS = [VALUESY,OTHERWISESY,SEGMENTEDSY]; V41AC20 14 (*$L'EXTERNAL ROUTINES.' *) COMP 896 COMP 897 COMP 898 PROCEDURE BMSG(NAME : ALFA); EXTERN; V41DC05 277 PROCEDURE CDATE(VAR COMPILEDATE : ALFA); EXTERN; V41DC05 278 PROCEDURE (*$E'CLOSE'*) CLOSEB(VAR F : LGOFILE); EXTERN; V41DC05 279 PROCEDURE (*$E'CLOSE'*) CLOSET(VAR F : TEXT); EXTERN; V41DC05 280 PROCEDURE CSARG(VAR ARGL : ARGLIST; VAR ARGC : INTEGER); EXTERN; V41DC05 281 PROCEDURE CSABORT(ERR : INTEGER; KEY, VAL : CH7); EXTERN; V41DC05 282 PROCEDURE (*$E'P.DADD'*) DADD(VAR R : DOUBLE; A, B : DOUBLE); EXTERN; V41DC05 283 PROCEDURE (*$E'P.DDIV'*) DDIV(VAR R : DOUBLE; A, B : DOUBLE); EXTERN; V41DC05 284 PROCEDURE (*$E'P.DMUL'*) DMUL(VAR R : DOUBLE; A, B : DOUBLE); EXTERN; V41DC05 285 FUNCTION (*$E'P.EFD'*) EFD : INTEGER; EXTERN; V41DC05 286 PROCEDURE FIND(VAR F : TEXT; FN, RN : ALFA); EXTERN; V41DC05 287 PROCEDURE GETPAGE(VAR P : PAGESIZEREC); EXTERN; V41DC05 288 PROCEDURE LOADGO(VAR F : LGOFILE); EXTERN; V41DC05 289 PROCEDURE MAKESET(N : CH7; VAR S : SETOFA2Z); EXTERN; V41DC05 290 FUNCTION MASK(C : BITRANGE) : INTEGER; EXTERN; V41DC05 291 FUNCTION MERGE(A, B : VALU) : INTEGER; EXTERN; V41DC05 292 PROCEDURE NEXTCH; EXTERN; V41DC05 293 PROCEDURE NEXTCHSETUP(VAR LINE : LINEBUFFER; V41DC05 294 VAR CH : CHAR; VAR CHCNT, SOURCELENGTH : INTEGER); EXTERN; V41DC05 295 PROCEDURE (*$E'OPEN'*) OPENB(VAR F : LGOFILE; V41DC05 296 FN : CH7; OPENWRITE : BOOLEAN); EXTERN; V41DC05 297 PROCEDURE (*$E'OPEN'*) OPENT(VAR F : TEXT; V41DC05 298 FN : CH7; OPENWRITE : BOOLEAN); EXTERN; V41DC05 299 FUNCTION (*$E'P.OS'*) OS : INTEGER; EXTERN; V41DC05 300 FUNCTION PORTION(W : INTEGER; SB,EB : BITRANGE) : INTEGER; EXTERN; V41DC05 301 PROCEDURE RLIBNAME(VAR FN : ALFA); EXTERN; V41DC05 302 FUNCTION ROTATE(W : INTEGER; C : BITRANGE) : INTEGER; EXTERN; V41DC05 303 PROCEDURE (*$E'P.TEN'*) TEN(VAR R : DOUBLE; X : INTEGER); EXTERN; V41DC05 304 PROCEDURE UNPACKCS(VAR LINE : LINEBUFFER); EXTERN; V41DC05 305 PROCEDURE WRITEOCT(VAR F : TEXT; N, W : INTEGER); EXTERN; V41DC05 306 (*$L'INPUT/OUTPUT PROCESSORS.' *) COMP 922 COMP 923 V41DC05 307 PROCEDURE CLOSEFILES; V41DC05 308 BEGIN (* CLOSEFILES *) V41DC05 309 CLOSET(ALTFILE); V41DC05 310 IF VALUES <> NIL THEN CLOSEB(VALUES^); V41DC05 311 CLOSET(SOURCE); CLOSET(LISTING); V41DC05 312 CLOSEB(LGO); CLOSET(ERRFILE) V41DC05 313 END (* CLOSEFILES *); V41DC05 314 V41DC05 315 PROCEDURE ABORT(MSG: PACKED ARRAY [LO..HI:INTEGER] OF CHAR); V41DC05 316 BEGIN (* ABORT *) V41DC05 317 CLOSEFILES; HALT(MSG) V41DC05 318 END (* ABORT *); V41DC05 319 COMP 924 PROCEDURE HEADING; COMP 925 CONST T1 = 'PASCAL COMPILER - E.T.H. ZUERICH / UNIVERSITY OF '; V41DC05 320 T2 = 'MINNESOTA. PASCAL-6000 V'; V41DC05 321 VAR CH : CHAR; V41DC05 322 BEGIN (* HEADING *) COMP 926 PAGE := PAGE + 1; COMP 927 IF FIRSTHEADING THEN COMP 928 BEGIN FIRSTHEADING := FALSE; COMP 929 WRITELN(LISTING,'Q'); (* CLEAR AUTO-EJECT *) V41DC05 323 IF OPTS.EIGHTLPI THEN CH := 'T' ELSE CH := 'S'; V41DC05 324 WRITELN(LISTING,CH) V41DC05 325 END; COMP 932 WRITE(LISTING,'1'); V41DC05 326 IF OPTS.EIGHTLPI THEN V41DC05 327 BEGIN WRITELN(LISTING); WRITE(LISTING,' ') END; V41DC05 328 WRITE(LISTING,T1,T2,CHR(RELNUM),'.',CHR(VERNUM),'.',CHR(LEVNUM),'.'); V41DC05 329 WRITELN(LISTING,CHR(ASCFLAG),TODAY,NOW); V41DC05 330 WRITE(LISTING,TITLE:41,SUBTITLE:44,OSNAME:15,' ':10,COMPILEDATE); V41DC05 331 IF OPTS.PAGESIZE < MAXINT THEN WRITE(LISTING,' PAGE ',PAGE:1); V41DC05 332 WRITELN(LISTING); WRITELN(LISTING); V41DC05 333 LINESLEFT := OPTS.PAGESIZE - 3; COMP 942 IF OPTS.EIGHTLPI THEN COMP 943 BEGIN WRITELN(LISTING); LINESLEFT := LINESLEFT - 2 END V41DC05 334 END (* HEADING *); COMP 945 COMP 946 PROCEDURE FLAGERROR; COMP 947 V41DC05 335 PROCEDURE WRITEFLAG(VAR F : SEGTEXT); V41DC05 336 VAR K, S : INTEGER; V41DC05 337 BEGIN (* WRITEFLAG *) V41DC05 338 IF LINENUMBERS THEN S := LINESZ ELSE S := 5; V41DC05 339 WRITE(F,' '); V41DC05 340 FOR K := 1 TO S DO WRITE(F,'*'); V41DC05 341 IF NOT LINENUMBERS THEN WRITE(F,' ') V41DC05 342 END (* WRITEFLAG *); V41DC05 343 V41DC05 344 BEGIN (* FLAGERROR *) COMP 949 IF LISTINGOPEN THEN V41DC05 345 BEGIN V41DC05 346 IF LINESLEFT < 1 THEN HEADING; V41DC05 347 LINESLEFT := LINESLEFT - 1; V41DC05 348 IF LISTON OR LCHANGED THEN WRITE(LISTING,' ':7); V41DC05 349 WRITEFLAG(LISTING) V41DC05 350 END; V41DC05 351 IF ERRFILEOPEN THEN WRITEFLAG(ERRFILE) V41DC05 352 END (* FLAGERROR *); COMP 956 COMP 957 PROCEDURE WRITEERRORS; COMP 958 V41DC05 353 PROCEDURE PUTERRORS(VAR F : SEGTEXT); V41DC05 354 VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,W,K: INTEGER; V41DC05 355 BEGIN (* PUTERRORS *) V41DC05 356 LASTPOS := LINESZ + 1; FREEPOS := LASTPOS + 1; V41DC05 357 FOR K := 1 TO ERRINX DO V41DC05 358 BEGIN V41DC05 359 WITH ERRLIST[K] DO V41DC05 360 BEGIN CURRPOS := POS; CURRNMR := NMR END; V41DC05 361 IF CURRPOS = LASTPOS THEN WRITE(F,',') V41DC05 362 ELSE V41DC05 363 BEGIN V41DC05 364 WHILE FREEPOS < CURRPOS DO V41DC05 365 BEGIN WRITE(F,' '); FREEPOS := FREEPOS + 1 END; V41DC05 366 WRITE(F,''''); LASTPOS := CURRPOS V41DC05 367 END; V41DC05 368 IF CURRNMR < 10 THEN W := 1 V41DC05 369 ELSE IF CURRNMR < 100 THEN W := 2 V41DC05 370 ELSE W := 3; V41DC05 371 WRITE(F,CURRNMR:W); FREEPOS := FREEPOS + W + 1 V41DC05 372 END; V41DC05 373 WRITELN(F) V41DC05 374 END (* PUTERRORS *); V41DC05 375 V41DC05 376 BEGIN (* WRITEERRORS *) COMP 960 FLAGERROR; COMP 961 IF LISTINGOPEN THEN PUTERRORS(LISTING); V41DC05 377 IF ERRFILEOPEN THEN PUTERRORS(ERRFILE); V41DC05 378 ERRINX := 0 V41DC05 379 END (* WRITEERRORS *); V41DC05 380 V41DC05 381 PROCEDURE WRITELINE(VAR F : SEGTEXT); V41DC05 382 VAR J : INTEGER; V41DC05 383 BEGIN (* WRITELINE *) V41DC05 384 FOR J := 1 TO LINELENGTH DO WRITE(F,LINE[J]); V41DC05 385 WRITELN(F) V41DC05 386 END (* WRITELINE *); V41DC05 387 V41DC05 388 PROCEDURE PUTERRMSG(MSG: PACKED ARRAY [L..H:INTEGER] OF CHAR; V41DC05 389 WEOL: BOOLEAN); V41DC05 390 BEGIN (* PUTERRMSG *) V41DC05 391 IF LISTINGOPEN THEN V41DC05 392 BEGIN WRITE(LISTING,MSG); V41DC05 393 IF WEOL THEN WRITELN(LISTING) V41DC05 394 END; V41DC05 395 IF ERRFILEOPEN THEN V41DC05 396 BEGIN WRITE(ERRFILE,MSG); V41DC05 397 IF WEOL THEN WRITELN(ERRFILE) V41DC05 398 END V41DC05 399 END (* PUTERRMSG *); V41DC05 400 COMP 983 PROCEDURE (*$E'BEGINLI'*) BEGINLINE; COMP 984 COMP 985 PROCEDURE READLINE( VAR F : TEXT ); COMP 986 BEGIN (* READLINE *) COMP 987 IF DP THEN LINELC := LC ELSE LINELC := IC; COMP 988 LINELENGTH := 0; COMP 989 WHILE NOT EOLN(F) AND (LINELENGTH < MAXLINELEN) DO COMP 990 BEGIN LINELENGTH := LINELENGTH + 1; COMP 991 LINE[LINELENGTH] := F^; COMP 992 GET(F) COMP 993 END COMP 994 END (* READLINE *); COMP 995 COMP 996 BEGIN (* BEGINLINE *) COMP 997 LCHANGED := FALSE; COMP 998 IF ALTERNATEINPUT THEN READLINE(ALTFILE) COMP 999 ELSE IF EOS(SOURCE) THEN COMP 1000 BEGIN FLAGERROR; PUTERRMSG(' INCOMPLETE PROGRAM.',TRUE); V41DC05 401 ERRORS := TRUE; COMP 1003 GOTO 13 COMP 1004 END COMP 1005 ELSE READLINE(SOURCE); COMP 1006 IF LINELENGTH > MAXSRCLEN THEN SOURCELENGTH := MAXSRCLEN COMP 1007 ELSE SOURCELENGTH := LINELENGTH; COMP 1008 CHCNT := 0; COMP 1009 LINESZ := 0; COMP 1010 IF LINENUMBERS COMP 1011 THEN BEGIN NEXTNUM := 0; COMP 1012 WHILE LINE[CHCNT+1] IN DIGITS DO COMP 1013 BEGIN CHCNT := CHCNT + 1; COMP 1014 IF LINESZ < 5 THEN LINESZ := LINESZ + 1; COMP 1015 NEXTNUM := NEXTNUM * 10 MOD 100000 + ORD(LINE[CHCNT]) - ORD('0') COMP 1016 END COMP 1017 END COMP 1018 ELSE IF NOT ALTERNATEINPUT THEN NEXTNUM := SUCC(NEXTNUM) COMP 1019 END (* BEGINLINE *); COMP 1020 COMP 1021 PROCEDURE (*$E'ENDLINE'*) ENDLINE; COMP 1022 VAR I: INTEGER; COMP 1023 COMP 1024 PROCEDURE FLAGSWITCH( B : BOOLEAN ); COMP 1025 BEGIN (* FLAGSWITCH *) COMP 1026 IF LISTON THEN COMP 1027 BEGIN COMP 1028 IF LINESLEFT < 3 THEN HEADING; COMP 1029 LINESLEFT := LINESLEFT - 3; COMP 1030 WRITELN(LISTING); V41DC05 402 WRITE(LISTING,' ------ '); V41DC05 403 IF B THEN WRITE(LISTING,'BEGIN') ELSE WRITE(LISTING,'END'); V41DC05 404 WRITELN(LISTING,' INCLUDED TEXT.'); V41DC05 405 WRITELN(LISTING) V41DC05 406 END COMP 1036 END (* FLAGSWITCH *); COMP 1037 COMP 1038 BEGIN (* ENDLINE *) COMP 1039 IF LISTON OR LCHANGED OR (ERRINX > 0) THEN COMP 1040 BEGIN V41DC05 407 IF LISTINGOPEN THEN V41DC05 408 BEGIN I := 1 + ORD(NOT LISTON AND LCHANGED); V41DC05 409 IF LINESLEFT < I + ORD(ERRINX > 0) THEN HEADING; V41DC05 410 LINESLEFT := LINESLEFT - I; V41DC05 411 IF LISTON OR LCHANGED THEN V41DC05 412 BEGIN WRITE(LISTING,' '); WRITEOCT(LISTING,LINELC,6) END; V41DC05 413 IF NOT LINENUMBERS THEN WRITE(LISTING,' ',NEXTNUM:5); V41DC05 414 WRITE(LISTING,' '); WRITELINE(LISTING) V41DC05 415 END; V41DC05 416 IF ERRINX > 0 THEN V41DC05 417 BEGIN V41DC05 418 IF ERRFILEOPEN THEN V41DC05 419 BEGIN V41DC05 420 IF NOT LINENUMBERS THEN WRITE(ERRFILE,' ',NEXTNUM:5); V41DC05 421 WRITE(ERRFILE,' '); WRITELINE(ERRFILE) V41DC05 422 END; V41DC05 423 WRITEERRORS V41DC05 424 END; V41DC05 425 IF NOT LISTON AND LCHANGED AND LISTINGOPEN THEN V41DC05 426 WRITELN(LISTING) V41DC05 427 END; V41DC05 428 IF ALTERINGINPUT THEN V41DC05 429 BEGIN ALTERINGINPUT := FALSE; V41DC05 430 ALTERNATEINPUT := TRUE; V41DC05 431 ALTLINENUMBERS := LINENUMBERS; V41DC05 432 LINENUMBERS := ALTFILE^ IN DIGITS; V41DC05 433 IF LISTINGOPEN THEN FLAGSWITCH(TRUE) V41DC05 434 END V41DC05 435 ELSE V41DC05 436 IF ALTERNATEINPUT THEN V41DC05 437 BEGIN READLN(ALTFILE); V41DC05 438 IF EOF(ALTFILE) THEN V41DC05 439 BEGIN ALTERNATEINPUT := FALSE; V41DC05 440 LINENUMBERS := ALTLINENUMBERS; V41DC05 441 IF LISTINGOPEN THEN FLAGSWITCH(FALSE); V41DC05 442 READLN(SOURCE) V41DC05 443 END V41DC05 444 END V41DC05 445 ELSE READLN(SOURCE) V41DC05 446 END (* ENDLINE *); COMP 1071 COMP 1072 PROCEDURE ERROR(FERRNR: ERRINDEX); COMP 1073 BEGIN COMP 1074 ERRORS := TRUE; ERLIST[FERRNR] := TRUE; COMP 1075 IF ERRINX = MAXERRPERLINE THEN COMP 1076 BEGIN ERRLIST[ERRINX].NMR := 354; ERLIST[354] := TRUE END COMP 1077 ELSE COMP 1078 BEGIN ERRINX := ERRINX + 1; COMP 1079 ERRLIST[ERRINX].NMR := FERRNR COMP 1080 END; COMP 1081 ERRLIST[ERRINX].POS := CHCNT COMP 1082 END (*ERROR*) ; COMP 1083 COMP 1084 PROCEDURE EXTENSION(FWARNNR: ERRINDEX); COMP 1085 BEGIN COMP 1086 IF STDFLAG THEN ERROR(FWARNNR) COMP 1087 END (* EXTENSION *); COMP 1088 COMP 1089 PROCEDURE OPTIONS( PROCEDURE NEXTCH ); COMP 1090 VAR ENDOPTIONS: BOOLEAN; CH1: CHAR; COMP 1091 SAVELISTON : BOOLEAN; COMP 1092 FILNAME,RECNAME : ALFA; COMP 1093 LINESPRINTED: INTEGER; COMP 1094 DLNG: LANGUAGEKIND; COMP 1095 TEMP: TITLEBUFFER; COMP 1096 COMP 1097 PROCEDURE OPTERROR(FERRNR: ERRINDEX); COMP 1098 BEGIN CHCNT := CHCNT + 1; COMP 1099 ERROR(FERRNR); CHCNT := CHCNT - 1; ENDOPTIONS := TRUE COMP 1100 END (* OPTERROR *); COMP 1101 COMP 1102 PROCEDURE SWITCH( VAR S,OLDS : BOOLEAN ); COMP 1103 BEGIN (* SWITCH *) COMP 1104 IF CH IN ['+','-','='] THEN COMP 1105 BEGIN COMP 1106 IF CH = '=' THEN S := OLDS COMP 1107 ELSE BEGIN OLDS := S; S := CH = '+' END; COMP 1108 NEXTCH COMP 1109 END COMP 1110 ELSE OPTERROR(353) COMP 1111 END (* SWITCH *); COMP 1112 COMP 1113 PROCEDURE NUMBER( VAR N,OLDN : INTEGER; MIN,MAX : INTEGER ); COMP 1114 VAR DIGIT,DEC,OCT : INTEGER; COMP 1115 BEGIN (* NUMBER *) COMP 1116 IF CH IN DIGITS THEN COMP 1117 BEGIN OLDN := N; COMP 1118 DEC := 0; OCT := 0; COMP 1119 REPEAT DIGIT := ORD(CH) - ORD('0'); COMP 1120 NEXTCH; COMP 1121 IF DEC <= MAX THEN DEC := DEC * 10 + DIGIT; COMP 1122 IF (OCT <= MAX) AND (DIGIT <= 7) THEN OCT := OCT * 8 + DIGIT COMP 1123 ELSE OCT := MAX + 1 COMP 1124 UNTIL NOT (CH IN DIGITS); COMP 1125 IF CH = 'B' THEN BEGIN DEC := OCT; NEXTCH END; COMP 1126 IF DEC < MIN THEN N := MIN COMP 1127 ELSE IF DEC > MAX THEN N := MAX COMP 1128 ELSE N := DEC COMP 1129 END COMP 1130 ELSE COMP 1131 IF CH = '=' THEN BEGIN N := OLDN; NEXTCH END COMP 1132 ELSE OPTERROR(353) COMP 1133 END (* NUMBER *); COMP 1134 COMP 1135 PROCEDURE READSTRING(VAR S: PACKED ARRAY [L..H: INTEGER] OF CHAR; COMP 1136 SIZE: INTEGER); COMP 1137 VAR I: INTEGER; COMP 1138 Q: CHAR; COMP 1139 BEGIN (* READSTRING *) COMP 1140 IF ASCII THEN Q := '''' ELSE Q := '#'; COMP 1141 IF CH = Q THEN COMP 1142 BEGIN FOR I := 1 TO H DO S[I] := ' '; COMP 1143 I := 0; COMP 1144 REPEAT NEXTCH; COMP 1145 WHILE (CH <> Q) AND (CHCNT <= SOURCELENGTH) DO COMP 1146 BEGIN IF I < SIZE THEN BEGIN I := I + 1; S[I] := CH END; COMP 1147 NEXTCH COMP 1148 END; COMP 1149 IF CH = Q THEN COMP 1150 BEGIN NEXTCH; COMP 1151 IF (CH = Q) AND (I < SIZE) THEN COMP 1152 BEGIN I := I + 1; S[I] := Q END COMP 1153 END COMP 1154 UNTIL CH <> Q COMP 1155 END COMP 1156 ELSE OPTERROR(353) COMP 1157 END (* READSTRING *); COMP 1158 COMP 1159 PROCEDURE TWOWORDS(VAR W1,W2: ALFA); COMP 1160 BEGIN (* TWOWORDS *) COMP 1161 READSTRING(W1,7); COMP 1162 IF NOT ENDOPTIONS AND (CH = '/') THEN COMP 1163 BEGIN NEXTCH; READSTRING(W2,7) END COMP 1164 END (* TWOWORDS *); COMP 1165 COMP 1166 PROCEDURE MEMORYOPTION; COMP 1167 VAR LCH: CHAR; COMP 1168 BEGIN (* MEMORYOPTION *) COMP 1169 IF CH IN [ COMP 1170 'B', COMP 1171 'D', COMP 1172 'F', COMP 1173 'I', COMP 1174 'R', COMP 1175 'S', COMP 1176 'V', COMP 1177 'X', COMP 1178 'Z' COMP 1179 ] THEN COMP 1180 BEGIN LCH := CH; NEXTCH; COMP 1181 IF LCH = 'B' THEN NUMBER(INITIALSPACE,OLDINITIALSPACE,0,MAXADDR) COMP 1182 ELSE IF LCH = 'D' THEN COMP 1183 BEGIN COMP 1184 IF CH IN ['+','-','='] THEN COMP 1185 SWITCH(ALLOWDECREASE,OLDALLOWDECREASE) COMP 1186 ELSE NUMBER(MINDECREASE,OLDMINDECREASE,0,MAXADDR) COMP 1187 END COMP 1188 ELSE IF LCH = 'F' THEN NUMBER(MAXFL,OLDMAXFL,0,MAXADDR) COMP 1189 ELSE IF LCH = 'I' THEN COMP 1190 BEGIN COMP 1191 IF CH IN ['+','-','='] THEN COMP 1192 SWITCH(ALLOWINCREASE,OLDALLOWINCREASE) COMP 1193 ELSE NUMBER(MININCREASE,OLDMININCREASE,0,MAXADDR) COMP 1194 END COMP 1195 ELSE IF LCH = 'R' THEN SWITCH(INITIALREDUCE,OLDINITIALREDUCE) COMP 1196 ELSE IF LCH = 'S' THEN NUMBER(MSOPTION,OLDMSOPTION,0,MAXADDR) COMP 1197 ELSE IF LCH = 'V' THEN NUMBER(MVOPTION,OLDMVOPTION,2,MAXADDR) COMP 1198 ELSE IF LCH = 'X' THEN NUMBER(MXOPTION,OLDMXOPTION,0,MAXADDR) COMP 1199 ELSE IF LCH = 'Z' THEN SWITCH(MZOPTION,OLDMZOPTION) COMP 1200 END COMP 1201 ELSE OPTERROR(353) COMP 1202 END (* MEMORYOPTION *); COMP 1203 COMP 1204 BEGIN (* OPTIONS *) COMP 1205 ENDOPTIONS := FALSE; COMP 1206 REPEAT NEXTCH; COMP 1207 IF (CH IN [ COMP 1208 'A', COMP 1209 'B', COMP 1210 'D', COMP 1211 'E', COMP 1212 'I', COMP 1213 'L', COMP 1214 'M', COMP 1215 'O', COMP 1216 'P', COMP 1217 'Q', COMP 1218 'S', COMP 1219 'T', COMP 1220 'U', COMP 1221 'X', COMP 1222 'Z' COMP 1223 ]) THEN COMP 1224 BEGIN CH1 := CH; NEXTCH; COMP 1225 IF (CH1 IN ['A','E','I','O','U']) AND (LINENUM <> 0) THEN COMP 1226 EXTENSION(331); COMP 1227 CASE CH1 OF COMP 1228 'A' : SWITCH(ASCII,OLDASCII); COMP 1229 'B' : BEGIN NUMBER(BUFFSZ,OLDBUFFSZ,0,MAXADDR); COMP 1230 IF BUFFSZ < 64 THEN BUFFSZ := BUFFSZ * 128 COMP 1231 END; COMP 1232 'D' : BEGIN READSTRING(LANG[USERDL],10); DLNG := ENGLISH; COMP 1233 WHILE LANG[DLNG] <> LANG[USERDL] DO COMP 1234 DLNG := SUCC(DLNG); COMP 1235 IF DLNG = USERDL THEN ERROR(350) COMP 1236 ELSE LANGUAGE := DLNG COMP 1237 END; COMP 1238 'E' : IF CH IN ['+','-','='] THEN SWITCH(EXTON,OLDEXTON) COMP 1239 ELSE TWOWORDS(EPT1,EPT2); COMP 1240 'I' : BEGIN FILNAME := ' '; COMP 1241 TWOWORDS(RECNAME,FILNAME); COMP 1242 IF NOT ENDOPTIONS THEN COMP 1243 BEGIN COMP 1244 IF NOT EOF(ALTFILE) THEN ERROR(199) COMP 1245 ELSE COMP 1246 BEGIN FIND(ALTFILE,FILNAME,RECNAME); COMP 1247 IF EOF(ALTFILE) THEN ERROR(198) COMP 1248 ELSE ALTERINGINPUT := TRUE COMP 1249 END COMP 1250 END COMP 1251 END; COMP 1252 'L' : IF CH IN ['+','-','='] THEN COMP 1253 BEGIN SAVELISTON := LISTON; COMP 1254 SWITCH(LISTON,OLDLISTON); COMP 1255 LISTON := LISTON AND LISTINGOPEN; V41DC05 447 LCHANGED := LCHANGED OR (LISTON <> SAVELISTON) COMP 1256 END COMP 1257 ELSE COMP 1258 BEGIN COMP 1259 IF CH = 'T' THEN BEGIN CH1 := CH; NEXTCH END; COMP 1260 READSTRING(TEMP,MAXTITLE); COMP 1261 IF NOT ENDOPTIONS THEN (* TITLE PRESENT *) COMP 1262 BEGIN COMP 1263 IF SETTITLE OR (CH1 = 'T') THEN COMP 1264 BEGIN SETTITLE := FALSE; COMP 1265 TITLE := TEMP; SUBTITLE := BLANKTITLE COMP 1266 END COMP 1267 ELSE SUBTITLE := TEMP; COMP 1268 IF LISTON THEN LINESLEFT := 0 COMP 1269 END COMP 1270 END; COMP 1271 'M' : MEMORYOPTION; COMP 1272 'O' : SWITCH(OPTALLOWED,OLDOPTALWD); COMP 1273 'P' : IF CH IN ['+','-','0','='] THEN COMP 1274 BEGIN COMP 1275 IF PMDOPT <> PMDNONE THEN COMP 1276 IF CH = '=' THEN PMDOPT := OLDPMDOPT COMP 1277 ELSE COMP 1278 BEGIN OLDPMDOPT := PMDOPT; COMP 1279 IF CH = '+' THEN PMDOPT := PMDON COMP 1280 ELSE COMP 1281 IF CH = '-' THEN PMDOPT := PMDOFF COMP 1282 ELSE PMDOPT := PMDSUPPRESS COMP 1283 END; COMP 1284 NEXTCH COMP 1285 END COMP 1286 ELSE COMP 1287 IF CH = 'L' THEN COMP 1288 BEGIN NEXTCH; COMP 1289 NUMBER(PRNTLIMIT,OLDPRNTLIMIT,0,MAXINT); COMP 1290 END COMP 1291 ELSE OPTERROR(353); COMP 1292 'Q' : SWITCH(QUICKMODE,OLDQUICKMODE); COMP 1293 'S' : SWITCH(STDFLAG,OLDSTDFLAG); COMP 1294 'T' : SWITCH(DEBUG,OLDDEBUG); COMP 1295 'U' : BEGIN COMP 1296 IF CH IN ['+','-'] THEN COMP 1297 BEGIN OLDMAXSL := MAXSRCLEN; COMP 1298 IF CH = '+' THEN MAXSRCLEN := 72 COMP 1299 ELSE MAXSRCLEN := MAXLINELEN; COMP 1300 NEXTCH COMP 1301 END COMP 1302 ELSE NUMBER(MAXSRCLEN,OLDMAXSL,10,MAXLINELEN); COMP 1303 IF NOT ENDOPTIONS THEN COMP 1304 IF LINELENGTH > MAXSRCLEN THEN COMP 1305 SOURCELENGTH := MAXSRCLEN COMP 1306 ELSE SOURCELENGTH := LINELENGTH COMP 1307 END; COMP 1308 'X' : NUMBER(XPARMAX,OLDXPARMAX,0,MAXPARAMSINREGS); COMP 1309 'Z' : SWITCH(ISSUESTAT,OLDISSUSTAT); COMP 1310 END; COMP 1311 ENDOPTIONS := ENDOPTIONS OR (CH <> ',') COMP 1312 END COMP 1313 ELSE OPTERROR(352) COMP 1314 UNTIL ENDOPTIONS; COMP 1315 END (*OPTIONS*); COMP 1316 COMP 1317 PROCEDURE INSYMBOL; COMP 1318 (* READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS DESCRIPTION COMP 1319 IN THE GLOBAL VARIABLES: SY, OP, ID, IVAL, RVAL, CONSTP, LGTH *) COMP 1320 LABEL 1,2; COMP 1321 CONST LIM1 = 322; (* MAXIMUM EXPONENT *) COMP 1322 LIM2 = -292; (* MINIMUM EXPONENT *) COMP 1323 T29 = 4000000000B; (* 2**29 *) COMP 1324 T30 = 10000000000B; (* 2**30 *) COMP 1325 SEVENBLANKS = ' '; COMP 1326 VAR D,DCOUNT,ECOUNT,I,K,SCALE,EXP,T: INTEGER; COMP 1327 UPPERD,LOWERD,UPPERB,LOWERB,UPPERR,LOWERR: INTEGER; COMP 1328 SIGN,BADB: BOOLEAN; COMP 1329 T1,T2,T3: DOUBLE; COMP 1330 APO,STRINGEND: BOOLEAN; NXTP,TAILP: CTAILP; Q: CHAR; COMP 1331 OA: RECORD COMP 1332 CASE BOOLEAN OF COMP 1333 FALSE: (A: ALFA); COMP 1334 TRUE: (I: INTEGER) COMP 1335 END; COMP 1336 DOT,STARTCMT,UL: BOOLEAN; V41CC18 11 LCH: CHAR; V41CC18 12 BEGIN (* INSYMBOL *) COMP 1339 SETLINENUM := SETLINENUM OR (LINENUM <> NEXTNUM); COMP 1340 LINENUM := NEXTNUM; COMP 1341 1: OP := NOOP; COMP 1342 CASE CH OF COMP 1343 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', COMP 1344 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z': COMP 1345 BEGIN K := 0; ID.TEN := TENBLANKS; SY := IDENT; COMP 1346 UL := FALSE; LCH := ' '; V41CC18 13 REPEAT K := K + 1; COMP 1347 ID.TEN[K] := CH; COMP 1348 IF CH = '_' THEN V41CC18 14 BEGIN UL := TRUE; V41CC18 15 IF (LCH = '_') AND (OPTS.DIALECT = P6000) THEN ERROR(23) V41DC05 448 END; V41CC18 17 LCH := CH; V41CC18 18 CHCNT := CHCNT + 1; COMP 1349 IF CHCNT > SOURCELENGTH THEN CH := ' ' COMP 1350 ELSE CH := LINE[CHCNT] COMP 1351 UNTIL (K = ALFALENG) OR NOT (CH IN ['A'..'Z','0'..'9','_']); V41CC18 19 IF CH IN ['A'..'Z','0'..'9','_'] THEN (*EXTRA IDSEGMENTS NEEDED*) V41CC18 20 BEGIN I := 0; ID.EXT := IDSTART; IDEND^.EXTRA := IDBREAK; COMP 1354 IDEND := IDSTART; IDEND^.SEVEN := SEVENBLANKS; COMP 1355 REPEAT COMP 1356 IF I = IDNAMEEXTLEN THEN (* NEXT IDSEGMENT *) COMP 1357 BEGIN IDEND := IDEND^.EXTRA; COMP 1358 I := 0; IDEND^.SEVEN := SEVENBLANKS; COMP 1359 END; COMP 1360 I := I + 1; IDEND^.SEVEN[I] := CH; COMP 1361 IF CH = '_' THEN V41CC18 21 BEGIN UL := TRUE; V41CC18 22 IF (LCH = '_') AND (OPTS.DIALECT = P6000) THEN ERROR(23) V41DC05 449 END; V41CC18 24 LCH := CH; V41CC18 25 CHCNT := CHCNT + 1; COMP 1362 IF CHCNT > SOURCELENGTH THEN CH := ' ' COMP 1363 ELSE CH := LINE[CHCNT] COMP 1364 UNTIL NOT (CH IN ['A'..'Z','0'..'9','_']); V41CC18 26 IDBREAK := IDEND^.EXTRA; IDEND^.EXTRA := NIL; COMP 1366 END COMP 1367 ELSE COMP 1368 BEGIN ID.EXT := NIL; COMP 1369 IF ID.TEN[1] IN FLRW[K] THEN COMP 1370 FOR I := LRW[K-1] + 1 TO LRW[K] DO COMP 1371 IF RW[I] = ID.TEN THEN COMP 1372 BEGIN SY := RSY[I]; V41AC20 15 IF (SY IN NONSTANDSYS) AND (OPTS.DIALECT <> P6000) THEN V41DC05 450 BEGIN SY := IDENT; OP := NOOP END V41AC20 17 ELSE OP := ROP[I]; V41AC20 18 GOTO 2 V41AC20 19 END V41AC20 20 END; COMP 1374 IF UL THEN V41CC18 27 IF OPTS.DIALECT IN [ISO0,ISO1,ANSI] THEN ERROR(24) V41DC05 451 ELSE V41CC18 29 BEGIN IF LCH = '_' THEN ERROR(23); V41CC18 30 EXTENSION(335) V41CC18 31 END; V41CC18 32 2: END; COMP 1375 '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': COMP 1376 BEGIN SY := INTCONST; COMP 1377 DCOUNT := 0; COMP 1378 UPPERD := 0; LOWERD := 0; COMP 1379 UPPERB := 0; LOWERB := 0; COMP 1380 UPPERR := 0; LOWERR := 0; COMP 1381 SCALE := 0; COMP 1382 BADB := FALSE; COMP 1383 REPEAT D := ORD(CH) - ORD('0'); COMP 1384 BADB := BADB OR NOT (CH IN ['0'..'7']); COMP 1385 LOWERD := LOWERD * 10 + D; COMP 1386 T := LOWERD DIV T30; COMP 1387 LOWERD := LOWERD - T * T30; COMP 1388 IF UPPERD < T30 THEN UPPERD := UPPERD * 10 + T; COMP 1389 LOWERB := LOWERB * 8 + D; COMP 1390 T := LOWERB DIV T30; COMP 1391 LOWERB := LOWERB - T * T30; COMP 1392 IF UPPERB < T30 THEN UPPERB := UPPERB * 8 + T; COMP 1393 IF DCOUNT < 28 THEN COMP 1394 BEGIN COMP 1395 IF DCOUNT < 14 THEN UPPERR := UPPERR * 10 + D COMP 1396 ELSE LOWERR := LOWERR * 10 + D; COMP 1397 IF (D <> 0) OR (DCOUNT <> 0) THEN DCOUNT := DCOUNT + 1 COMP 1398 END COMP 1399 ELSE SCALE := SCALE + 1; COMP 1400 NEXTCH COMP 1401 UNTIL NOT (CH IN DIGITS); COMP 1402 IVAL := 0; COMP 1403 IF (CH = 'B') AND (OPTS.DIALECT = P6000) THEN (* OCTAL CONST *) V41DC05 452 BEGIN NEXTCH; COMP 1405 EXTENSION(321); COMP 1406 IF BADB THEN ERROR(204) COMP 1407 ELSE COMP 1408 IF UPPERB >= T30 THEN ERROR(203) COMP 1409 ELSE IVAL := UPPERB * T30 + LOWERB COMP 1410 END COMP 1411 ELSE (* DECIMAL INTEGER OR REAL *) COMP 1412 BEGIN COMP 1413 DOT := CH = '.'; COMP 1414 IF DOT AND (CHCNT < SOURCELENGTH) THEN COMP 1415 DOT := LINE[CHCNT+1] IN DIGITS; COMP 1416 IF DOT OR (CH = 'E') THEN (* REAL NUMBER *) COMP 1417 BEGIN SY := REALCONST; COMP 1418 IF CH = '.' THEN (* GATHER FRACTION *) COMP 1419 BEGIN NEXTCH; COMP 1420 IF NOT (CH IN DIGITS) THEN ERROR(201) COMP 1421 ELSE COMP 1422 REPEAT D := ORD(CH) - ORD('0'); COMP 1423 IF DCOUNT < 28 THEN COMP 1424 BEGIN SCALE := SCALE - 1; COMP 1425 IF DCOUNT < 14 THEN UPPERR := UPPERR * 10 + D COMP 1426 ELSE LOWERR := LOWERR * 10 + D; COMP 1427 IF (D <> 0) OR (DCOUNT <> 0) THEN DCOUNT := DCOUNT + 1 COMP 1428 END; COMP 1429 NEXTCH COMP 1430 UNTIL NOT (CH IN DIGITS) COMP 1431 END; COMP 1432 IF CH = 'E' THEN (* GATHER EXPONENT *) COMP 1433 BEGIN NEXTCH; COMP 1434 IF CH IN ['+','-'] THEN COMP 1435 BEGIN SIGN := CH = '-'; NEXTCH END COMP 1436 ELSE SIGN := FALSE; COMP 1437 EXP := 0; ECOUNT := 0; COMP 1438 IF NOT (CH IN DIGITS) THEN ERROR(201) COMP 1439 ELSE COMP 1440 REPEAT D := ORD(CH) - ORD('0'); COMP 1441 IF ECOUNT < 14 THEN COMP 1442 BEGIN EXP := EXP * 10 + D; COMP 1443 IF (D <> 0) OR (ECOUNT <> 0) THEN ECOUNT := ECOUNT + 1 COMP 1444 END; COMP 1445 NEXTCH COMP 1446 UNTIL NOT (CH IN DIGITS); COMP 1447 IF SIGN THEN SCALE := SCALE - EXP ELSE SCALE := SCALE + EXP COMP 1448 END; COMP 1449 T1.UPPER := UPPERR; T1.LOWER := 0.0; COMP 1450 IF DCOUNT > 14 THEN COMP 1451 BEGIN T2.UPPER := LOWERR; T2.LOWER := 0.0; COMP 1452 TEN(T3,DCOUNT - 14); COMP 1453 DMUL(T1,T3,T1); COMP 1454 DADD(T1,T1,T2) COMP 1455 END; COMP 1456 EXP := SCALE + DCOUNT; COMP 1457 IF (EXP < LIM2) OR (EXP > LIM1) THEN COMP 1458 BEGIN T1.UPPER := 0.0; T1.LOWER := 0.0; SCALE := 0; COMP 1459 IF EXP > LIM1 THEN ERROR(207) COMP 1460 END; COMP 1461 TEN(T2,ABS(SCALE)); COMP 1462 IF SCALE < 0 THEN DDIV(T1,T1,T2) COMP 1463 ELSE COMP 1464 IF SCALE <> 0 THEN DMUL(T1,T1,T2); COMP 1465 RVAL := T1.UPPER + T1.LOWER COMP 1466 END (* REAL NUMBER *) COMP 1467 ELSE (* INTEGER NUMBER *) COMP 1468 IF UPPERD >= T29 THEN ERROR(203) COMP 1469 ELSE COMP 1470 BEGIN IVAL := UPPERD * T30 + LOWERD; COMP 1471 IF UPPERD > (MAXINT DIV T30) THEN V41AC20 22 IF OPTS.DIALECT = P6000 THEN EXTENSION(322) V41DC05 453 ELSE ERROR(203) V41AC20 24 END COMP 1473 END; COMP 1474 IF CH IN ['A'..'Z'] THEN ERROR(50) COMP 1475 END; COMP 1476 COL, PER: (* CHR(00B) AND CHR(63B) *) COMP 1477 BEGIN NEXTCH; COMP 1478 IF CH = '=' THEN COMP 1479 BEGIN SY := BECOMES; NEXTCH END COMP 1480 ELSE SY := COLON COMP 1481 END; COMP 1482 ' ': COMP 1483 BEGIN COMP 1484 REPEAT CHCNT := CHCNT + 1; COMP 1485 IF CHCNT > SOURCELENGTH THEN COMP 1486 BEGIN ENDLINE; BEGINLINE; CH := ' ' END COMP 1487 ELSE CH := LINE[CHCNT] COMP 1488 UNTIL CH <> ' '; COMP 1489 GOTO 1 COMP 1490 END; COMP 1491 '#', '''': COMP 1492 IF ASCII = (CH = '''') THEN (* QUOTE CHARACTER *) COMP 1493 BEGIN Q := CH; COMP 1494 APO := FALSE; STRINGEND := FALSE; COMP 1495 LGTH := 0; I := 0; CONSTP := NIL; COMP 1496 OA.I := 0; (* GUARANTEE ZEROS IN UNUSED BITS *) COMP 1497 NEXTCH; COMP 1498 REPEAT COMP 1499 IF CHCNT > SOURCELENGTH THEN COMP 1500 BEGIN ERROR(202); STRINGEND := TRUE END COMP 1501 ELSE COMP 1502 IF (CH <> Q) OR APO THEN COMP 1503 BEGIN COMP 1504 IF I = ALFALENG THEN COMP 1505 BEGIN MNEW(TAILP); COMP 1506 WITH TAILP^ DO COMP 1507 BEGIN NXTCSP := CONSTP; CSVAL := OA.I END; COMP 1508 CONSTP := TAILP; I := 0; OA.I := 0 COMP 1509 END; COMP 1510 I := I + 1; LGTH := LGTH + 1; APO := FALSE; COMP 1511 OA.A[I] := CH; COMP 1512 NEXTCH COMP 1513 END COMP 1514 ELSE COMP 1515 BEGIN APO := TRUE; COMP 1516 NEXTCH; STRINGEND := CH <> Q COMP 1517 END COMP 1518 UNTIL STRINGEND; COMP 1519 SY := STRINGCONST; COMP 1520 IF LGTH = 0 THEN ERROR(205) COMP 1521 ELSE COMP 1522 IF LGTH = 1 THEN COMP 1523 BEGIN SY := CHARCONST; IVAL := ORD(OA.A[1]) END COMP 1524 ELSE COMP 1525 BEGIN MNEW(TAILP); COMP 1526 WITH TAILP^ DO COMP 1527 BEGIN NXTCSP := CONSTP; CSVAL := OA.I END; COMP 1528 (*REVERSE POINTERS:*) COMP 1529 CONSTP := NIL; COMP 1530 WHILE TAILP <> NIL DO COMP 1531 WITH TAILP^ DO COMP 1532 BEGIN NXTP := NXTCSP; NXTCSP := CONSTP; COMP 1533 CONSTP := TAILP; TAILP := NXTP COMP 1534 END; COMP 1535 END COMP 1536 END COMP 1537 ELSE COMP 1538 BEGIN COMP 1539 IF ASCII THEN (* '#' IS A BAD CHARACTER *) COMP 1540 SY := OTHERSY COMP 1541 ELSE (* '''' IS A ARROW *) COMP 1542 SY := ARROW; COMP 1543 NEXTCH COMP 1544 END; COMP 1545 '.': COMP 1546 BEGIN NEXTCH; COMP 1547 IF CH = '.' THEN COMP 1548 BEGIN SY := DOTDOT; NEXTCH END COMP 1549 ELSE IF CH = ')' THEN COMP 1550 BEGIN SY := RBRACK; NEXTCH END COMP 1551 ELSE SY := PERIOD COMP 1552 END; COMP 1553 '(': COMP 1554 BEGIN NEXTCH; COMP 1555 IF CH = '*' THEN COMP 1556 BEGIN NEXTCH; COMP 1557 IF (CH = '$') AND OPTALLOWED THEN OPTIONS(NEXTCH); COMP 1558 STARTCMT := FALSE; COMP 1559 REPEAT COMP 1560 IF STARTCMT THEN ERROR(351); COMP 1561 REPEAT COMP 1562 (*LOOP UNTIL CH IN ['*','(']:*) COMP 1563 WHILE NOT (CH IN ['*','(']) DO NEXTCH; COMP 1564 STARTCMT := CH = '('; COMP 1565 IF STARTCMT THEN NEXTCH COMP 1566 UNTIL CH = '*'; COMP 1567 NEXTCH COMP 1568 UNTIL CH = ')'; COMP 1569 NEXTCH; GOTO 1 COMP 1570 END; COMP 1571 IF CH = '.' THEN COMP 1572 BEGIN SY := LBRACK; NEXTCH END COMP 1573 ELSE SY := LPARENT; COMP 1574 END; COMP 1575 '<': COMP 1576 BEGIN NEXTCH; SY := RELOP; COMP 1577 IF CH = '=' THEN COMP 1578 BEGIN OP := LEOP; NEXTCH END COMP 1579 ELSE COMP 1580 IF CH = '>' THEN COMP 1581 BEGIN OP := NEOP; NEXTCH END COMP 1582 ELSE OP := LTOP COMP 1583 END; COMP 1584 '>': COMP 1585 BEGIN NEXTCH; SY := RELOP; COMP 1586 IF CH = '=' THEN COMP 1587 BEGIN OP := GEOP; NEXTCH END COMP 1588 ELSE OP := GTOP COMP 1589 END; COMP 1590 '+', '-', '*', '/', ')', '$', '=', ',', '[', COMP 1591 ']', '"', '_', '!', '&', '?', '@', '\', '^', ';': COMP 1592 BEGIN SY := SSY[ASCII,CH]; OP := SOP[CH]; NEXTCH END COMP 1593 END (* CASE *) COMP 1594 END (* INSYMBOL *); COMP 1595 (*$L'SYMBOL / STRUCTURE TABLE PROCESSORS.' *) COMP 1596 COMP 1597 COMP 1598 PROCEDURE WRITEID(NAME: IDNAME); COMP 1599 V41DC05 454 PROCEDURE PUTID(VAR F : SEGTEXT); V41DC05 455 VAR S : IDSEGMENT; V41DC05 456 BEGIN (* PUTID *) V41DC05 457 WRITE(F,NAME.TEN); S := NAME.EXT; V41DC05 458 WHILE S <> NIL DO V41DC05 459 BEGIN WRITE(F,S^.SEVEN); S := S^.EXTRA END; V41DC05 460 WRITELN(F) V41DC05 461 END (* PUTID *); V41DC05 462 V41DC05 463 BEGIN (* WRITEID *) V41DC05 464 IF LISTINGOPEN THEN PUTID(LISTING); V41DC05 465 IF ERRFILEOPEN THEN PUTID(ERRFILE) V41DC05 466 END (* WRITEID *); COMP 1606 COMP 1607 FUNCTION COMPAREEXTENSIONS(FXP1, FXP2: IDSEGMENT): ORDERING; COMP 1608 BEGIN COMP 1609 WHILE (FXP1 <> NIL) AND (FXP2 <> NIL) DO COMP 1610 IF FXP1^.SEVEN < FXP2^.SEVEN THEN FXP1 := NIL COMP 1611 ELSE COMP 1612 IF FXP1^.SEVEN > FXP2^.SEVEN THEN FXP2 := NIL COMP 1613 ELSE COMP 1614 BEGIN FXP1 := FXP1^.EXTRA; FXP2 := FXP2^.EXTRA END; COMP 1615 IF FXP1 = FXP2 THEN COMPAREEXTENSIONS := EQUALTO COMP 1616 ELSE COMP 1617 IF FXP1 = NIL THEN COMPAREEXTENSIONS := LESSTHAN COMP 1618 ELSE COMPAREEXTENSIONS := GREATERTHAN COMP 1619 END (* COMPAREEXTENSIONS *); COMP 1620 COMP 1621 FUNCTION COMPAREIDS(FID1,FID2: IDNAME): ORDERING; COMP 1622 BEGIN (* COMPAREIDS *) COMP 1623 IF FID1.TEN < FID2.TEN THEN COMPAREIDS := LESSTHAN COMP 1624 ELSE COMP 1625 IF FID1.TEN > FID2.TEN THEN COMPAREIDS := GREATERTHAN COMP 1626 ELSE COMPAREIDS := COMPAREEXTENSIONS(FID1.EXT,FID2.EXT) COMP 1627 END (* COMPAREIDS *); COMP 1628 COMP 1629 PROCEDURE COPYID(VAR FCP: CTP); COMP 1630 (*COPY (AND ALLOCATE DYNAMIC STORAGE IF NECESSARY) ID INTO THE LCP COMP 1631 WHICH WILL EVENTUALLY BE PLACED IN THE SYMBOL TABLE BY ENTERID. COMP 1632 UNFORTUNATELY THE COPY CANNOT BE MADE BY ENTERID INSTEAD. *) COMP 1633 VAR S1,S2: IDSEGMENT; COMP 1634 BEGIN FCP^.NAME := ID; COMP 1635 IF ID.EXT <> NIL THEN (* COPY SEGMENTS *) COMP 1636 BEGIN MNEW(S2); S1 := ID.EXT; FCP^.NAME.EXT := S2; COMP 1637 S2^.SEVEN := S1^.SEVEN; S1 := S1^.EXTRA; COMP 1638 WHILE S1 <> NIL DO COMP 1639 BEGIN MNEW(S2^.EXTRA); S2 := S2^.EXTRA; COMP 1640 S2^.SEVEN := S1^.SEVEN; S1 := S1^.EXTRA COMP 1641 END; COMP 1642 S2^.EXTRA := NIL COMP 1643 END COMP 1644 END (* COPYID *); COMP 1645 COMP 1646 PROCEDURE ENTERID(FCP: CTP; FREGION: WHERE); COMP 1647 (*ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE, COMP 1648 WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS COMP 1649 AN UNBALANCED BINARY TREE*) COMP 1650 VAR NAM: IDNAME; LCP, LCP1: CTP; LLEFT, CONFLICT: BOOLEAN; COMP 1651 LLEV, LLEV1: DISPRANGE; COMP 1652 COMP 1653 PROCEDURE CHECKFWPTR(FCP: CTP); COMP 1654 BEGIN COMP 1655 WHILE FCP <> NIL DO COMP 1656 BEGIN IF COMPAREIDS(FCP^.NAME,NAM) = EQUALTO THEN CONFLICT := TRUE; COMP 1657 FCP := FCP^.NEXT COMP 1658 END COMP 1659 END (* CHECKFWPTR *); COMP 1660 COMP 1661 PROCEDURE SEARCHNAM(FCP: CTP; VAR FCP1: CTP); COMP 1662 BEGIN COMP 1663 FCP1 := NIL; COMP 1664 WHILE FCP <> NIL DO COMP 1665 CASE COMPAREIDS(FCP^.NAME,NAM) OF COMP 1666 LESSTHAN : FCP := FCP^.RLINK; COMP 1667 EQUALTO : BEGIN FCP1 := FCP; FCP := NIL END; COMP 1668 GREATERTHAN: FCP := FCP^.LLINK COMP 1669 END COMP 1670 END (* SEARCHNAM *); COMP 1671 COMP 1672 BEGIN (* ENTERID *) COMP 1673 CONFLICT := FALSE; NAM := FCP^.NAME; COMP 1674 CHECKFWPTR(FWPTR); LLEV := TOP; COMP 1675 WHILE FREGION <> DISPLAY[LLEV].REGION DO COMP 1676 WITH DISPLAY[LLEV] DO COMP 1677 BEGIN IF REGION = DREC THEN CHECKFWPTR(FFWPTR); COMP 1678 SEARCHNAM(FNAME,LCP); COMP 1679 IF LCP <> NIL THEN CONFLICT := TRUE; COMP 1680 LLEV := LLEV - 1 COMP 1681 END; COMP 1682 LLEV1 := LLEV; COMP 1683 WHILE LLEV > 0 DO COMP 1684 BEGIN LLEV := LLEV - 1; COMP 1685 SEARCHNAM(DISPLAY[LLEV].FNAME,LCP); COMP 1686 IF LCP <> NIL THEN COMP 1687 BEGIN COMP 1688 IF LCP^.LASTUSESCOPE >= THISSCOPE THEN CONFLICT := TRUE; COMP 1689 LLEV := 0 COMP 1690 END COMP 1691 END; COMP 1692 LCP := DISPLAY[LLEV1].FNAME; COMP 1693 IF LCP = NIL THEN COMP 1694 DISPLAY[LLEV1].FNAME := FCP COMP 1695 ELSE COMP 1696 BEGIN COMP 1697 REPEAT LCP1 := LCP; COMP 1698 CASE COMPAREIDS(LCP^.NAME,NAM) OF COMP 1699 LESSTHAN: COMP 1700 BEGIN LCP := LCP^.RLINK; LLEFT := FALSE END; COMP 1701 EQUALTO: (* NAME CONFLICT--FOLLOW RIGHT LINK *) COMP 1702 BEGIN ERROR(101); LCP := LCP^.RLINK; LLEFT := FALSE END; COMP 1703 GREATERTHAN: COMP 1704 BEGIN LCP := LCP^.LLINK; LLEFT := TRUE END; COMP 1705 END COMP 1706 UNTIL LCP = NIL; COMP 1707 IF LLEFT THEN LCP1^.LLINK := FCP ELSE LCP1^.RLINK := FCP COMP 1708 END; COMP 1709 FCP^.LLINK := NIL; FCP^.RLINK := NIL; COMP 1710 FCP^.LASTUSESCOPE := 0; COMP 1711 IF CONFLICT THEN ERROR(190); COMP 1712 END (*ENTERID*) ; COMP 1713 COMP 1714 PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP); COMP 1715 (*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S' COMP 1716 --> PROCEDURE PROCEDUREDECLARATION COMP 1717 --> PROCEDURE SELECTOR*) COMP 1718 LABEL 1; COMP 1719 BEGIN COMP 1720 WHILE FCP <> NIL DO COMP 1721 CASE COMPAREIDS(FCP^.NAME,ID) OF COMP 1722 LESSTHAN : FCP := FCP^.RLINK; COMP 1723 EQUALTO : GOTO 1; COMP 1724 GREATERTHAN: FCP := FCP^.LLINK COMP 1725 END; COMP 1726 1: FCP1 := FCP COMP 1727 END (*SEARCHSECTION*) ; COMP 1728 COMP 1729 PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP); COMP 1730 LABEL 1; COMP 1731 VAR LCP: CTP; LDISX: DISPRANGE; COMP 1732 BEGIN COMP 1733 FOR LDISX := TOP DOWNTO -1 DO COMP 1734 BEGIN LCP := DISPLAY[LDISX].FNAME; COMP 1735 WHILE LCP <> NIL DO (* IN-LINE COMPAREIDS *) COMP 1736 IF LCP^.NAME.TEN < ID.TEN THEN LCP := LCP^.RLINK COMP 1737 ELSE COMP 1738 IF LCP^.NAME.TEN > ID.TEN THEN LCP := LCP^.LLINK COMP 1739 ELSE COMP 1740 CASE COMPAREEXTENSIONS(LCP^.NAME.EXT,ID.EXT) OF COMP 1741 LESSTHAN: COMP 1742 LCP := LCP^.RLINK; COMP 1743 EQUALTO: COMP 1744 IF LCP^.KLASS IN FIDCLS THEN COMP 1745 BEGIN IF LDISX = -1 THEN EXTENSION(320); COMP 1746 LCP^.LASTUSESCOPE := THISSCOPE; GOTO 1 COMP 1747 END COMP 1748 ELSE COMP 1749 BEGIN IF NOT (UNKNOWNID IN FIDCLS) THEN ERROR(103); COMP 1750 LCP := LCP^.RLINK COMP 1751 END; COMP 1752 GREATERTHAN: COMP 1753 LCP := LCP^.LLINK COMP 1754 END (* CASE *) COMP 1755 END; COMP 1756 LDISX := 0; COMP 1757 (*SEARCH NOT SUCCESSFUL; SUPPRESS ERROR MESSAGE IN CASE COMP 1758 OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION COMP 1759 OR VARIANTS WITHOUT TAGFIELDS COMP 1760 --> PROCEDURE FIELDLIST COMP 1761 --> PROCEDURE SIMPLETYPE*) COMP 1762 IF NOT (UNKNOWNID IN FIDCLS) THEN COMP 1763 BEGIN ERROR(104); COMP 1764 (*TO AVOID RETURNING NIL, REFERENCE AN ENTRY COMP 1765 FOR AN UNDECLARED ID OF APPROPRIATE CLASS COMP 1766 --> PROCEDURE ENTERUNDECL*) COMP 1767 IF TYPES IN FIDCLS THEN LCP := UTYPPTR COMP 1768 ELSE COMP 1769 IF VARS IN FIDCLS THEN LCP := UVARPTR COMP 1770 ELSE COMP 1771 IF FIELD IN FIDCLS THEN LCP := UFLDPTR COMP 1772 ELSE COMP 1773 IF KONST IN FIDCLS THEN LCP := UCSTPTR COMP 1774 ELSE COMP 1775 IF PROC IN FIDCLS THEN LCP := UPRCPTR COMP 1776 ELSE LCP := UFCTPTR; COMP 1777 END; COMP 1778 1: FCP := LCP; DISX := LDISX COMP 1779 END (*SEARCHID*) ; COMP 1780 V41CC07 35 PROCEDURE DISPOSEID(FCP: CTP); V41CC07 36 VAR LXP1, LXP2: IDSEGMENT; V41CC07 37 BEGIN (* DISPOSEID *) V41CC07 38 LXP1 := FCP^.NAME.EXT; V41CC07 39 WHILE LXP1 <> NIL DO V41CC07 40 BEGIN V41CC07 41 LXP2 := LXP1^.EXTRA; V41CC07 42 DISPOSE(LXP1); V41CC07 43 LXP1 := LXP2 V41CC07 44 END; V41CC07 45 DISPOSE(FCP) V41CC07 46 END (* DISPOSEID *) ; V41CC07 47 COMP 1781 PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER); COMP 1782 (* GET INTERNAL BOUNDS OF ORDINAL TYPE *) COMP 1783 (* ASSUME FSP <> REALPTR *) COMP 1784 BEGIN COMP 1785 IF FSP <> NIL THEN COMP 1786 WITH FSP^ DO COMP 1787 IF FORM = SUBRANGE THEN COMP 1788 BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END COMP 1789 ELSE COMP 1790 BEGIN FMIN := 0; FMAX := 0; COMP 1791 IF FORM = SCALAR THEN COMP 1792 BEGIN COMP 1793 IF SCALKIND = PREDECLARED THEN COMP 1794 BEGIN COMP 1795 IF FSP = CHARPTR THEN COMP 1796 BEGIN FMIN := MINORDCH; FMAX := MAXORDCH END COMP 1797 ELSE COMP 1798 IF FSP = INTPTR THEN COMP 1799 BEGIN FMIN := -MAXINT; FMAX := MAXINT END COMP 1800 END COMP 1801 ELSE COMP 1802 IF FSP^.FCONST <> NIL THEN COMP 1803 FMAX := FSP^.FCONST^.VALUES.IVAL COMP 1804 END COMP 1805 END COMP 1806 END (*GETBOUNDS*); COMP 1807 COMP 1808 FUNCTION NROFBITS(FVAL: INTEGER): INTEGER; COMP 1809 (*COMPUTE NUMBER OF BITS NECESSARY TO REPRESENT 0..FVAL*) COMP 1810 VAR B: INTEGER; COMP 1811 BEGIN B := 0; COMP 1812 REPEAT FVAL := FVAL DIV 2; B := B + 1 COMP 1813 UNTIL FVAL = 0; COMP 1814 NROFBITS := B COMP 1815 END (*NROFBITS*); COMP 1816 COMP 1817 PROCEDURE SKIP(FSYS: SETOFSYS); COMP 1818 (*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*) COMP 1819 BEGIN WHILE NOT (SY IN FSYS) DO INSYMBOL COMP 1820 END (*SKIP*) ; COMP 1821 COMP 1822 PROCEDURE EXPECTSYMBOL(FSY: SYMBOL; FERR: ERRINDEX); COMP 1823 BEGIN IF SY = FSY THEN INSYMBOL ELSE ERROR(FERR) COMP 1824 END (* EXPECTSYMBOL *); COMP 1825 COMP 1826 PROCEDURE CHECKCONTEXT(FSYS1:SETOFSYS; FERR:ERRINDEX; FSYS2:SETOFSYS); COMP 1827 BEGIN COMP 1828 IF NOT (SY IN FSYS1) THEN COMP 1829 BEGIN ERROR(FERR); SKIP(FSYS1+FSYS2) END COMP 1830 END (* CHECKCONTEXT *); COMP 1831 (*$L'PROCEDURE / FUNCTION BLOCK PROCESSOR.' *) COMP 1832 COMP 1833 COMP 1834 PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP); COMP 1835 VAR LSY: SYMBOL; FLABP: LBP; LFSTCSP: CSP; COMP 1836 LFORWCNT: INTEGER; COMP 1837 PMD: PMDKIND; COMP 1838 BLOCKSCOPE: SCOPERANGE; COMP 1839 INORDER,EXITLOOP: BOOLEAN; COMP 1840 COMP 1841 PROCEDURE CHECKFORW(FCP: CTP); V41CC20 12 (*PRINT ERROR MESSAGE FOR FORWARD DECLARED PROCEDURE*) V41CC20 13 BEGIN V41CC20 14 IF FCP <> NIL THEN V41CC20 15 WITH FCP^ DO V41CC20 16 BEGIN V41CC20 17 IF KLASS IN [PROC,FUNC] THEN V41CC20 18 IF PFKIND = ACTUAL THEN V41CC20 19 IF PFDECL = FORWDECL THEN V41CC20 20 BEGIN PFDECL := FORWDECLERR; ERROR(117); V41CC20 21 FLAGERROR; PUTERRMSG(' UNDECLARED PROCEDURE: ',FALSE); V41DC05 467 WRITEID(NAME) V41DC05 468 END; V41CC20 24 CHECKFORW(LLINK); CHECKFORW(RLINK) V41CC20 25 END V41CC20 26 END (*CHECKFORW*); V41CC20 27 COMP 1858 FUNCTION FULLWORDS(FSIZE: WBSIZE) : INTEGER; COMP 1859 BEGIN COMP 1860 WITH FSIZE DO FULLWORDS := WORDS + ORD(BITS <> 0) COMP 1861 END (*FULLWORDS*) ; COMP 1862 COMP 1863 FUNCTION CONFORMARRAY(FSP: STP): BOOLEAN; COMP 1864 (* DETERMINE IF STRUCTURE POINTED TO BY FSP IS CONFORMANT ARRAY. *) COMP 1865 BEGIN CONFORMARRAY := FALSE; COMP 1866 IF FSP <> NIL THEN COMP 1867 WITH FSP^ DO COMP 1868 IF FORM = ARRAYS THEN COMP 1869 IF CONFORMANT THEN CONFORMARRAY := TRUE COMP 1870 END (* CONFORMARRAY *); COMP 1871 COMP 1872 FUNCTION EMPTYCNF(FSP: STP): BOOLEAN; COMP 1873 (* DETERMINE IF STRUCTURE POINTED TO BY FSP HAS EMPTY ARRAY COMP 1874 ELEMENTS. ASSUMES FSP POINTS TO CONFORMANT ARRAY SCHEMA. *) COMP 1875 BEGIN EMPTYCNF := TRUE; COMP 1876 WHILE CONFORMARRAY(FSP) DO FSP := FSP^.AELTYPE; COMP 1877 IF FSP <> NIL THEN COMP 1878 EMPTYCNF := FULLWORDS(FSP^.SIZE) = 0 COMP 1879 END (* EMPTYCNF *); COMP 1880 COMP 1881 FUNCTION COMPTYPES(FSP1,FSP2: STP): BOOLEAN; FORWARD; COMP 1882 COMP 1883 FUNCTION STRING(FSP: STP): BOOLEAN; COMP 1884 (* DETERMINE IF FSP DESCRIBES A STRING TYPE *) COMP 1885 VAR LMIN,LMAX: INTEGER; COMP 1886 BEGIN (* STRING *) COMP 1887 STRING := FALSE; COMP 1888 IF FSP <> NIL THEN COMP 1889 WITH FSP^ DO COMP 1890 IF FORM = ARRAYS THEN COMP 1891 IF PCKDARR AND (AELTYPE = CHARPTR) THEN COMP 1892 IF CONFORMANT THEN COMP 1893 BEGIN COMP 1894 IF INXTYPE <> NIL THEN COMP 1895 STRING := COMPTYPES(INXTYPE^.BOUNDTYPE,INTPTR) V41AC11 9 END COMP 1897 ELSE COMP 1898 IF COMPTYPES(INXTYPE,INTPTR) AND (INXTYPE <> NIL) THEN COMP 1899 BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); COMP 1900 STRING := (LMIN = 1) AND (LMAX > 1) V41AC11 10 END COMP 1902 END (* STRING *); COMP 1903 COMP 1904 FUNCTION COMPTYPES; COMP 1905 VAR LMIN1,LMAX1,LMIN2,LMAX2: INTEGER; COMP 1906 BEGIN (*COMPTYPES*) COMP 1907 IF FSP1 <> NIL THEN COMP 1908 IF FSP1^.FORM = SUBRANGE THEN COMP 1909 FSP1 := FSP1^.RANGETYPE; COMP 1910 IF FSP2 <> NIL THEN COMP 1911 IF FSP2^.FORM = SUBRANGE THEN COMP 1912 FSP2 := FSP2^.RANGETYPE; COMP 1913 IF FSP1 = FSP2 THEN COMPTYPES := TRUE COMP 1914 ELSE COMP 1915 IF (FSP1 <> NIL)AND (FSP2 <> NIL) THEN COMP 1916 IF FSP1^.FORM = FSP2^.FORM THEN COMP 1917 CASE FSP1^.FORM OF COMP 1918 POINTER: COMP 1919 COMPTYPES := (FSP1 = NILPTR) OR (FSP2 = NILPTR); COMP 1920 POWER: COMP 1921 COMPTYPES := (FSP1^.PCKDSET * FSP2^.PCKDSET <> []) COMP 1922 AND COMPTYPES(FSP1^.ELSET,FSP2^.ELSET); COMP 1923 ARRAYS: COMP 1924 BEGIN COMPTYPES := FALSE; COMP 1925 IF STRING(FSP1) THEN COMP 1926 IF STRING(FSP2) THEN COMP 1927 IF NOT CONFORMARRAY(FSP1) THEN COMP 1928 IF NOT CONFORMARRAY(FSP2) THEN COMP 1929 BEGIN GETBOUNDS(FSP1^.INXTYPE,LMIN1,LMAX1); COMP 1930 GETBOUNDS(FSP2^.INXTYPE,LMIN2,LMAX2); COMP 1931 COMPTYPES := LMAX1 = LMAX2 COMP 1932 END COMP 1933 END; COMP 1934 SCALAR, COMP 1935 REALS, COMP 1936 BOUNDDESC, COMP 1937 RECORDS, COMP 1938 FILES: COMP 1939 COMPTYPES := FALSE COMP 1940 END (*CASE*) COMP 1941 ELSE COMPTYPES := FALSE COMP 1942 ELSE COMPTYPES := TRUE COMP 1943 END (*COMPTYPES*) ; COMP 1944 COMP 1945 PROCEDURE STRINGTYPE(VAR FSP: STP); COMP 1946 (*ENTER TYPE OF STRINGCONST (PACKED ARRAY [1..LGTH] OF CHAR) INTO COMP 1947 STRUCTURE TABLE*) COMP 1948 VAR LSP,LSP1: STP; COMP 1949 BEGIN MNEW(LSP,SUBRANGE); COMP 1950 WITH LSP^ DO COMP 1951 BEGIN FORM := SUBRANGE; RANGETYPE := INTPTR; COMP 1952 MIN.IVAL := 1; MAX.IVAL := LGTH ; FTYPE := FALSE; COMP 1953 WITH SIZE DO COMP 1954 BEGIN WORDS := 0; BITS := NROFBITS(LGTH) END COMP 1955 END; COMP 1956 MNEW(LSP1,ARRAYS,TRUE,TRUE); COMP 1957 WITH LSP1^ DO COMP 1958 BEGIN FORM := ARRAYS; CONFORMANT := FALSE; COMP 1959 AELTYPE := CHARPTR; INXTYPE := LSP; COMP 1960 PCKDARR := TRUE; PARTWORDELS := TRUE; COMP 1961 ELSPERWORD := ALFALENG; FTYPE := FALSE; COMP 1962 WITH SIZE DO COMP 1963 BEGIN WORDS := LGTH DIV ALFALENG; COMP 1964 BITS := (LGTH MOD ALFALENG) * CHARSIZE COMP 1965 END COMP 1966 END; COMP 1967 FSP := LSP1 COMP 1968 END (*STRINGTYPE*) ; COMP 1969 (*$L'DECLARATIONS PROCESSORS.' *) COMP 1970 COMP 1971 COMP 1972 PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU); COMP 1973 VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG); LCSP: CSP; COMP 1974 BEGIN LSP := NIL; FVALU.IVAL := 0; COMP 1975 CHECKCONTEXT(CONSTBEGSYS,50,FSYS); COMP 1976 IF SY IN CONSTBEGSYS THEN COMP 1977 BEGIN COMP 1978 IF SY = CHARCONST THEN COMP 1979 BEGIN LSP := CHARPTR; FVALU.IVAL := IVAL; INSYMBOL END COMP 1980 ELSE COMP 1981 IF SY = STRINGCONST THEN COMP 1982 BEGIN STRINGTYPE(LSP); COMP 1983 FVALU.VALP := CONSTP; COMP 1984 INSYMBOL COMP 1985 END COMP 1986 ELSE COMP 1987 BEGIN COMP 1988 SIGN := NONE; COMP 1989 IF OP IN [PLUS,MINUS] THEN COMP 1990 BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG; COMP 1991 INSYMBOL COMP 1992 END; COMP 1993 IF SY = IDENT THEN COMP 1994 BEGIN SEARCHID([KONST],LCP); COMP 1995 WITH LCP^ DO COMP 1996 BEGIN LSP := IDTYPE; FVALU := VALUES END; COMP 1997 IF SIGN <> NONE THEN COMP 1998 IF LSP = INTPTR THEN COMP 1999 BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END COMP 2000 ELSE COMP 2001 IF LSP = REALPTR THEN COMP 2002 BEGIN COMP 2003 IF SIGN = NEG THEN FVALU.RVAL := -FVALU.RVAL COMP 2004 END COMP 2005 ELSE ERROR(105); COMP 2006 INSYMBOL; COMP 2007 END COMP 2008 ELSE COMP 2009 IF SY = INTCONST THEN COMP 2010 BEGIN IF SIGN = NEG THEN IVAL := -IVAL; COMP 2011 LSP := INTPTR; FVALU.IVAL := IVAL; INSYMBOL COMP 2012 END COMP 2013 ELSE COMP 2014 IF SY = REALCONST THEN COMP 2015 BEGIN IF SIGN = NEG THEN RVAL := -RVAL; COMP 2016 LSP := REALPTR; FVALU.RVAL := RVAL; INSYMBOL COMP 2017 END COMP 2018 ELSE COMP 2019 BEGIN ERROR(106); SKIP(FSYS) END COMP 2020 END; COMP 2021 CHECKCONTEXT(FSYS,6,[]) COMP 2022 END; COMP 2023 FSP := LSP COMP 2024 END (*CONSTANT*) ; COMP 2025 COMP 2026 PROCEDURE CASECONSTANTLIST(FSYS: SETOFSYS; FSP: STP; V41CC07 48 FMIN,FMAX: INTEGER; FERROR: ERRINDEX; V41CC07 49 VAR FCC1,FCC2: CCP); V41CC07 50 (* PARSE A CASE CONSTANT LIST, PUTTING ENTRIES INTO THE ASCENDING V41CC07 51 LIST HEADED BY FCC1; ALL ENTRIES FOR THIS LIST ARE THREADED V41CC07 52 STARTING AT FCC2 (RETURNED). *) V41CC07 53 VAR V41CC07 54 LSP1,LSP2: STP; LCC1,LCC2,LCC3: CCP; DONE: BOOLEAN; V41CC07 55 LMIN,LMAX: INTEGER; V41CC07 56 V41CC07 57 PROCEDURE INSERT; V41CC07 58 BEGIN (* INSERT *) V41CC07 59 WITH LCC3^ DO V41CC07 60 BEGIN NEXTCC := LCC1; V41CC07 61 CCMAX := LMAX; CCMIN := LMIN; V41CC07 62 IF LCC2 <> NIL THEN LCC2^.NEXTCC := LCC3 V41CC07 63 ELSE FCC1 := LCC3; V41CC07 64 THREAD := FCC2; FCC2 := LCC3 V41CC07 65 END V41CC07 66 END (* INSERT *) ; V41CC07 67 V41CC07 68 PROCEDURE CASECONSTANT(FSYS: SETOFSYS; V41CC07 69 VAR FSP2: STP; VAR FVAL: INTEGER); V41CC07 70 VAR LVAL: VALU; V41CC07 71 BEGIN (* CASECONSTANT *) V41CC07 72 CONSTANT(FSYS,FSP2,LVAL); FVAL := LVAL.IVAL; V41CC07 73 IF (FSP2 <> NIL) AND (FSP <> NIL) THEN V41CC07 74 IF NOT COMPTYPES(FSP,FSP2) OR (FSP2^.FORM > SUBRANGE) THEN V41CC07 75 BEGIN ERROR(147); FSP2 := NIL END V41CC07 76 ELSE IF (LVAL.IVAL < FMIN) OR (LVAL.IVAL > FMAX) THEN V41CC07 77 BEGIN ERROR(FERROR); FSP2 := NIL END V41CC07 78 END (* CASECONSTANT *) ; V41CC07 79 V41CC07 80 BEGIN (* CASECONSTANTLIST *) ; V41CC07 81 FCC2 := NIL; V41CC07 82 REPEAT V41CC07 83 CASECONSTANT(FSYS+[COMMA,COLON,DOTDOT],LSP1,LMIN); V41CC07 84 LMAX := LMIN; LSP2 := LSP1; V41CC07 85 IF OPTS.DIALECT = P6000 THEN V41DC05 469 IF SY = DOTDOT THEN V41CC07 87 BEGIN EXTENSION(334); INSYMBOL; V41CC07 88 CASECONSTANT(FSYS+[COMMA,COLON],LSP2,LMAX) V41CC07 89 END; V41CC07 90 IF (FSP<>NIL) AND (LSP1<>NIL) AND (LSP2 <> NIL) THEN V41CC07 91 BEGIN V41CC07 92 LCC1 := FCC1; LCC2 := NIL; DONE := FALSE; V41CC07 93 IF LMIN <= LMAX THEN V41CC07 94 REPEAT V41CC07 95 IF LCC1 = NIL THEN V41CC07 96 BEGIN NEW(LCC3); INSERT; DONE := TRUE END V41CC07 97 ELSE V41CC07 98 WITH LCC1^ DO V41CC07 99 IF LMIN <= CCMAX THEN V41CC07 100 IF LMAX < CCMIN THEN V41CC07 101 BEGIN NEW(LCC3); INSERT; DONE := TRUE END V41CC07 102 ELSE V41CC07 103 BEGIN ERROR(156); FCC2 := NIL; V41CC07 104 IF CCMIN < LMIN THEN LMIN := CCMIN; V41CC07 105 REPEAT LCC3 := LCC1; V41CC07 106 LCC1 := LCC1^.NEXTCC; V41CC07 107 IF LCC1 = NIL THEN DONE := TRUE V41CC07 108 ELSE V41CC07 109 IF LMAX < LCC1^.CCMIN THEN DONE := TRUE V41CC07 110 ELSE DISPOSE(LCC3); V41CC07 111 UNTIL DONE; V41CC07 112 IF LCC3^.CCMAX > LMAX THEN LMAX := LCC3^.CCMAX; V41CC07 113 INSERT V41CC07 114 END V41CC07 115 ELSE V41CC07 116 BEGIN LCC2 := LCC1; LCC1 := NEXTCC END V41CC07 117 UNTIL DONE V41CC07 118 ELSE ERROR(102) V41CC07 119 END; V41CC07 120 DONE := SY <> COMMA; V41CC07 121 IF NOT DONE THEN INSYMBOL V41CC07 122 UNTIL DONE; V41CC07 123 EXPECTSYMBOL(COLON,5) V41CC07 124 END (* CASECONSTANTLIST *) ; V41CC07 125 V41CC07 126 FUNCTION FINDVARIANT(FSP: STP; FVAL: VALU): STP; V41CC07 127 (*LOOK UP CASE CONSTANT VALUE IN TAGVALUELIST OF FSP*) V41CC07 128 VAR FOUND: BOOLEAN; LCC: CCP; V41CC07 129 BEGIN V41CC07 130 LCC := FSP^.TAGVALUELIST; FOUND := FALSE; V41CC07 131 WHILE (LCC <> NIL) AND NOT FOUND DO V41CC07 132 WITH LCC^ DO V41CC07 133 IF FVAL.IVAL <= CCMAX THEN V41CC07 134 IF FVAL.IVAL >= CCMIN THEN V41CC07 135 FOUND := TRUE V41CC07 136 ELSE LCC := NIL V41CC07 137 ELSE LCC := NEXTCC; V41CC07 138 IF FOUND THEN FINDVARIANT := LCC^.CCVAR V41CC07 139 ELSE FINDVARIANT := FSP^.COMPLETER V41CC07 140 END (* FINDVARIANT *); V41CC07 141 V41CC07 142 PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP); COMP 2027 VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP; COMP 2028 LSIZE,DISPL,FILEDISPL: WBSIZE; LMIN,LMAX,LRL: INTEGER; COMP 2029 T,T1,W,B: INTEGER; PACKFLAG,SEGFLAG,EXITLOOP: BOOLEAN; V41CC07 143 NROFELS: INTEGER; LSCOPE: SCOPERANGE; LLEV: DISPRANGE; COMP 2031 COMP 2032 PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP); COMP 2033 VAR LSP,LSP1: STP; LCP,LCP1: CTP; COMP 2034 LVAL: INTEGER; LVALU: VALU; COMP 2035 COMP 2036 PROCEDURE SUBRANGES(FSP: STP; FVALU: VALU); COMP 2037 (*PROCESS SUBRANGE TYPE*) COMP 2038 VAR LOW,HIGH: INTEGER; COMP 2039 BEGIN MNEW(LSP,SUBRANGE); COMP 2040 WITH LSP^ DO COMP 2041 BEGIN RANGETYPE := FSP; FORM := SUBRANGE; COMP 2042 MIN := FVALU; FTYPE := FALSE COMP 2043 END; COMP 2044 EXPECTSYMBOL(DOTDOT,21); COMP 2045 CONSTANT(FSYS,LSP1,LVALU); COMP 2046 WITH LSP^ DO COMP 2047 BEGIN MAX := LVALU; COMP 2048 WITH SIZE DO COMP 2049 BEGIN WORDS := 1; BITS := 0 END; COMP 2050 IF NOT COMPTYPES(FSP,LSP1) THEN ERROR(107) COMP 2051 ELSE COMP 2052 WITH SIZE DO COMP 2053 IF FSP <> NIL THEN COMP 2054 IF FSP^.FORM > SUBRANGE THEN COMP 2055 BEGIN ERROR(148); RANGETYPE := NIL COMP 2056 END COMP 2057 ELSE COMP 2058 BEGIN LOW := MIN.IVAL; HIGH := MAX.IVAL; COMP 2059 IF LOW > HIGH THEN ERROR(102); COMP 2060 WORDS := 0; COMP 2061 IF ABS(LOW) < ABS(HIGH) THEN COMP 2062 BITS := NROFBITS(ABS(HIGH)) COMP 2063 ELSE BITS := NROFBITS(ABS(LOW)); COMP 2064 IF LOW < 0 THEN BITS := BITS + 1 COMP 2065 END COMP 2066 END COMP 2067 END (*SUBRANGES*); COMP 2068 COMP 2069 BEGIN (*SIMPLETYPE*) COMP 2070 CHECKCONTEXT(SIMPTYPEBEGSYS,1,FSYS); COMP 2071 IF SY IN SIMPTYPEBEGSYS THEN COMP 2072 BEGIN COMP 2073 IF SY = LPARENT THEN COMP 2074 BEGIN MNEW(LSP,SCALAR,USERDECLARED); COMP 2075 WITH LSP^ DO COMP 2076 BEGIN FORM := SCALAR; SCALKIND := USERDECLARED; FTYPE := FALSE; COMP 2077 FCONST := NIL COMP 2078 END; COMP 2079 LCP1 := NIL; LVAL := -1; COMP 2080 REPEAT INSYMBOL; COMP 2081 IF SY = IDENT THEN COMP 2082 BEGIN MNEW(LCP,KONST); LVAL := LVAL + 1; COMP 2083 WITH LCP^ DO COMP 2084 BEGIN COPYID(LCP); IDTYPE := LSP; NEXT := LCP1; COMP 2085 VALUES.IVAL := LVAL; KLASS := KONST COMP 2086 END; COMP 2087 ENTERID(LCP,BLCK); COMP 2088 LCP1 := LCP; INSYMBOL COMP 2089 END COMP 2090 ELSE ERROR(2); COMP 2091 CHECKCONTEXT(FSYS+[COMMA,RPARENT],6,[]) COMP 2092 UNTIL SY <> COMMA; COMP 2093 WITH LSP^, SIZE DO COMP 2094 BEGIN FCONST := LCP1; COMP 2095 WORDS := 0; BITS := NROFBITS(LVAL) COMP 2096 END; COMP 2097 EXPECTSYMBOL(RPARENT,4) COMP 2098 END COMP 2099 ELSE COMP 2100 BEGIN COMP 2101 IF SY = IDENT THEN COMP 2102 BEGIN SEARCHID([TYPES,KONST],LCP); COMP 2103 INSYMBOL; COMP 2104 WITH LCP^ DO COMP 2105 IF KLASS = KONST THEN SUBRANGES(IDTYPE,VALUES) COMP 2106 ELSE COMP 2107 LSP := IDTYPE COMP 2108 END (*SY = IDENT*) COMP 2109 ELSE COMP 2110 BEGIN CONSTANT(FSYS+[DOTDOT],LSP1,LVALU); COMP 2111 SUBRANGES(LSP1,LVALU) COMP 2112 END; COMP 2113 END; COMP 2114 FSP := LSP; COMP 2115 CHECKCONTEXT(FSYS,6,[]) COMP 2116 END COMP 2117 ELSE FSP := NIL COMP 2118 END (*SIMPLETYPE*) ; COMP 2119 COMP 2120 FUNCTION INCRADDR(FA, FI: ADDRRANGE): ADDRRANGE; COMP 2121 BEGIN (* INCRADDR *) COMP 2122 IF FA + FI <= MAXADDR THEN INCRADDR := FA + FI COMP 2123 ELSE INCRADDR := MAXADDR COMP 2124 END (* INCRADDR *); COMP 2125 COMP 2126 PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FSP: STP); V41CC07 144 VAR LASTFLD,LCP,LCP1,THIS,LLSTFLD: CTP; V41CC07 145 LSP,LSP1: STP; LCC1,LCC2: CCP; V41CC07 146 MINSIZE,MAXSIZE: WBSIZE; V41CC07 147 LFILTYP,EXITLOOP,DISCRIMINATED: BOOLEAN; V41CC07 148 TAGVALCOUNT: 0..MAXINT; TAGSP: STP; COMP 2133 TAGMIN, TAGMAX: INTEGER; COMP 2134 COMP 2135 PROCEDURE VARIANT(FSP: STP; VAR FSP2: STP); V41CC07 149 BEGIN (* VARIANT *) V41CC07 150 EXPECTSYMBOL(LPARENT,9); V41CC07 151 DISPL := MINSIZE; V41CC07 152 FIELDLIST(FSYS+[RPARENT,SEMICOLON],FSP2); V41CC07 153 FSP2^.NXTFLDLST := FSP^.VARIANTLIST; V41CC07 154 FSP^.VARIANTLIST := FSP2; V41CC07 155 LFILTYP := LFILTYP OR FSP2^.FTYPE; V41CC07 156 IF (DISPL.WORDS > MAXSIZE.WORDS) OR V41CC07 157 (DISPL.WORDS = MAXSIZE.WORDS) AND (DISPL.BITS > MAXSIZE.BITS) V41CC07 158 THEN MAXSIZE := DISPL V41CC07 159 END (* VARIANT *); V41CC07 160 V41CC07 161 PROCEDURE FIELDADDRESS(FCP: CTP; FSIZE: WBSIZE; COMP 2136 VAR FDISPL: WBSIZE; FLASTFLD: CTP); COMP 2137 (*COMPUTE ADDRESS OF FCP^ ACCORDING TO ITS SIZE *) COMP 2138 VAR W,B: INTEGER; COMP 2139 COMP 2140 PROCEDURE ADJUST; COMP 2141 (*ADJUST LASTFLD*) COMP 2142 BEGIN COMP 2143 IF FLASTFLD <> NIL THEN COMP 2144 WITH FLASTFLD^ DO COMP 2145 IF IDTYPE <> NIL THEN COMP 2146 IF IDTYPE^.FORM <= POWER THEN COMP 2147 IF BITADDR = 0 THEN PCKDFLD := FALSE COMP 2148 ELSE COMP 2149 BITADDR := WORDSIZE - IDTYPE^.SIZE.BITS; COMP 2150 W := INCRADDR(W,1); B := 0 COMP 2151 END (*ADJUST*); COMP 2152 COMP 2153 BEGIN (*FIELDADDRESS*) COMP 2154 WITH FDISPL, FCP^ DO COMP 2155 BEGIN COMP 2156 W := WORDS; B := BITS; COMP 2157 IF PACKFLAG AND (FSIZE.WORDS = 0) THEN COMP 2158 BEGIN IF B + FSIZE.BITS > WORDSIZE THEN ADJUST; COMP 2159 FLDADDR := W; PCKDFLD := TRUE; COMP 2160 BITADDR := B; COMP 2161 IF B + FSIZE.BITS = WORDSIZE THEN COMP 2162 BEGIN W := W + 1; B := 0 END COMP 2163 ELSE B := B + FSIZE.BITS COMP 2164 END COMP 2165 ELSE COMP 2166 BEGIN IF B <> 0 THEN ADJUST; COMP 2167 FLDADDR := W; PCKDFLD := FALSE; COMP 2168 W := W + FULLWORDS(FSIZE) COMP 2169 END; COMP 2170 IF W > MAXADDR THEN BEGIN W := MAXADDR; B := 0 END; COMP 2171 WORDS := W; BITS := B COMP 2172 END COMP 2173 END (*FIELDADDRESS*) ; COMP 2174 COMP 2175 BEGIN (* FIELDLIST *) V41CC07 162 LASTFLD := NIL; LSP := NIL; LFILTYP := FALSE; V41CC07 163 MNEW(FSP,FIELDLISTS); V41CC07 164 WITH FSP^ DO V41CC07 165 BEGIN FORM := FIELDLISTS; V41CC07 166 FIXEDPART := NIL; NXTFLDLST := NIL V41CC07 167 END; V41CC07 168 CHECKCONTEXT(FSYS+[IDENT,CASESY],19,[]); COMP 2179 WHILE SY = IDENT DO COMP 2180 BEGIN THIS := NIL; COMP 2181 (*LOOP UNTIL SY <> COMMA:*) COMP 2182 REPEAT COMP 2183 IF SY = IDENT THEN COMP 2184 BEGIN MNEW(LCP,FIELD); COMP 2185 WITH LCP^ DO COMP 2186 BEGIN COPYID(LCP); IDTYPE := NIL; COMP 2187 KLASS := FIELD COMP 2188 END; COMP 2189 IF FSP^.FIXEDPART = NIL THEN FSP^.FIXEDPART := LCP V41CC07 169 ELSE LLSTFLD^.NEXT := LCP; COMP 2191 LLSTFLD := LCP; COMP 2192 IF THIS = NIL THEN THIS := LCP; COMP 2193 ENTERID(LCP,DREC); COMP 2194 INSYMBOL COMP 2195 END COMP 2196 ELSE ERROR(2); COMP 2197 CHECKCONTEXT([COMMA,COLON],6,FSYS+[SEMICOLON,CASESY]); COMP 2198 EXITLOOP := SY <> COMMA; COMP 2199 IF NOT EXITLOOP THEN INSYMBOL COMP 2200 UNTIL EXITLOOP; COMP 2201 LLSTFLD^.NEXT := NIL; COMP 2202 EXPECTSYMBOL(COLON,5); COMP 2203 TYP(FSYS+[CASESY,SEMICOLON],LSP); COMP 2204 WHILE THIS <> NIL DO COMP 2205 WITH THIS^ DO COMP 2206 BEGIN IDTYPE := LSP; COMP 2207 IF LSP <> NIL THEN COMP 2208 IF LSP^.FTYPE THEN COMP 2209 BEGIN LFILTYP := TRUE; V41CC07 170 FIELDADDRESS(THIS,LSP^.SIZE,FILEDISPL,NIL) COMP 2211 END COMP 2212 ELSE COMP 2213 BEGIN FIELDADDRESS(THIS,LSP^.SIZE,DISPL,LASTFLD); COMP 2214 LASTFLD := THIS COMP 2215 END COMP 2216 ELSE COMP 2217 BEGIN FLDADDR := DISPL.WORDS; PCKDFLD := FALSE END; COMP 2218 THIS := NEXT COMP 2219 END; COMP 2220 IF SY = SEMICOLON THEN COMP 2221 BEGIN INSYMBOL; COMP 2222 CHECKCONTEXT(FSYS+[IDENT,CASESY],19,[]); COMP 2223 END COMP 2224 END (*WHILE*); COMP 2225 IF SY = CASESY THEN COMP 2226 BEGIN MNEW(LSP,VARIANTPART); COMP 2227 WITH LSP^ DO COMP 2228 BEGIN V41CC07 171 FORM := VARIANTPART; TAGFIELDID := NIL; V41CC07 172 FTYPE := FALSE; COMPLETER := NIL; VARIANTLIST := NIL; V41CC07 173 END; V41CC07 174 FSP^.VARPART := LSP; TAGSP := NIL; TAGVALCOUNT := 0; V41CC07 175 INSYMBOL; COMP 2231 IF SY = IDENT THEN COMP 2232 BEGIN MNEW(LCP,TAGFIELD); V41CC07 176 COPYID(LCP); (* SAVE ID UNTIL WE KNOW NEXT SYMBOL *) COMP 2234 WITH LCP^ DO COMP 2235 BEGIN IDTYPE := NIL; KLASS := TAGFIELD; NEXT := NIL END; COMP 2236 INSYMBOL; DISCRIMINATED := (SY = COLON); COMP 2237 IF DISCRIMINATED THEN COMP 2238 BEGIN ENTERID(LCP,DREC); INSYMBOL; COMP 2239 LSP^.TAGFIELDID := LCP; V41CC07 177 IF SY = IDENT THEN COMP 2240 BEGIN SEARCHID([TYPES],LCP1); INSYMBOL END COMP 2241 ELSE COMP 2242 BEGIN LCP1 := UTYPPTR; COMP 2243 ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) COMP 2244 END; V41CC07 178 LCP^.IDTYPE := LCP1^.IDTYPE V41CC07 179 END COMP 2246 ELSE COMP 2247 BEGIN ID := LCP^.NAME; V41CC07 180 SEARCHID([TYPES],LCP1); DISPOSEID(LCP) V41CC07 181 END; V41CC07 182 IF LCP1^.IDTYPE <> NIL THEN V41CC07 183 IF LCP1^.IDTYPE^.FORM <= SUBRANGE THEN V41CC07 184 BEGIN TAGSP := LCP1^.IDTYPE; V41CC07 185 GETBOUNDS(TAGSP,TAGMIN,TAGMAX); V41CC07 186 IF DISCRIMINATED THEN V41CC07 187 FIELDADDRESS(LCP,TAGSP^.SIZE,DISPL,LASTFLD) V41CC07 188 END V41CC07 189 ELSE ERROR(110) V41CC07 190 END COMP 2263 ELSE (* SY <> IDENT *) COMP 2264 BEGIN ERROR(2); SKIP(FSYS+[OFSY,LPARENT]) END; COMP 2265 LSP^.TAGTYPE := TAGSP; V41CC07 191 LSP^.SIZE := DISPL; COMP 2266 EXPECTSYMBOL(OFSY,8); COMP 2267 CHECKCONTEXT(CONSTBEGSYS,19,FSYS+[COLON,LPARENT]); COMP 2268 LCC1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; V41CC07 192 REPEAT V41CC07 193 CASECONSTANTLIST(FSYS+[LPARENT],TAGSP,TAGMIN,TAGMAX, V41CC07 194 111,LCC1,LCC2); V41CC07 195 VARIANT(LSP,LSP1); V41CC07 196 WHILE LCC2 <> NIL DO V41CC07 197 WITH LCC2^ DO V41CC07 198 BEGIN CCVAR := LSP1; LCC2 := THREAD; V41CC07 199 TAGVALCOUNT := TAGVALCOUNT + (CCMAX - CCMIN + 1) V41CC07 200 END; COMP 2313 IF SY = RPARENT THEN COMP 2314 BEGIN INSYMBOL; COMP 2315 CHECKCONTEXT(FSYS+[SEMICOLON,OTHERWISESY],6,[]) V41CC07 201 END COMP 2317 ELSE ERROR(4); COMP 2318 IF SY = SEMICOLON THEN INSYMBOL COMP 2319 UNTIL SY IN (FSYS+[OTHERWISESY]); V41CC07 202 IF SY = OTHERWISESY THEN V41CC07 203 BEGIN EXTENSION(328); V41CC07 204 IF TAGMIN - 1 + TAGVALCOUNT = TAGMAX THEN ERROR(195); V41CC07 205 INSYMBOL; V41CC07 206 VARIANT(LSP,LSP1); V41CC07 207 LSP^.COMPLETER := LSP1; V41CC07 208 EXPECTSYMBOL(RPARENT,4); V41CC07 209 IF SY = SEMICOLON THEN INSYMBOL; V41CC07 210 CHECKCONTEXT(FSYS,6,[]) V41CC07 211 END; V41CC07 212 DISPL := MAXSIZE; V41CC07 213 WITH LSP^ DO V41CC07 214 BEGIN TAGVALUELIST := LCC1; V41CC07 215 FTYPE := LFILTYP; V41CC07 216 IF (COMPLETER = NIL) AND (TAGSP <> NIL) THEN V41CC07 217 IF TAGMIN - 1 + TAGVALCOUNT < TAGMAX THEN ERROR(186) V41CC07 218 END V41CC07 219 END V41CC07 220 ELSE (* SY <> CASESY *) V41CC07 221 FSP^.VARPART := NIL; V41CC07 222 WITH FSP^ DO V41CC07 223 BEGIN FTYPE := LFILTYP; SIZE := DISPL END V41CC07 224 END (* FIELDLIST *) ; V41CC07 225 V41CC07 226 PROCEDURE FIXFIELDALLOCATION(FSP: STP; FWORDS: ADDRRANGE); V41CC07 227 (* INCREASE NON-FILE FIELD OFFSETS IN FIELDLIST FSP BY FWORDS. *) V41CC07 228 VAR LCP: CTP; LSP: STP; V41CC07 229 BEGIN (* FIXFIELDALLOCATION *) V41CC07 230 WITH FSP^ DO V41CC07 231 BEGIN LCP := FIXEDPART; LSP := VARPART END; V41CC07 232 WHILE LCP <> NIL DO V41CC07 233 WITH LCP^ DO V41CC07 234 BEGIN COMP 2336 IF IDTYPE <> NIL THEN COMP 2337 IF NOT IDTYPE^.FTYPE THEN COMP 2338 FLDADDR := INCRADDR(FLDADDR,FWORDS); COMP 2339 LCP := NEXT V41CC07 235 END; V41CC07 236 IF LSP <> NIL THEN V41CC07 237 BEGIN V41CC07 238 IF LSP^.TAGFIELDID <> NIL THEN V41CC07 239 WITH LSP^.TAGFIELDID^ DO V41CC07 240 FLDADDR := INCRADDR(FLDADDR,FWORDS); V41CC07 241 LSP := LSP^.VARIANTLIST; V41CC07 242 WHILE LSP <> NIL DO V41CC07 243 WITH LSP^ DO (* FORM = FIELDLISTS *) V41CC07 244 BEGIN SIZE.WORDS := INCRADDR(SIZE.WORDS,FWORDS); V41CC07 245 FIXFIELDALLOCATION(LSP,FWORDS); V41CC07 246 LSP := NXTFLDLST V41CC07 247 END COMP 2349 END COMP 2350 END (* FIXFIELDALLOCATION *); COMP 2351 COMP 2352 BEGIN (*TYP*) LSP := NIL; COMP 2353 PACKFLAG := FALSE; SEGFLAG := FALSE; COMP 2354 CHECKCONTEXT(TYPEBEGSYS,10,FSYS); COMP 2355 IF SY IN TYPEBEGSYS THEN COMP 2356 BEGIN COMP 2357 IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,LSP) COMP 2358 ELSE COMP 2359 (*^*) COMP 2360 IF SY = ARROW THEN COMP 2361 BEGIN MNEW(LSP,POINTER); COMP 2362 WITH LSP^ DO COMP 2363 BEGIN FORM := POINTER; FTYPE := FALSE; ELTYPE := NIL; COMP 2364 DBG := DEBUG; COMP 2365 WITH SIZE DO COMP 2366 BEGIN WORDS := 0; BITS := NROFBITS(MAXADDR); COMP 2367 IF DEBUG THEN BITS := 2 * (BITS + 1) COMP 2368 END COMP 2369 END; COMP 2370 INSYMBOL; COMP 2371 IF SY = IDENT THEN COMP 2372 BEGIN COMP 2373 IF INTYPEDEFINITION THEN COMP 2374 BEGIN LLEV := TOP; COMP 2375 REPEAT SEARCHSECTION(DISPLAY[LLEV].FNAME,LCP); COMP 2376 EXITLOOP := (LLEV = 0) OR (LCP <> NIL); COMP 2377 IF NOT EXITLOOP THEN LLEV := LLEV - 1 COMP 2378 UNTIL EXITLOOP; COMP 2379 IF LCP <> NIL THEN COMP 2380 IF (LCP^.LASTUSESCOPE < BLOCKSCOPE) AND (LLEV < LEVEL) COMP 2381 THEN LCP := NIL COMP 2382 ELSE COMP 2383 IF LCP^.KLASS <> TYPES THEN COMP 2384 BEGIN ERROR(191); LCP := NIL END COMP 2385 ELSE LCP^.LASTUSESCOPE := THISSCOPE COMP 2386 END COMP 2387 ELSE SEARCHID([TYPES],LCP); COMP 2388 IF LCP = NIL THEN (*FORWARD REFERENCED TYPE ID*) COMP 2389 BEGIN MNEW(LCP,TYPES); COMP 2390 WITH LCP^ DO COMP 2391 BEGIN COPYID(LCP); IDTYPE := LSP; KLASS := TYPES; COMP 2392 NEXT := FWPTR COMP 2393 END; COMP 2394 FWPTR := LCP COMP 2395 END COMP 2396 ELSE LSP^.ELTYPE := LCP^.IDTYPE; COMP 2397 INSYMBOL; COMP 2398 END COMP 2399 ELSE ERROR(2); COMP 2400 END COMP 2401 ELSE (* SY <> ARROW *) COMP 2402 BEGIN COMP 2403 IF SY = SEGMENTEDSY THEN COMP 2404 BEGIN SEGFLAG := TRUE; EXTENSION(323); INSYMBOL END; COMP 2405 IF SEGFLAG AND (SY = IDENT) THEN COMP 2406 BEGIN SEARCHID([TYPES],LCP); COMP 2407 WITH LCP^ DO COMP 2408 IF IDTYPE <> NIL THEN COMP 2409 WITH IDTYPE^ DO COMP 2410 IF FORM = FILES THEN COMP 2411 IF SEGFILE THEN COMP 2412 BEGIN ERROR(60); LSP := IDTYPE END COMP 2413 ELSE COMP 2414 BEGIN MNEW(LSP); (* DON'T DO MNEW(LSP,FILES) *) COMP 2415 (* BECAUSE LSP^ := IDTYPE^ WILL FAIL *) COMP 2416 LSP^ := IDTYPE^; COMP 2417 WITH LSP^ DO COMP 2418 BEGIN BASEFILE := IDTYPE; SEGFILE := TRUE END COMP 2419 END COMP 2420 ELSE ERROR(60); COMP 2421 INSYMBOL COMP 2422 END COMP 2423 ELSE COMP 2424 BEGIN COMP 2425 IF SY = PACKEDSY THEN COMP 2426 BEGIN PACKFLAG := TRUE; INSYMBOL END; COMP 2427 CHECKCONTEXT(TYPEDELS,10,FSYS); COMP 2428 IF (SY <> FILESY)AND SEGFLAG THEN ERROR(57); COMP 2429 (*ARRAY*) COMP 2430 IF SY = ARRAYSY THEN COMP 2431 BEGIN INSYMBOL; COMP 2432 EXPECTSYMBOL(LBRACK,11); COMP 2433 LSP1 := NIL; COMP 2434 (*LOOP UNTIL SY <> COMMA:*) COMP 2435 REPEAT MNEW(LSP,ARRAYS); COMP 2436 WITH LSP^ DO COMP 2437 BEGIN AELTYPE := LSP1; INXTYPE := NIL; COMP 2438 PCKDARR := PACKFLAG; FORM := ARRAYS; COMP 2439 FTYPE := FALSE; CONFORMANT := FALSE COMP 2440 END; COMP 2441 LSP1 := LSP; COMP 2442 SIMPLETYPE(FSYS+[COMMA,RBRACK,OFSY],LSP2); COMP 2443 IF LSP2 <> NIL THEN COMP 2444 IF LSP2^.FORM <= SUBRANGE THEN LSP^.INXTYPE := LSP2 COMP 2445 ELSE ERROR(113); COMP 2446 EXITLOOP := SY <> COMMA; COMP 2447 IF NOT EXITLOOP THEN INSYMBOL COMP 2448 UNTIL EXITLOOP; COMP 2449 EXPECTSYMBOL(RBRACK,12); COMP 2450 EXPECTSYMBOL(OFSY,8); COMP 2451 TYP(FSYS,LSP); COMP 2452 IF LSP <> NIL THEN (* REVERSE POINTERS, COMPUTE SIZE *) COMP 2453 BEGIN LSIZE := LSP^.SIZE; COMP 2454 REPEAT COMP 2455 WITH LSP1^ DO COMP 2456 BEGIN LSP2 := AELTYPE; AELTYPE := LSP; COMP 2457 FTYPE := LSP^.FTYPE; COMP 2458 IF INXTYPE <> NIL THEN COMP 2459 BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); COMP 2460 NROFELS := LMAX - LMIN + 1; COMP 2461 IF (NROFELS <= 0) OR (NROFELS > MAXINT) THEN COMP 2462 NROFELS := MAXINT; COMP 2463 IF (LSIZE.WORDS > 0)OR NOT PACKFLAG THEN COMP 2464 BEGIN T := FULLWORDS(LSIZE); COMP 2465 IF (NROFELS >= MAXADDR) OR (T >= MAXADDR) THEN COMP 2466 LSIZE.WORDS := MAXADDR COMP 2467 ELSE V41CC08 7 BEGIN W := NROFELS * T; V41CC08 8 IF W >= MAXADDR THEN LSIZE.WORDS := MAXADDR V41CC08 9 ELSE LSIZE.WORDS := W V41CC08 10 END; V41CC08 11 LSIZE.BITS := 0; PARTWORDELS := FALSE COMP 2469 END COMP 2470 ELSE COMP 2471 BEGIN COMP 2472 IF LSIZE.BITS > 0 THEN COMP 2473 T := WORDSIZE DIV LSIZE.BITS COMP 2474 ELSE T := 1; COMP 2475 T1 := NROFELS MOD T; COMP 2476 IF (T1 = 0)AND(T*LSIZE.BITS < WORDSIZE) THEN T1 := T; COMP 2477 W := (NROFELS - T1) DIV T; COMP 2478 B := T1*LSIZE.BITS; COMP 2479 (* NOTE- ORD(TRUE)=1 AND ORD(FALSE)=0 *) COMP 2480 IF W + ORD(B <> 0) > MAXADDR THEN COMP 2481 BEGIN W := MAXADDR; B := 0 END; COMP 2482 LSIZE.WORDS := W; LSIZE.BITS := B; COMP 2483 IF T > 1 THEN COMP 2484 BEGIN PARTWORDELS := TRUE; COMP 2485 ELSPERWORD := T COMP 2486 END COMP 2487 ELSE PARTWORDELS := FALSE COMP 2488 END COMP 2489 END; COMP 2490 SIZE := LSIZE COMP 2491 END (*WITH LSP1^*) ; COMP 2492 LSP := LSP1; LSP1 := LSP2 COMP 2493 UNTIL LSP1 = NIL COMP 2494 END (*LSP <> NIL*) COMP 2495 END COMP 2496 ELSE COMP 2497 (*RECORD*) COMP 2498 IF SY = RECORDSY THEN COMP 2499 BEGIN INSYMBOL; COMP 2500 OLDTOP := TOP; LSCOPE := THISSCOPE; COMP 2501 IF HIGHSCOPE = SCOPEMAX THEN ERROR(252) COMP 2502 ELSE HIGHSCOPE := HIGHSCOPE + 1; COMP 2503 THISSCOPE := HIGHSCOPE; COMP 2504 IF TOP < DISPLIMIT THEN COMP 2505 BEGIN TOP := TOP + 1; COMP 2506 WITH DISPLAY[TOP] DO COMP 2507 BEGIN FNAME := NIL; REGION := DREC; FFWPTR := FWPTR END; COMP 2508 FWPTR := NIL COMP 2509 END COMP 2510 ELSE ERROR(250); COMP 2511 WITH DISPL DO COMP 2512 BEGIN WORDS := 0; BITS := 0 END; COMP 2513 FILEDISPL := DISPL; COMP 2514 FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1); V41CC07 248 MNEW(LSP,RECORDS); COMP 2516 WITH LSP^ DO COMP 2517 BEGIN FORM := RECORDS; PCKDREC := PACKFLAG; COMP 2518 FIELDIDTREE := DISPLAY[TOP].FNAME; FTYPE := LSP1^.FTYPE; V41CC07 249 FIELDLST := LSP1; SIZE := DISPL; V41CC07 250 IF FTYPE THEN (* ALTER FIELD OFFSETS *) V41CC07 251 BEGIN SIZE.WORDS := INCRADDR(SIZE.WORDS,FILEDISPL.WORDS); V41CC07 252 FIXFIELDALLOCATION(LSP1,FILEDISPL.WORDS) V41CC07 253 END COMP 2524 END; COMP 2525 IF FWPTR = NIL THEN FWPTR := DISPLAY[TOP].FFWPTR COMP 2526 ELSE COMP 2527 IF TOP <> OLDTOP THEN COMP 2528 BEGIN LCP := FWPTR; COMP 2529 WHILE LCP^.NEXT <> NIL DO LCP := LCP^.NEXT; COMP 2530 LCP^.NEXT := DISPLAY[TOP].FFWPTR COMP 2531 END; COMP 2532 THISSCOPE := LSCOPE; COMP 2533 TOP := OLDTOP; COMP 2534 EXPECTSYMBOL(ENDSY,13) COMP 2535 END COMP 2536 ELSE COMP 2537 (*SET*) COMP 2538 IF SY = SETSY THEN COMP 2539 BEGIN INSYMBOL; COMP 2540 EXPECTSYMBOL(OFSY,8); COMP 2541 SIMPLETYPE(FSYS,LSP1); COMP 2542 IF LSP1 <> NIL THEN COMP 2543 IF LSP1^.FORM > SUBRANGE THEN COMP 2544 BEGIN ERROR(115); LSP1 := NIL END COMP 2545 ELSE COMP 2546 BEGIN GETBOUNDS(LSP1,LMIN,LMAX); COMP 2547 IF (LMIN < 0) OR (LMAX > 58) THEN ERROR(169); COMP 2548 (*IMPLEMENTATION RESTRICTION TO ONE-WORD SETS*) COMP 2549 IF LMAX < LMIN THEN COMP 2550 WITH LSP1^ DO MAX.IVAL := MIN.IVAL; COMP 2551 MNEW(LSP,POWER); COMP 2552 WITH LSP^, SIZE DO COMP 2553 BEGIN ELSET := LSP1; COMP 2554 IF PACKFLAG THEN PCKDSET := [PCKD] COMP 2555 ELSE PCKDSET := [UNPCKD]; COMP 2556 FORM := POWER; FTYPE := FALSE; COMP 2557 IF LMAX >= 58 THEN COMP 2558 BEGIN WORDS := 1; BITS := 0 END COMP 2559 ELSE COMP 2560 BEGIN WORDS := 0; BITS := LMAX + 1 END COMP 2561 END COMP 2562 END COMP 2563 END COMP 2564 ELSE COMP 2565 (*FILE*) IF SY = FILESY THEN COMP 2566 BEGIN INSYMBOL; COMP 2567 EXPECTSYMBOL(OFSY,8); COMP 2568 TYP(FSYS,LSP1); COMP 2569 IF LSP1 <> NIL THEN (* COMPUTE IMPL.-DEP. FILE SIZE *) COMP 2570 BEGIN LRL := FULLWORDS(LSP1^.SIZE); COMP 2571 IF LRL <= 1 THEN LRL := 1 COMP 2572 END COMP 2573 ELSE LRL := 1; COMP 2574 MNEW(LSP,FILES); COMP 2575 WITH LSP^ DO COMP 2576 BEGIN FILTYPE := LSP1; FORM := FILES; FTYPE := TRUE; COMP 2577 SEGFILE := SEGFLAG; COMP 2578 BASEFILE := LSP; COMP 2579 TEXTFILE := FALSE; COMP 2580 PCKDFIL := PACKFLAG; COMP 2581 T := ((BUFFSZ + LRL - 1) DIV LRL + 1) * LRL; COMP 2582 IF T > MAXADDR THEN BSIZE := MAXADDR ELSE BSIZE := T; COMP 2583 WITH SIZE DO COMP 2584 BEGIN COMP 2585 IF OS = XSCOPE2 THEN WORDS := BNEFITSZ V41CC04 10 ELSE WORDS := BNEFETSZ; V41CC04 11 BITS := 0 COMP 2588 END COMP 2589 END; COMP 2590 IF LSP1 <> NIL THEN COMP 2591 IF LSP1^.FTYPE THEN COMP 2592 BEGIN ERROR(108); LSP^.FILTYPE := NIL END; COMP 2593 END; COMP 2594 END COMP 2595 END; COMP 2596 CHECKCONTEXT(FSYS,6,[]) COMP 2597 END; COMP 2598 FSP := LSP COMP 2599 END (*TYP*) ; COMP 2600 COMP 2601 PROCEDURE LABELDECLARATION; COMP 2602 LABEL 1; COMP 2603 VAR LLP: LBP; EXITLOOP: BOOLEAN; COMP 2604 BEGIN COMP 2605 (*LOOP UNTIL SY <> COMMA:*) COMP 2606 REPEAT COMP 2607 IF SY = INTCONST THEN COMP 2608 BEGIN COMP 2609 IF IVAL > MAXLABEL THEN ERROR(163); COMP 2610 LLP := FSTLABP; COMP 2611 WHILE LLP <> FLABP DO COMP 2612 IF LLP^.LABVAL = IVAL THEN COMP 2613 BEGIN ERROR(166); GOTO 1 END COMP 2614 ELSE LLP := LLP^.NEXTLAB; COMP 2615 MNEW(LLP); COMP 2616 WITH LLP^ DO COMP 2617 BEGIN LABVAL := IVAL; EPT := EPT1; EPT1 := TENBLANKS; COMP 2618 NEXTLAB := FSTLABP; LABLEV := LEVEL; DEFINED := FALSE; COMP 2619 ACCESSIBLE := TRUE; LABSTMTLEVEL := 0; COMP 2620 FSTOCC := NIL COMP 2621 END; COMP 2622 FSTLABP := LLP; COMP 2623 1: INSYMBOL; COMP 2624 END COMP 2625 ELSE ERROR(15); COMP 2626 CHECKCONTEXT(FSYS+[COMMA,SEMICOLON],6,[]); COMP 2627 EXITLOOP := SY <> COMMA; COMP 2628 IF NOT EXITLOOP THEN INSYMBOL COMP 2629 UNTIL EXITLOOP; COMP 2630 EXPECTSYMBOL(SEMICOLON,14) COMP 2631 END (*LABELDECLARATION*) ; COMP 2632 COMP 2633 PROCEDURE CONSTDECLARATION; COMP 2634 VAR LCP: CTP; LSP: STP; LVALU: VALU; COMP 2635 BEGIN COMP 2636 IF SY <> IDENT THEN COMP 2637 BEGIN ERROR(2); SKIP(FSYS+[IDENT]) END; COMP 2638 WHILE SY = IDENT DO COMP 2639 BEGIN MNEW(LCP,KONST); COMP 2640 WITH LCP^ DO COMP 2641 BEGIN COPYID(LCP); IDTYPE := NIL; NEXT := NIL; COMP 2642 KLASS := KONST COMP 2643 END; COMP 2644 INSYMBOL; COMP 2645 IF OP = EQOP THEN INSYMBOL ELSE ERROR(16); COMP 2646 CONSTANT(FSYS+[SEMICOLON],LSP,LVALU); COMP 2647 ENTERID(LCP,BLCK); COMP 2648 LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU; COMP 2649 IF SY = SEMICOLON THEN COMP 2650 BEGIN INSYMBOL; COMP 2651 CHECKCONTEXT(FSYS+[IDENT],6,[]) COMP 2652 END COMP 2653 ELSE ERROR(14) COMP 2654 END COMP 2655 END (*CONSTDECLARATION*) ; COMP 2656 COMP 2657 PROCEDURE TYPEDECLARATION; COMP 2658 VAR LCP,LCP1,LCP2: CTP; LSP: STP; LID: IDNAME; GOTONE: BOOLEAN; V41DC05 470 BEGIN COMP 2660 INTYPEDEFINITION := TRUE; COMP 2661 IF SY <> IDENT THEN COMP 2662 BEGIN ERROR(2); SKIP(FSYS+[IDENT]) END; COMP 2663 WHILE SY = IDENT DO COMP 2664 BEGIN MNEW(LCP,TYPES); COMP 2665 WITH LCP^ DO COMP 2666 BEGIN COPYID(LCP); IDTYPE := NIL; KLASS := TYPES END; COMP 2667 INSYMBOL; COMP 2668 IF OP = EQOP THEN INSYMBOL ELSE ERROR(16); COMP 2669 TYP(FSYS+[SEMICOLON],LSP); COMP 2670 LCP^.IDTYPE := LSP; COMP 2671 LCP1 := FWPTR; GOTONE := FALSE; COMP 2672 WHILE LCP1 <> NIL DO (*HAS ANY FORWARD REFERENCE BEEN SATISFIED?*) COMP 2673 BEGIN COMP 2674 IF COMPAREIDS(LCP1^.NAME,LCP^.NAME) = EQUALTO THEN COMP 2675 BEGIN COMP 2676 LCP1^.IDTYPE^.ELTYPE := LSP; GOTONE := TRUE; COMP 2677 IF LCP1 <> FWPTR THEN COMP 2678 LCP2^.NEXT := LCP1^.NEXT COMP 2679 ELSE FWPTR := LCP1^.NEXT; COMP 2680 END COMP 2681 ELSE LCP2 := LCP1; COMP 2682 LCP1 := LCP1^.NEXT COMP 2683 END; COMP 2684 ENTERID(LCP,BLCK); COMP 2685 IF GOTONE THEN LCP^.LASTUSESCOPE := THISSCOPE; COMP 2686 IF SY = SEMICOLON THEN COMP 2687 BEGIN INSYMBOL; COMP 2688 CHECKCONTEXT(FSYS+[IDENT],6,[]) COMP 2689 END COMP 2690 ELSE ERROR(14) COMP 2691 END; COMP 2692 LID := ID; LCP := NIL; COMP 2693 WHILE FWPTR <> NIL DO COMP 2694 BEGIN LCP1 := FWPTR; FWPTR := FWPTR^.NEXT; COMP 2695 ID := LCP1^.NAME; SEARCHID([TYPES,UNKNOWNID],LCP2); COMP 2696 IF LCP2 = NIL THEN (* UNDEFINED *) COMP 2697 BEGIN LCP1^.NEXT := LCP; LCP := LCP1 END COMP 2698 ELSE (* CAN RESOLVE *) COMP 2699 BEGIN LCP1^.IDTYPE^.ELTYPE := LCP2^.IDTYPE; COMP 2700 DISPOSE(LCP1,TYPES) COMP 2701 END COMP 2702 END; COMP 2703 IF LCP <> NIL THEN COMP 2704 BEGIN ERROR(117); COMP 2705 REPEAT FLAGERROR; V41DC05 471 PUTERRMSG(' UNDEFINED TYPE: ',FALSE); WRITEID(LCP^.NAME); V41DC05 472 LCP1 := LCP; LCP := LCP^.NEXT; COMP 2708 DISPOSE(LCP1,TYPES) COMP 2709 UNTIL LCP = NIL COMP 2710 END; COMP 2711 ID := LID; INTYPEDEFINITION := FALSE COMP 2712 END (*TYPEDECLARATION*) ; COMP 2713 COMP 2714 PROCEDURE VARDECLARATION; COMP 2715 VAR LCP,NXT: CTP; LSP: STP; EXITLOOP: BOOLEAN; COMP 2716 LEXFILP: EXTFILEP; LSIZE: ADDRRANGE; LACCESS: DRCTINDRCT; COMP 2717 BEGIN COMP 2718 NXT := NIL; COMP 2719 REPEAT COMP 2720 (*LOOP UNTIL SY <> COMMA:*) COMP 2721 REPEAT COMP 2722 IF SY = IDENT THEN COMP 2723 BEGIN MNEW(LCP,VARS); COMP 2724 WITH LCP^ DO COMP 2725 BEGIN COPYID(LCP); NEXT := NXT; KLASS := VARS; COMP 2726 IDTYPE := NIL; VINIT := FALSE; VACCESS := DRCT; COMP 2727 VKIND := ACTUAL; VARPARAM := FALSE; COMP 2728 VLEV := LEVEL; CONFORMNT := FALSE; COMP 2729 FIRSTINPARMGROUP := FALSE; COMP 2730 THREAT := FALSE; CONTROLVAR := FALSE; COMP 2731 END; COMP 2732 ENTERID(LCP,BLCK); COMP 2733 NXT := LCP; COMP 2734 INSYMBOL; COMP 2735 END COMP 2736 ELSE ERROR(2); COMP 2737 CHECKCONTEXT(FSYS+[COMMA,COLON]+TYPEDELS,6,[SEMICOLON]); COMP 2738 EXITLOOP := SY <> COMMA; COMP 2739 IF NOT EXITLOOP THEN INSYMBOL COMP 2740 UNTIL EXITLOOP; COMP 2741 EXPECTSYMBOL(COLON,5); COMP 2742 TYP(FSYS+[SEMICOLON]+TYPEDELS,LSP); COMP 2743 LACCESS := DRCT; LSIZE := 1; COMP 2744 IF LSP <> NIL THEN COMP 2745 BEGIN COMP 2746 LSIZE := FULLWORDS(LSP^.SIZE); COMP 2747 IF (LSIZE >= MVOPTION) AND (LEVEL <> 1) THEN COMP 2748 BEGIN LSIZE := 1; LACCESS := INDRCT END COMP 2749 END; COMP 2750 WHILE NXT <> NIL DO COMP 2751 WITH NXT^ DO COMP 2752 BEGIN IDTYPE := LSP; VADDR := LC; VACCESS := LACCESS; COMP 2753 LC := LC + LSIZE; COMP 2754 IF LC > MAXADDR THEN COMP 2755 BEGIN LC := 0; ERROR(261) END; COMP 2756 IF (LEVEL = 1) AND (LSP <> NIL) THEN COMP 2757 BEGIN LEXFILP := FEXFILP; COMP 2758 WHILE LEXFILP <> NIL DO COMP 2759 IF NAME.TEN = LEXFILP^.FILENAME THEN COMP 2760 BEGIN COMP 2761 LEXFILP^.FILECP := NXT; VKIND := FORMAL; COMP 2762 LEXFILP := NIL; COMP 2763 IF LSP <> NIL THEN COMP 2764 IF LSP^.FORM <> FILES THEN ERROR(171) COMP 2765 END COMP 2766 ELSE LEXFILP := LEXFILP^.NXTP COMP 2767 END; COMP 2768 NXT := NEXT COMP 2769 END; COMP 2770 IF SY = SEMICOLON THEN COMP 2771 BEGIN INSYMBOL; COMP 2772 CHECKCONTEXT(FSYS+[IDENT],6,[]) COMP 2773 END COMP 2774 ELSE ERROR(14) COMP 2775 UNTIL (SY <> IDENT)AND NOT (SY IN TYPEDELS); COMP 2776 END (*VARDECLARATION*) ; COMP 2777 COMP 2778 PROCEDURE VALUEDECLARATION; COMP 2779 VAR LASTADDR: INTEGER; COMP 2780 LSP: STP; COMP 2781 LCP: CTP; COMP 2782 TEXTTAB: ARRAY[0..15] OF VALU; COMP 2783 THIST: 0..15; COMP 2784 IDW: PACKED RECORD CASE BOOLEAN OF COMP 2785 FALSE: (I: INTEGER); COMP 2786 TRUE: (CN: 0..7777B; COMP 2787 WC: 0..7777B; COMP 2788 LR: 0..777777B; COMP 2789 L : 0..777777B) COMP 2790 END; COMP 2791 LMARK: MARKER; COMP 2792 COMP 2793 PROCEDURE PUTTEXTTAB; COMP 2794 VAR I: INTEGER; COMP 2795 BEGIN (* PUTTEXTTAB *) COMP 2796 IF THIST <> 0 THEN COMP 2797 BEGIN IDW.WC := THIST + 1; COMP 2798 VALUES^^ := IDW.I; PUT(VALUES^); COMP 2799 VALUES^^ := 0; PUT(VALUES^); COMP 2800 FOR I := 1 TO THIST DO COMP 2801 BEGIN VALUES^^ := TEXTTAB[I].IVAL; COMP 2802 PUT(VALUES^) COMP 2803 END; COMP 2804 THIST := 0 COMP 2805 END COMP 2806 END (* PUTTEXTTAB *); COMP 2807 COMP 2808 PROCEDURE VALUESPECIFICATION(FSYS: SETOFSYS; FSP: STP; COMP 2809 FWRD: ADDRRANGE; FBIT: BITRANGE; FPCKD: BOOLEAN); COMP 2810 VAR LCP: CTP; COMP 2811 LSP,LSP1: STP; COMP 2812 LVALU: VALU; COMP 2813 LSYS: SETOFSYS; COMP 2814 WRDS: ADDRRANGE; COMP 2815 BITS: BITRANGE; COMP 2816 RIGHTADJ: BOOLEAN; COMP 2817 COMP 2818 PROCEDURE EMITVALUE(FVALU: VALU); COMP 2819 VAR L,R: BITRANGE; COMP 2820 BEGIN (* EMITVALUE *) COMP 2821 IF FWRD <> LASTADDR THEN COMP 2822 BEGIN COMP 2823 IF (FWRD <> LASTADDR+1) OR (THIST = 15) THEN COMP 2824 BEGIN PUTTEXTTAB; IDW.L := ARPS + FWRD END; COMP 2825 THIST := THIST + 1; COMP 2826 TEXTTAB[THIST].IVAL := 0; COMP 2827 LASTADDR := FWRD COMP 2828 END; COMP 2829 IF FPCKD AND (WRDS = 0) THEN COMP 2830 BEGIN (* MASK AND ROTATE VALUE INTO ITS FIELD *) COMP 2831 IF RIGHTADJ THEN BEGIN L := BITS-1; R := 0 END COMP 2832 ELSE BEGIN L := WORDSIZE-1; R := WORDSIZE-BITS END; COMP 2833 FVALU.IVAL := PORTION(FVALU.IVAL,L,R); COMP 2834 FVALU.IVAL := ROTATE(FVALU.IVAL,WORDSIZE - FBIT - BITS) COMP 2835 END; COMP 2836 TEXTTAB[THIST].IVAL := MERGE(TEXTTAB[THIST],FVALU); COMP 2837 END (* EMITVALUE *); COMP 2838 COMP 2839 PROCEDURE EMITSTRING(FCSP: CTAILP); COMP 2840 VAR LVALU: VALU; COMP 2841 LRIGHTADJ: BOOLEAN; COMP 2842 BEGIN (* EMITSTRING *) COMP 2843 LRIGHTADJ := RIGHTADJ; COMP 2844 RIGHTADJ := FALSE; COMP 2845 WHILE FCSP <> NIL DO COMP 2846 BEGIN LVALU.IVAL := FCSP^.CSVAL; COMP 2847 EMITVALUE(LVALU); COMP 2848 IF NOT FPCKD THEN FWRD := FWRD + 1; COMP 2849 FCSP := FCSP^.NXTCSP COMP 2850 END; COMP 2851 RIGHTADJ := LRIGHTADJ COMP 2852 END (* EMITSTRING *); COMP 2853 COMP 2854 PROCEDURE CHECKRANGE(FSP1,FSP2: STP; FVALU: VALU); COMP 2855 VAR LMIN,LMAX: INTEGER; COMP 2856 BEGIN (* CHECKRANGE *) COMP 2857 IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN COMP 2858 IF COMPTYPES(FSP1,FSP2) THEN COMP 2859 BEGIN COMP 2860 IF FSP1^.FORM <= SUBRANGE THEN COMP 2861 BEGIN GETBOUNDS(FSP1,LMIN,LMAX); COMP 2862 IF (FVALU.IVAL < LMIN) OR (FVALU.IVAL > LMAX) THEN ERROR(303) COMP 2863 END COMP 2864 END COMP 2865 ELSE ERROR(145) COMP 2866 END (* CHECKRANGE *); COMP 2867 COMP 2868 PROCEDURE SKIPSTRUCTUREDVALUE( INSY : BOOLEAN ); COMP 2869 BEGIN (* SKIPSTRUCTUREDVALUE *) COMP 2870 IF INSY THEN INSYMBOL; COMP 2871 VALUESPECIFICATION(LSYS+[OFSY],NIL,0,0,FALSE); COMP 2872 WHILE SY IN [COMMA,OFSY] DO COMP 2873 BEGIN INSYMBOL; VALUESPECIFICATION(LSYS+[OFSY],NIL,0,0,FALSE) END COMP 2874 END (* SKIPSTRUCTUREDVALUE *); COMP 2875 COMP 2876 PROCEDURE RECORDVALUE; COMP 2877 VAR LCP: CTP; COMP 2878 LSP,LSP1: STP; COMP 2879 LVALU: VALU; COMP 2880 LWRD: ADDRRANGE; COMP 2882 LBIT,BIT: BITRANGE; COMP 2883 EXITLOOP: BOOLEAN; COMP 2884 BEGIN (* RECORDVALUE *) COMP 2885 IF FSP^.FIELDLST <> NIL THEN V41CC07 254 WITH FSP^.FIELDLST^ DO V41CC07 255 BEGIN LCP := FIXEDPART; LSP := VARPART END; V41CC07 256 LWRD := FWRD; LBIT := FBIT; COMP 2888 INSYMBOL; COMP 2889 IF SY <> RPARENT THEN COMP 2890 REPEAT COMP 2891 IF LCP = NIL THEN COMP 2892 IF LSP = NIL THEN COMP 2893 BEGIN ERROR(42); (* TOO MANY VALUES SPECIFIED *) COMP 2894 SKIPSTRUCTUREDVALUE(FALSE) COMP 2895 END COMP 2896 ELSE (* LSP <> NIL *) COMP 2897 BEGIN WITH LSP^ DO COMP 2898 IF TAGTYPE <> NIL THEN V41CC07 257 BEGIN CONSTANT(LSYS,LSP1,LVALU); V41CC07 258 CHECKRANGE(TAGTYPE,LSP1,LVALU); V41CC07 259 IF TAGFIELDID <> NIL THEN V41CC07 260 BEGIN V41CC07 261 WITH TAGTYPE^ DO V41CC07 262 BEGIN WRDS := SIZE.WORDS; BITS := SIZE.BITS END; V41CC07 263 WITH TAGFIELDID^ DO V41CC07 264 BEGIN FWRD := LWRD + FLDADDR; V41CC07 265 FPCKD := PCKDFLD; V41CC07 266 IF FPCKD THEN FBIT := LBIT + BITADDR; V41CC07 267 EMITVALUE(LVALU) V41CC07 268 END V41CC07 269 END; V41CC07 270 LSP1 := FINDVARIANT(LSP,LVALU); V41CC07 271 IF LSP1 <> NIL THEN V41CC07 272 WITH LSP1^ DO V41CC07 273 BEGIN LCP := FIXEDPART; LSP := VARPART END V41CC07 274 ELSE BEGIN ERROR(158); LSP := NIL END V41CC07 275 END (* TAGTYPE <> NIL *) V41CC07 276 ELSE SKIPSTRUCTUREDVALUE(FALSE) COMP 2924 END (* LSP <> NIL *) COMP 2925 ELSE (* LCP <> NIL *) COMP 2926 WITH LCP^ DO COMP 2927 BEGIN IF PCKDFLD THEN BIT := LBIT+BITADDR ELSE BIT := 0; COMP 2928 VALUESPECIFICATION(LSYS,IDTYPE,LWRD+FLDADDR,BIT,PCKDFLD); COMP 2929 LCP := NEXT COMP 2930 END; COMP 2931 EXITLOOP := SY <> COMMA; COMP 2932 IF NOT EXITLOOP THEN INSYMBOL COMP 2933 UNTIL EXITLOOP; COMP 2934 IF (LCP <> NIL) OR (LSP <> NIL) THEN ERROR(41) (*TOO FEW VALUES*) COMP 2935 END (* RECORDVALUE *); COMP 2936 COMP 2937 PROCEDURE ARRAYVALUE; COMP 2938 TYPE REPLKIND = 1..4; COMP 2939 VAR EL,TEMP,REPCNT,LMIN,LMAX: INTEGER; COMP 2940 LVALU: VALU; COMP 2941 LCP: CTP; COMP 2942 LSP: STP; COMP 2943 CONSTVALUE: BOOLEAN; COMP 2944 LWRD,NWRDS: ADDRRANGE; COMP 2945 REPL: PACKED RECORD CASE REPLKIND OF COMP 2946 1: (I : INTEGER); COMP 2947 2: (CN : 0..7777B; COMP 2948 WC : 0..7777B; COMP 2949 CR : 0..77777777B; COMP 2950 IM : 0..7777B); COMP 2951 3: (INC : 0..77777777777B; COMP 2952 SR : 0..777B; COMP 2953 SADDR: 0..777777B); COMP 2954 4: (REP : 0..777777B; COMP 2955 BSZ : 0..77777B; COMP 2956 DR : 0..777B; COMP 2957 DADDR: 0..777777B) COMP 2958 END; COMP 2959 BEGIN (* ARRAYVALUE *) COMP 2960 WITH FSP^ DO COMP 2961 BEGIN REPCNT := 0; COMP 2962 WITH AELTYPE^ DO COMP 2963 BEGIN WRDS := SIZE.WORDS; COMP 2964 BITS := SIZE.BITS; COMP 2965 NWRDS := FULLWORDS(SIZE) COMP 2966 END; COMP 2967 FPCKD := PCKDARR; COMP 2968 IF FPCKD THEN FPCKD := PARTWORDELS; COMP 2969 GETBOUNDS(INXTYPE,LMIN,LMAX); COMP 2970 EL := LMIN; COMP 2971 REPEAT COMP 2972 IF REPCNT = 0 THEN COMP 2973 BEGIN INSYMBOL; COMP 2974 IF SY = IDENT THEN COMP 2975 BEGIN SEARCHID([KONST,UNKNOWNID],LCP); COMP 2976 CONSTVALUE := LCP <> NIL COMP 2977 END COMP 2978 ELSE CONSTVALUE := SY IN CONSTBEGSYS; COMP 2979 IF CONSTVALUE THEN COMP 2980 BEGIN CONSTANT(LSYS+[OFSY],LSP,LVALU); COMP 2981 IF SY = OFSY THEN COMP 2982 BEGIN REPCNT := 1; COMP 2983 IF COMPTYPES(LSP,INTPTR) THEN COMP 2984 IF LVALU.IVAL > 0 THEN REPCNT := LVALU.IVAL COMP 2985 ELSE ERROR(45) (* REPETITION FACTOR MUST BE > 0 *) COMP 2986 ELSE ERROR(145); COMP 2987 INSYMBOL; COMP 2988 IF FPCKD THEN COMP 2989 BEGIN TEMP := TEXTTAB[THIST].IVAL; COMP 2990 TEXTTAB[THIST].IVAL := 0; COMP 2991 VALUESPECIFICATION(LSYS,AELTYPE,LASTADDR,0,TRUE); COMP 2992 LVALU.IVAL := ROTATE(TEXTTAB[THIST].IVAL,BITS); COMP 2993 TEXTTAB[THIST].IVAL := TEMP; COMP 2994 EMITVALUE(LVALU); COMP 2995 REPCNT := REPCNT - 1 COMP 2996 END COMP 2997 ELSE (* NOT FPCKD *) COMP 2998 BEGIN VALUESPECIFICATION(LSYS,AELTYPE,FWRD,0,FALSE); COMP 2999 IF REPCNT > 1 THEN COMP 3000 BEGIN PUTTEXTTAB; COMP 3001 WITH REPL DO COMP 3002 BEGIN CN := 4300B; (* REPL TABLE *) COMP 3003 WC := 2; CR := 0; IM := 1; COMP 3004 VALUES^^ := I; PUT(VALUES^); COMP 3005 INC := NWRDS; SR := 1; SADDR := ARPS + FWRD; COMP 3006 VALUES^^ := I; PUT(VALUES^); COMP 3007 REP := REPCNT - 1; BSZ := NWRDS; DR := 1; COMP 3008 DADDR := ARPS + FWRD + NWRDS; COMP 3009 VALUES^^ := I; PUT(VALUES^) COMP 3010 END; COMP 3011 FWRD := FWRD + (REPCNT-1) * NWRDS; COMP 3012 EL := EL + REPCNT - 1 COMP 3013 END (* REPCNT > 1 *); COMP 3014 REPCNT := 0 COMP 3015 END (* NOT FPCKD *) COMP 3016 END COMP 3017 ELSE (* SY <> OFSY *) COMP 3018 BEGIN CHECKRANGE(AELTYPE,LSP,LVALU); COMP 3019 IF STRING(LSP) THEN COMP 3020 BEGIN LWRD := FWRD; COMP 3021 EMITSTRING(LVALU.VALP); COMP 3022 FWRD := LWRD COMP 3023 END COMP 3024 ELSE EMITVALUE(LVALU) COMP 3025 END COMP 3026 END COMP 3027 ELSE (* NOT CONSTVALUE *) COMP 3028 VALUESPECIFICATION(LSYS,AELTYPE,FWRD,FBIT,FPCKD) COMP 3029 END COMP 3030 ELSE (* REPCNT <> 0 *) COMP 3031 BEGIN EMITVALUE(LVALU); COMP 3032 REPCNT := REPCNT - 1 COMP 3033 END; COMP 3034 IF FPCKD THEN COMP 3035 IF FBIT + BITS + BITS > WORDSIZE THEN COMP 3036 BEGIN FBIT := 0; FWRD := FWRD + 1 END COMP 3037 ELSE FBIT := FBIT + BITS COMP 3038 ELSE FWRD := FWRD + NWRDS; COMP 3039 IF EL > LMAX THEN COMP 3040 BEGIN ERROR(42); (* TOO MANY VALUES SPECIFIED *) COMP 3041 REPCNT := 0; COMP 3042 IF SY = COMMA THEN SKIPSTRUCTUREDVALUE(TRUE) COMP 3043 END; COMP 3044 EL := EL + 1 COMP 3045 UNTIL (SY <> COMMA) AND (REPCNT = 0); COMP 3046 IF EL <= LMAX THEN ERROR(41) (* TOO FEW VALUES SPECIFIED *) COMP 3047 END (* WITH FSP^ *) COMP 3048 END (* ARRAYVALUE *); COMP 3049 COMP 3050 PROCEDURE SETVALUE; COMP 3051 VAR LOELEMENT,HIELEMENT: INTEGER; COMP 3052 EXITLOOP: BOOLEAN; COMP 3053 LVALU: VALU; COMP 3054 LSP: STP; COMP 3055 COMP 3056 PROCEDURE SETELEMENT(FSYS: SETOFSYS; VAR ELEMENT: INTEGER); COMP 3057 VAR LSP1: STP; COMP 3058 LVALU: VALU; COMP 3059 BEGIN (* SETELEMENT *) COMP 3060 CONSTANT(FSYS,LSP1,LVALU); COMP 3061 ELEMENT := 0; COMP 3062 IF LSP1 <> NIL THEN COMP 3063 IF LSP1^.FORM <= SUBRANGE THEN COMP 3064 BEGIN ELEMENT := LVALU.IVAL; CHECKRANGE(LSP,LSP1,LVALU) END COMP 3065 ELSE ERROR(136) COMP 3066 END (* SETELEMENT *); COMP 3067 COMP 3068 BEGIN (* SETVALUE *) COMP 3069 LVALU.PVAL := []; COMP 3070 LSP := NIL; COMP 3071 IF FSP <> NIL THEN COMP 3072 WITH FSP^ DO COMP 3073 IF FORM <> POWER THEN ERROR(145) COMP 3074 ELSE LSP := ELSET; COMP 3075 INSYMBOL; COMP 3076 IF SY <> RBRACK THEN COMP 3077 REPEAT SETELEMENT(FSYS+[DOTDOT,COMMA,RBRACK],LOELEMENT); COMP 3078 IF SY = DOTDOT THEN COMP 3079 BEGIN INSYMBOL; COMP 3080 SETELEMENT(FSYS+[COMMA,RBRACK],HIELEMENT); COMP 3081 LVALU.PVAL := LVALU.PVAL + [LOELEMENT..HIELEMENT] COMP 3082 END COMP 3083 ELSE LVALU.PVAL := LVALU.PVAL + [LOELEMENT]; COMP 3084 EXITLOOP := SY <> COMMA; COMP 3085 IF NOT EXITLOOP THEN INSYMBOL COMP 3086 UNTIL EXITLOOP; COMP 3087 EMITVALUE(LVALU); COMP 3088 EXPECTSYMBOL(RBRACK,12) COMP 3089 END (* SETVALUE *); COMP 3090 COMP 3091 BEGIN (* VALUESPECIFICATION *) COMP 3092 IF FSP <> NIL THEN WITH FSP^ DO COMP 3093 BEGIN WRDS := SIZE.WORDS; BITS := SIZE.BITS END; COMP 3094 LSYS := FSYS+[COMMA,RPARENT]; COMP 3095 RIGHTADJ := TRUE; COMP 3096 CHECKCONTEXT(VALSPECBEGSYS,6,FSYS); COMP 3097 IF SY IN VALSPECBEGSYS THEN COMP 3098 BEGIN COMP 3099 IF SY = IDENT THEN COMP 3100 BEGIN SEARCHID([KONST,TYPES],LCP); COMP 3101 IF LCP^.KLASS = TYPES THEN COMP 3102 BEGIN COMP 3103 IF FSP <> NIL THEN COMP 3104 BEGIN COMP 3105 IF NOT COMPTYPES(FSP,LCP^.IDTYPE) THEN ERROR(145) COMP 3106 END COMP 3107 ELSE FSP := LCP^.IDTYPE; COMP 3108 INSYMBOL; COMP 3109 IF SY <> LPARENT THEN COMP 3110 BEGIN ERROR(9); IF SY = IDENT THEN SEARCHID([KONST],LCP) END COMP 3111 END COMP 3112 END (* SY = IDENT *); COMP 3113 IF SY = LPARENT THEN COMP 3114 BEGIN COMP 3115 IF FSP = NIL THEN SKIPSTRUCTUREDVALUE(TRUE) COMP 3116 ELSE COMP 3117 WITH FSP^ DO COMP 3118 IF FORM = RECORDS THEN RECORDVALUE COMP 3119 ELSE COMP 3120 IF FORM = ARRAYS THEN ARRAYVALUE COMP 3121 ELSE COMP 3122 BEGIN ERROR(44); (* TYPE IS NEITHER ARRAY NOR RECORD *) COMP 3123 SKIPSTRUCTUREDVALUE(TRUE) COMP 3124 END; COMP 3125 EXPECTSYMBOL(RPARENT,4) COMP 3126 END COMP 3127 ELSE (* SY <> LPARENT *) COMP 3128 IF SY = LBRACK THEN SETVALUE COMP 3129 ELSE COMP 3130 BEGIN COMP 3131 IF SY = NILSY THEN COMP 3132 BEGIN LSP := NILPTR; COMP 3133 LVALU.IVAL := NILP; INSYMBOL COMP 3134 END COMP 3135 ELSE CONSTANT(FSYS,LSP,LVALU); COMP 3136 IF LSP <> NIL THEN COMP 3137 BEGIN CHECKRANGE(FSP,LSP,LVALU); COMP 3138 IF STRING(LSP) THEN EMITSTRING(LVALU.VALP) COMP 3139 ELSE EMITVALUE(LVALU) COMP 3140 END COMP 3141 END; COMP 3142 CHECKCONTEXT(FSYS,6,[]) COMP 3143 END (* SY IN VALSPECBEGSYS *) ; COMP 3144 END (* VALUESPECIFICATION *); COMP 3145 COMP 3146 BEGIN (* VALUEDECLARATION *) COMP 3147 IF LEVEL = 1 THEN COMP 3148 BEGIN LASTADDR := MAXADDR+1; THIST := 0; COMP 3149 COMP 3150 IDW.I := 0; IDW.CN := 4000B; (* TEXT TABLE *); IDW.LR := 1; COMP 3151 CHECKCONTEXT([IDENT],2,FSYS); COMP 3152 IF VALUES = NIL THEN BEGIN NEW(VALUES); REWRITE(VALUES^) END; COMP 3153 WHILE SY = IDENT DO COMP 3154 BEGIN SEARCHID([VARS],LCP); COMP 3155 WITH LCP^ DO COMP 3156 BEGIN IF VINIT THEN ERROR(43); (* INITIALIZED TWICE *) COMP 3157 VINIT := TRUE; COMP 3158 LSP := IDTYPE; COMP 3159 IF LSP <> NIL THEN COMP 3160 IF LSP^.FORM = FILES THEN COMP 3161 BEGIN ERROR(108); LSP := NIL END; COMP 3162 INSYMBOL; COMP 3163 IF OP = EQOP THEN INSYMBOL ELSE ERROR(16); COMP 3164 MARK(LMARK); COMP 3165 VALUESPECIFICATION(FSYS+[SEMICOLON],LSP,VADDR,0,FALSE); COMP 3166 RELEASE(LMARK) COMP 3167 END; COMP 3168 IF SY = SEMICOLON THEN COMP 3169 BEGIN INSYMBOL; CHECKCONTEXT(FSYS+[IDENT],6,[]) END COMP 3170 ELSE ERROR(14) COMP 3171 END (* WHILE *); COMP 3172 PUTTEXTTAB COMP 3173 END (* LEVEL = 1 *) COMP 3174 ELSE COMP 3175 BEGIN ERROR(40); (* VALUE PART ALLOWED ONLY IN MAIN PROGRAM *) COMP 3176 SKIP(FSYS) COMP 3177 END COMP 3178 END (* VALUEDECLARATION *); COMP 3179 COMP 3180 PROCEDURE PROCEDUREDECLARATION(FSY: SYMBOL); COMP 3181 VAR OLDLEV: LEVRANGE; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP; COMP 3182 FORW: BOOLEAN; OLDTOP: DISPRANGE; COMP 3183 LLC: ADDRRANGE; LMARK: MARKER; COMP 3184 MULTIWORDVALUEPARAMETER: BOOLEAN; COMP 3185 COMP 3186 PROCEDURE PFHEADER(HSYS: SETOFSYS; FSY: SYMBOL; VAR FCP: CTP; COMP 3187 VAR FORW: BOOLEAN; FKIND: IDKIND); COMP 3188 (* GATHER PROCEDURE/FUNCTION HEADER. FSY SPECIFIES WHETHER IT IS COMP 3189 A PROCEDURE OR FUNCTION, FKIND SPECIFIES WHETHER IT IS AN ACTUAL COMP 3190 PROC/FUNC OR A FORMAL PARAMETER. THE PARAMETER LIST IS COMP 3191 RETURNED IN FCP, AND FORW INDICATES IF IT IS FORWARD DECLARED. *) COMP 3192 VAR LCP,LCP1,LCP2: CTP; LSP: STP; COMP 3193 LKLASS: IDCLASS; COMP 3194 COMP 3195 PROCEDURE PARAMETERLIST(PSYS: SETOFSYS; VAR FPAR: CTP); COMP 3196 (* GATHER A PARAMETER LIST, RETURNING IT IN FPAR. *) COMP 3197 VAR LCP,LCP1,LCP2,LCP3: CTP; LSP,LSP1,LSP2: STP; COMP 3198 LACCESS: DRCTINDRCT; LVARPARAM: BOOLEAN; COMP 3199 SZ: INTEGER; LSY: SYMBOL; LFORW: BOOLEAN; COMP 3200 OLDTOP: DISPRANGE; LLC: ADDRRANGE; LSCOPE: SCOPERANGE; COMP 3201 EXITLOOP,CONFORMFLAG: BOOLEAN; COMP 3202 COMP 3203 PROCEDURE CNFARRAYSCHEMA(VAR FSP: STP); COMP 3204 VAR LSP,LSP1,LSP2: STP; LSIZE: ADDRRANGE; COMP 3205 PACKFLAG,EXITLOOP: BOOLEAN; T: INTEGER; COMP 3206 COMP 3207 PROCEDURE INDEXTYPESPECIFICATION(VAR FSP: STP); COMP 3208 VAR LSP1,LSP2: STP; LCP1,LCP2,LCP3: CTP; COMP 3209 COMP 3210 PROCEDURE BOUNDDECLARATION(VAR FCP: CTP); COMP 3211 VAR LCP: CTP; COMP 3212 BEGIN (* BOUNDDECLARATION *) COMP 3213 IF SY = IDENT THEN COMP 3214 BEGIN MNEW(LCP,BOUNDID); COMP 3215 WITH LCP^ DO COMP 3216 BEGIN COPYID(LCP); IDTYPE := NIL; NEXT := NIL; COMP 3217 KLASS := BOUNDID; COMP 3218 BADDR := 0; BLEV := LEVEL + ORD(LEVEL < MAXLEVEL) COMP 3219 END; COMP 3220 ENTERID(LCP,PFPAR); INSYMBOL COMP 3221 END COMP 3222 ELSE COMP 3223 BEGIN ERROR(222); LCP := NIL; COMP 3224 SKIP(FSYS+[DOTDOT,IDENT,COLON,RBRACK]) COMP 3225 END; COMP 3226 FCP := LCP COMP 3227 END (* BOUNDDECLARATION *); COMP 3228 COMP 3229 BEGIN (* INDEXTYPESPECIFICATION *) COMP 3230 BOUNDDECLARATION(LCP1); COMP 3231 EXPECTSYMBOL(DOTDOT,21); COMP 3232 BOUNDDECLARATION(LCP2); COMP 3233 EXPECTSYMBOL(COLON,5); COMP 3234 IF SY = IDENT THEN COMP 3235 BEGIN SEARCHID([TYPES],LCP3); COMP 3236 LSP2 := LCP3^.IDTYPE; COMP 3237 IF LSP2 <> NIL THEN COMP 3238 IF LSP2^.FORM > SUBRANGE THEN COMP 3239 BEGIN LSP2 := NIL; ERROR(223) END; COMP 3240 INSYMBOL COMP 3241 END COMP 3242 ELSE BEGIN ERROR(2); LSP2 := NIL END; COMP 3243 IF LCP1 <> NIL THEN LCP1^.IDTYPE := LSP2; COMP 3244 IF LCP2 <> NIL THEN LCP2^.IDTYPE := LSP2; COMP 3245 MNEW(LSP1,BOUNDDESC); COMP 3246 WITH LSP1^ DO COMP 3247 BEGIN FORM := BOUNDDESC; FTYPE := FALSE; COMP 3248 SIZE.WORDS := 0; SIZE.BITS := 0; BOUNDTYPE := LSP2; COMP 3249 LOWBOUND := LCP1; HIGHBOUND := LCP2 COMP 3250 END; COMP 3251 FSP := LSP1 COMP 3252 END (* INDEXTYPESPECIFICATION *); COMP 3253 COMP 3254 BEGIN (* CNFARRAYSCHEMA *) COMP 3255 IF SY = PACKEDSY THEN COMP 3256 BEGIN PACKFLAG := TRUE; INSYMBOL END COMP 3257 ELSE PACKFLAG := FALSE; COMP 3258 IF SY = ARRAYSY THEN COMP 3259 BEGIN LSP1 := NIL; COMP 3260 INSYMBOL; EXPECTSYMBOL(LBRACK,11); COMP 3261 (*LOOP UNTIL SY <> SEMICOLON:*) COMP 3262 REPEAT INDEXTYPESPECIFICATION(LSP2); COMP 3263 MNEW(LSP,ARRAYS); COMP 3264 WITH LSP^ DO COMP 3265 BEGIN FORM := ARRAYS; COMP 3266 AELTYPE := LSP1; INXTYPE := LSP2; FTYPE := FALSE; COMP 3267 PCKDARR := PACKFLAG; CONFORMANT := TRUE COMP 3268 END; COMP 3269 LSP1 := LSP; COMP 3270 EXITLOOP := SY <> SEMICOLON; COMP 3271 IF NOT EXITLOOP THEN COMP 3272 BEGIN INSYMBOL; IF PACKFLAG THEN ERROR(220) END COMP 3273 UNTIL EXITLOOP; COMP 3274 EXPECTSYMBOL(RBRACK,12); EXPECTSYMBOL(OFSY,8); COMP 3275 IF SY = IDENT THEN COMP 3276 BEGIN SEARCHID([TYPES],LCP); COMP 3277 LSP := LCP^.IDTYPE; INSYMBOL COMP 3278 END COMP 3279 ELSE COMP 3280 BEGIN IF PACKFLAG THEN ERROR(220); COMP 3281 CNFARRAYSCHEMA(LSP) COMP 3282 END COMP 3283 END COMP 3284 ELSE BEGIN ERROR(221); LSP := NIL END; COMP 3285 (*REVERSE POINTERS, COMPUTE SIZE, SET PARTWORDELS+ELSPERWORD*) COMP 3286 IF LSP <> NIL THEN COMP 3287 BEGIN LSIZE := 0; COMP 3288 IF CONFORMARRAY(LSP) THEN LSIZE := LSP^.SIZE.WORDS; COMP 3289 REPEAT COMP 3290 WITH LSP1^ DO COMP 3291 BEGIN LSP2 := AELTYPE; AELTYPE := LSP; FTYPE := LSP^.FTYPE; COMP 3292 LSIZE := LSIZE + 3; SIZE.WORDS := LSIZE; SIZE.BITS := 0; COMP 3293 IF PCKDARR THEN COMP 3294 IF LSP^.SIZE.WORDS > 0 THEN PARTWORDELS := FALSE COMP 3295 ELSE COMP 3296 IF LSP^.SIZE.BITS > 0 THEN COMP 3297 BEGIN T := WORDSIZE DIV LSP^.SIZE.BITS; COMP 3298 IF T > 1 THEN COMP 3299 BEGIN PARTWORDELS := TRUE; ELSPERWORD := T END COMP 3300 ELSE PARTWORDELS := FALSE COMP 3301 END COMP 3302 ELSE PARTWORDELS := FALSE COMP 3303 END; COMP 3304 LSP := LSP1; LSP1 := LSP2 COMP 3305 UNTIL LSP1 = NIL COMP 3306 END; COMP 3307 FSP := LSP COMP 3308 END (* CNFARRAYSCHEMA *); COMP 3309 COMP 3310 BEGIN (* PARAMETERLIST *) LCP1 := NIL; COMP 3311 CHECKCONTEXT(PSYS+[LPARENT],7,FSYS); COMP 3312 IF SY = LPARENT THEN COMP 3313 BEGIN IF FORW THEN ERROR(119); COMP 3314 OLDTOP := TOP; COMP 3315 IF TOP < DISPLIMIT THEN COMP 3316 BEGIN TOP := TOP + 1; COMP 3317 WITH DISPLAY[TOP] DO COMP 3318 BEGIN FNAME := NIL; REGION := PFPAR END COMP 3319 END COMP 3320 ELSE ERROR(250); COMP 3321 LSCOPE := THISSCOPE; COMP 3322 IF HIGHSCOPE = SCOPEMAX THEN ERROR(252) COMP 3323 ELSE HIGHSCOPE := HIGHSCOPE + 1; COMP 3324 THISSCOPE := HIGHSCOPE; COMP 3325 INSYMBOL; COMP 3326 IF NOT (SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY]) THEN COMP 3327 BEGIN ERROR(7); SKIP(FSYS+[IDENT,RPARENT]) END; COMP 3328 WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO COMP 3329 BEGIN COMP 3330 IF SY IN [PROCEDURESY,FUNCTIONSY] THEN COMP 3331 BEGIN COMP 3332 LSY := SY; INSYMBOL; LLC := LC; COMP 3333 PFHEADER(HSYS+[RPARENT],LSY,LCP,LFORW,FORMAL); COMP 3334 LCP^.PFADDR := LLC; LC := LLC + 1; COMP 3335 LCP^.NEXT := LCP1; LCP1 := LCP COMP 3336 END COMP 3337 ELSE COMP 3338 BEGIN LCP2 := LCP1; LSP := NIL; COMP 3339 IF SY = VARSY THEN COMP 3340 BEGIN LACCESS := INDRCT; LVARPARAM := TRUE; INSYMBOL END COMP 3341 ELSE BEGIN LACCESS := DRCT; LVARPARAM := FALSE END; COMP 3342 (*LOOP UNTIL SY <> COMMA:*) COMP 3343 REPEAT COMP 3344 IF SY = IDENT THEN COMP 3345 BEGIN MNEW(LCP,VARS); COMP 3346 WITH LCP^ DO COMP 3347 BEGIN COPYID(LCP); IDTYPE := NIL; KLASS := VARS; COMP 3348 VKIND := FORMAL; VARPARAM := LVARPARAM; COMP 3349 NEXT := LCP1; COMP 3350 VLEV := LEVEL + ORD(LEVEL < MAXLEVEL); COMP 3351 VADDR := LC; THREAT := FALSE; CONTROLVAR := FALSE; COMP 3352 FIRSTINPARMGROUP := (LCP1 = LCP2) COMP 3353 END; COMP 3354 ENTERID(LCP,PFPAR); COMP 3355 LCP1 := LCP; LC := LC + 1; COMP 3356 INSYMBOL; COMP 3357 END COMP 3358 ELSE ERROR(2); COMP 3359 IF NOT (SY IN [COMMA,COLON]) THEN COMP 3360 BEGIN ERROR(7); SKIP(FSYS+[COMMA,SEMICOLON,RPARENT]) COMP 3361 END; COMP 3362 EXITLOOP := SY <> COMMA; COMP 3363 IF NOT EXITLOOP THEN INSYMBOL COMP 3364 UNTIL EXITLOOP; COMP 3365 IF SY = COLON THEN COMP 3366 BEGIN INSYMBOL; COMP 3367 IF SY = IDENT THEN COMP 3368 BEGIN SEARCHID([TYPES],LCP); COMP 3369 LSP := LCP^.IDTYPE; INSYMBOL COMP 3370 END COMP 3371 ELSE V41AC20 25 IF NOT (OPTS.DIALECT IN [ANSI,ISO0]) THEN V41DC05 473 CNFARRAYSCHEMA(LSP) V41DC05 474 ELSE ERROR(191); V41AC20 27 IF LSP <> NIL THEN COMP 3373 IF NOT LVARPARAM THEN COMP 3374 BEGIN COMP 3375 IF LSP^.FTYPE THEN ERROR(121); COMP 3376 IF CONFORMARRAY(LSP) THEN LACCESS := INDRCT COMP 3377 ELSE COMP 3378 IF FULLWORDS(LSP^.SIZE) >= MVOPTION THEN COMP 3379 LACCESS := INDRCT; COMP 3380 MULTIWORDVALUEPARAMETER := MULTIWORDVALUEPARAMETER COMP 3381 OR (FULLWORDS(LSP^.SIZE) > 1) COMP 3382 END; COMP 3383 CHECKCONTEXT([SEMICOLON,RPARENT],7,FSYS) COMP 3384 END COMP 3385 ELSE ERROR(5); COMP 3386 LCP3 := LCP1; CONFORMFLAG := CONFORMARRAY(LSP); COMP 3387 WHILE LCP3 <> LCP2 DO COMP 3388 BEGIN LCP3^.IDTYPE := LSP; COMP 3389 LCP3^.VACCESS := LACCESS; COMP 3390 LCP3^.CONFORMNT := CONFORMFLAG; LCP3 := LCP3^.NEXT COMP 3391 END COMP 3392 END; COMP 3393 IF SY = SEMICOLON THEN COMP 3394 BEGIN INSYMBOL; COMP 3395 IF NOT (SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY]) THEN COMP 3396 BEGIN ERROR(7); SKIP(FSYS+[IDENT,RPARENT]) END COMP 3397 END COMP 3398 END (* WHILE *); COMP 3399 IF LC - PFLC > MAXPARAMS THEN ERROR(263); COMP 3400 IF SY = RPARENT THEN COMP 3401 BEGIN INSYMBOL; COMP 3402 CHECKCONTEXT(PSYS+FSYS,6,[]) COMP 3403 END COMP 3404 ELSE ERROR(4); COMP 3405 LCP3 := NIL; COMP 3406 (*REVERSE POINTERS AND RESERVE LOCAL CELLS FOR COPIES OF MULTI- COMP 3407 WORD NON-CONFORMANT VALUES AND CONFORMANT-ARRAY DESCRIPTORS*) COMP 3408 WHILE LCP1 <> NIL DO COMP 3409 WITH LCP1^ DO COMP 3410 BEGIN LCP2 := NEXT; NEXT := LCP3; COMP 3411 IF KLASS = VARS THEN COMP 3412 IF IDTYPE <> NIL THEN COMP 3413 IF CONFORMNT THEN COMP 3414 BEGIN COMP 3415 IF FIRSTINPARMGROUP THEN COMP 3416 BEGIN (* SET DESCADDR, BOUNDID ADDRESSES *) COMP 3417 LSP := IDTYPE; LLC := LC; COMP 3418 REPEAT COMP 3419 LSP1 := LSP^.INXTYPE; LSP^.DESCADDR := LLC; COMP 3420 IF LSP1 <> NIL THEN COMP 3421 WITH LSP1^ DO COMP 3422 BEGIN COMP 3423 IF LOWBOUND <> NIL THEN LOWBOUND^.BADDR := LLC+2; COMP 3424 IF HIGHBOUND <> NIL THEN HIGHBOUND^.BADDR := LLC+1 COMP 3425 END; COMP 3426 LLC := LLC+3; LSP := LSP^.AELTYPE; COMP 3427 EXITLOOP := TRUE; COMP 3428 IF LSP <> NIL THEN COMP 3429 IF LSP^.FORM = ARRAYS THEN COMP 3430 IF LSP^.CONFORMANT THEN EXITLOOP := FALSE COMP 3431 UNTIL EXITLOOP; COMP 3432 LC := LLC COMP 3433 END COMP 3434 END COMP 3435 ELSE COMP 3436 BEGIN SZ := FULLWORDS(IDTYPE^.SIZE); COMP 3437 IF (VACCESS = DRCT) AND (SZ <> 1) THEN COMP 3438 BEGIN VADDR := LC; LC := LC + SZ END COMP 3439 END; COMP 3440 LCP3 := LCP1; LCP1 := LCP2 COMP 3441 END; COMP 3442 TOP := OLDTOP; THISSCOPE := LSCOPE; COMP 3443 FPAR := LCP3 COMP 3444 END COMP 3445 ELSE FPAR := NIL COMP 3446 END (* PARAMETERLIST *); COMP 3447 COMP 3448 PROCEDURE PFNAME(FI: INTEGER); COMP 3449 (* CREATE INTERNAL NAME FOR PROC/FUNC FROM FI *) COMP 3450 VAR K,L: INTEGER; COMP 3451 BEGIN COMP 3452 FOR K := 7 DOWNTO 4 DO COMP 3453 BEGIN L := FI DIV 8; COMP 3454 PNAME[K] := CHR(ORD('0') + FI - 8 * L); COMP 3455 FI := L COMP 3456 END COMP 3457 END (* PFNAME *); COMP 3458 COMP 3459 BEGIN (* PFHEADER *) COMP 3460 LC := PFLC; COMP 3461 IF FSY = PROCEDURESY THEN LKLASS := PROC ELSE LKLASS := FUNC; COMP 3462 IF SY = IDENT THEN (* DECIDE WHETHER FORWARD *) COMP 3463 BEGIN SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); COMP 3464 IF LCP <> NIL THEN COMP 3465 WITH LCP^ DO COMP 3466 BEGIN COMP 3467 FORW := (KLASS = LKLASS) AND (FKIND = ACTUAL); V41CC20 28 IF FORW THEN V41CC20 29 BEGIN FORW := PFKIND = ACTUAL; V41CC20 30 IF FORW THEN FORW := PFDECL IN [FORWDECL,FORWDECLERR] V41CC20 31 END; V41CC20 32 IF NOT FORW THEN ERROR(160) COMP 3471 END COMP 3472 ELSE FORW := FALSE; COMP 3473 IF NOT FORW THEN COMP 3474 BEGIN COMP 3475 IF FKIND = ACTUAL THEN MNEW(LCP,PROC,USERDECLARED,ACTUAL) COMP 3476 ELSE MNEW(LCP,PROC,USERDECLARED,FORMAL); COMP 3477 WITH LCP^ DO COMP 3478 BEGIN COPYID(LCP); IDTYPE := NIL; NEXT := NIL; COMP 3479 KLASS := LKLASS; PFDECKIND := USERDECLARED; PFKIND := FKIND; COMP 3480 PFLEV := LEVEL + ORD((FKIND=FORMAL) AND (LEVEL NIL THEN COMP 3510 IF LSP^.FORM > POINTER THEN COMP 3511 BEGIN ERROR(120); LCP^.IDTYPE := NIL END; COMP 3512 INSYMBOL COMP 3513 END COMP 3514 ELSE BEGIN ERROR(2); SKIP(FSYS+HSYS) END COMP 3515 END COMP 3516 ELSE (* SY <> COLON *) COMP 3517 IF NOT FORW THEN ERROR(123) COMP 3518 END; COMP 3519 IF NOT FORW THEN LCP^.PARAMLIST := LCP1; COMP 3520 FCP := LCP COMP 3521 END (* PFHEADER *); COMP 3522 COMP 3523 BEGIN (*PROCEDUREDECLARATION*) COMP 3524 LLC := LC; DP := TRUE; COMP 3525 MULTIWORDVALUEPARAMETER := FALSE; COMP 3526 PFHEADER([SEMICOLON],FSY,LCP,FORW,ACTUAL); COMP 3527 WITH LCP^ DO COMP 3528 BEGIN LC := LC + ORD(KLASS = FUNC); COMP 3529 FIRSTVAR := LC COMP 3530 END; COMP 3531 EXPECTSYMBOL(SEMICOLON,14); COMP 3532 IF SY = IDENT THEN COMP 3533 BEGIN IF FORW THEN ERROR(161); COMP 3534 WITH LCP^ DO COMP 3535 IF ID.TEN = KW[FORWARDKW] THEN COMP 3536 BEGIN PFDECL := FORWDECL; LFORWCNT := LFORWCNT + 1 END COMP 3537 ELSE COMP 3538 IF OPTS.DIALECT = P6000 THEN V41DC05 475 BEGIN V41AC20 29 IF ID.TEN = KW[EXTERNALKW] THEN V41AC20 30 BEGIN EXTENSION(325); PFDECL := EXTDECL END V41AC20 31 ELSE V41AC20 32 IF ID.TEN = KW[FORTRANKW] THEN V41AC20 33 BEGIN EXTENSION(325); PFDECL := FTNDECL; V41AC20 34 IF MULTIWORDVALUEPARAMETER THEN ERROR(240) V41AC20 35 END V41AC20 36 ELSE BEGIN ERROR(162); PFDECL := EXTDECL END; V41AC20 37 IF EPT1 = TENBLANKS THEN EPT := NAME.TEN V41AC20 38 END V41AC20 39 ELSE ERROR(162); V41AC20 40 INSYMBOL; COMP 3550 EXPECTSYMBOL(SEMICOLON,14); COMP 3551 CHECKCONTEXT(FSYS,6,[]) COMP 3552 END COMP 3553 ELSE COMP 3554 BEGIN V41CC20 33 IF FORW THEN LFORWCNT := LFORWCNT - ORD(LCP^.PFDECL = FORWDECL); V41CC20 34 LCP^.PFDECL := DECL; V41CC20 35 OLDLEV := LEVEL; OLDTOP := TOP; COMP 3557 IF LEVEL < MAXLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(251); COMP 3558 IF TOP < DISPLIMIT THEN COMP 3559 BEGIN TOP := TOP + 1; COMP 3560 WITH DISPLAY[TOP] DO COMP 3561 BEGIN FNAME := LCP^.PARAMLIST; REGION := BLCK; COMP 3562 PFCP := LCP; ASSIGNED := FALSE COMP 3563 END COMP 3564 END COMP 3565 ELSE ERROR(250); COMP 3566 (* BLOCKSCOPE = THISSCOPE *) COMP 3567 IF HIGHSCOPE = SCOPEMAX THEN ERROR(252) COMP 3568 ELSE HIGHSCOPE := HIGHSCOPE + 1; COMP 3569 THISSCOPE := HIGHSCOPE; COMP 3570 MARK(LMARK); COMP 3571 BLOCK(FSYS,SEMICOLON,LCP); COMP 3572 IF (LCP^.KLASS = FUNC) AND NOT DISPLAY[TOP].ASSIGNED THEN COMP 3573 ERROR(185); COMP 3574 IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); COMP 3575 IF TOP <> OLDTOP THEN RELEASE(LMARK); COMP 3576 LEVEL := OLDLEV; TOP := OLDTOP; COMP 3577 THISSCOPE := BLOCKSCOPE COMP 3578 END; COMP 3579 LC := LLC; COMP 3580 END (*PROCEDUREDECLARATION*) ; COMP 3581 (*$L'PROCEDURE / FUNCTION BODY PROCESSOR.' *) COMP 3582 COMP 3583 COMP 3584 PROCEDURE BODY(FSYS: SETOFSYS); COMP 3585 TYPE RCODERANGE = 0..RCODEMAX; COMP 3586 CODEP = ^CODESEGMENT; COMP 3587 CODESEGMENT = RECORD NXTSEG: CODEP; COMP 3588 RCODE: ARRAY [RCODERANGE] OF INTEGER; COMP 3589 CODE: ARRAY [CODERANGE] OF INTEGER COMP 3590 END; COMP 3591 COMP 3592 CSTKIND = (NOP,PUREP,POSP,NEGP); COMP 3593 CSTREC = PACKED RECORD COMP 3594 CASE CKIND : CSTKIND OF COMP 3595 NOP: (); COMP 3596 PUREP: (EXP: BITRANGE); COMP 3597 POSP, COMP 3598 NEGP: (EXP1,EXP2: BITRANGE) COMP 3599 END; COMP 3600 REGSET = SET OF REGNR; COMP 3601 COMP 3602 VAR COMP 3603 CSEGP: CODEP; COMP 3604 PMDCODE : INTEGER; COMP 3605 PARAMS: 0..MAXINT; PARAMSINREGS: 0..MAXPARAMSINREGS; COMP 3606 BHWFIXES, PMDFIXES: INTEGER; COMP 3607 BHWIC,EPTIC,PITIC: INTEGER; COMP 3608 BHWPC, PMDPC, INITARPC, ENTRYPC1, ENTRYPC2: PLACE; COMP 3609 QUICKENTRY, INITARFLAG, EPILOGUEFLAG: BOOLEAN; COMP 3610 LCP: CTP; LFSTOCC: LOCOFREF; COMP 3611 LP: CTAILP; COMP 3612 I,K: REGNR; COMP 3613 LPL,LPL1,LPL2 : PLACE; COMP 3614 LCMAX,LDISP,LSZ,LDESC,LINDEX : ADDRRANGE; COMP 3615 RCIX: RCODERANGE; RCP: 1..15; COMP 3616 LASTOP : OPCODE; COMP 3617 LASTI : REGNR; COMP 3618 LOCP: LOCOFREF; LCSP: CSP; COMP 3619 STMTLEVEL: ADDRRANGE; COMP 3620 PSMAX, (* MAX SIZE OF PARAM STACK FOR BODY. *) COMP 3621 PSSTORE, (* 1 + HIGHEST PARAM STACK OFFSET STORED INTO. *) COMP 3622 PSMARK: INTEGER;(* B6 = PSMARK + FWA(PARAM STACK). *) COMP 3623 COMP 3624 PROCEDURE NOOP; COMP 3625 BEGIN (* NOOP *) COMP 3626 WITH PC DO COMP 3627 WHILE CP < 4 DO COMP 3628 BEGIN CBUF := CBUF * 100000B + NOI[ODD(CP)]; COMP 3629 RBUF := 2 * RBUF; CP := CP + 1 COMP 3630 END; COMP 3631 LASTOP := NO COMP 3632 END (* NOOP *); COMP 3633 COMP 3634 PROCEDURE PUTREL(R: INTEGER); COMP 3635 VAR SEGP: CODEP; COMP 3636 BEGIN CSEGP^.RCODE[RCIX] := RBUF; RBUF := R; RCP := 1; COMP 3637 WITH PC DO COMP 3638 IF CIX = CODEMAX THEN COMP 3639 BEGIN MNEW(SEGP); SEGP^.NXTSEG := CSEGP; CSEGP := SEGP; COMP 3640 CIX := 0; SIX := SIX + 1; RCIX := 0 COMP 3641 END; COMP 3642 RCIX := RCIX + 1 COMP 3643 END (*PUTREL*) ; COMP 3644 COMP 3645 PROCEDURE SHORTNAME(FNAME: ALFA; VAR F1NAME: ALFA); COMP 3646 VAR I: 1..ALFALENG; COMP 3647 BEGIN I := ALFALENG; COMP 3648 IF FNAME <> TENBLANKS THEN COMP 3649 WHILE (FNAME[I] = ' ')OR (I > 7) DO COMP 3650 BEGIN FNAME[I] := CHR(0); I := I - 1 END; COMP 3651 F1NAME := FNAME COMP 3652 END (*SHORTNAME*); COMP 3653 COMP 3654 PROCEDURE SEARCHEXTID(FNAME: ALFA); COMP 3655 (* RETURNS POINTER TO FNAME-ENTRY IN EXT *) COMP 3656 COMP 3657 PROCEDURE ALLOCID; COMP 3658 BEGIN MNEW(EXT); COMP 3659 WITH EXT^ DO COMP 3660 BEGIN COMP 3661 L := NIL; R := NIL; REF := NIL; EXID := FNAME; COMP 3662 EXTIDX := EXTIDX + 1 COMP 3663 END COMP 3664 END; COMP 3665 COMP 3666 BEGIN SHORTNAME(FNAME,FNAME); COMP 3667 IF EXTROOT = NIL THEN COMP 3668 BEGIN ALLOCID; EXTROOT := EXT END COMP 3669 ELSE COMP 3670 BEGIN EXT := EXTROOT; COMP 3671 WHILE EXT^.EXID <> FNAME DO WITH EXT^ DO COMP 3672 IF EXID < FNAME THEN COMP 3673 IF R = NIL THEN BEGIN ALLOCID; R := EXT END ELSE EXT := R COMP 3674 ELSE COMP 3675 IF L = NIL THEN BEGIN ALLOCID; L:= EXT END ELSE EXT := L COMP 3676 END COMP 3677 END; COMP 3678 COMP 3679 PROCEDURE GEN30(FOP: OPCODE; FI,FJ: REGNR; FK: ADDRFIELD; COMP 3680 FR: RELOCATION); COMP 3681 FORWARD; COMP 3682 COMP 3683 PROCEDURE CHECKLINENUM; COMP 3684 (* ASSUMES PMD=PMDON *) COMP 3685 VAR EXTL : EXTIDP; COMP 3686 BEGIN IF SETLINENUM COMP 3687 THEN BEGIN SETLINENUM := FALSE; COMP 3688 EXTL := EXT; COMP 3689 EXT := NIL; COMP 3690 GEN30(SABPK,0,0,LINENUM,ABSR); COMP 3691 EXT := EXTL COMP 3692 END COMP 3693 END (* CHECKLINENUM *); COMP 3694 COMP 3695 PROCEDURE GEN15(FOP: OPCODE; FI,FJ: REGNR; FK: BITRANGE); COMP 3696 BEGIN (* GEN15 *) COMP 3697 IF PMD = PMDON THEN CHECKLINENUM; COMP 3698 LASTOP := FOP; LASTI := FI; COMP 3699 WITH PC DO COMP 3700 IF CP <> 4 THEN COMP 3701 BEGIN CP := CP + 1; COMP 3702 CBUF := CBUF * 100B + ORD(FOP); COMP 3703 RBUF := RBUF * 2 COMP 3704 END COMP 3705 ELSE COMP 3706 BEGIN CSEGP^.CODE[CIX] := CBUF; COMP 3707 CBUF := ORD(FOP); CP := 1; COMP 3708 IF RCP = 15 THEN PUTREL(0) COMP 3709 ELSE BEGIN RBUF := 2 * RBUF; RCP := RCP + 1 END; COMP 3710 IF IC = ICMAX THEN ERROR(253); COMP 3711 CIX := CIX + 1; IC := IC + 1 COMP 3712 END; COMP 3713 CBUF := ((10B * CBUF + FI) * 10B + FJ) * 10B + FK COMP 3714 END (* GEN15 *); COMP 3715 COMP 3716 PROCEDURE GEN30; COMP 3717 VAR EXTRP: EXTREFP; COMP 3718 BEGIN (* GEN30 *) COMP 3719 IF PMD = PMDON THEN CHECKLINENUM; COMP 3720 IF FR IN [VARR,GLOBLR,TERAR,TMEMR] THEN COMP 3721 BEGIN SEARCHEXTID(EXTNAMES[FR]); FR := ABSR END; COMP 3722 WITH PC DO COMP 3723 IF CP < 3 THEN COMP 3724 BEGIN CBUF := CBUF * 100B + ORD(FOP); COMP 3725 RBUF := RBUF * 4 + ORD(FR); COMP 3726 CP := CP + 2 COMP 3727 END COMP 3728 ELSE COMP 3729 BEGIN IF CP = 3 THEN NOOP; COMP 3730 CSEGP^.CODE[CIX] := CBUF; COMP 3731 CBUF := ORD(FOP); CP := 2; COMP 3732 IF RCP = 15 THEN PUTREL(ORD(FR)) COMP 3733 ELSE BEGIN RBUF := RBUF * 4 + ORD(FR); RCP := RCP + 1 END; COMP 3734 IF IC = ICMAX THEN ERROR(253); COMP 3735 CIX := CIX + 1; IC := IC + 1 COMP 3736 END; COMP 3737 LASTOP := FOP; LASTI := FI; COMP 3738 IF FK < 0 THEN FK := FK + 777777B; COMP 3739 CBUF := ((CBUF * 10B + FI) * 10B + FJ) * 1000000B + FK; COMP 3740 IF EXT <> NIL THEN COMP 3741 BEGIN MNEW(EXTRP); EXTRX := EXTRX + 1; COMP 3742 WITH EXTRP^,EXT^ DO COMP 3743 BEGIN LINK := REF; COMP 3744 REF := EXTRP; COMP 3745 LOC := ((8 - PC.CP) * 1000B + 1) * 1000000B + IC - 1; COMP 3746 EXT := NIL COMP 3747 END COMP 3748 END COMP 3749 END (* GEN30 *); COMP 3750 COMP 3751 PROCEDURE GENINC(FOP: INCOPRANGE; FI, FJ: REGNR; FK: ADDRFIELD); COMP 3752 (* GENERATE INCREMENT-UNIT INSTRUCTION. CHANGES 30-BIT *) COMP 3753 (* INSTRUCTIONS TO 15-BIT INSTRUCTIONS IF POSSIBLE BY *) COMP 3754 (* ASSUMING B1 = 1. THE ADDRESS FIELD MUST BE ABSOLUTE AND *) COMP 3755 (* NOT RELATIVE TO AN EXTERNAL SYMBOL. *) COMP 3756 VAR LOP: OPCODE; COMP 3757 BEGIN (* GENINC *) COMP 3758 LOP := GENINCOPS[FOP]; COMP 3759 IF LOP = PS THEN GEN15(FOP,FI,FJ,FK) COMP 3760 ELSE COMP 3761 IF FK IN [0,1] THEN GEN15(LOP,FI,FJ,FK) COMP 3762 ELSE COMP 3763 IF (FK = -1) AND (FOP IN [SAAPK,SABPK,SBAPK,SBBPK,SXAPK,SXBPK]) COMP 3764 THEN GEN15(SUCC(LOP),FI,FJ,1) COMP 3765 ELSE COMP 3766 IF (FK = 2) AND (FJ = 0) AND (FOP IN [SABPK,SBBPK,SXBPK]) COMP 3767 THEN GEN15(LOP,FI,1,1) COMP 3768 ELSE GEN30(FOP,FI,FJ,FK,ABSR) COMP 3769 END (* GENINC *) ; COMP 3770 COMP 3771 PROCEDURE INS(FIC: INTEGER; FPL: PLACE); COMP 3772 VAR SEGP: CODEP; I: INTEGER; COMP 3773 BEGIN IF FIC < 0 THEN FIC := 777777B + FIC; COMP 3774 WITH FPL DO COMP 3775 BEGIN IF (SIX=PC.SIX)AND(CIX=PC.CIX) THEN CP := 4 - PC.CP + CP; COMP 3776 CASE CP OF COMP 3777 1: FIC := FIC*1000000000000000B; COMP 3778 2: FIC := FIC*10000000000B; COMP 3779 3: FIC := FIC*100000B; COMP 3780 4: COMP 3781 END; COMP 3782 IF SIX = PC.SIX THEN COMP 3783 BEGIN IF CIX = PC.CIX THEN CBUF := CBUF + FIC COMP 3784 ELSE WITH CSEGP^ DO CODE[CIX] := CODE[CIX] + FIC COMP 3785 END COMP 3786 ELSE COMP 3787 BEGIN SEGP := CSEGP; COMP 3788 FOR I := PC.SIX - 1 DOWNTO SIX DO SEGP := SEGP^.NXTSEG; COMP 3789 WITH SEGP^ DO CODE[CIX] := CODE[CIX] + FIC COMP 3790 END COMP 3791 END COMP 3792 END (*INS*) ; COMP 3793 COMP 3794 PROCEDURE LINKOCC(VAR FPTR: LOCOFREF); COMP 3795 VAR LOCP: LOCOFREF; COMP 3796 BEGIN MNEW(LOCP); COMP 3797 WITH LOCP^, PC DO COMP 3798 BEGIN NXTREF := FPTR; FPTR := LOCP; COMP 3799 LOC := PC COMP 3800 END COMP 3801 END (*LINKOCC*) ; COMP 3802 COMP 3803 PROCEDURE GEN60(FC:INTEGER); COMP 3804 VAR I:SHRTINT; COMP 3805 BEGIN NOOP; COMP 3806 WITH PC DO COMP 3807 BEGIN COMP 3808 CSEGP^.CODE[CIX] := CBUF; CBUF := FC; COMP 3809 IF RCP = 15 THEN PUTREL(0) COMP 3810 ELSE BEGIN RBUF := RBUF*16; RCP := RCP + 1 END; COMP 3811 IF IC = ICMAX THEN ERROR(253); COMP 3812 CIX := CIX + 1; IC := IC + 1 COMP 3813 END COMP 3814 END (*GEN60*); COMP 3815 COMP 3816 PROCEDURE CLEARREGS; COMP 3817 VAR I: INTEGER; COMP 3818 BEGIN COMP 3819 FOR I := 0 TO 7 DO COMP 3820 BEGIN COMP 3821 XRGS[I].XCONT := AVAIL; ARGS[I].ACONT := UNSPECADDR COMP 3822 END; COMP 3823 BRGS := [0,2,3,7] (* B0 IS ALWAYS FREE *) COMP 3824 END (* CLEARREGS *) ; COMP 3825 COMP 3826 PROCEDURE SAVEREGMAP(VAR FREGMAP: REGMAP); COMP 3827 BEGIN COMP 3828 WITH FREGMAP DO COMP 3829 BEGIN XMAP := XRGS; AMAP := ARGS END COMP 3830 END (* SAVEREGMAP *) ; COMP 3831 COMP 3832 PROCEDURE RESTOREREGMAP(VAR FREGMAP: REGMAP); COMP 3833 BEGIN COMP 3834 WITH FREGMAP DO COMP 3835 BEGIN XRGS := XMAP; ARGS := AMAP END COMP 3836 END (* RESTOREREGMAP *) ; COMP 3837 COMP 3838 PROCEDURE MERGEREGMAP(VAR FREGMAP: REGMAP); COMP 3839 (* MERGE GLOBAL REGISTER MAP AND FREGMAP INTO FREGMAP *) COMP 3840 (* *) COMP 3841 (* PRESERVES INVARIANT ON FREGMAP: *) COMP 3842 (* XMAP[I].REFNR = *) COMP 3843 (* CARD( [ J : (XMAP[J].XCONT = INDVAR) AND *) COMP 3844 (* (XMAP[J].XREG = I) ] ) *) COMP 3845 COMP 3846 VAR I: REGNR; COMP 3847 COMP 3848 PROCEDURE MERGEX(VAR FX1, FX2: XRGSTAT); COMP 3849 VAR F: BOOLEAN; COMP 3850 BEGIN COMP 3851 IF FX1.XCONT = FX2.XCONT THEN COMP 3852 CASE FX1.XCONT OF COMP 3853 AVAIL: F := FALSE; COMP 3854 SHRTCST: F := FX1.CSTVAL <> FX2.CSTVAL; COMP 3855 LONGCST: F := FX1.CPTR <> FX2.CPTR; (* COULD COMPARE VALUES *) COMP 3856 SIMPVAR: F := (FX1.SHFTCNT <> FX2.SHFTCNT) OR COMP 3857 (FX1.XLEV <> FX2.XLEV) OR COMP 3858 (FX1.XADDR <> FX2.XADDR); COMP 3859 INDVAR: BEGIN COMP 3860 F := (FX1.SHFTCNT <> FX2.SHFTCNT) OR COMP 3861 (FX1.XREG <> FX2.XREG) OR COMP 3862 (FX1.XDISPL <> FX2.XDISPL); COMP 3863 IF NOT F THEN COMP 3864 BEGIN MERGEX(FREGMAP.XMAP[FX1.XREG],XRGS[FX1.XREG]); COMP 3865 F := FREGMAP.XMAP[FX1.XREG].XCONT = AVAIL COMP 3866 END COMP 3867 END; COMP 3868 OTHER: F := TRUE COMP 3869 END COMP 3870 ELSE F := TRUE; COMP 3871 IF F THEN COMP 3872 BEGIN COMP 3873 IF FX1.XCONT = INDVAR THEN COMP 3874 WITH FREGMAP.XMAP[FX1.XREG] DO COMP 3875 IF XCONT <> AVAIL THEN REFNR := REFNR - 1; COMP 3876 FX1.XCONT := AVAIL COMP 3877 END COMP 3878 END (* MERGEX *) ; COMP 3879 COMP 3880 PROCEDURE MERGEA(VAR FA1, FA2: ARGSTAT); COMP 3881 (* ASSUMES X-REGISTER MAPS ARE ALREADY MERGED. *) COMP 3882 BEGIN COMP 3883 IF FA1.ACONT <> UNSPECADDR THEN COMP 3884 IF (FA1.ACONT = FA2.ACONT) AND (FA1.ADISPL = FA2.ADISPL) THEN COMP 3885 CASE FA1.ACONT OF COMP 3886 SIMPADDR: IF FA1.ALEV <> FA2.ALEV THEN FA1.ACONT := UNSPECADDR; COMP 3887 INDADDR: IF (FA1.AREG <> FA2.AREG) OR COMP 3888 (FREGMAP.XMAP[FA1.AREG].XCONT = AVAIL) COMP 3889 THEN FA1.ACONT := UNSPECADDR COMP 3890 END COMP 3891 ELSE FA1.ACONT := UNSPECADDR COMP 3892 END (* MERGEA *) ; COMP 3893 COMP 3894 BEGIN (* MERGEREGMAP *) COMP 3895 FOR I := 7 DOWNTO 0 DO MERGEX(FREGMAP.XMAP[I],XRGS[I]); COMP 3896 FOR I := 7 DOWNTO 1 DO MERGEA(FREGMAP.AMAP[I],ARGS[I]) COMP 3897 END (* MERGEREGMAP *) ; COMP 3898 COMP 3899 PROCEDURE RJTOEXT(FNAME: ALFA); COMP 3900 BEGIN COMP 3901 SEARCHEXTID(FNAME); CLEARREGS; COMP 3902 GEN30(RJ,0,0,0,ABSR); NOOP COMP 3903 END; (* RJTOEXT *) COMP 3904 COMP 3905 PROCEDURE EQTOEXT(FNAME: ALFA); COMP 3906 BEGIN COMP 3907 SEARCHEXTID(FNAME); CLEARREGS; COMP 3908 GEN30(EQ,0,0,0,ABSR); NOOP COMP 3909 END; (* EQTOEXT *) COMP 3910 COMP 3911 COMP 3912 PROCEDURE ENTERCST(FCSTP: CTAILP); COMP 3913 (*ENTER CONST POINTED AT BY FCSTP INTO CONSTANT TABLE AND CHAIN COMP 3914 ACTUAL OCCURRENCE IN CODE (AT ) WITH EARLIER OCCURRENCES*) COMP 3915 LABEL 1,2; COMP 3916 VAR LCSP: CSP; P1,P2: CTAILP; LFSTOCC: LOCOFREF; COMP 3917 BEGIN LCSP := FSTCSP; COMP 3918 WHILE LCSP <> NIL DO COMP 3919 BEGIN P1 := LCSP^.CSTP; P2 := FCSTP; COMP 3920 WHILE (P1 <> NIL)AND (P2 <> NIL) DO COMP 3921 BEGIN IF P1^.CSVAL <> P2^.CSVAL THEN GOTO 1; COMP 3922 P1 := P1^.NXTCSP; P2 := P2^.NXTCSP COMP 3923 END; COMP 3924 IF P1 = P2 THEN GOTO 2; COMP 3925 1: LCSP := LCSP^.NXTCSP COMP 3926 END; COMP 3927 (*NEW ENTRY:*) COMP 3928 MNEW(LCSP); COMP 3929 WITH LCSP^ DO COMP 3930 BEGIN NXTCSP := FSTCSP; CSTP := FCSTP; CREF := NIL END; COMP 3931 FSTCSP := LCSP; COMP 3932 2: (* CHAIN OCCURRENCES: *) COMP 3933 LFSTOCC := LCSP^.CREF; LINKOCC(LFSTOCC); COMP 3934 LCSP^.CREF := LFSTOCC COMP 3935 END (*ENTERCST*) ; COMP 3936 COMP 3937 PROCEDURE SUBFILES(FSP : STP; FADDR : ADDRRANGE; COMP 3938 PROCEDURE PROCESSFILE(FSP : STP; FADDR : ADDRRANGE) ); COMP 3939 (* PROCESS (OPEN OR CLOSE) ALL FILES WHICH ARE PART OF A *) COMP 3940 (* VARIABLE WITH STRUCTURE FSP AND ADDRESS FADDR *) COMP 3941 VAR I,LMIN,LMAX : INTEGER; COMP 3942 COMP 3943 PROCEDURE RECFILES(FSP: STP); V41CC07 277 (* APPLY SUBFILES TO FIELDLIST FSP. *) V41CC07 278 VAR LSP: STP; LCP: CTP; V41CC07 279 BEGIN (* RECFILES *) V41CC07 280 IF FSP <> NIL THEN V41CC07 281 WITH FSP^ DO V41CC07 282 BEGIN LCP := FIXEDPART; LSP := VARPART END; V41CC07 283 WHILE LCP <> NIL DO V41CC07 284 WITH LCP^ DO (* KLASS = FIELD *) V41CC07 285 BEGIN SUBFILES(IDTYPE,FADDR+FLDADDR,PROCESSFILE); V41CC07 286 LCP := NEXT V41CC07 287 END; V41CC07 288 IF LSP <> NIL THEN V41CC07 289 BEGIN LSP := LSP^.VARIANTLIST; V41CC07 290 WHILE LSP <> NIL DO V41CC07 291 WITH LSP^ DO (* FORM = FIELDLISTS *) V41CC07 292 BEGIN V41CC07 293 IF FTYPE THEN RECFILES(LSP); V41CC07 294 LSP := NXTFLDLST V41CC07 295 END COMP 3959 END COMP 3960 END (* RECFILES *); COMP 3961 COMP 3962 BEGIN (* SUBFILES *) COMP 3963 IF FSP <> NIL THEN COMP 3964 WITH FSP^ DO COMP 3965 IF FTYPE THEN COMP 3966 CASE FORM OF COMP 3967 RECORDS : RECFILES(FIELDLST); V41CC07 296 ARRAYS : COMP 3969 IF INXTYPE <> NIL THEN COMP 3970 BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); COMP 3971 FOR I := LMIN TO LMAX DO COMP 3972 BEGIN SUBFILES(AELTYPE,FADDR,PROCESSFILE); COMP 3973 IF AELTYPE <> NIL THEN COMP 3974 FADDR := FADDR + AELTYPE^.SIZE.WORDS COMP 3975 END COMP 3976 END; COMP 3977 FILES : COMP 3978 PROCESSFILE(FSP,FADDR) COMP 3979 END (* CASE *) COMP 3980 END (* SUBFILES *); COMP 3981 COMP 3982 PROCEDURE COMMISSIONFILES(FSP: STP; FDRCT: BOOLEAN; COMP 3983 FADDR: ADDRRANGE; FEX: EXTFILEP); COMP 3984 COMP 3985 PROCEDURE COMMISSIONFILEVAR(FSP: STP; FADDR: ADDRRANGE); COMP 3986 VAR LDISPCODE: INTEGER; LCSP: CTAILP; COMP 3987 LRL: ADDRRANGE; LBASE: REGNR; COMP 3988 BEGIN (* COMMISSIONFILEVAR *) COMP 3989 WITH FSP^ DO COMP 3990 BEGIN COMP 3991 LDISPCODE := ROTATE(ORD(TEXTFILE),ETEXT-EDISPC); V41CC04 12 LDISPCODE := ROTATE(ORD(SEGFILE),ESEGMENT-EDISPC) + LDISPCODE; V41CC04 13 IF FEX <> NIL THEN (* PROGRAM PARAMETER *) COMP 3993 WITH FEX^ DO COMP 3994 BEGIN COMP 3995 LDISPCODE := ROTATE(ORD(TERMINAL),ETERMFIL-EDISPC)+LDISPCODE; V41CC04 14 LDISPCODE := ROTATE(1,EPERSIST-EDISPC) + LDISPCODE; V41CC04 15 LDISPCODE := ROTATE(1,EPROGPAR-EDISPC) + LDISPCODE; V41CC04 16 SHORTNAME(FILENAME,ALFINT.A); COMP 3997 GEN30(SABPK,2,0,0,PROGR); (* FORMAL FILE NAME *) COMP 3998 MNEW(LCSP); COMP 3999 WITH LCSP^ DO COMP 4000 BEGIN NXTCSP := NIL; CSVAL := ALFINT.I END; COMP 4001 ENTERCST(LCSP); COMP 4002 GEN30(SABPK,5,0,SYSLOC,ABSR) (* ACTUAL FILE PARAM *) COMP 4003 END; COMP 4004 GEN30(SXBPK,1,0,LDISPCODE,ABSR); (* DISPOSITION CODE *) COMP 4005 FADDR := FADDR + EFETOFFSET[TEXTFILE]; V41CC04 17 IF FDRCT THEN LBASE := 5 ELSE LBASE := 2; COMP 4008 GENINC(SBBPK,3,LBASE,FADDR); (* EFET ADDRESS *) COMP 4009 GEN30(SBBPK,7,0,BSIZE,ABSR); (* BUFFER SIZE *) COMP 4010 IF FILTYPE <> NIL THEN COMP 4011 BEGIN COMP 4012 LRL := FULLWORDS(FILTYPE^.SIZE); COMP 4013 IF LRL = 0 THEN LRL := 1; COMP 4014 GENINC(SXBPK,6,0,LRL) COMP 4015 END; COMP 4016 RJTOEXT(EX[CFVEX]) COMP 4017 END COMP 4018 END (* COMMISSIONFILEVAR *) ; COMP 4019 COMP 4020 BEGIN (* COMMISSIONFILES *) COMP 4021 IF NOT FDRCT THEN GEN15(SBXPB,2,6,0); COMP 4022 SUBFILES(FSP,FADDR,COMMISSIONFILEVAR) COMP 4023 END (* COMMISSIONFILES *) ; COMP 4024 COMP 4025 PROCEDURE DECOMMISSIONFILES(FSP: STP; FDRCT: BOOLEAN; COMP 4026 FADDR: ADDRRANGE); COMP 4027 COMP 4028 PROCEDURE DECOMMISSIONFILEVAR(FSP: STP; FADDR: ADDRRANGE); COMP 4029 VAR LBASE: REGNR; COMP 4030 BEGIN (* DECOMMISSIONFILEVAR *) COMP 4031 FADDR := FADDR + EFETOFFSET[FSP^.TEXTFILE]; V41CC04 18 IF FDRCT THEN LBASE := 5 ELSE LBASE := 2; COMP 4035 GENINC(SABPK,1,LBASE,FADDR); COMP 4036 RJTOEXT(EX[DFVEX]) COMP 4037 END (* DECOMMISSIONFILEVAR *) ; COMP 4038 COMP 4039 BEGIN (* DECOMMISSIONFILES *) COMP 4040 SUBFILES(FSP,FADDR,DECOMMISSIONFILEVAR) COMP 4041 END (* DECOMMISSIONFILES *) ; COMP 4042 COMP 4043 PROCEDURE UNROTATEX(FI: REGNR); V41AC08 15 (*IF X-FI IS SHIFTED, SHIFT IT BACK*) COMP 4045 BEGIN COMP 4046 WITH XRGS[FI] DO COMP 4047 IF XCONT IN [SIMPVAR,INDVAR] THEN COMP 4048 IF SHFTCNT <> 0 THEN COMP 4049 BEGIN GEN15(LXJK,FI,0,WORDSIZE-SHFTCNT); SHFTCNT := 0 COMP 4050 END COMP 4051 END (*UNROTATEX*); V41AC08 16 COMP 4053 PROCEDURE DECREFX(FI: REGNR); COMP 4054 (*DECREASE NUMBER OF REFERENCES TO X-FI BY ONE*) COMP 4055 BEGIN COMP 4056 WITH XRGS[FI] DO COMP 4057 IF XCONT <> AVAIL THEN COMP 4058 IF REFNR > 0 THEN COMP 4059 BEGIN REFNR := REFNR - 1; COMP 4060 IF REFNR = 0 THEN COMP 4061 IF XCONT = OTHER THEN XCONT := AVAIL COMP 4062 ELSE LASTREF := IC COMP 4063 END COMP 4064 END (*DECREFX*) ; COMP 4065 COMP 4066 PROCEDURE CLEARINDVARREFS(FREGS: REGSET); COMP 4067 (* FIND EACH INDVAR IN XRGS THAT REFERS (VIA XREG) TO A COMP 4068 REGISTER IN FREGS, AND DEMOTE IT TO AVAIL OR OTHER. *) COMP 4069 VAR I: REGNR; COMP 4070 BEGIN (* CLEARINDVARREFS *) COMP 4071 FOR I := 7 DOWNTO 0 DO COMP 4072 WITH XRGS[I] DO COMP 4073 IF XCONT = INDVAR THEN COMP 4074 IF XREG IN FREGS THEN COMP 4075 BEGIN COMP 4076 DECREFX(XREG); COMP 4077 IF REFNR = 0 THEN XCONT := AVAIL COMP 4078 ELSE COMP 4079 BEGIN COMP 4080 IF SHFTCNT <> 0 THEN GEN15(LXJK,I,0,WORDSIZE-SHFTCNT); COMP 4081 XCONT := OTHER COMP 4082 END COMP 4083 END COMP 4084 END (* CLEARINDVARREFS *) ; COMP 4085 COMP 4086 PROCEDURE CLEARINDADDRREFS(FI: REGNR); COMP 4087 (* FIND EACH INDADDR IN ARGS THAT REFERS (VIA AREG) TO COMP 4088 REGISTER FI, AND DEMOTE IT TO UNSPECADDR. *) COMP 4089 VAR I: REGNR; COMP 4090 BEGIN (* CLEARINDADDRREFS *) COMP 4091 FOR I := 7 DOWNTO 1 DO COMP 4092 WITH ARGS[I] DO COMP 4093 IF ACONT = INDADDR THEN COMP 4094 IF AREG = FI THEN ACONT := UNSPECADDR COMP 4095 END (* CLEARINDADDRREFS *) ; COMP 4096 COMP 4097 PROCEDURE BXIXJ(FI,FJ: REGNR); COMP 4098 (*AVOID GENERATION OF B XI XJ INSTRUCTIONS WHENEVER APPROPRIATE BY COMP 4099 ALTERING PREVIOUSLY GENERATED INSTRUCTION*) COMP 4100 VAR I: REGNR; COMP 4101 BEGIN COMP 4102 IF FI <> FJ THEN COMP 4103 BEGIN COMP 4104 WITH XRGS[FI] DO COMP 4105 IF XCONT = INDVAR THEN DECREFX(XREG) COMP 4106 ELSE BEGIN CLEARINDVARREFS([FI]); CLEARINDADDRREFS(FI) END; COMP 4107 XRGS[FI] := XRGS[FJ]; COMP 4108 IF (LASTI = FJ) AND COMP 4109 ((LASTOP IN [BXX..BXXMCX,LXBX..RXXDX,CXX]) OR COMP 4110 (LASTOP >= SXAPK)) AND COMP 4111 (XRGS[FJ].REFNR <= 1) THEN COMP 4112 BEGIN COMP 4113 IF (LASTOP < SXAPK) OR (LASTOP >= SXXPB) THEN COMP 4114 CBUF := CBUF - (LASTI - FI)*100B COMP 4115 ELSE COMP 4116 CBUF := CBUF - (LASTI - FI)*10000B*1000B; COMP 4117 LASTI := FI; XRGS[FJ].XCONT := AVAIL COMP 4118 END COMP 4119 ELSE COMP 4120 BEGIN GEN15(BXX,FI,FJ,FJ); DECREFX(FJ); XRGS[FI].REFNR := 1; COMP 4121 WITH XRGS[FJ] DO COMP 4122 IF XCONT = INDVAR THEN COMP 4123 WITH XRGS[XREG] DO REFNR := REFNR + 1 COMP 4124 END COMP 4125 END COMP 4126 END (*BXIXJ*) ; COMP 4127 COMP 4128 PROCEDURE SAVEREFXRGS(VAR FXRGS: XRGSTATUS); COMP 4129 VAR I,J,K: REGNR; LXRGS: XRGSTATUS; COMP 4130 BEGIN LXRGS:=XRGS; CLEARREGS; COMP 4131 FOR I:=0 TO 7 DO COMP 4132 WITH LXRGS[I] DO COMP 4133 IF XCONT <> AVAIL THEN COMP 4134 IF XCONT = INDVAR THEN COMP 4135 BEGIN WITH LXRGS[XREG] DO COMP 4136 BEGIN REFNR:=REFNR - 1; COMP 4137 IF REFNR = 0 THEN XCONT:=AVAIL COMP 4138 END; COMP 4139 IF REFNR = 0 THEN XCONT:=AVAIL ELSE XCONT:=OTHER COMP 4140 END COMP 4141 ELSE IF REFNR = 0 THEN XCONT:=AVAIL; COMP 4142 K:=0; COMP 4143 FOR I:=6 TO 7 DO COMP 4144 WITH LXRGS[I] DO COMP 4145 IF XCONT <> AVAIL THEN COMP 4146 BEGIN COMP 4147 IF K=0 THEN GENINC(SABPK,I,5,LC) COMP 4148 ELSE GEN15(SAAPB,7,6,1); COMP 4149 K:=K+1; J:=I COMP 4150 END; COMP 4151 FOR I:=0 TO 5 DO COMP 4152 WITH LXRGS[I] DO COMP 4153 IF XCONT <> AVAIL THEN COMP 4154 BEGIN GEN15(BXX,7,I,I); COMP 4155 IF K=0 THEN GENINC(SABPK,7,5,LC) COMP 4156 ELSE GEN15(SAAPB,7,J,1); COMP 4157 K:=K+1; J:=7 COMP 4158 END; COMP 4159 LC := LC + K; COMP 4160 IF LC > LCMAX THEN LCMAX := LC; COMP 4161 FXRGS := LXRGS COMP 4162 END (*SAVEREFXRGS*) ; COMP 4163 COMP 4164 PROCEDURE RELOADREFXRGS(VAR FXRGS: XRGSTATUS); COMP 4165 VAR I,J,K,L,M: REGNR; LPL: PLACE; COMP 4166 BEGIN K := 0; M := 0; COMP 4167 FOR I := 0 TO 7 DO COMP 4168 BEGIN J := (I+6) MOD 8; COMP 4169 WITH FXRGS[J] DO COMP 4170 IF XCONT <> AVAIL THEN COMP 4171 IF REFNR <> 0 THEN COMP 4172 BEGIN IF I <= 2 THEN L := 5 ELSE L := J; COMP 4173 IF K = 0 THEN COMP 4174 BEGIN GEN30(SABPK,L,5,0,ABSR); LPL := PC; COMP 4175 END COMP 4176 ELSE GEN15(SAAPB,L,K,1); COMP 4177 IF I <= 2 THEN GEN15(BXX,J,5,5); COMP 4178 XRGS[J] := FXRGS[J]; COMP 4179 K := L; M := M + 1 COMP 4180 END COMP 4181 END; COMP 4182 IF M <> 0 THEN COMP 4183 BEGIN LC := LC - M; INS(LC,LPL) END; COMP 4184 END (*RELOADXRGS*) ; COMP 4185 COMP 4186 PROCEDURE NEEDB(VAR FI: REGNR); COMP 4187 (*RETURN INDEX OF AVAILABLE B-REGISTER*) COMP 4188 VAR I: REGNR; COMP 4189 BEGIN COMP 4190 I := 7; COMP 4191 WHILE NOT (I IN BRGS) DO I := PRED(I); COMP 4192 FI := I; COMP 4193 IF I = 0 THEN ERROR(259) ELSE BRGS := BRGS - [I] COMP 4194 END (*NEEDB*) ; COMP 4195 COMP 4196 PROCEDURE FREEB(FR: REGNR); COMP 4197 BEGIN COMP 4198 BRGS := BRGS + [FR] COMP 4199 END (* FREEB *) ; COMP 4200 COMP 4201 PROCEDURE NEEDX(FREGS: REGSET; VAR FI: REGNR); COMP 4202 (* RETURN INDEX FI (FI IN FREGS) OF AVAILABLE X-REGISTER; COMP 4203 DON'T TOUCH ANY X-REG. CONTENTS*) COMP 4204 (* IT IS ASSUMED THAT FREGS IS A SET OF THE FORM [FLOW..FHIGH]. COMP 4205 IF THIS IS NOT TRUE, THE FOLLOWING CODE DOES NOT WORK. *) COMP 4206 LABEL 1; COMP 4207 VAR I,NR: REGNR; PR,MAXPR: INTEGER; FIRSTTIME: BOOLEAN; COMP 4208 FLOW,FHIGH: REGNR; COMP 4209 BEGIN MAXPR := 0; FIRSTTIME := TRUE; COMP 4210 FLOW := 0; COMP 4211 WHILE NOT (FLOW IN FREGS) DO FLOW := FLOW + 1; COMP 4212 FHIGH := FLOW + CARD(FREGS) - 1; COMP 4213 NR := FHIGH; COMP 4214 REPEAT COMP 4215 FOR I := FLOW TO FHIGH DO COMP 4216 WITH XRGS[I] DO COMP 4217 IF XCONT = AVAIL THEN COMP 4218 BEGIN NR := I; GOTO 1 END COMP 4219 ELSE COMP 4220 IF XCONT <> OTHER THEN COMP 4221 IF REFNR = 0 THEN COMP 4222 BEGIN PR := IC - LASTREF + BONUS[XCONT]; COMP 4223 IF PR > MAXPR THEN COMP 4224 BEGIN MAXPR := PR; NR := I END COMP 4225 END; COMP 4226 IF MAXPR = 0 THEN COMP 4227 IF FIRSTTIME THEN COMP 4228 BEGIN CLEARINDVARREFS(FREGS); FIRSTTIME := FALSE END COMP 4229 ELSE COMP 4230 BEGIN IF FLOW <> FHIGH THEN ERROR(259); MAXPR := 1 END COMP 4231 UNTIL MAXPR > 0; COMP 4232 1:WITH XRGS[NR] DO COMP 4233 BEGIN COMP 4234 IF XCONT = INDVAR THEN DECREFX(XREG) COMP 4235 ELSE CLEARINDADDRREFS(NR); COMP 4236 XCONT := OTHER; REFNR := 1 COMP 4237 END; COMP 4238 FI := NR COMP 4239 END (*NEEDX*) ; COMP 4240 V41AC08 17 PROCEDURE GENROTATE(FX1, FX2: REGNR; SC: SHIFTRANGE); V41AC08 18 (* ROTATE LEFT (SC MOD 60) BITS FROM FX2 INTO FX1. *) V41AC08 19 BEGIN V41AC08 20 IF SC < 0 THEN SC := SC + WORDSIZE; V41AC08 21 IF SC <> 0 THEN V41AC08 22 IF SC <> 1 THEN V41AC08 23 BEGIN V41AC08 24 IF FX1 <> FX2 THEN GEN15(BXX,FX1,FX2,FX2); V41AC08 25 GEN15(LXJK,FX1,0,SC) V41AC08 26 END V41AC08 27 ELSE GEN15(LXBX,FX1,1,FX2) V41AC08 28 END (* GENROTATE *) ; V41AC08 29 V41AC08 30 PROCEDURE ROTATEX(VAR FX1: REGNR; FX2: REGNR; SC: SHIFTRANGE); V41AC08 31 (* ROTATE THE CONTENTS OF X.FX2 LEFT (SC MOD 60) BITS, *) V41AC08 32 (* PUTTING THE RESULT INTO FX1. *) V41AC08 33 BEGIN V41AC08 34 IF SC = 0 THEN FX1 := FX2 V41AC08 35 ELSE V41AC08 36 BEGIN DECREFX(FX2); NEEDX([0..7],FX1); V41AC08 37 GENROTATE(FX1,FX2,SC) V41AC08 38 END V41AC08 39 END (* ROTATEX *) ; V41AC08 40 COMP 4241 PROCEDURE MAKEVARBLATTR(VAR FATTR: ATTR; COMP 4242 FSP: STP; FLEV: LEVRANGE; FDISPL: ADDRRANGE); COMP 4243 VAR LATTR: ATTR; COMP 4244 BEGIN COMP 4245 WITH LATTR DO COMP 4246 BEGIN COMP 4247 TYPTR := FSP; KIND := VARBL; WORDACC := DRCT; TAGF := FALSE; COMP 4248 VLEVEL := FLEV; CWDISPL := FDISPL; VWDISPL := 0; COMP 4249 DCLPCKD := FALSE; PCKD := FALSE COMP 4250 END; COMP 4251 FATTR := LATTR COMP 4252 END (* MAKEVARBLATTR *) ; COMP 4253 COMP 4254 PROCEDURE MAKETEMP(VAR FATTR: ATTR; FSP: STP; FSIZE: ADDRRANGE); COMP 4255 BEGIN COMP 4256 MAKEVARBLATTR(FATTR,FSP,LEVEL,LC); COMP 4257 LC := LC + FSIZE; COMP 4258 IF LC > LCMAX THEN LCMAX := LC COMP 4259 END (* MAKETEMP *) ; COMP 4260 COMP 4261 PROCEDURE SETADDRESS( COMP 4262 VAR FATTR: ATTR; (* DESCRIBING THE ADDRESS *) COMP 4263 FSIMPIND: BOOLEAN; (* TRUE IF FATTR DESCRIBES AN INDIRECT VARIABLE COMP 4264 AND X.VWDISPL CONTAINS A SIMPLE VARIABLE AND COMP 4265 THIS CALL REPRESENTS A MEMORY REFERENCE *) COMP 4266 FR: REGTYPE; (* SELECTING A- OR X-REGISTER *) COMP 4267 FREGS: REGSET; (* SELECTING ACCEPTABLE REGISTER NUMBERS *) COMP 4268 VAR FI: REGNR); (* RESULT REGISTER NUMBER *) COMP 4269 (* SET ADDRESS OF FATTR INTO AN A-REGISTER OR X-REGISTER. COMP 4270 IF FREGS <> [], IT DEFINES THE SET OF ACCEPTABLE REGISTER COMP 4271 NUMBERS. IN THIS CASE, A NEEDX(FREGS,FI) IS DONE. COMP 4272 IF FREGS = [], WE ASSUME THAT THE REGISTER HAS ALREADY BEEN COMP 4273 ALLOCATED AND FI CONTAINS THE REGISTER NUMBER. COMP 4274 IF THE CALL TO SETADDRESS REPRESENTS A MEMORY REFERENCE COMP 4275 (FR = REGA), THE REGISTER MAP IS UPDATED TO REFLECT THE CHANGE COMP 4276 IN A-REGISTER VALUE. FOR REFERENCES TO AN COMP 4277 INDIRECT OR INDEXED VALUE (WORDACC IN [INDRCT,INXD]), THE COMP 4278 NUMBER OF REFERENCES TO THE X-REGISTER WHICH CONTAINS THE COMP 4279 BASE ADDRESS (VWDISPL) MAY BE DECREMENTED UNLESS IT IS COMP 4280 A STORING OPERATION (FI IN [6..7]). THE VALUE OF COMP 4281 FSIMPIND IS ONLY RELEVANT FOR A STORING OPERATION. IN ALL COMP 4282 CASES THE UPDATING OF FATTR AND THE X-REGISTER MAP IS LEFT COMP 4283 UP TO THE PROCEDURE WHICH CALLED SETADDRESS. COMP 4284 *) COMP 4285 LABEL 1; COMP 4286 VAR I,J,L,LAREG: REGNR; COMP 4287 LADDR: INTEGER; COMP 4288 NOTSTORING: BOOLEAN; COMP 4289 COMP 4290 PROCEDURE FINDAREG(FCONT: ARGSTR); COMP 4291 VAR I: REGNR; D: SHRTINT; COMP 4292 BEGIN (* FINDAREG *) COMP 4293 LAREG := 0; COMP 4294 LADDR := MAXADDR; COMP 4295 WITH FATTR DO COMP 4296 FOR I := 1 TO 7 DO COMP 4297 WITH ARGS[I] DO COMP 4298 IF ACONT = FCONT THEN COMP 4299 BEGIN COMP 4300 D := MAXADDR; COMP 4301 IF FCONT = SIMPADDR THEN COMP 4302 BEGIN COMP 4303 IF ALEV = VLEVEL THEN D := CWDISPL - ADISPL COMP 4304 END COMP 4305 ELSE COMP 4306 IF AREG = VWDISPL THEN D := CWDISPL - ADISPL; COMP 4307 IF ABS(D) < ABS(LADDR) THEN COMP 4308 BEGIN LADDR := D; LAREG := I END COMP 4309 END COMP 4310 END (* FINDAREG *); COMP 4311 COMP 4312 PROCEDURE SETBASEADDRESS(FLEV: LEVRANGE; VAR FI: REGNR); COMP 4313 VAR LATTR: ATTR; COMP 4314 BEGIN COMP 4315 MAKEVARBLATTR(LATTR,NILPTR,FLEV+1,0); COMP 4316 SETADDRESS(LATTR,FALSE,REGA,[1..5],FI); COMP 4317 DECREFX(FI) COMP 4318 END (* SETBASEADDRESS *); COMP 4319 COMP 4320 PROCEDURE NEED; COMP 4321 BEGIN (* NEED *) COMP 4322 IF FREGS <> [] THEN NEEDX(FREGS,I) COMP 4323 ELSE I := FI COMP 4324 END (* NEED *); COMP 4325 COMP 4326 BEGIN (* SETADDRESS *) COMP 4327 NOTSTORING := TRUE; COMP 4328 IF FR = REGA THEN COMP 4329 IF FREGS = [] THEN NOTSTORING := FI IN [0..5] COMP 4330 ELSE NOTSTORING := FREGS <= [0..5]; COMP 4331 LAREG := 0; COMP 4332 WITH FATTR DO COMP 4333 IF TYPTR <> NIL THEN COMP 4334 CASE KIND OF COMP 4335 CST: COMP 4336 (* MUST BE A STRING CONSTANT *) COMP 4337 BEGIN NEED; GEN30(SETINST[BPK,FR],I,0,0,PROGR); COMP 4338 IF FR = REGA THEN ARGS[I].ACONT := UNSPECADDR; COMP 4339 IF STRING(TYPTR) THEN ENTERCST(CVAL.VALP) COMP 4340 END; COMP 4341 VARBL: COMP 4342 CASE WORDACC OF COMP 4343 DRCT: COMP 4344 BEGIN COMP 4345 FINDAREG(SIMPADDR); COMP 4346 IF ABS(LADDR) <= 1 THEN COMP 4347 BEGIN NEED; COMP 4348 GENINC(SETINST[APK,FR],I,LAREG,LADDR) COMP 4349 END COMP 4350 ELSE COMP 4351 IF VLEVEL IN LEVELS THEN COMP 4352 BEGIN NEED; COMP 4353 GENINC(SETINST[BPK,FR],I,BRG[VLEVEL],CWDISPL) COMP 4354 END COMP 4355 ELSE COMP 4356 IF LAREG <> 0 THEN COMP 4357 BEGIN NEED; COMP 4358 GEN30(SETINST[APK,FR],I,LAREG,LADDR,ABSR) COMP 4359 END COMP 4360 ELSE COMP 4361 IF VLEVEL = 1 THEN COMP 4362 BEGIN NEED; COMP 4363 GEN30(SETINST[BPK,FR],I,0,CWDISPL,VARR) COMP 4364 END COMP 4365 ELSE COMP 4366 BEGIN COMP 4367 SETBASEADDRESS(VLEVEL,J); COMP 4368 NEED; COMP 4369 GENINC(SETINST[XPK,FR],I,J,CWDISPL) COMP 4370 END; COMP 4371 IF FR = REGA THEN COMP 4372 WITH ARGS[I] DO COMP 4373 BEGIN ACONT := SIMPADDR; ALEV := VLEVEL; COMP 4374 ADISPL := CWDISPL COMP 4375 END; COMP 4376 END (* DRCT *) ; COMP 4377 INDRCT: COMP 4378 BEGIN COMP 4379 IF NOTSTORING THEN COMP 4380 FSIMPIND := XRGS[VWDISPL].XCONT = SIMPVAR; COMP 4381 IF FSIMPIND THEN COMP 4382 BEGIN COMP 4383 IF FR = REGX THEN DECREFX(VWDISPL); COMP 4384 FINDAREG(INDADDR); COMP 4385 IF ABS(LADDR) <= 1 THEN COMP 4386 BEGIN NEED; COMP 4387 GENINC(SETINST[APK,FR],I,LAREG,LADDR); COMP 4388 GOTO 1 COMP 4389 END COMP 4390 END COMP 4391 ELSE COMP 4392 IF NOTSTORING THEN DECREFX(VWDISPL); COMP 4393 NEED; COMP 4394 GENINC(SETINST[XPK,FR],I,VWDISPL,CWDISPL); COMP 4395 1:IF FR = REGA THEN COMP 4396 IF FSIMPIND THEN COMP 4397 WITH ARGS[I] DO COMP 4398 BEGIN ACONT := INDADDR; COMP 4399 AREG := VWDISPL; ADISPL := CWDISPL COMP 4400 END COMP 4401 ELSE ARGS[I].ACONT := UNSPECADDR; COMP 4402 END (* INDRCT *) ; COMP 4403 INXD: COMP 4404 BEGIN COMP 4405 IF NOTSTORING THEN DECREFX(VWDISPL); COMP 4406 IF VLEVEL = 1 THEN COMP 4407 BEGIN NEED; COMP 4408 GEN30(SETINST[XPK,FR],I,VWDISPL,CWDISPL,VARR) COMP 4409 END COMP 4410 ELSE COMP 4411 IF VLEVEL IN LEVELS THEN COMP 4412 BEGIN NEEDX([0..7],J); DECREFX(J); NEED; COMP 4413 IF PC.CP = 3 THEN COMP 4414 BEGIN GEN15(SXXPB,J,VWDISPL,BRG[VLEVEL]); COMP 4415 GENINC(SETINST[XPK,FR],I,J,CWDISPL) COMP 4416 END COMP 4417 ELSE COMP 4418 BEGIN GENINC(SXXPK,J,VWDISPL,CWDISPL); COMP 4419 GEN15(SETINST[XPB,FR],I,J,BRG[VLEVEL]) COMP 4420 END COMP 4421 END COMP 4422 ELSE COMP 4423 BEGIN NEEDB(L); COMP 4424 FINDAREG(SIMPADDR); COMP 4425 IF LAREG <> 0 THEN COMP 4426 BEGIN NEED; COMP 4427 GENINC(SBAPK,L,LAREG,LADDR); COMP 4428 GEN15(SETINST[XPB,FR],I,VWDISPL,L) COMP 4429 END COMP 4430 ELSE COMP 4431 BEGIN GENINC(SBXPK,L,VWDISPL,CWDISPL); COMP 4432 SETBASEADDRESS(VLEVEL,J); NEED; COMP 4433 GEN15(SETINST[XPB,FR],I,J,L) COMP 4434 END; COMP 4435 FREEB(L) COMP 4436 END; COMP 4437 IF FR = REGA THEN ARGS[I].ACONT := UNSPECADDR COMP 4438 END (* INXD *) COMP 4439 END (* CASE WORDACC OF *) ; COMP 4440 COND,EXPR: COMP 4441 NEED COMP 4442 END (* CASE KIND OF *) COMP 4443 ELSE NEED; COMP 4444 FI := I COMP 4445 END (* SETADDRESS *); COMP 4446 COMP 4447 PROCEDURE LOADBASE(FLEV: LEVRANGE; VAR FI: REGNR); COMP 4448 VAR LATTR: ATTR; COMP 4449 BEGIN COMP 4450 MAKEVARBLATTR(LATTR,NILPTR,FLEV,0); COMP 4451 SETADDRESS(LATTR,FALSE,REGX,[1..5],FI) COMP 4452 END (* LOADBASE *); COMP 4453 COMP 4454 PROCEDURE LOADADDRESS(VAR FATTR: ATTR; VAR FI: REGNR); COMP 4455 (*LOAD WORD-ADDRESS OF FATTR INTO X-FI*) COMP 4456 BEGIN COMP 4457 WITH FATTR DO COMP 4458 IF KIND = VARBL THEN COMP 4459 IF (WORDACC = INDRCT) AND (CWDISPL = 0) THEN FI := VWDISPL COMP 4460 ELSE COMP 4461 BEGIN SETADDRESS(FATTR,FALSE,REGX,[0..7],FI); COMP 4462 WORDACC := INDRCT; VWDISPL := FI; CWDISPL := 0 COMP 4463 END COMP 4464 ELSE SETADDRESS(FATTR,FALSE,REGX,[0..7],FI) COMP 4465 END (*LOADADDRESS*) ; COMP 4466 COMP 4467 PROCEDURE LOAD(VAR FATTR: ATTR; VAR FI: REGNR); FORWARD; COMP 4468 COMP 4469 PROCEDURE LOADCST(FCST: INTEGER; VAR FI: REGNR); COMP 4470 (* LOAD FCST INTO X.FI *) COMP 4471 BEGIN (* LOADCST *) COMP 4472 WITH CATTR DO BEGIN KIND := CST; CVAL.IVAL := FCST END; COMP 4473 LOAD(CATTR,FI) COMP 4474 END (* LOADCST *); COMP 4475 COMP 4476 PROCEDURE LOADMSK(FBTS: BITRANGE; VAR FI: REGNR); COMP 4477 (* LOAD MASK OF FBTS BITS INTO X.FI *) COMP 4478 BEGIN LOADCST(MASK(FBTS),FI) END; COMP 4479 COMP 4480 PROCEDURE LOAD; COMP 4481 (*LOAD FATTR INTO X-FI*) COMP 4482 LABEL 1,4,6; COMP 4483 VAR I,J,K: REGNR; SHRT,SIMPIND: BOOLEAN; COMP 4484 BITSZ,SHIFT,MASK: BITRANGE; COMP 4485 SVAL: SHRTINT; CSHFT: INTEGER; LCSP: CTAILP; COMP 4486 LCST: INTEGER; LMODE: (USRADJ,SRADJ,USLADJ); COMP 4487 MSK,STR: BOOLEAN; MCST: INTEGER; COMP 4488 BEGIN COMP 4489 IF PMD = PMDON THEN CHECKLINENUM; COMP 4490 WITH FATTR DO COMP 4491 BEGIN COMP 4492 IF TYPTR <> NIL THEN COMP 4493 CASE KIND OF COMP 4494 CST: COMP 4495 BEGIN SHRT := FALSE; SVAL := 0; LCSP := NIL; COMP 4496 MSK := FALSE; COMP 4497 STR := STRING(TYPTR); COMP 4498 IF STR THEN LCSP := CVAL.VALP COMP 4499 ELSE COMP 4500 BEGIN LCST := CVAL.IVAL; (* INTERNAL VALUE OF CONSTANT *) COMP 4501 IF ABS(LCST) < TWOTO17 THEN COMP 4502 BEGIN SVAL := LCST; SHRT := TRUE END COMP 4503 ELSE COMP 4504 BEGIN MNEW(LCSP); COMP 4505 WITH LCSP^ DO COMP 4506 BEGIN NXTCSP := NIL; CSVAL := LCST END COMP 4507 END COMP 4508 END; COMP 4509 IF SHRT THEN COMP 4510 BEGIN COMP 4511 FOR I := 0 TO 7 DO COMP 4512 WITH XRGS[I] DO COMP 4513 IF XCONT = SHRTCST THEN COMP 4514 IF CSTVAL = SVAL THEN COMP 4515 BEGIN REFNR := REFNR + 1; GOTO 1 END COMP 4516 END COMP 4517 ELSE COMP 4518 FOR I := 0 TO 7 DO COMP 4519 WITH XRGS[I] DO COMP 4520 IF XCONT = LONGCST THEN COMP 4521 IF CPTR = LCSP THEN COMP 4522 BEGIN REFNR := REFNR + 1; GOTO 1 END; COMP 4523 IF NOT (STR OR (LCST IN [0,1,2])) THEN COMP 4524 BEGIN SHIFT := 0; MASK := 0; MCST := LCST; COMP 4525 WHILE NOT ODD(MCST) DO COMP 4526 BEGIN MCST := MCST DIV 2; SHIFT := SHIFT + 1 END; COMP 4527 REPEAT MCST := MCST DIV 2; SHIFT := SHIFT + 1; COMP 4528 MASK := MASK + 1 COMP 4529 UNTIL NOT ODD(MCST); COMP 4530 IF (MCST = 0) THEN (* MASK CONSTANT *) COMP 4531 BEGIN COMP 4532 IF LCST < 0 THEN COMP 4533 BEGIN SHIFT := SHIFT - MASK; MASK := WORDSIZE - MASK END; COMP 4534 (* DECIDE WHETHER TO USE MASK AND SHIFT *) COMP 4535 MSK := NOT SHRT OR (SHIFT = 0) OR (PC.CP = 3) COMP 4536 END COMP 4537 END; COMP 4538 IF MSK THEN COMP 4539 BEGIN NEEDX([0..7],I); COMP 4540 GEN15(MXJK,I,0,MASK); COMP 4541 IF SHIFT <> 0 THEN GEN15(LXJK,I,0,SHIFT) COMP 4542 END COMP 4543 ELSE COMP 4544 IF SHRT THEN COMP 4545 BEGIN NEEDX([0..7],I); COMP 4546 GENINC(SXBPK,I,0,SVAL) COMP 4547 END COMP 4548 ELSE COMP 4549 BEGIN NEEDX([1..5],I); COMP 4550 ARGS[I].ACONT := UNSPECADDR; COMP 4551 GEN30(SABPK,I,0,0,PROGR); COMP 4552 ENTERCST(LCSP) COMP 4553 END; COMP 4554 WITH XRGS[I] DO COMP 4555 BEGIN REFNR := 1; COMP 4556 IF SHRT THEN COMP 4557 BEGIN XCONT := SHRTCST; CSTVAL := SVAL END COMP 4558 ELSE BEGIN XCONT := LONGCST; CPTR := LCSP END COMP 4559 END; COMP 4560 1: END; COMP 4561 VARBL: COMP 4562 BEGIN COMP 4563 CASE WORDACC OF COMP 4564 DRCT: COMP 4565 BEGIN COMP 4566 FOR I := 0 TO 7 DO COMP 4567 WITH XRGS[I] DO COMP 4568 IF XCONT = SIMPVAR THEN COMP 4569 IF (XLEV = VLEVEL)AND (XADDR = CWDISPL) THEN COMP 4570 BEGIN REFNR := REFNR + 1; GOTO 4 END; COMP 4571 SETADDRESS(FATTR,FALSE,REGA,[1..5],I); COMP 4572 WITH XRGS[I] DO COMP 4573 BEGIN XCONT := SIMPVAR; REFNR := 1; VPADDR := FALSE; COMP 4574 SHFTCNT := 0; XLEV := VLEVEL; XADDR := CWDISPL COMP 4575 END; COMP 4576 4: END; COMP 4577 INDRCT: COMP 4578 BEGIN SIMPIND := XRGS[VWDISPL].XCONT = SIMPVAR; COMP 4579 IF SIMPIND THEN COMP 4580 FOR I := 0 TO 7 DO COMP 4581 WITH XRGS[I] DO COMP 4582 IF XCONT = INDVAR THEN COMP 4583 IF (XREG = VWDISPL) AND (XDISPL = CWDISPL) THEN COMP 4584 BEGIN REFNR := REFNR + 1; DECREFX(VWDISPL); COMP 4585 GOTO 6 COMP 4586 END; COMP 4587 SETADDRESS(FATTR,FALSE,REGA,[1..5],I); COMP 4588 IF SIMPIND THEN COMP 4589 WITH XRGS[I] DO COMP 4590 BEGIN XCONT := INDVAR; REFNR := 1; SHFTCNT := 0; COMP 4591 XREG := VWDISPL; XDISPL := CWDISPL COMP 4592 END; COMP 4593 6: END; COMP 4594 INXD: COMP 4595 SETADDRESS(FATTR,FALSE,REGA,[1..5],I) COMP 4596 END (*CASE*) ; COMP 4597 IF PCKD THEN COMP 4598 BEGIN COMP 4599 WITH TYPTR^ DO COMP 4600 BEGIN COMP 4601 IF FORM = SUBRANGE THEN COMP 4602 IF MIN.IVAL < 0 THEN LMODE := SRADJ COMP 4603 ELSE LMODE := USRADJ COMP 4604 ELSE COMP 4605 IF FORM IN [ARRAYS,RECORDS] THEN LMODE := USLADJ COMP 4606 ELSE LMODE := USRADJ; COMP 4607 BITSZ := SIZE.BITS COMP 4608 END; COMP 4609 WITH XRGS[I] DO COMP 4610 IF XCONT IN [SIMPVAR,INDVAR] THEN SHIFT := SHFTCNT COMP 4611 ELSE SHIFT := 0; COMP 4612 IF LMODE = USLADJ THEN MASK := BITSZ COMP 4613 ELSE MASK := WORDSIZE - BITSZ; COMP 4614 CSHFT := CBDISPL - SHIFT; COMP 4615 IF LMODE = USRADJ THEN CSHFT := CSHFT + BITSZ; COMP 4616 IF BITREG = XREG THEN COMP 4617 BEGIN COMP 4618 IF SHIFT <> 0 THEN (*TO GUARANTEE 0 <= B-K <= 60*) COMP 4619 BEGIN GEN15(LXJK,I,0,WORDSIZE-SHIFT); COMP 4620 XRGS[I].SHFTCNT := 0; CSHFT := CSHFT + SHIFT COMP 4621 END; COMP 4622 NEEDB(K); COMP 4623 GENINC(SBXPK,K,VBDISPL,CSHFT); COMP 4624 DECREFX(VBDISPL); DECREFX(I); COMP 4625 NEEDX([0..7],J); GEN15(LXBX,J,K,I); COMP 4626 FREEB(K); COMP 4627 IF LMODE = SRADJ THEN GEN15(AXJK,J,0,MASK) COMP 4628 ELSE COMP 4629 BEGIN LOADMSK(MASK,K); COMP 4630 IF LMODE = USRADJ THEN GEN15(BXXTCX,J,J,K) COMP 4631 ELSE GEN15(BXXTX,J,J,K); COMP 4632 DECREFX(K) COMP 4633 END; COMP 4634 I := J COMP 4635 END COMP 4636 ELSE COMP 4637 BEGIN IF CSHFT < 0 THEN CSHFT := CSHFT + WORDSIZE COMP 4638 ELSE COMP 4639 IF CSHFT = WORDSIZE THEN CSHFT := 0; COMP 4640 WITH XRGS[I] DO COMP 4641 IF XCONT IN [SIMPVAR,INDVAR] THEN COMP 4642 IF LMODE = SRADJ THEN COMP 4643 BEGIN NEEDX([0..7],J); DECREFX(I); COMP 4644 GEN15(BXX,J,I,I); I := J COMP 4645 END COMP 4646 ELSE COMP 4647 SHFTCNT := (SHFTCNT + CSHFT) MOD WORDSIZE; COMP 4648 IF CSHFT <> 0 THEN GEN15(LXJK,I,0,CSHFT); COMP 4649 IF LMODE = SRADJ THEN GEN15(AXJK,I,0,MASK) COMP 4650 ELSE COMP 4651 BEGIN LOADMSK(MASK,K); DECREFX(K); NEEDX([0..7],J); COMP 4652 IF LMODE = USRADJ THEN GEN15(BXXTCX,J,I,K) COMP 4653 ELSE GEN15(BXXTX,J,I,K); COMP 4654 DECREFX(I); I := J COMP 4655 END COMP 4656 END COMP 4657 END (*PCKD*) COMP 4658 ELSE IF LOADROTATEFLAG THEN UNROTATEX(I); V41AC08 41 END; COMP 4660 COND: COMP 4661 BEGIN NEEDX([0..7],I); COMP 4662 IF CONDCD IN [ZR,NZ] THEN COMP 4663 BEGIN LOADCST(0,K); GEN15(IXXMX,I,K,CDR); DECREFX(K); COMP 4664 IF CONDCD = ZR THEN GEN15(BXXMX,I,I,CDR) COMP 4665 ELSE GEN15(BXXMCX,I,I,CDR); COMP 4666 LOADMSK(59,K); GEN15(BXXTCX,I,I,K) COMP 4667 END COMP 4668 ELSE COMP 4669 BEGIN LOADMSK(1,K); COMP 4670 IF CONDCD = PL THEN GEN15(BXXTX,I,K,CDR) COMP 4671 ELSE GEN15(BXXTCX,I,K,CDR); COMP 4672 GEN15(LXJK,I,0,1) COMP 4673 END; COMP 4674 DECREFX(K); COMP 4675 DECREFX(CDR) COMP 4676 END; COMP 4677 EXPR: COMP 4678 I := EXPREG COMP 4679 END (*CASE*) COMP 4680 ELSE NEEDX([0..7],I); COMP 4681 KIND := EXPR; EXPREG := I COMP 4682 END (*WITH FATTR*) ; COMP 4683 FI := I COMP 4684 END (*LOAD*) ; COMP 4685 COMP 4686 PROCEDURE OPERATION(FOP: OPCODE; VAR FK: REGNR; FI,FJ: REGNR); COMP 4687 BEGIN DECREFX(FI); DECREFX(FJ); NEEDX([0..7],FK); GEN15(FOP,FK,FI,FJ) COMP 4688 END (* OPERATION *); COMP 4689 COMP 4690 PROCEDURE LOADDESC(VAR FATTR: ATTR; VAR FI: REGNR; FDISPL: SHRTINT); COMP 4691 (* LOAD THE DESCRIPTOR WORD FDISPL FOR NON-PARAMETRIC USE. *) COMP 4692 VAR LATTR: ATTR; COMP 4693 BEGIN COMP 4694 IF FATTR.TYPTR <> NIL THEN COMP 4695 MAKEVARBLATTR(LATTR,INTPTR,FATTR.VLEVEL, COMP 4696 FATTR.TYPTR^.DESCADDR+FDISPL) COMP 4697 ELSE LATTR.TYPTR := NIL; COMP 4698 LOAD(LATTR,FI) COMP 4699 END (*LOADDESC*) ; COMP 4700 COMP 4701 PROCEDURE STORE(VAR FATTR: ATTR; FI: REGNR); COMP 4702 (*STORE X-FI AT FATTR*) COMP 4703 (*ASSUMES FATTR.KIND = VARBL*) COMP 4704 VAR I,J,K,LNR: REGNR; LATTR: ATTR; LXRG: XRGSTAT; COMP 4705 L: REGNR; OP1,OP2: OPCODE; TRUNCATE: BOOLEAN; COMP 4706 BITSZ,SHIFT,MASK: BITRANGE; CSHFT: INTEGER; LCST: SHRTINT; COMP 4707 LCP: POSRANGE; LADDR: INTEGER; LFTADJ,LBX,LXFICST: BOOLEAN; COMP 4708 LCLEARED : BOOLEAN; COMP 4709 COMP 4710 BEGIN COMP 4711 IF PMD = PMDON THEN CHECKLINENUM; COMP 4712 WITH FATTR DO COMP 4713 IF TYPTR <> NIL THEN COMP 4714 BEGIN COMP 4715 IF PCKD THEN COMP 4716 BEGIN LATTR := FATTR; COMP 4717 IF WORDACC <> DRCT THEN COMP 4718 WITH XRGS[VWDISPL] DO REFNR := REFNR + 1; COMP 4719 LATTR.PCKD := FALSE; V41AC08 42 LOADROTATEFLAG := FALSE; LOAD(LATTR,I); V41AC08 43 LOADROTATEFLAG := TRUE; V41AC08 44 WITH TYPTR^ DO COMP 4721 BEGIN LFTADJ := FORM IN [ARRAYS,RECORDS]; COMP 4722 BITSZ := SIZE.BITS COMP 4723 END; COMP 4724 WITH XRGS[I] DO COMP 4725 IF XCONT IN [SIMPVAR,INDVAR] THEN SHIFT := SHFTCNT COMP 4726 ELSE SHIFT := 0; COMP 4727 IF LFTADJ THEN COMP 4728 BEGIN MASK := BITSZ; CSHFT := CBDISPL - SHIFT; COMP 4729 OP1 := BXXTCX; OP2 := BXXTX COMP 4730 END COMP 4731 ELSE COMP 4732 BEGIN MASK := WORDSIZE - BITSZ; COMP 4733 CSHFT := CBDISPL - SHIFT + BITSZ; COMP 4734 OP1 := BXXTX; OP2 := BXXTCX COMP 4735 END; COMP 4736 IF BITREG = XREG THEN COMP 4737 BEGIN COMP 4738 IF BITSZ < SHIFT THEN (*TO GUARANTEE 0 <= B-K <= 60*) COMP 4739 BEGIN GEN15(LXJK,I,0,WORDSIZE - SHIFT); COMP 4740 XRGS[I].SHFTCNT := 0; CSHFT := CSHFT + SHIFT COMP 4741 END; COMP 4742 NEEDB(K); COMP 4743 GENINC(SBXPK,K,VBDISPL,CSHFT); COMP 4744 DECREFX(VBDISPL); DECREFX(I); NEEDX([0..7],J); COMP 4745 GEN15(LXBX,J,K,I); COMP 4746 END COMP 4747 ELSE COMP 4748 BEGIN COMP 4749 IF CSHFT < 0 THEN CSHFT := CSHFT + WORDSIZE COMP 4750 ELSE IF CSHFT = WORDSIZE THEN CSHFT := 0; COMP 4751 IF CSHFT <> 0 THEN GEN15(LXJK,I,0,CSHFT); J := I; COMP 4752 WITH XRGS[I] DO COMP 4753 IF XCONT IN [SIMPVAR,INDVAR] THEN COMP 4754 BEGIN SHFTCNT := (SHFTCNT + CSHFT) MOD WORDSIZE; COMP 4755 CSHFT := 0 COMP 4756 END COMP 4757 END; COMP 4758 WITH TYPTR^ DO COMP 4759 IF FORM <= POINTER THEN COMP 4760 IF FORM = SUBRANGE THEN TRUNCATE := MIN.IVAL < 0 COMP 4761 ELSE TRUNCATE := FALSE COMP 4762 ELSE TRUNCATE := TRUE; COMP 4763 IF TRUNCATE THEN COMP 4764 WITH XRGS[FI] DO COMP 4765 IF XCONT = SHRTCST THEN TRUNCATE := CSTVAL < 0 COMP 4766 ELSE COMP 4767 IF XCONT = LONGCST THEN TRUNCATE := CPTR^.CSVAL < 0; COMP 4768 LOADMSK(MASK,L); DECREFX(L); COMP 4769 GEN15(OP1,J,J,L); COMP 4770 IF TRUNCATE THEN COMP 4771 BEGIN NEEDX([0..7],I); GEN15(OP2,I,FI,L); DECREFX(FI) END COMP 4772 ELSE I := FI; COMP 4773 GEN15(BXXPX,J,J,I); COMP 4774 IF BITREG = XREG THEN COMP 4775 BEGIN GEN30(SBBPK,K,K,-WORDSIZE,ABSR); GEN15(AXBX,J,K,J); COMP 4776 FREEB(K) COMP 4777 END COMP 4778 ELSE IF CSHFT <> 0 THEN GEN15(LXJK,J,0,WORDSIZE-CSHFT); COMP 4779 DECREFX(I); FI := J COMP 4780 END (*PCKD*) ; COMP 4781 LCP := PC.CP; LNR := FI; COMP 4782 IF NOT (FI IN [6,7]) THEN COMP 4783 BEGIN NEEDX([6,7],I); BXIXJ(I,FI); COMP 4784 FI := I COMP 4785 END; COMP 4786 LBX := LCP <> PC.CP; COMP 4787 WITH XRGS[FI] DO COMP 4788 BEGIN LXFICST := XCONT = SHRTCST; COMP 4789 IF LXFICST THEN LCST := CSTVAL COMP 4790 ELSE UNROTATEX(FI); V41AC08 45 END; COMP 4792 CASE WORDACC OF COMP 4793 DRCT: COMP 4794 BEGIN LCLEARED := FALSE; COMP 4795 FOR I := 0 TO 7 DO COMP 4796 IF I <> FI THEN COMP 4797 WITH XRGS[I] DO COMP 4798 IF XCONT = SIMPVAR THEN COMP 4799 IF (XLEV = VLEVEL)AND (XADDR = CWDISPL) THEN COMP 4800 BEGIN XCONT := AVAIL; LCLEARED := TRUE END; COMP 4801 IF LCLEARED THEN COMP 4802 BEGIN COMP 4803 FOR I := 0 TO 7 DO COMP 4804 WITH XRGS[I] DO COMP 4805 IF XCONT = INDVAR THEN COMP 4806 IF XRGS[XREG].XCONT = AVAIL THEN XCONT := AVAIL; COMP 4807 FOR I := 1 TO 7 DO COMP 4808 WITH ARGS[I] DO COMP 4809 IF ACONT = INDADDR THEN COMP 4810 IF XRGS[AREG].XCONT = AVAIL THEN COMP 4811 ACONT := UNSPECADDR COMP 4812 END; COMP 4813 WITH LXRG DO COMP 4814 BEGIN XCONT := SIMPVAR; REFNR := 1; VPADDR := FALSE; COMP 4815 XLEV := VLEVEL; XADDR := CWDISPL; SHFTCNT := 0 COMP 4816 END COMP 4817 END; COMP 4818 INDRCT: COMP 4819 BEGIN COMP 4820 FOR I := 0 TO 7 DO COMP 4821 IF I <> FI THEN COMP 4822 WITH XRGS[I] DO COMP 4823 IF XCONT = INDVAR THEN COMP 4824 IF (XREG = VWDISPL)AND (XDISPL = CWDISPL) THEN COMP 4825 BEGIN DECREFX(VWDISPL); XCONT := AVAIL END; COMP 4826 IF XRGS[VWDISPL].XCONT = SIMPVAR THEN COMP 4827 WITH LXRG DO COMP 4828 BEGIN XCONT := INDVAR; REFNR := 1; COMP 4829 XREG := VWDISPL; XDISPL := CWDISPL; SHFTCNT := 0 COMP 4830 END COMP 4831 ELSE COMP 4832 WITH LXRG DO COMP 4833 BEGIN XCONT := OTHER; REFNR := 1 END COMP 4834 END; COMP 4835 INXD: COMP 4836 WITH LXRG DO COMP 4837 BEGIN XCONT := OTHER; REFNR := 1 END COMP 4838 END (*CASE*); COMP 4839 IF WORDACC <> DRCT THEN DECREFX(VWDISPL); COMP 4840 IF LXRG.XCONT = OTHER THEN COMP 4841 BEGIN COMP 4842 IF NOT LXFICST AND LBX THEN COMP 4843 WITH XRGS[FI] DO COMP 4844 BEGIN IF XCONT = INDVAR THEN DECREFX(XREG); COMP 4845 XCONT := OTHER COMP 4846 END COMP 4847 END COMP 4848 ELSE COMP 4849 BEGIN IF LBX THEN K := LNR ELSE K := FI; COMP 4850 IF (LXRG.XCONT <> INDVAR) OR (LXRG.XREG <> K) THEN COMP 4851 BEGIN COMP 4852 WITH XRGS[K] DO COMP 4853 IF XCONT = INDVAR THEN DECREFX(XREG) COMP 4854 ELSE IF XCONT = SIMPVAR THEN COMP 4855 FOR I := 0 TO 7 DO COMP 4856 WITH XRGS[I] DO COMP 4857 IF XCONT = INDVAR THEN COMP 4858 IF XREG = K THEN COMP 4859 IF REFNR = 0 THEN XCONT := AVAIL COMP 4860 ELSE XCONT := OTHER; COMP 4861 IF K = LNR THEN COMP 4862 BEGIN LXRG.REFNR := XRGS[K].REFNR; COMP 4863 IF LXRG.REFNR = 0 THEN LXRG.LASTREF := IC COMP 4864 END; COMP 4865 XRGS[K] := LXRG; COMP 4866 IF LXRG.XCONT = INDVAR THEN COMP 4867 WITH XRGS[LXRG.XREG] DO REFNR := REFNR + 1; COMP 4868 END COMP 4869 END; COMP 4870 SETADDRESS(FATTR,LXRG.XCONT=INDVAR,REGA,[],FI); COMP 4871 IF VLEVEL > 0 THEN COMP 4872 (*UPDATE OF REGISTER CONTENTS:*) COMP 4873 IF WORDACC = DRCT THEN (*SIMPLE VAR HAS GOT NEW VALUE. DISPOSE*) COMP 4874 BEGIN (*X-REGS CONTAINING VAR PARAMS*) COMP 4875 FOR I := 0 TO 7 DO COMP 4876 IF I <> FI THEN COMP 4877 WITH XRGS[I] DO COMP 4878 IF XCONT = INDVAR THEN COMP 4879 IF XRGS[XREG].VPADDR THEN COMP 4880 IF XRGS[XREG].XLEV > VLEVEL THEN COMP 4881 BEGIN DECREFX(XREG); COMP 4882 IF REFNR > 0 THEN XCONT := OTHER ELSE XCONT := AVAIL COMP 4883 END COMP 4884 END COMP 4885 ELSE (*ASSUME COINCIDANCE. DISPOSE X-REGS NOT CONT. SIMPLE VARS*) COMP 4886 BEGIN COMP 4887 FOR I := 0 TO 7 DO COMP 4888 IF I <> FI THEN COMP 4889 WITH XRGS[I] DO COMP 4890 IF XCONT = INDVAR THEN COMP 4891 BEGIN DECREFX(XREG); COMP 4892 IF REFNR > 0 THEN XCONT := OTHER ELSE XCONT := AVAIL COMP 4893 END; COMP 4894 IF XRGS[VWDISPL].VPADDR THEN (*DISPOSE X-REGS CONTAINING*) COMP 4895 BEGIN (*SIMPLE VARS OF LEVEL < XLEV*) COMP 4896 FOR I := 0 TO 7 DO COMP 4897 IF I <> FI THEN COMP 4898 WITH XRGS[I] DO COMP 4899 IF XCONT = SIMPVAR THEN COMP 4900 IF XLEV < XRGS[VWDISPL].XLEV THEN COMP 4901 IF REFNR > 0 THEN XCONT := OTHER ELSE XCONT := AVAIL; COMP 4902 FOR I := 1 TO 7 DO COMP 4903 WITH ARGS[I] DO COMP 4904 IF ACONT = INDADDR THEN COMP 4905 IF XRGS[AREG].XCONT = AVAIL THEN COMP 4906 ACONT := UNSPECADDR COMP 4907 END COMP 4908 END; COMP 4909 END (*TYPTR <> NIL*); COMP 4910 DECREFX(FI) COMP 4911 END (*STORE*) ; COMP 4912 COMP 4913 PROCEDURE CHECKBNDS(FI: REGNR; FMIN,FMAX: INTEGER; FADDR: ADDRRANGE); COMP 4914 (*TEST X-FI AGAINST BOUNDS FMIN AND FMAX.IF OUT OF BOUNDS JUMP COMP 4915 TO FADDR*) COMP 4916 VAR I,J,K: REGNR; COMP 4917 BEGIN COMP 4918 IF FMIN <> 0 THEN COMP 4919 BEGIN LOADCST(FMIN,I); DECREFX(I); NEEDX([0..7],K); COMP 4920 GEN15(IXXMX,K,FI,I) COMP 4921 END; COMP 4922 LOADCST(FMAX,I); COMP 4923 DECREFX(I); NEEDX([0..7],J); GEN15(IXXMX,J,I,FI); COMP 4924 IF FMIN <> 0 THEN COMP 4925 BEGIN GEN15(BXXPX,J,J,K); DECREFX(K) END COMP 4926 ELSE GEN15(BXXPX,J,J,FI); COMP 4927 GEN30(TESTX,ORD(NG),J,FADDR,TERAR); DECREFX(J) COMP 4928 END (*CHECKBNDS*) ; COMP 4929 COMP 4930 PROCEDURE CHECKORDINAL(FSP: STP; VAR FI: REGNR; FERR: ERRINDEX); COMP 4931 VAR LMIN, LMAX: INTEGER; COMP 4932 BEGIN COMP 4933 GETBOUNDS(FSP,LMIN,LMAX); COMP 4934 IF GATTR.KIND = CST THEN COMP 4935 BEGIN COMP 4936 WITH GATTR.CVAL DO COMP 4937 IF (IVAL < LMIN) OR (IVAL > LMAX) THEN ERROR(FERR); COMP 4938 LOAD(GATTR,FI) COMP 4939 END COMP 4940 ELSE COMP 4941 BEGIN LOAD(GATTR,FI); COMP 4942 IF DEBUG THEN CHECKBNDS(FI,LMIN,LMAX,ASSERR) COMP 4943 END COMP 4944 END (* CHECKORDINAL *) ; COMP 4945 COMP 4946 PROCEDURE CHECKSET(FSP: STP; VAR FI: REGNR; FERR: ERRINDEX); COMP 4947 VAR LMIN, LMAX: INTEGER; J,K: REGNR; COMP 4948 BEGIN COMP 4949 GETBOUNDS(FSP^.ELSET,LMIN,LMAX); COMP 4950 IF (LMIN >= 0) AND (LMAX <= 58) THEN COMP 4951 IF GATTR.KIND = CST THEN COMP 4952 BEGIN COMP 4953 IF GATTR.CVAL.PVAL - [LMIN..LMAX] <> [] THEN ERROR(FERR); COMP 4954 LOAD(GATTR,FI) COMP 4955 END COMP 4956 ELSE COMP 4957 BEGIN LOAD(GATTR,FI); COMP 4958 IF DEBUG THEN COMP 4959 BEGIN LOADCST(ROTATE(MASK(59-LMAX-LMIN),LMIN),J); COMP 4960 DECREFX(J); NEEDX([0..7],K); GEN15(BXXTX,K,FI,J); COMP 4961 GEN30(TESTX,ORD(NZ),K,ASSERR,TERAR); DECREFX(K) COMP 4962 END COMP 4963 END COMP 4964 ELSE NEEDX([0..7],FI) COMP 4965 END (* CHECKSET *); COMP 4966 (*$L'STATEMENT PROCESSOR.' *) COMP 4967 COMP 4968 COMP 4969 PROCEDURE STATEMENT(FSYS: SETOFSYS; STMTSEQUENCE: BOOLEAN); COMP 4970 LABEL 1; COMP 4971 VAR LCP: CTP; LLP: LBP; LOCP: LOCOFREF; COMP 4972 LASTSY: SYMBOL; EXITLOOP: BOOLEAN; COMP 4973 COMP 4974 PROCEDURE THREATEN(FCP: CTP); COMP 4975 BEGIN COMP 4976 IF (FCP <> NIL) AND (FCP <> UVARPTR) THEN COMP 4977 IF FCP^.KLASS = VARS THEN COMP 4978 BEGIN IF FCP^.CONTROLVAR THEN ERROR(184); COMP 4979 IF FCP^.VLEV < LEVEL THEN COMP 4980 FCP^.THREAT := TRUE COMP 4981 END COMP 4982 END (* THREATEN *); COMP 4983 COMP 4984 PROCEDURE PACKOFL(FI: REGNR); COMP 4985 VAR K: REGNR; COMP 4986 BEGIN NEEDX([0..7],K); GEN15(BXX,K,FI,FI); COMP 4987 GEN15(AXJK,K,0,48); GEN30(TESTX,ORD(NZ),K,OVLERR,TERAR); DECREFX(K) COMP 4988 END (*PACKOFL*) ; COMP 4989 COMP 4990 PROCEDURE PACKANDNORM(VAR FI: REGNR); COMP 4991 VAR K: REGNR; COMP 4992 BEGIN IF DEBUG THEN PACKOFL(FI); DECREFX(FI); NEEDX([0..7],K); COMP 4993 GEN15(PXBX,K,0,FI); GEN15(NXBX,K,0,K); COMP 4994 FI := K COMP 4995 END (*PACKANDNORM*) ; COMP 4996 COMP 4997 PROCEDURE EXPREP(FVAL: INTEGER;VAR FREC: CSTREC); COMP 4998 (*RETURN EXPONENTIAL REPRESENTATION OF FVAL: COMP 4999 CKIND = PUREP IF FVAL = 2**EXP, COMP 5000 CKIND = POSP IF FVAL = 2**EXP1*(2**EXP2 + 1), COMP 5001 CKIND = NEGP IF FVAL = 2**EXP1*(2**EXP2 - 1), COMP 5002 CKIND = NOP ELSE.*) COMP 5003 VAR E1,E2: BITRANGE; COMP 5004 BEGIN COMP 5005 IF FVAL > 0 THEN COMP 5006 BEGIN E1 := 0; COMP 5007 WHILE NOT ODD(FVAL) DO COMP 5008 BEGIN FVAL := FVAL DIV 2; E1 := E1 + 1 END; COMP 5009 IF FVAL = 1 THEN COMP 5010 WITH FREC DO COMP 5011 BEGIN CKIND := PUREP; EXP := E1 END COMP 5012 ELSE COMP 5013 BEGIN FVAL := FVAL DIV 2; E2 := 1; COMP 5014 IF ODD(FVAL) THEN COMP 5015 BEGIN COMP 5016 REPEAT FVAL := FVAL DIV 2; E2 := E2 + 1 COMP 5017 UNTIL NOT ODD(FVAL); COMP 5018 IF FVAL > 0 THEN FREC.CKIND := NOP COMP 5019 ELSE COMP 5020 WITH FREC DO COMP 5021 BEGIN CKIND := NEGP; EXP1 := E1; EXP2 := E2 END COMP 5022 END COMP 5023 ELSE COMP 5024 BEGIN COMP 5025 REPEAT FVAL := FVAL DIV 2; E2 := E2 + 1 COMP 5026 UNTIL ODD(FVAL); COMP 5027 IF FVAL > 1 THEN FREC.CKIND := NOP COMP 5028 ELSE COMP 5029 WITH FREC DO COMP 5030 BEGIN CKIND := POSP; EXP1 := E1; EXP2 := E2 END COMP 5031 END COMP 5032 END COMP 5033 END COMP 5034 ELSE FREC.CKIND := NOP COMP 5035 END (*EXPREP*) ; COMP 5036 COMP 5037 PROCEDURE OPTMULT(FI: REGNR; FREC: CSTREC; FEQ: BOOLEAN; COMP 5038 VAR FK: REGNR); COMP 5039 (*GENERATE CODE FOR X-FK := X-FI*FREC. FEQ <=> FI=FK IS ALLOWED*) COMP 5040 VAR E: BITRANGE; I,K: REGNR; B: BOOLEAN; COMP 5041 BEGIN B := FALSE; COMP 5042 WITH FREC DO COMP 5043 BEGIN IF CKIND = PUREP THEN E := EXP ELSE E := EXP1; COMP 5044 IF E <> 0 THEN COMP 5045 IF E = 1 THEN COMP 5046 BEGIN NEEDX([0..7],K); GEN15(LXBX,K,1,FI); COMP 5047 IF FEQ OR (CKIND = PUREP) THEN DECREFX(FI) COMP 5048 ELSE COMP 5049 BEGIN B := TRUE; I := FI END; COMP 5050 FI := K COMP 5051 END COMP 5052 ELSE COMP 5053 IF FEQ AND (XRGS[FI].REFNR = 1) THEN (*DESTROY X-FI*) COMP 5054 BEGIN GEN15(LXJK,FI,0,E); COMP 5055 WITH XRGS[FI] DO COMP 5056 BEGIN IF XCONT = INDVAR THEN DECREFX(XREG); COMP 5057 XCONT := OTHER COMP 5058 END COMP 5059 END COMP 5060 ELSE (*COPY X-FI*) COMP 5061 BEGIN NEEDX([0..7],K); GEN15(BXX,K,FI,FI); COMP 5062 GEN15(LXJK,K,0,E); COMP 5063 IF FEQ OR (CKIND = PUREP) THEN DECREFX(FI) COMP 5064 ELSE COMP 5065 BEGIN B := TRUE; I := FI END; COMP 5066 FI := K COMP 5067 END; COMP 5068 IF CKIND <> PUREP THEN COMP 5069 BEGIN NEEDX([0..7],K); COMP 5070 IF B THEN DECREFX(I); COMP 5071 GEN15(BXX,K,FI,FI); GEN15(LXJK,K,0,EXP2); COMP 5072 IF CKIND = POSP THEN GEN15(IXXPX,K,K,FI) COMP 5073 ELSE GEN15(IXXMX,K,K,FI); COMP 5074 DECREFX(FI); FK := K COMP 5075 END COMP 5076 ELSE FK := FI COMP 5077 END COMP 5078 END (*OPTMULT*) ; COMP 5079 COMP 5080 PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD; COMP 5081 COMP 5082 PROCEDURE ASSIGNTO(VAR FATTR: ATTR); COMP 5083 VAR I,J,K,L,M: REGNR; FLOAT: BOOLEAN; COMP 5084 LWORDS: ADDRRANGE; COMP 5085 SIMPIND,LONG: BOOLEAN; COMP 5086 BEGIN COMP 5087 IF (FATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN COMP 5088 BEGIN COMP 5089 FLOAT := COMPTYPES(GATTR.TYPTR,INTPTR) AND COMP 5090 (FATTR.TYPTR = REALPTR); COMP 5091 IF COMPTYPES(FATTR.TYPTR,GATTR.TYPTR) OR FLOAT THEN COMP 5092 CASE FATTR.TYPTR^.FORM OF COMP 5093 SCALAR, COMP 5094 SUBRANGE, COMP 5095 REALS: COMP 5096 BEGIN COMP 5097 IF (FATTR.TYPTR = INTPTR) OR (FATTR.TYPTR = REALPTR) THEN COMP 5098 LOAD(GATTR,I) COMP 5099 ELSE CHECKORDINAL(FATTR.TYPTR,I,303); COMP 5100 IF FLOAT THEN PACKANDNORM(I); COMP 5101 STORE(FATTR,I) COMP 5102 END; COMP 5103 POINTER: COMP 5104 BEGIN LOAD(GATTR,I); COMP 5105 STORE(FATTR,I) COMP 5106 END; COMP 5107 POWER: COMP 5108 BEGIN COMP 5109 CHECKSET(FATTR.TYPTR,I,303); COMP 5110 STORE(FATTR,I) COMP 5111 END; COMP 5112 ARRAYS, COMP 5113 RECORDS: COMP 5114 IF FATTR.TYPTR^.FTYPE THEN ERROR(146) COMP 5115 ELSE COMP 5116 BEGIN COMP 5117 IF CONFORMARRAY(FATTR.TYPTR) THEN COMP 5118 BEGIN COMP 5119 IF NOT EMPTYCNF(FATTR.TYPTR) THEN COMP 5120 BEGIN LOADDESC(FATTR,I,0); COMP 5121 DECREFX(I); NEEDB(J); COMP 5122 GEN30(SBXPK,J,I,-1,ABSR); COMP 5123 LOADADDRESS(GATTR,I); COMP 5124 LOADADDRESS(FATTR,K); COMP 5125 NEEDX([1..5],L); NEEDX([6,7],M); COMP 5126 NOOP; COMP 5127 GEN15(SAXPB,L,I,J); GEN15(BXX,M,L,L); COMP 5128 GEN15(SAXPB,M,K,J); GEN15(SBBMB,J,J,1); COMP 5129 GEN30(GE,J,0,IC-1,PROGR); COMP 5130 (* TAKE THE EASY WAY OUT: *) COMP 5131 CLEARREGS COMP 5132 END COMP 5133 END COMP 5134 ELSE (* NOT CONFORMANT ARRAY PARAMETER *) COMP 5135 BEGIN LWORDS := FULLWORDS(FATTR.TYPTR^.SIZE); COMP 5136 IF LWORDS = 1 THEN COMP 5137 BEGIN LOAD(GATTR,I); STORE(FATTR,I) END COMP 5138 ELSE COMP 5139 IF LWORDS > 31 THEN COMP 5140 BEGIN BRGS := BRGS - [2]; (* RESERVE B2 *) COMP 5141 LOADADDRESS(FATTR,I); GEN15(SBXPB,2,I,0); COMP 5142 NEEDX([1],K); SETADDRESS(GATTR,FALSE,REGA,[],K); COMP 5143 GEN30(SBBPK,7,0,LWORDS,ABSR); RJTOEXT(EX[MVEEX]) COMP 5144 END COMP 5145 ELSE (* LWORDS <= 31 *) COMP 5146 IF LWORDS <> 0 THEN COMP 5147 BEGIN SETADDRESS(GATTR,FALSE,REGA,[1..5],I); COMP 5148 NEEDX([6,7],K); COMP 5149 GEN15(BXX,K,I,I); COMP 5150 LONG := LWORDS >= 4; COMP 5151 LWORDS := LWORDS - 1; (* COUNT FIRST WORD *) COMP 5152 IF LONG THEN COMP 5153 BEGIN NEEDX([0..7],J); GEN15(MXJK,J,0,LWORDS) END; COMP 5154 SIMPIND := FALSE; COMP 5155 IF FATTR.WORDACC = INDRCT THEN COMP 5156 SIMPIND := XRGS[FATTR.VWDISPL].XCONT = SIMPVAR; COMP 5157 SETADDRESS(FATTR,SIMPIND,REGA,[],K); COMP 5158 IF LONG THEN COMP 5159 BEGIN NOOP; COMP 5160 GEN15(SAAPB,I,I,1); GEN15(BXX,K,I,I); COMP 5161 GEN15(LXJK,J,0,1); GEN15(SAAPB,K,K,1); COMP 5162 GEN30(TESTX,ORD(NG),J,IC-1,PROGR); COMP 5163 DECREFX(J) COMP 5164 END COMP 5165 ELSE (* NOT LONG *) COMP 5166 FOR J := 1 TO LWORDS DO COMP 5167 BEGIN GEN15(SAAPB,I,I,1); GEN15(BXX,K,I,I); COMP 5168 GEN15(SAAPB,K,K,1) COMP 5169 END; COMP 5170 (* RATHER THAN ATTEMPTING TO DETERMINE WHICH REGISTER COMP 5171 DESCRIPTORS HAVE BEEN INVALIDATED BY THE STORE COMP 5172 OPERATION, WE SIMPLY CLEAR THE REGISTER MAP. *) COMP 5173 CLEARREGS COMP 5174 END (* LWORDS <= 31 *) COMP 5175 END COMP 5176 END; COMP 5177 FILES: ERROR(146) COMP 5178 END COMP 5179 ELSE ERROR(129) COMP 5180 END COMP 5181 END (* ASSIGNTO *); COMP 5182 COMP 5183 PROCEDURE CHECKPTRREF(FI: REGNR); COMP 5184 (* CHECK THAT THE EXTENDED ($T+) POINTER VALUE IN X.FI *) COMP 5185 (* IS VALID AND NON-NIL. *) COMP 5186 VAR J, K: REGNR; COMP 5187 BEGIN (* CHECKPTRREF *) COMP 5188 NEEDX([1..5],J); NEEDX([0..7],K); COMP 5189 GEN30(SABPK,J,0,MEMFL,TMEMR); COMP 5190 GEN30(SXXPK,K,FI,-1,ABSR); COMP 5191 GEN15(IXXMX,J,K,J); COMP 5192 GEN15(BXXPCX,J,K,J); COMP 5193 GEN30(TESTX,ORD(NG),J,PTRERR,TERAR); COMP 5194 GEN15(SAXPB,J,K,0); COMP 5195 GEN15(IXXMX,J,FI,J); COMP 5196 GEN30(TESTX,ORD(NZ),J,PTRERR,TERAR); COMP 5197 DECREFX(J); DECREFX(K); COMP 5198 ARGS[J].ACONT := UNSPECADDR COMP 5199 END (* CHECKPTRREF *); COMP 5200 COMP 5201 PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP); COMP 5202 VAR LATTR: ATTR; COMP 5203 I,J: REGNR; LSP: STP; COMP 5204 COMP 5205 PROCEDURE IDADDRESS; COMP 5206 VAR I: REGNR; COMP 5207 BEGIN COMP 5208 WITH FCP^, LATTR DO COMP 5209 BEGIN TYPTR := IDTYPE; KIND := VARBL; TAGF := FALSE; COMP 5210 IF TYPTR <> NIL THEN COMP 5211 CASE KLASS OF COMP 5212 VARS: COMP 5213 BEGIN COMP 5214 VLEVEL := VLEV; CWDISPL := VADDR; PCKD := FALSE; COMP 5215 DCLPCKD := FALSE; COMP 5216 WORDACC := VACCESS; COMP 5217 IF WORDACC = INDRCT THEN COMP 5218 BEGIN WORDACC := DRCT; LOAD(LATTR,I); COMP 5219 KIND := VARBL; XRGS[I].VPADDR := VARPARAM; COMP 5220 WORDACC := INDRCT; CWDISPL := 0; COMP 5221 VWDISPL := I; PCKD := FALSE COMP 5222 END COMP 5223 END; COMP 5224 TAGFIELD, COMP 5225 FIELD: COMP 5226 WITH DISPLAY[DISX] DO COMP 5227 BEGIN WORDACC := DRCT; VLEVEL := LEV; COMP 5228 IF WACC = DRCT THEN CWDISPL := CWDSPL + FLDADDR COMP 5229 ELSE COMP 5230 BEGIN CWDISPL := CWDSPL; PCKD := FALSE; COMP 5231 LOAD(LATTR,I); COMP 5232 KIND := VARBL; WORDACC := INDRCT; COMP 5233 CWDISPL := FLDADDR; VWDISPL := I COMP 5234 END; COMP 5235 DCLPCKD := DCLPKD; COMP 5236 IF PKD THEN (*IMPLIES (FLDADDR=0)AND PCKDFLD*) COMP 5237 BEGIN PCKD := TRUE; COMP 5238 IF BACC = DRCT THEN COMP 5239 BEGIN CBDISPL := BDSPL + BITADDR; COMP 5240 BITREG := NONE COMP 5241 END COMP 5242 ELSE COMP 5243 BEGIN COMP 5244 MAKEVARBLATTR(GATTR,IDTYPE,LEVEL,BDSPL); COMP 5245 LOAD(GATTR,I); COMP 5246 CBDISPL := BITADDR; BITREG := XREG; COMP 5247 VBDISPL := I COMP 5248 END COMP 5249 END (*PKD*) COMP 5250 ELSE COMP 5251 IF PCKDFLD THEN COMP 5252 BEGIN PCKD := TRUE; CBDISPL := BITADDR; COMP 5253 BITREG := NONE COMP 5254 END COMP 5255 ELSE PCKD := FALSE; COMP 5256 TAGF := (KLASS = TAGFIELD) COMP 5257 END (*WITH*) ; COMP 5258 FUNC: (* WE GET HERE ONLY FROM ASSIGNMENT STATEMENT *) COMP 5259 BEGIN TYPTR := NIL; COMP 5260 IF PFDECKIND = PREDECLARED THEN ERROR(150) COMP 5261 ELSE COMP 5262 IF PFKIND = FORMAL THEN ERROR(151) COMP 5263 ELSE COMP 5264 IF PFDECL IN [EXTDECL, FTNDECL] THEN ERROR(150) COMP 5265 ELSE COMP 5266 BEGIN VLEVEL := PFLEV + 1; COMP 5267 IF VLEVEL > LEVEL THEN ERROR(177) COMP 5268 ELSE COMP 5269 IF FCP <> DISPLAY[VLEVEL].PFCP THEN ERROR(177) COMP 5270 ELSE COMP 5271 IF SY IN SELECTSYS THEN ERROR(194) V41AC18 7 ELSE V41AC18 8 BEGIN TYPTR := IDTYPE; WORDACC := DRCT; V41AC18 9 CWDISPL := FIRSTVAR - 1; PCKD := FALSE; V41AC18 10 DISPLAY[VLEVEL].ASSIGNED := TRUE V41AC18 11 END V41AC18 12 END COMP 5276 END (* FUNC *) COMP 5277 END (*CASE*) COMP 5278 END (*WITH*) COMP 5279 END (*IDADDRESS*) ; COMP 5280 COMP 5281 PROCEDURE INDEXCODE; COMP 5282 VAR LBREG: REGKIND; LBITS: BITRANGE; LWORDS: ADDRRANGE; COMP 5283 LOW,HIGH: INTEGER; I,J,K,L,M: REGNR; COMP 5284 LACC: ACCESSKIND; SZE: INTEGER; LREC: CSTREC; COMP 5285 CW: INTEGER; COMP 5286 DSHIFT,RSHIFT,MSHIFT: INTEGER; COMP 5287 EPW,LARGEST,PRECISION: INTEGER; COMP 5288 COMP 5289 PROCEDURE TESTBOUNDS(FI: REGNR; VAR FATTR: ATTR; VAR FJ: REGNR); COMP 5290 (* TEST X.FI AGAINST BOUNDS DENOTED BY THE DESCRIPTOR OF FATTR. COMP 5291 X.FJ := X.FI - LOW. *) COMP 5292 VAR I,J: REGNR; COMP 5293 BEGIN LOADDESC(FATTR,I,1); COMP 5294 DECREFX(I); NEEDX([0..7],J); GEN15(IXXMX,J,I,FI); COMP 5295 LOADDESC(FATTR,I,2); COMP 5296 OPERATION(IXXMX,FJ,FI,I); COMP 5297 DECREFX(J); NEEDX([0..7],I); GEN15(BXXPX,I,J,FJ); COMP 5298 DECREFX(I); GEN30(TESTX,ORD(NG),I,INXERR,TERAR) COMP 5299 END (*TESTBOUNDS*) ; COMP 5300 COMP 5301 BEGIN (*INDEXCODE*) LACC := DRCT; LBREG := NONE; COMP 5302 IF GATTR.KIND <> CST THEN LOAD(GATTR,I); COMP 5303 WITH LATTR, TYPTR^ DO COMP 5304 BEGIN COMP 5305 IF CONFORMANT THEN COMP 5306 BEGIN COMP 5307 IF GATTR.KIND = CST THEN LOAD(GATTR,I); COMP 5308 (*TEST INDEX, SET J TO INDEX - LOW*) COMP 5309 IF DEBUG THEN TESTBOUNDS(I,LATTR,J) COMP 5310 ELSE COMP 5311 BEGIN LOADDESC(LATTR,J,2); OPERATION(IXXMX,J,I,J) COMP 5312 END COMP 5313 END COMP 5314 ELSE COMP 5315 BEGIN COMP 5316 GETBOUNDS(INXTYPE,LOW,HIGH); COMP 5317 IF GATTR.KIND = CST THEN COMP 5318 BEGIN IF (GATTR.CVAL.IVAL>HIGH)OR (GATTR.CVAL.IVAL 1 *) COMP 5327 IF NOT PCKD THEN COMP 5328 BEGIN PCKD := TRUE; CBDISPL := 0; BITREG := NONE END; COMP 5329 LBITS := AELTYPE^.SIZE.BITS; COMP 5330 IF FULLWORDS(SIZE) = 1 THEN COMP 5331 IF GATTR.KIND = CST THEN COMP 5332 CBDISPL := CBDISPL + (GATTR.CVAL.IVAL - LOW)*LBITS COMP 5333 ELSE COMP 5334 BEGIN CBDISPL := CBDISPL - LOW*LBITS; COMP 5335 EXPREP(LBITS,LREC); COMP 5336 IF LREC.CKIND <> NOP THEN OPTMULT(I,LREC,TRUE,J) COMP 5337 ELSE COMP 5338 BEGIN LOADCST(LBITS,K); COMP 5339 OPERATION(DXXTX,J,I,K) COMP 5340 END; COMP 5341 LBREG := XREG COMP 5342 END COMP 5343 ELSE COMP 5344 IF GATTR.KIND = CST THEN COMP 5345 BEGIN CWDISPL := CWDISPL + (GATTR.CVAL.IVAL - LOW) COMP 5346 DIV ELSPERWORD; COMP 5347 CBDISPL := CBDISPL + (GATTR.CVAL.IVAL - LOW) COMP 5348 MOD ELSPERWORD * LBITS COMP 5349 END COMP 5350 ELSE COMP 5351 BEGIN COMP 5352 EPW := ELSPERWORD; COMP 5353 IF CONFORMANT THEN LARGEST := EPW * 400000B COMP 5354 (* ASSUME MAX SIZE FOR CONFORMANT ARRAYS *) COMP 5355 ELSE COMP 5356 BEGIN LARGEST := HIGH - LOW; COMP 5357 IF LARGEST > MAXADDR * WORDSIZE THEN COMP 5358 LARGEST := MAXADDR * WORDSIZE; COMP 5359 IF LOW = 0 THEN J := I COMP 5360 ELSE BEGIN LOADCST(LOW,J); OPERATION(IXXMX,J,I,J) END COMP 5361 END; COMP 5362 (* COMP 5363 COMPUTE WORD INDEX INTO PACKED ARRAY GIVEN COMP 5364 EPW IN [2..8,10,12,15,20,30,60]. COMP 5365 COMP 5366 WE DO THIS BY REPRESENTING EPW AS COMP 5367 EPW = 2**DSHIFT * X * Y COMP 5368 COMP 5369 WHERE COMP 5370 COMP 5371 DSHIFT = 0 FOR EPW IN [3,5,7,15] COMP 5372 DSHIFT = 1 FOR EPW IN [2,6,10,30] COMP 5373 DSHIFT = 2 FOR EPW IN [4,12,20,60] COMP 5374 DSHIFT = 3 FOR EPW = 8 COMP 5375 COMP 5376 X = 1 FOR EPW IN [2,4,7,8,15,30,60] COMP 5377 X = 3 FOR EPW IN [5,10,20] COMP 5378 X = 5 FOR EPW IN [3,6,12] COMP 5379 COMP 5380 Y = 1 FOR EPW IN [2,4,8] COMP 5381 Y = 7 FOR EPW = 7 COMP 5382 Y = 15 FOR EPW IN [3,5,6,10,12,15,20,30,60] COMP 5383 COMP 5384 COMP 5385 MSHIFT REPRESENTS THE SHIFT BETWEEN BITS IN X: COMP 5386 COMP 5387 1 = 1 + 2**0 MSHIFT = 0 COMP 5388 3 = 1 + 2**1 MSHIFT = 1 COMP 5389 5 = 1 + 2**2 MSHIFT = 2 COMP 5390 COMP 5391 RSHIFT REPRESENTS THE SHIFT BETWEEN BITS IN THE BINARY COMP 5392 REPRESENTATION OF 1/1, 1/7, AND 1/15: COMP 5393 COMP 5394 1/1 = 1.0 RSHIFT = 0 COMP 5395 1/7 = 0.001001001 ... RSHIFT = 3 COMP 5396 1/15 = 0.000100010001 ... RSHIFT = 4 COMP 5397 *) COMP 5398 DSHIFT := ORD(EPW-2 IN [0,2,4,6,8,10,18,28,58]) + COMP 5399 ORD(EPW-2 IN [2,6,10,18,58]) + COMP 5400 ORD(EPW = 8); COMP 5401 IF EPW IN [2,4,8] THEN RSHIFT := 0 COMP 5402 ELSE COMP 5403 IF EPW = 7 THEN RSHIFT := 3 COMP 5404 ELSE RSHIFT := 4; COMP 5405 MSHIFT := ORD(EPW IN [3,5,6,10,12,20]) + COMP 5406 ORD(EPW IN [3,6,12]); COMP 5407 NEEDX([0..7],K); COMP 5408 IF DSHIFT = 0 THEN I := J (* RSHIFT CANNOT BE 0 *) COMP 5409 ELSE COMP 5410 BEGIN I := K; M := 1; COMP 5411 IF DSHIFT <> 1 THEN COMP 5412 BEGIN NEEDB(M); GEN15(SBBPB,M,1,1); COMP 5413 IF DSHIFT = 3 THEN GEN15(SBBPB,M,M,1); COMP 5414 FREEB(M) COMP 5415 END; COMP 5416 GEN15(AXBX,K,M,J) COMP 5417 END; COMP 5418 IF RSHIFT = 0 THEN COMP 5419 BEGIN NEEDX([0..7],L); GEN15(LXBX,L,M,K) END COMP 5420 ELSE COMP 5421 BEGIN COMP 5422 FOR L := 1 TO DSHIFT DO LARGEST := LARGEST DIV 2; COMP 5423 PRECISION := 1; COMP 5424 FOR L := 1 TO RSHIFT DO PRECISION := PRECISION * 2; COMP 5425 IF LARGEST < 377776B THEN GEN15(SXXPB,K,I,1) COMP 5426 ELSE COMP 5427 BEGIN LOADCST(1,L); DECREFX(L); COMP 5428 GEN15(IXXPX,K,L,I) COMP 5429 END; COMP 5430 NEEDX([0..7],L); DECREFX(L); COMP 5431 IF MSHIFT <> 0 THEN COMP 5432 BEGIN COMP 5433 GENROTATE(L,K,MSHIFT); V41AC08 46 GEN15(IXXPX,K,L,K) COMP 5437 END; COMP 5438 REPEAT COMP 5439 GEN15(BXX,L,K,K); COMP 5440 GEN15(LXJK,K,0,RSHIFT); COMP 5441 GEN15(IXXPX,K,L,K); COMP 5442 RSHIFT := RSHIFT * 2; COMP 5443 PRECISION := SQR(PRECISION) COMP 5444 UNTIL LARGEST < PRECISION; COMP 5445 GEN15(AXJK,K,0,RSHIFT); COMP 5446 EXPREP(EPW,LREC); COMP 5447 IF LREC.CKIND <> NOP THEN COMP 5448 BEGIN OPTMULT(K,LREC,FALSE,L); COMP 5449 (*RESET REFERENCE:*) COMP 5450 WITH XRGS[K] DO COMP 5451 BEGIN XCONT := OTHER; REFNR := 1 END; COMP 5452 END COMP 5453 ELSE COMP 5454 BEGIN LOADCST(EPW,I); DECREFX(I); COMP 5455 NEEDX([0..7],L); GEN15(DXXTX,L,K,I); COMP 5456 END COMP 5457 END; COMP 5458 DECREFX(J); I := J; NEEDX([0..7],J); GEN15(IXXMX,J,I,L); COMP 5459 EXPREP(LBITS,LREC); COMP 5460 IF LREC.CKIND <> NOP THEN OPTMULT(J,LREC,TRUE,J) COMP 5461 ELSE COMP 5462 BEGIN GEN30(SXBPK,L,0,LBITS,ABSR); GEN15(DXXTX,J,J,L) END; COMP 5463 DECREFX(L); COMP 5464 LACC := INXD; LBREG := XREG COMP 5465 END COMP 5466 END (*PCKDARR AND PARTWORDELS*) COMP 5467 ELSE COMP 5468 IF CONFORMANT THEN COMP 5469 BEGIN COMP 5470 IF CONFORMARRAY(AELTYPE) THEN COMP 5471 BEGIN (*SIZE (FOR AELTYPE) IS VARIABLE*) COMP 5472 LOADDESC(LATTR,I,3); OPERATION(DXXTX,K,I,J) COMP 5473 END COMP 5474 ELSE (*SIZE OF AELTYPE IS CONSTANT*) COMP 5475 BEGIN SZE := FULLWORDS(AELTYPE^.SIZE); COMP 5476 EXPREP(SZE,LREC); COMP 5477 IF LREC.CKIND <> NOP THEN OPTMULT(J,LREC,TRUE,K) COMP 5478 ELSE COMP 5479 BEGIN COMP 5480 WITH GATTR DO COMP 5481 BEGIN TYPTR := INTPTR; KIND := CST; COMP 5482 CVAL.IVAL := SZE COMP 5483 END; COMP 5484 LOAD(GATTR,I); OPERATION(DXXTX,K,I,J) COMP 5485 END; COMP 5486 END; COMP 5487 LACC := INXD COMP 5488 END COMP 5489 ELSE COMP 5490 BEGIN COMP 5491 LWORDS := FULLWORDS(AELTYPE^.SIZE); COMP 5492 IF GATTR.KIND = CST THEN COMP 5493 BEGIN CW := CWDISPL + (GATTR.CVAL.IVAL - LOW) * LWORDS; COMP 5494 IF ABS(CW) > MAXADDR THEN COMP 5495 BEGIN CWDISPL := 0; COMP 5496 LOADCST(CW,K); LACC := INXD COMP 5497 END COMP 5498 ELSE CWDISPL := CW COMP 5499 END COMP 5500 ELSE COMP 5501 BEGIN CW := CWDISPL - LOW * LWORDS; COMP 5502 IF ABS(CW) > MAXADDR THEN COMP 5503 BEGIN COMP 5504 IF DEBUG (* LOW ALREADY IN X-REG *) OR COMP 5505 (ABS(LOW) > MAXADDR) THEN COMP 5506 BEGIN LOADCST(LOW,K); OPERATION(IXXMX,K,I,K) END COMP 5507 ELSE COMP 5508 BEGIN DECREFX(I); NEEDX([0..7],K); COMP 5509 GEN30(SXXPK,K,I,-LOW,ABSR) COMP 5510 END; COMP 5511 I := K COMP 5512 END COMP 5513 ELSE CWDISPL := CW; COMP 5514 EXPREP(LWORDS,LREC); COMP 5515 IF LREC.CKIND <> NOP THEN OPTMULT(I,LREC,TRUE,K) COMP 5516 ELSE COMP 5517 BEGIN LOADCST(LWORDS,J); COMP 5518 OPERATION(DXXTX,K,I,J) COMP 5519 END; COMP 5520 LACC := INXD COMP 5521 END; COMP 5522 END; COMP 5523 IF LACC <> DRCT THEN COMP 5524 IF WORDACC = DRCT THEN COMP 5525 BEGIN VWDISPL := K; WORDACC := INXD; COMP 5526 END COMP 5527 ELSE COMP 5528 BEGIN OPERATION(IXXPX,L,VWDISPL,K); VWDISPL := L END; COMP 5529 IF LBREG <> NONE THEN COMP 5530 IF BITREG = NONE THEN COMP 5531 BEGIN BITREG := XREG; VBDISPL := J END COMP 5532 ELSE COMP 5533 BEGIN OPERATION(IXXPX,L,VBDISPL,J); VBDISPL := L END COMP 5534 END (*WITH LATTR*) COMP 5535 END (*INDEXCODE*) ; COMP 5536 COMP 5537 BEGIN (*SELECTOR*) COMP 5538 IDADDRESS; COMP 5539 CHECKCONTEXT(FSYS+SELECTSYS,59,[]); COMP 5540 WHILE SY IN SELECTSYS DO COMP 5541 BEGIN COMP 5542 (*[*) IF SY = LBRACK THEN COMP 5543 BEGIN COMP 5544 REPEAT COMP 5545 WITH LATTR DO COMP 5546 IF TYPTR <> NIL THEN COMP 5547 IF TYPTR^.FORM <> ARRAYS THEN COMP 5548 BEGIN ERROR(138); TYPTR := NIL END; COMP 5549 INSYMBOL; EXPRESSION(FSYS+[COMMA,RBRACK]); COMP 5550 IF GATTR.TYPTR <> NIL THEN COMP 5551 IF GATTR.TYPTR^.FORM > SUBRANGE THEN ERROR(113); COMP 5552 IF LATTR.TYPTR <> NIL THEN COMP 5553 WITH LATTR.TYPTR^ DO COMP 5554 BEGIN LSP := INXTYPE; COMP 5555 IF LSP <> NIL THEN COMP 5556 IF LSP^.FORM = BOUNDDESC THEN COMP 5557 LSP := LSP^.BOUNDTYPE; COMP 5558 IF COMPTYPES(LSP,GATTR.TYPTR) THEN COMP 5559 BEGIN COMP 5560 IF (INXTYPE <> NIL)AND (AELTYPE <> NIL) THEN INDEXCODE COMP 5561 END COMP 5562 ELSE ERROR(139); COMP 5563 LATTR.DCLPCKD := PCKDARR; COMP 5564 LATTR.TYPTR := AELTYPE COMP 5565 END COMP 5566 UNTIL SY <> COMMA; COMP 5567 EXPECTSYMBOL(RBRACK,12) COMP 5568 END (*IF SY = LBRACK*) COMP 5569 ELSE COMP 5570 (*.*) IF SY = PERIOD THEN COMP 5571 BEGIN COMP 5572 WITH LATTR DO COMP 5573 BEGIN COMP 5574 IF TYPTR <> NIL THEN COMP 5575 IF TYPTR^.FORM <> RECORDS THEN COMP 5576 BEGIN ERROR(140); TYPTR := NIL END; COMP 5577 INSYMBOL; COMP 5578 IF SY = IDENT THEN COMP 5579 BEGIN COMP 5580 IF TYPTR <> NIL THEN COMP 5581 BEGIN SEARCHSECTION(TYPTR^.FIELDIDTREE,LCP); V41CC07 297 IF LCP = NIL THEN COMP 5583 BEGIN ERROR(152); TYPTR := NIL END COMP 5584 ELSE COMP 5585 WITH LCP^ DO COMP 5586 BEGIN DCLPCKD := TYPTR^.PCKDREC; COMP 5587 TYPTR := IDTYPE; TAGF := (KLASS = TAGFIELD); COMP 5588 IF PCKD THEN (*IMPLIES (FLDADDR=0)AND PCKDFLD*) COMP 5589 CBDISPL := CBDISPL + BITADDR COMP 5590 ELSE COMP 5591 BEGIN CWDISPL := CWDISPL + FLDADDR; COMP 5592 IF PCKDFLD THEN COMP 5593 BEGIN PCKD := TRUE; BITREG := NONE; COMP 5594 CBDISPL := BITADDR COMP 5595 END COMP 5596 END COMP 5597 END COMP 5598 END; COMP 5599 INSYMBOL COMP 5600 END (*SY = IDENT*) COMP 5601 ELSE ERROR(2) COMP 5602 END (*WITH GATTR*) COMP 5603 END (*IF SY = PERIOD*) COMP 5604 ELSE COMP 5605 (*^*) BEGIN COMP 5606 IF LATTR.TYPTR <> NIL THEN COMP 5607 BEGIN COMP 5608 WITH LATTR DO COMP 5609 BEGIN COMP 5610 IF TYPTR^.FORM = FILES THEN COMP 5611 CWDISPL := CWDISPL+EFETOFFSET[TYPTR^.TEXTFILE]+EFETPTR; V41CC04 19 LOAD(LATTR,I); COMP 5615 WITH TYPTR^ DO COMP 5616 IF FORM = POINTER THEN COMP 5617 BEGIN TYPTR:=ELTYPE; COMP 5618 IF DBG THEN COMP 5619 BEGIN COMP 5620 IF DEBUG THEN (* TEST POINTER *) COMP 5621 CHECKPTRREF(I); COMP 5622 (* SET KEY PART TO ZERO *) COMP 5623 J := I; DECREFX(J); NEEDX([0..7],I); COMP 5624 GEN15(SXXPB,I,J,0); COMP 5625 END COMP 5626 END COMP 5627 ELSE COMP 5628 IF FORM = FILES THEN TYPTR := FILTYPE COMP 5629 ELSE ERROR(141); COMP 5630 KIND := VARBL; WORDACC := INDRCT; COMP 5631 CWDISPL := 0; VWDISPL := I; COMP 5632 DCLPCKD := FALSE; COMP 5633 PCKD := FALSE COMP 5634 END COMP 5635 END; COMP 5636 INSYMBOL COMP 5637 END; COMP 5638 CHECKCONTEXT(FSYS+SELECTSYS,6,[]) COMP 5639 END (*WHILE*) ; COMP 5640 GATTR := LATTR; COMP 5641 END (*SELECTOR*) ; COMP 5642 COMP 5643 PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP); COMP 5644 VAR LKEY: KEYWORD; I,J,K: REGNR; COMP 5645 COMP 5646 PROCEDURE STOREPARAM(FDPL: ADDRRANGE; FI: REGNR); COMP 5647 (* STORE X REG. FI INTO B6+ARPS+PFLC+FDPL. *) COMP 5648 VAR LATTR: ATTR; COMP 5649 BEGIN COMP 5650 MAKEVARBLATTR(LATTR,INTPTR,0,ARPS+PFLC+FDPL); COMP 5651 STORE(LATTR,FI); COMP 5652 IF LATTR.CWDISPL + PSMARK >= PSSTORE THEN COMP 5653 BEGIN PSSTORE := LATTR.CWDISPL + PSMARK + 1; COMP 5654 IF PSSTORE > PSMAX THEN PSMAX := PSSTORE COMP 5655 END COMP 5656 END (* STOREPARAM *) ; COMP 5657 COMP 5658 PROCEDURE VARIABLE(FSYS: SETOFSYS); COMP 5659 VAR LCP: CTP; COMP 5660 BEGIN COMP 5661 IF SY = IDENT THEN COMP 5662 BEGIN SEARCHID([VARS,FIELD,TAGFIELD],LCP); COMP 5663 THREATEN(LCP); INSYMBOL COMP 5664 END COMP 5665 ELSE BEGIN ERROR(2); LCP := UVARPTR END; COMP 5666 SELECTOR(FSYS,LCP) COMP 5667 END (*VARIABLE*) ; COMP 5668 COMP 5669 PROCEDURE DEFAULTFILE(VAR FATTR: ATTR; FCP: CTP; FERR: ERRINDEX); COMP 5670 BEGIN COMP 5671 MAKEVARBLATTR(FATTR,TEXTPTR,1,0); COMP 5672 IF FCP <> NIL THEN COMP 5673 WITH FATTR, FCP^ DO COMP 5674 BEGIN TYPTR := IDTYPE; CWDISPL := VADDR END COMP 5675 ELSE ERROR(FERR) COMP 5676 END (* DEFAULTFILE *) ; COMP 5677 COMP 5678 PROCEDURE GETCPUTC(FEXT: EXTERNALNAME); COMP 5679 BEGIN (* GETCPUTC *) COMP 5680 GEN15(SAXPB,3,1,1); COMP 5681 IF FEXT = GETCHEX THEN COMP 5682 BEGIN GEN15(SXXPB,6,1,1); COMP 5683 IF DEBUG THEN COMP 5684 BEGIN GENROTATE(1,1,59-PREWRITE); GEN15(BXXPX,0,3,1) END V41AC08 47 END COMP 5686 ELSE (* PUT *) COMP 5687 BEGIN GEN15(SXBPB,4,1,0); GEN15(IXXPX,6,1,4); COMP 5688 IF DEBUG THEN COMP 5689 BEGIN GENROTATE(0,1,59-PREWRITE); GEN15(BXXPCX,0,3,0) END V41AC08 48 END; COMP 5691 GEN15(SAAPB,6,1,0); COMP 5692 GEN30(SXBPK,7,0,IC+1,PROGR); COMP 5693 SEARCHEXTID(EX[FEXT]); COMP 5694 IF DEBUG THEN GEN30(TESTX,ORD(NG),0,0,ABSR) COMP 5695 ELSE GEN30(TESTX,ORD(NG),3,0,ABSR); COMP 5696 CLEARREGS; COMP 5697 NOOP COMP 5698 END (* GETCPUTC *); COMP 5699 COMP 5700 PROCEDURE FILEPROCS(FEXT: EXTERNALNAME); COMP 5701 VAR CHARFILE,SEGMFILE: BOOLEAN; I: REGNR; COMP 5702 LDPLMT: ADDRRANGE; COMP 5703 BEGIN EXPECTSYMBOL(LPARENT,9); COMP 5704 CLEARREGS; XRGS[1].XCONT := OTHER; (*RESERVE A1/X1*) COMP 5705 VARIABLE(FSYS+[COMMA,RPARENT]); COMP 5706 CLEARREGS; (*TO PREVENT BX1... AND GUARANTEE SA1...*) COMP 5707 CHARFILE := FALSE; SEGMFILE := FALSE; LDPLMT := BINEFET; COMP 5708 IF GATTR.TYPTR <> NIL THEN COMP 5709 BEGIN COMP 5710 IF GATTR.WORDACC <> DRCT THEN COMP 5711 XRGS[GATTR.VWDISPL].XCONT := OTHER; COMP 5712 WITH GATTR.TYPTR^ DO COMP 5713 IF FORM = FILES THEN COMP 5714 BEGIN CHARFILE := TEXTFILE; SEGMFILE := SEGFILE; COMP 5715 IF CHARFILE THEN LDPLMT := TXTEFET V41CC04 20 END COMP 5717 ELSE ERROR(116) COMP 5718 END COMP 5719 ELSE GATTR.CWDISPL := 0; COMP 5720 IF LKEY IN [GETKW,PUTKW] THEN COMP 5721 BEGIN COMP 5722 IF CHARFILE THEN LDPLMT := TXTEFET + EFETPTR V41CC04 21 END COMP 5724 ELSE COMP 5725 IF LKEY IN [GETSEGKW,PUTSEGKW] THEN COMP 5726 IF NOT SEGMFILE THEN ERROR(116); COMP 5727 GATTR.CWDISPL := GATTR.CWDISPL + LDPLMT; COMP 5728 LOAD(GATTR,I); COMP 5729 IF SY = COMMA THEN COMP 5730 BEGIN COMP 5731 IF (LKEY = REWRITEKW) AND (OPTS.DIALECT = P6000) THEN V41DC05 476 BEGIN IF NOT SEGMFILE THEN ERROR(126); COMP 5733 EXTENSION(326); FEXT := RWRTSEX COMP 5734 END COMP 5735 ELSE COMP 5736 IF NOT (LKEY IN [GETSEGKW,GETFILEKW]) THEN ERROR(126); V41AC15 16 INSYMBOL; COMP 5738 EXPRESSION(FSYS+[RPARENT]); COMP 5739 IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN ERROR(142); COMP 5740 LOAD(GATTR,I); BXIXJ(2,I) COMP 5741 END COMP 5742 ELSE COMP 5743 IF LKEY IN [GETSEGKW,GETFILEKW] THEN GEN15(SXBPB,2,1,0); V41AC15 17 IF CHARFILE AND (LKEY IN [GETKW,PUTKW]) THEN COMP 5745 IF LKEY = GETKW THEN GETCPUTC(GETCHEX) ELSE GETCPUTC(PUTCHEX) COMP 5746 ELSE RJTOEXT(EX[FEXT]); COMP 5747 EXPECTSYMBOL(RPARENT,4) COMP 5748 END (* FILEPROCS *); COMP 5749 COMP 5750 PROCEDURE LOADFILEWORD(FATTR: ATTR; FDRCT: BOOLEAN; COMP 5751 FDISPL: SHRTINT); COMP 5752 (* LOAD WORD FDISPL RELATIVE TO THE EFET OF THE FILE COMP 5753 DESCRIBED BY INTO A1/X1, GUARANTEEING COMP 5754 A MEMORY REFERENCE IS GENERATED. UPON ENTRY, A1/X1 COMP 5755 SHOULD BE RESERVED. *) COMP 5756 VAR I: REGNR; L: ADDRRANGE; LATTR: ATTR; COMP 5757 BEGIN (* LOADFILEWORD *) COMP 5758 WITH FATTR DO COMP 5759 BEGIN COMP 5760 L := FDISPL + EFETOFFSET[TYPTR^.TEXTFILE]; V41CC04 22 IF FDRCT THEN CWDISPL := CWDISPL + L COMP 5763 ELSE COMP 5764 BEGIN LATTR := FATTR; COMP 5765 LOAD(LATTR,I); COMP 5766 WORDACC := INDRCT; COMP 5767 VWDISPL := I; COMP 5768 CWDISPL := L COMP 5769 END; COMP 5770 I := 1; COMP 5771 SETADDRESS(FATTR,TRUE,REGA,[],I); (* GENERATE SA1 ... *) COMP 5772 IF WORDACC = INDRCT THEN DECREFX(VWDISPL) COMP 5773 END COMP 5774 END (* LOADFILEWORD *); COMP 5775 COMP 5776 PROCEDURE READ; COMP 5777 VAR LATTR,FILATTR: ATTR; I,J: REGNR; COMP 5778 LDRCT,GETIN,EXITLOOP: BOOLEAN; COMP 5779 LMIN,LMAX: INTEGER; COMP 5780 LXRGS: XRGSTATUS; COMP 5781 COMP 5782 BEGIN (*READ*) COMP 5783 MAKEVARBLATTR(FILATTR,TEXTPTR,1,0); COMP 5784 LDRCT := TRUE; COMP 5785 NEEDX([1],I); (*RESERVE A1/X1*) COMP 5786 IF SY = LPARENT THEN COMP 5787 BEGIN GETIN := TRUE; COMP 5788 INSYMBOL; VARIABLE(FSYS+[COMMA,RPARENT]); COMP 5789 IF GATTR.TYPTR <> NIL THEN COMP 5790 IF GATTR.TYPTR^.FORM = FILES THEN COMP 5791 BEGIN IF NOT GATTR.TYPTR^.TEXTFILE AND (LKEY = READLNKW) COMP 5792 THEN ERROR(116); COMP 5793 IF GATTR.WORDACC = DRCT THEN COMP 5794 BEGIN FILATTR := GATTR; LDRCT := TRUE END COMP 5795 ELSE COMP 5796 BEGIN LOADADDRESS(GATTR,I); COMP 5797 MAKETEMP(FILATTR,GATTR.TYPTR,1); COMP 5798 STORE(FILATTR,I); COMP 5799 LDRCT := FALSE COMP 5800 END; COMP 5801 IF SY = RPARENT THEN COMP 5802 BEGIN IF LKEY = READKW THEN ERROR(116); COMP 5803 GETIN := FALSE COMP 5804 END COMP 5805 ELSE COMP 5806 IF SY = COMMA THEN COMP 5807 BEGIN INSYMBOL; VARIABLE(FSYS+[COMMA,RPARENT]) END COMP 5808 END (*FORM = FILES*) COMP 5809 ELSE DEFAULTFILE(FILATTR,INPUTPTR,175); COMP 5810 IF GETIN THEN COMP 5811 (*LOOP UNTIL SY <> COMMA:*) COMP 5812 REPEAT COMP 5813 IF FILATTR.TYPTR^.TEXTFILE AND COMP 5814 NOT COMPTYPES(GATTR.TYPTR,CHARPTR) THEN COMP 5815 BEGIN DECREFX(1); COMP 5816 IF (GATTR.TYPTR = REALPTR) OR COMP 5817 COMPTYPES(GATTR.TYPTR,INTPTR) THEN COMP 5818 BEGIN NEEDX([6,7],I); DECREFX(I); (* STORING REG.*) COMP 5819 SAVEREFXRGS(LXRGS); (* SAVE ACCESS TO VARIABLE *) COMP 5820 LATTR := FILATTR; (* PASS FILE ADDRESS *) COMP 5821 IF LDRCT THEN LOADADDRESS(LATTR,J) ELSE LOAD(LATTR,J); COMP 5822 STOREPARAM(0,J); PSSTORE := PSMARK; COMP 5823 IF GATTR.TYPTR = REALPTR THEN RJTOEXT(EX[RDREX]) COMP 5824 ELSE RJTOEXT(EX[RDIEX]); COMP 5825 IF I <> 6 THEN GEN15(BXX,I,6,6); COMP 5826 RELOADREFXRGS(LXRGS); NEEDX([I],I); COMP 5827 LATTR := GATTR; COMP 5828 GATTR.KIND := EXPR; GATTR.EXPREG := I; COMP 5829 ASSIGNTO(LATTR) COMP 5830 END COMP 5831 ELSE ERROR(116) COMP 5832 END COMP 5833 ELSE COMP 5834 BEGIN LATTR := GATTR; COMP 5835 LOADFILEWORD(FILATTR,LDRCT,EFETPTR); V41CC04 23 WITH GATTR DO COMP 5837 BEGIN TYPTR := FILATTR.TYPTR^.FILTYPE; KIND := VARBL; COMP 5838 WORDACC := INDRCT; CWDISPL := 0; VWDISPL := 1; COMP 5839 PCKD := FALSE COMP 5840 END; COMP 5841 XRGS[1].REFNR := 2; (*TO PROTECT A1/X1*) COMP 5842 ASSIGNTO(LATTR); COMP 5843 NEEDX([1],I); (*RESET REFERENCE TO X1*) COMP 5844 IF FILATTR.TYPTR^.TEXTFILE THEN GETCPUTC(GETCHEX) COMP 5845 ELSE BEGIN LOADFILEWORD(FILATTR,LDRCT,EFET); V41CC04 24 RJTOEXT(EX[GETBEX]); COMP 5847 END; COMP 5848 END; COMP 5849 EXITLOOP := SY <> COMMA; COMP 5850 IF NOT EXITLOOP THEN COMP 5851 BEGIN NEEDX([1],I); (*RESERVE A1/X1*) COMP 5852 INSYMBOL; VARIABLE(FSYS+[COMMA,RPARENT]) COMP 5853 END COMP 5854 UNTIL EXITLOOP; COMP 5855 EXPECTSYMBOL(RPARENT,4) COMP 5856 END (*SY = LPARENT*) COMP 5857 ELSE COMP 5858 IF LKEY = READKW THEN ERROR(116) COMP 5859 ELSE DEFAULTFILE(FILATTR,INPUTPTR,175); COMP 5860 IF LKEY = READLNKW THEN COMP 5861 BEGIN LOADFILEWORD(FILATTR,LDRCT,EFETPTR); V41CC04 25 RJTOEXT(EX[GETLNEX]) COMP 5863 END; COMP 5864 IF NOT LDRCT THEN LC := LC - 1 COMP 5865 END (*READ*) ; COMP 5866 COMP 5867 PROCEDURE WRITE; COMP 5868 VAR LATTR,LATTR2,FILATTR: ATTR; K: REGNR; COMP 5869 LSP: STP; I,J: REGNR; LDEF,LDRCT,PUTOUT,EXITLOOP: BOOLEAN; COMP 5870 SHORTSTRING: BOOLEAN; COMP 5871 COMP 5872 PROCEDURE SETWIDTHANDJUMP(FW: INTEGER; FNAME: ALFA); COMP 5873 VAR I: REGNR; COMP 5874 BEGIN COMP 5875 IF LDEF THEN (* PASS DEFAULT FIELDWIDTH *) COMP 5876 BEGIN LOADCST(FW,I); COMP 5877 STOREPARAM(2,I) COMP 5878 END; COMP 5879 RJTOEXT(FNAME) COMP 5880 END (* SETWIDTHANDJUMP *); COMP 5881 COMP 5882 PROCEDURE FORMATSPEC(FSYS: SETOFSYS; FDPL: ADDRRANGE); COMP 5883 VAR I,J,K: REGNR; CSTWIDTH: BOOLEAN; COMP 5884 BEGIN COMP 5885 INSYMBOL; EXPRESSION(FSYS); COMP 5886 CSTWIDTH := TRUE; COMP 5887 IF GATTR.TYPTR <> NIL THEN COMP 5888 IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN ERROR(116) COMP 5889 ELSE COMP 5890 BEGIN CSTWIDTH := GATTR.KIND = CST; COMP 5891 IF CSTWIDTH THEN COMP 5892 IF GATTR.CVAL.IVAL <= 0 THEN ERROR(305) COMP 5893 END; COMP 5894 LOAD(GATTR,I); COMP 5895 IF DEBUG AND NOT CSTWIDTH THEN COMP 5896 BEGIN LOADCST(1,J); COMP 5897 DECREFX(J); COMP 5898 NEEDX([0..7],K); COMP 5899 GEN15(IXXMX,K,I,J); COMP 5900 GEN30(TESTX,ORD(NG),K,ASSERR,TERAR); COMP 5901 DECREFX(K) COMP 5902 END; COMP 5903 STOREPARAM(FDPL,I) COMP 5904 END (* FORMATSPEC *); COMP 5905 COMP 5906 BEGIN (*WRITE*) COMP 5907 MAKEVARBLATTR(FILATTR,TEXTPTR,1,0); COMP 5908 LDRCT := TRUE; COMP 5909 NEEDX([1],I); (*RESERVE A1/X1*) COMP 5910 IF SY = LPARENT THEN COMP 5911 BEGIN PUTOUT := TRUE; COMP 5912 INSYMBOL; EXPRESSION(FSYS+[COMMA,COLON,RPARENT,IDENT]); COMP 5913 IF GATTR.TYPTR <> NIL THEN COMP 5914 IF GATTR.TYPTR^.FORM = FILES THEN COMP 5915 BEGIN IF NOT GATTR.TYPTR^.TEXTFILE AND (LKEY = WRITELNKW) COMP 5916 THEN ERROR(116); COMP 5917 IF SY = RPARENT THEN COMP 5918 BEGIN IF LKEY = WRITEKW THEN ERROR(116); COMP 5919 PUTOUT := FALSE COMP 5920 END COMP 5921 ELSE COMP 5922 IF SY <> COMMA THEN COMP 5923 BEGIN ERROR(116); SKIP(FSYS+[COMMA,RPARENT]) END; COMP 5924 IF GATTR.WORDACC = DRCT THEN COMP 5925 BEGIN FILATTR := GATTR; LDRCT := TRUE END COMP 5926 ELSE COMP 5927 BEGIN LOADADDRESS(GATTR,I); COMP 5928 MAKETEMP(FILATTR,GATTR.TYPTR,1); COMP 5929 STORE(FILATTR,I); COMP 5930 LDRCT := FALSE COMP 5931 END; COMP 5932 IF SY = COMMA THEN COMP 5933 BEGIN INSYMBOL; COMP 5934 EXPRESSION(FSYS+[COMMA,COLON,RPARENT,IDENT]) COMP 5935 END COMP 5936 END (* FORM = FILES *) COMP 5937 ELSE DEFAULTFILE(FILATTR,OUTPUTPTR,176); COMP 5938 IF PUTOUT THEN COMP 5939 (*LOOP UNTIL SY <> COMMA*) COMP 5940 REPEAT COMP 5941 IF FILATTR.TYPTR^.TEXTFILE AND COMP 5942 (NOT COMPTYPES(GATTR.TYPTR,CHARPTR) OR (SY = COLON)) THEN COMP 5943 BEGIN LSP := GATTR.TYPTR; DECREFX(1); COMP 5944 LATTR := FILATTR; LATTR2 := GATTR; COMP 5945 IF LDRCT THEN (* PASS FILEADDRESS: *) LOADADDRESS(LATTR,J) COMP 5946 ELSE LOAD(LATTR,J); COMP 5947 STOREPARAM(0,J); COMP 5948 IF STRING(LSP) THEN (* PASS VALUE TO BE OUTPUT: *) COMP 5949 BEGIN SHORTSTRING := FULLWORDS(LSP^.SIZE) = 1; COMP 5950 IF CONFORMARRAY(LSP) THEN V41AC20 42 IF OPTS.DIALECT = P6000 THEN EXTENSION(333) V41DC05 477 ELSE ERROR(116); V41DC05 478 (* DYNAMIC STRINGS ARE NOT SHORTSTRINGS *) COMP 5952 IF SHORTSTRING THEN LOAD(GATTR,I) COMP 5953 ELSE LOADADDRESS(GATTR,I) COMP 5954 END COMP 5955 ELSE LOAD(GATTR,I); COMP 5956 STOREPARAM(1,I); COMP 5957 LDEF := SY <> COLON; COMP 5958 IF NOT LDEF THEN (* PASS FIELDWIDTH: *) COMP 5959 FORMATSPEC(FSYS+[COMMA,COLON,RPARENT],2); COMP 5960 IF SY = COLON THEN COMP 5961 BEGIN COMP 5962 IF LSP <> REALPTR THEN ERROR(124); COMP 5963 FORMATSPEC(FSYS+[COMMA,RPARENT],3); COMP 5964 SETWIDTHANDJUMP(20,EX[WRFEX]) COMP 5965 END COMP 5966 ELSE COMP 5967 IF COMPTYPES(LSP,INTPTR) THEN COMP 5968 SETWIDTHANDJUMP(10,EX[WRIEX]) COMP 5969 ELSE COMP 5970 IF LSP = REALPTR THEN COMP 5971 SETWIDTHANDJUMP(21,EX[WREEX]) COMP 5972 ELSE COMP 5973 IF COMPTYPES(LSP,CHARPTR) THEN COMP 5974 IF DEBUG THEN SETWIDTHANDJUMP(1,EX[WRCDEX]) COMP 5975 ELSE SETWIDTHANDJUMP(1,EX[WRCEX]) COMP 5976 ELSE COMP 5977 IF COMPTYPES(LSP,BOOLPTR) THEN COMP 5978 SETWIDTHANDJUMP(10,EX[WRBEX]) COMP 5979 ELSE COMP 5980 IF LSP <> NIL THEN COMP 5981 IF STRING(LSP) THEN COMP 5982 WITH LSP^ DO COMP 5983 IF CONFORMARRAY(LSP) THEN COMP 5984 BEGIN LOADDESC(LATTR2,J,1); COMP 5985 LOADDESC(LATTR2,I,2); OPERATION(IXXMX,K,J,I); COMP 5986 NEEDX([6,7],I); GEN15(SXXPB,I,K,1); DECREFX(K); COMP 5987 STOREPARAM(3,I); COMP 5988 IF LDEF THEN COMP 5989 BEGIN NEEDX([I],I); COMP 5990 STOREPARAM(2,I) COMP 5991 END; COMP 5992 GEN30(SXBPK,7,0,IC+1,PROGR); COMP 5993 RJTOEXT(EX[WRSEX]) COMP 5994 END COMP 5995 ELSE COMP 5996 BEGIN (* PASS STRING LENGTH: *) COMP 5997 LSZ := ALFALENG * SIZE.WORDS + COMP 5998 SIZE.BITS DIV CHARSIZE; COMP 5999 IF SHORTSTRING THEN LOADCST(-LSZ,I) COMP 6000 ELSE LOADCST(LSZ,I); COMP 6001 STOREPARAM(3,I); COMP 6002 SETWIDTHANDJUMP(LSZ,EX[WRSEX]) COMP 6003 END COMP 6004 ELSE ERROR(116); COMP 6005 END COMP 6006 ELSE COMP 6007 BEGIN LOADFILEWORD(FILATTR,LDRCT,EFETPTR); V41CC04 26 WITH LATTR DO COMP 6009 BEGIN TYPTR := FILATTR.TYPTR^.FILTYPE; KIND := VARBL; COMP 6010 WORDACC := INDRCT; CWDISPL := 0; VWDISPL := 1; COMP 6011 PCKD := FALSE COMP 6012 END; COMP 6013 ASSIGNTO(LATTR); COMP 6014 NEEDX([1],I); (*RESET REFERENCE TO X1*) COMP 6015 IF FILATTR.TYPTR^.TEXTFILE THEN GETCPUTC(PUTCHEX) COMP 6016 ELSE COMP 6017 BEGIN LOADFILEWORD(FILATTR,LDRCT,EFET); RJTOEXT(EX[PUTBEX]) V41CC04 27 END; COMP 6019 END; COMP 6020 PSSTORE := PSMARK; COMP 6021 EXITLOOP := SY <> COMMA; COMP 6022 IF NOT EXITLOOP THEN COMP 6023 BEGIN INSYMBOL; NEEDX([1],I); (*RESERVE A1/X1*) COMP 6024 EXPRESSION(FSYS+[COMMA,COLON,RPARENT,IDENT]) COMP 6025 END; COMP 6026 UNTIL EXITLOOP; COMP 6027 EXPECTSYMBOL(RPARENT,4) COMP 6028 END (*SY = LPARENT*) COMP 6029 ELSE COMP 6030 IF LKEY = WRITEKW THEN ERROR(116) COMP 6031 ELSE DEFAULTFILE(FILATTR,OUTPUTPTR,176); COMP 6032 IF LKEY = WRITELNKW THEN COMP 6033 BEGIN LOADFILEWORD(FILATTR,LDRCT,EFETPTR); V41CC04 28 RJTOEXT(EX[PUTLNEX]) COMP 6035 END; COMP 6036 IF NOT LDRCT THEN LC := LC - 1 COMP 6037 END (*WRITE*) ; COMP 6038 COMP 6039 PROCEDURE STRINGPARAM(FSYS: SETOFSYS); COMP 6040 VAR I,J: REGNR; COMP 6041 LATTR: ATTR; LSTRING: BOOLEAN; V41CC15 7 BEGIN EXPECTSYMBOL(LPARENT,9); COMP 6042 EXPRESSION(FSYS); COMP 6043 LSTRING := STRING(GATTR.TYPTR); V41CC15 8 IF LSTRING THEN V41CC15 9 WITH GATTR DO V41CC15 10 IF (FULLWORDS(TYPTR^.SIZE) = 1) AND PCKD THEN V41CC15 11 BEGIN LOAD(GATTR,I); V41CC15 12 MAKETEMP(LATTR,GATTR.TYPTR,1); STORE(LATTR,I); V41CC15 13 GATTR := LATTR V41CC15 14 END; V41CC15 15 LOADADDRESS(GATTR,I); BXIXJ(1,I); COMP 6044 IF GATTR.TYPTR <> NIL THEN COMP 6045 IF LSTRING THEN V41CC15 16 IF CONFORMARRAY(GATTR.TYPTR) THEN COMP 6047 BEGIN LOADDESC(GATTR,I,1); COMP 6048 LOADDESC(GATTR,J,2); OPERATION(IXXMX,I,I,J); COMP 6049 GEN15(SXXPB,I,I,1); BXIXJ(2,I); COMP 6050 END COMP 6051 ELSE COMP 6052 WITH GATTR.TYPTR^.SIZE DO COMP 6053 BEGIN LOADCST(WORDS*ALFALENG+BITS DIV CHARSIZE,I); BXIXJ(2,I) COMP 6054 END COMP 6055 ELSE ERROR(116); COMP 6056 END (* STRINGPARAM *); COMP 6057 COMP 6058 PROCEDURE MESSAGE; COMP 6059 BEGIN (* MESSAGE *) COMP 6060 STRINGPARAM(FSYS+[RPARENT,COMMA]); COMP 6061 IF SY = COMMA THEN COMP 6062 BEGIN INSYMBOL; COMP 6063 EXPRESSION(FSYS+[RPARENT]); COMP 6064 IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN ERROR(116); COMP 6065 LOAD(GATTR,I); BXIXJ(3,I) COMP 6066 END COMP 6067 ELSE GEN15(MXJK,3,0,1); COMP 6068 EXPECTSYMBOL(RPARENT,4); COMP 6069 RJTOEXT(EX[MSGEX]) COMP 6070 END (*MESSAGE*) ; COMP 6071 COMP 6072 PROCEDURE PAGE; COMP 6073 VAR I: REGNR; COMP 6074 BEGIN (* PAGE *) COMP 6075 NEEDX([1],I); (* RESERVE A1/X1 *) COMP 6076 IF SY = LPARENT THEN COMP 6077 BEGIN INSYMBOL; VARIABLE(FSYS+[RPARENT]); COMP 6078 IF GATTR.TYPTR <> NIL THEN COMP 6079 IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(116) COMP 6080 ELSE IF NOT GATTR.TYPTR^.TEXTFILE THEN ERROR(116); COMP 6081 EXPECTSYMBOL(RPARENT,4) COMP 6082 END COMP 6083 ELSE DEFAULTFILE(GATTR,OUTPUTPTR,176); COMP 6084 IF GATTR.TYPTR <> NIL THEN LOADFILEWORD(GATTR,TRUE,EFETPTR); V41CC04 29 RJTOEXT(EX[PAGEEX]) COMP 6086 END (*PAGE*) ; COMP 6087 COMP 6088 PROCEDURE TIMEDATE(FEXT: EXTERNALNAME); COMP 6089 VAR I: REGNR; COMP 6090 BEGIN EXPECTSYMBOL(LPARENT,9); COMP 6091 VARIABLE(FSYS+[RPARENT]); COMP 6092 IF NOT COMPTYPES(GATTR.TYPTR,ALFAPTR) THEN ERROR(116); COMP 6093 LOADADDRESS(GATTR,I); BXIXJ(1,I); COMP 6094 RJTOEXT(EX[FEXT]); COMP 6095 EXPECTSYMBOL(RPARENT,4) COMP 6096 END (*TIMEDATE*) ; COMP 6097 COMP 6098 PROCEDURE HALT; COMP 6099 BEGIN (* HALT *) COMP 6100 IF SY = LPARENT THEN COMP 6101 BEGIN STRINGPARAM(FSYS+[RPARENT]); COMP 6102 EXPECTSYMBOL(RPARENT,4) COMP 6103 END COMP 6104 ELSE GEN15(SXBPB,1,0,0); COMP 6105 RJTOEXT(EX[HALTEX]) COMP 6106 END (* HALT *); COMP 6107 COMP 6108 PROCEDURE INDEXUNPACKEDARRAY(VAR SRC: ATTR; COMP 6109 INDEX: ATTR; LOW: INTEGER); COMP 6110 (*IF SRC IS CONFORMANT THEN LOW IS THE NUMBER OF THE V41AC16 13 X-REGISTER CONTAINING THE VALUE OF INDEX MINUS THE V41AC16 14 LOWER BOUND OF SRC. OTHERWISE LOW IS THE VALUE OF V41AC16 15 THE LOWER BOUND OF SRC*) V41AC16 16 VAR WORDS: ADDRRANGE; REC: CSTREC; I,J,K: REGNR; COMP 6111 CW: INTEGER; LACC: ACCESSKIND; COMP 6112 BEGIN (* INDEXUNPACKEDARRAY *) COMP 6113 IF (SRC.TYPTR <> NIL) AND (INDEX.TYPTR <> NIL) THEN COMP 6114 WITH SRC,TYPTR^ DO COMP 6115 BEGIN COMP 6116 LACC := DRCT; COMP 6117 IF AELTYPE <> NIL THEN WORDS := FULLWORDS(AELTYPE^.SIZE) COMP 6118 ELSE WORDS := 1; COMP 6119 IF CONFORMANT THEN V41AC16 17 BEGIN V41AC16 18 LOADCST(WORDS,K); XRGS[K].XCONT := OTHER; V41AC16 19 (*LOW IS X-REGISTER CONTAINING INDEX - LOWER BOUND OF SRC*) V41AC16 20 GEN15(PXBX,K,0,K); GEN15(PXBX,LOW,0,LOW); V41AC16 21 GEN15(DXXTX,K,LOW,K); LACC := INXD V41AC16 22 END V41AC16 23 ELSE V41AC16 24 IF INDEX.KIND = CST THEN V41AC16 25 BEGIN CW := CWDISPL + (INDEX.CVAL.IVAL - LOW) * WORDS; V41AC16 26 IF ABS(CW) > MAXADDR THEN V41AC16 27 BEGIN CWDISPL := 0; V41AC16 28 LOADCST(CW,K); LACC := INXD V41AC16 29 END V41AC16 30 ELSE CWDISPL := CW V41AC16 31 END V41AC16 32 ELSE V41AC16 33 BEGIN CW := CWDISPL - LOW * WORDS; V41AC16 34 LOAD(INDEX,I); V41AC16 35 IF ABS(CW) > MAXADDR THEN V41AC16 36 BEGIN V41AC16 37 IF ABS(LOW) > MAXADDR THEN V41AC16 38 BEGIN LOADCST(LOW,K); OPERATION(IXXMX,K,I,K) END V41AC16 39 ELSE V41AC16 40 BEGIN DECREFX(I); NEEDX([0..7],K); V41AC16 41 GEN30(SXXPK,K,I,-LOW,ABSR) V41AC16 42 END; V41AC16 43 I := K V41AC16 44 END V41AC16 45 ELSE CWDISPL := CW; V41AC16 46 EXPREP(WORDS,REC); V41AC16 47 IF REC.CKIND <> NOP THEN OPTMULT(I,REC,TRUE,K) V41AC16 48 ELSE V41AC16 49 BEGIN LOADCST(WORDS,J); V41AC16 50 OPERATION(DXXTX,K,I,J) V41AC16 51 END; V41AC16 52 LACC := INXD V41AC16 53 END; V41AC16 54 IF LACC <> DRCT THEN COMP 6150 IF WORDACC = DRCT THEN COMP 6151 BEGIN VWDISPL := K; WORDACC := INXD END COMP 6152 ELSE COMP 6153 BEGIN OPERATION(IXXPX,J,VWDISPL,K); VWDISPL := J END COMP 6154 END COMP 6155 END (* INDEXUNPACKEDARRAY *); COMP 6156 COMP 6157 PROCEDURE PACK; COMP 6158 VAR BITS: BITRANGE; FW,LADDR,LADDR1,LADDR2: ADDRRANGE; V41AC16 55 I,J,K,M,N,P,Q,R,S,T: REGNR; LSP,LSP1: STP; SRC,INDEX: ATTR; V41AC16 56 PW,EPW,LOW,HIGH,LMIN,LMAX: INTEGER; V41AC16 57 LEFTADJ, CONFDEST, CONFSRC: BOOLEAN; V41AC16 58 V41AC16 59 PROCEDURE PACKELEMENT; V41AC16 60 BEGIN V41AC16 61 IF LEFTADJ THEN COMP 6168 BEGIN GEN15(BXXTX,K,I,K); GEN15(BXXPX,J,J,K); COMP 6169 GEN15(LXJK,J,0,BITS) COMP 6170 END COMP 6171 ELSE COMP 6172 BEGIN GEN15(BXXTCX,K,K,I); GEN15(LXJK,J,0,BITS); COMP 6173 GEN15(BXXPX,J,J,K) COMP 6174 END V41AC16 62 END (* PACKELEMENT *); V41AC16 63 V41AC16 64 PROCEDURE PACKWORD(NROFELS: EPWRANGE); V41AC16 65 VAR LADDR: ADDRRANGE; T: REGNR; V41AC16 66 BEGIN V41AC16 67 NEEDB(T); GEN30(SBBPK,T,R,NROFELS,ABSR); V41AC16 68 GEN15(BXXMX,J,J,J); NOOP; LADDR := IC; V41AC16 69 GEN15(SABPB,K,R,0); V41AC16 70 PACKELEMENT; V41AC16 71 GEN15(SBBPB,R,R,1); GEN30(NE,R,T,LADDR,PROGR); FREEB(T); V41AC16 72 GENROTATE(J,J,WORDSIZE-NROFELS*BITS) V41AC16 73 END (*PACKWORD*) ; COMP 6180 COMP 6181 BEGIN (*PACK*) COMP 6182 EXPECTSYMBOL(LPARENT,9); COMP 6183 VARIABLE(FSYS+[COMMA,RPARENT]); SRC := GATTR; COMP 6184 LSP := NIL; LSP1 := NIL; LOW := 0; HIGH := 0; LEFTADJ := FALSE; COMP 6185 CONFDEST:= FALSE; CONFSRC := FALSE; V41AC16 74 IF GATTR.TYPTR <> NIL THEN V41AC16 75 WITH GATTR.TYPTR^ DO V41AC16 76 IF FORM = ARRAYS THEN V41AC16 77 IF NOT PCKDARR THEN V41AC16 78 BEGIN LSP1 := AELTYPE; V41AC16 79 IF LSP1 <> NIL THEN V41AC16 80 LEFTADJ := LSP1^.FORM IN [ARRAYS,RECORDS]; V41AC16 81 CONFSRC := CONFORMARRAY(GATTR.TYPTR); V41AC16 82 IF CONFSRC THEN LSP := INXTYPE^.BOUNDTYPE V41AC16 83 ELSE V41AC16 84 BEGIN LSP := INXTYPE; V41AC16 85 IF LSP <> NIL THEN GETBOUNDS(LSP,LOW,HIGH) V41AC16 86 END V41AC16 87 END V41AC16 88 ELSE ERROR(116) COMP 6196 ELSE ERROR(116); COMP 6197 EXPECTSYMBOL(COMMA,20); COMP 6198 EXPRESSION(FSYS+[COMMA,RPARENT]); INDEX := GATTR; COMP 6199 IF NOT COMPTYPES(GATTR.TYPTR,LSP) THEN ERROR(116); COMP 6200 EXPECTSYMBOL(COMMA,20); COMP 6201 VARIABLE(FSYS+[RPARENT]); COMP 6202 IF GATTR.TYPTR <> NIL THEN COMP 6203 WITH GATTR.TYPTR^ DO COMP 6204 IF FORM = ARRAYS THEN COMP 6205 BEGIN COMP 6206 IF PCKDARR AND (AELTYPE = LSP1) THEN COMP 6207 BEGIN V41AC16 89 CONFDEST := CONFORMARRAY(GATTR.TYPTR); V41AC16 90 IF NOT CONFDEST THEN V41AC16 91 BEGIN LMIN := 0; LMAX := 0; V41AC16 92 IF INXTYPE <> NIL THEN V41AC16 93 BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); V41AC16 94 IF NOT CONFSRC THEN V41AC16 95 IF LMAX - LMIN > HIGH - LOW THEN ERROR(307); V41AC16 96 END V41AC16 97 END; V41AC16 98 IF NOT CONFSRC AND NOT CONFDEST THEN V41AC16 99 WITH INDEX DO V41AC16 100 IF KIND = CST THEN V41AC16 101 BEGIN V41AC16 102 IF (CVAL.IVAL < LOW) OR (CVAL.IVAL > HIGH-(LMAX-LMIN)) V41AC16 103 THEN ERROR(302) V41AC16 104 END V41AC16 105 ELSE V41AC16 106 BEGIN V41AC16 107 IF DEBUG THEN V41AC16 108 BEGIN LOAD(INDEX,I); V41AC16 109 CHECKBNDS(I,LOW,HIGH-(LMAX-LMIN),INXERR) V41AC16 110 END V41AC16 111 END V41AC16 112 ELSE V41AC16 113 BEGIN (*IF LMAX-LMIN > HIGH-LOW THEN OUT OF BOUNDS*) V41AC16 114 IF CONFDEST THEN V41AC16 115 BEGIN LOADDESC(GATTR,N,1); LOADDESC(GATTR,M,2) END V41AC16 116 ELSE V41AC16 117 BEGIN LOADCST(LMAX,N); XRGS[N].XCONT := OTHER; V41AC16 118 LOADCST(LMIN,M) V41AC16 119 END; V41AC16 120 GEN15(IXXMX,N,N,M); DECREFX(M); V41AC16 121 IF CONFSRC THEN V41AC16 122 BEGIN LOADDESC(SRC,I,1); LOADDESC(SRC,J,2) END V41AC16 123 ELSE V41AC16 124 BEGIN LOADCST(HIGH,I); LOADCST(LOW,J); V41AC16 125 XRGS[J].XCONT := OTHER V41AC16 126 END; V41AC16 127 NEEDX([6..7],M); GEN15(IXXMX,M,I,J); DECREFX(I); V41AC16 128 GEN15(IXXMX,M,M,N); GEN30(TESTX,ORD(NG),M,INXERR,TERAR); V41AC16 129 (*CHECK IF INDEX WITHIN BOUNDS*) V41AC16 130 LOAD(INDEX,K); V41AC16 131 GEN15(IXXPX,M,M,J); GEN15(IXXMX,M,M,K); V41AC16 132 GEN15(IXXMX,J,K,J); GEN15(BXXPX,M,M,J); V41AC16 133 GEN30(TESTX,ORD(NG),M,INXERR,TERAR); DECREFX(M) V41AC16 134 (*REGISTER STATUS: XK=INDEX,XJ=INDEX-LOW,XN=LMAX-LMIN*) V41AC16 135 END; V41AC16 136 IF PARTWORDELS THEN V41AC16 137 BEGIN V41AC16 138 (*LOAD SOURCE ADDRESS (SRC[INDEX]) INTO B-R:*) V41AC16 139 NEEDB(R); V41AC16 140 IF (SRC.TYPTR <> NIL) AND (INDEX.TYPTR <> NIL) THEN V41AC16 141 IF CONFSRC THEN V41AC16 142 BEGIN DECREFX(K); V41AC16 143 LOADADDRESS(SRC,I); GEN15(IXXPX,I,J,I); V41AC16 144 GEN15(SBXPB,R,I,0); DECREFX(I); DECREFX(J); V41AC16 145 END V41AC16 146 ELSE V41AC16 147 BEGIN SRC.CWDISPL := SRC.CWDISPL - LOW; V41AC16 148 IF INDEX.KIND = CST THEN V41AC16 149 BEGIN SRC.CWDISPL := SRC.CWDISPL + INDEX.CVAL.IVAL; V41AC16 150 LOADADDRESS(SRC,I) V41AC16 151 END V41AC16 152 ELSE V41AC16 153 BEGIN LOADADDRESS(SRC,J); LOAD(INDEX,K); V41AC16 154 OPERATION(IXXPX,I,K,J) V41AC16 155 END; V41AC16 156 GEN15(SBXPB,R,I,0); DECREFX(I) V41AC16 157 END; V41AC16 158 IF AELTYPE <> NIL THEN BITS := AELTYPE^.SIZE.BITS V41AC16 159 ELSE BITS := 1; V41AC16 160 NEEDX([1..5],K); ARGS[K].ACONT := UNSPECADDR; V41AC16 161 NEEDX([6,7],J); ARGS[J].ACONT := UNSPECADDR; V41AC16 162 IF LEFTADJ THEN LOADMSK(BITS,I) V41AC16 163 ELSE LOADMSK(WORDSIZE - BITS,I); V41AC16 164 EPW := ELSPERWORD; V41AC16 165 IF CONFDEST THEN V41AC16 166 BEGIN V41AC16 167 LOADCST(BITS*EPW,M); GEN30(SXBPK,J,0,BITS,ABSR); V41AC16 168 GEN15(DXXTX,N,J,N); V41AC16 169 LOADADDRESS(GATTR,P); V41AC16 170 GEN15(IXXMX,N,N,M); V41AC16 171 GEN30(TESTX,ORD(NG),N,0,PROGR); LPL := PC; V41AC16 172 NOOP; LADDR2 := IC; V41AC16 173 PACKWORD(EPW); V41AC16 174 GEN15(SAXPB,J,P,0); V41AC16 175 GEN15(SXXPB,P,P,1); GEN15(IXXMX,N,N,M); V41AC16 176 GEN30(TESTX,ORD(PL),N,LADDR2,PROGR); V41AC16 177 NOOP; INS(IC,LPL); NEEDB(T); NEEDB(S); V41AC16 178 GEN30(SBXPK,T,N,BITS,ABSR); V41AC16 179 GEN15(SBXPB,S,M,T); V41AC16 180 GEN15(BXXMX,J,J,J); NOOP; LADDR1 := IC; V41AC16 181 GEN15(SABPB,K,R,0); V41AC16 182 GEN30(SBBPK,S,S,-BITS,ABSR); V41AC16 183 PACKELEMENT; V41AC16 184 GEN15(SBBPB,R,R,1); GEN30(LT,0,S,LADDR1,PROGR); V41AC16 185 FREEB(S); V41AC16 186 GENROTATE(J,J,WORDSIZE-EPW*BITS); V41AC16 187 GEN15(AXBX,J,T,J); FREEB(T); GEN15(SAXPB,J,P,0) V41AC16 188 END V41AC16 189 ELSE (* NOT CONFDEST *) V41AC16 190 BEGIN V41AC16 191 FW := (LMAX - LMIN + 1) DIV EPW; V41AC16 192 PW := (LMAX - LMIN + 1) - FW * EPW; V41AC16 193 IF FW > 0 THEN V41AC16 194 BEGIN V41AC16 195 IF FW <> 1 THEN V41AC16 196 BEGIN NEEDX([0..7],T); GEN15(SXBPB,T,4,0); V41AC16 197 LOADADDRESS(GATTR,S); DECREFX(S); NEEDB(Q); V41AC16 198 GEN15(SBXPB,4,S,0); GEN30(SBBPK,Q,4,FW,ABSR); V41AC16 199 NOOP; LADDR := IC V41AC16 200 END; V41AC16 201 PACKWORD(EPW); V41AC16 202 IF FW = 1 THEN STORE(GATTR,J) V41AC16 203 ELSE V41AC16 204 BEGIN GEN15(SABPB,J,4,0); DECREFX(J); V41AC16 205 GEN15(SBBPB,4,4,1); GEN30(NE,4,Q,LADDR,PROGR); V41AC16 206 GEN15(SBXPB,4,T,0); DECREFX(T) V41AC16 207 END V41AC16 208 END (*FW > 0*) ; V41AC16 209 IF PW > 0 THEN V41AC16 210 BEGIN PACKWORD(PW); V41AC16 211 IF FW > 0 THEN GEN15(SAAPB,J,J,1) V41AC16 212 ELSE STORE(GATTR,J); V41AC16 213 END V41AC16 214 END V41AC16 215 END V41AC16 216 ELSE (* NOT PARTWORDELS *) V41AC16 217 BEGIN V41AC16 218 IF CONFSRC THEN V41AC16 219 BEGIN DECREFX(K); DECREFX(N); V41AC16 220 INDEXUNPACKEDARRAY(SRC,INDEX,J) V41AC16 221 END V41AC16 222 ELSE INDEXUNPACKEDARRAY(SRC,INDEX,LOW); V41AC16 223 INDEX := GATTR; (* DESTINATION *) V41AC16 224 GATTR := SRC; (* SOURCE *) V41AC16 225 GATTR.TYPTR := INDEX.TYPTR; V41AC16 226 ASSIGNTO(INDEX) V41AC16 227 END V41AC16 228 END V41AC16 229 ELSE ERROR(116) COMP 6282 END COMP 6283 ELSE ERROR(116); COMP 6284 CLEARREGS; COMP 6285 EXPECTSYMBOL(RPARENT,4) COMP 6286 END (*PACK*) ; COMP 6287 COMP 6288 PROCEDURE UNPACK; COMP 6289 VAR BITS: BITRANGE; FW,LADDR,LADDR1: ADDRRANGE; V41AC16 230 I,J,K,M,N,P,Q,R,S,T: REGNR; LSP,LSP1: STP; SRC,DEST: ATTR; V41AC16 231 EPW,PW,LOW,HIGH,LMIN,LMAX: INTEGER; LMODE: (USRADJ,SRADJ,USLADJ); V41AC16 232 CONFSRC,CONFDEST: BOOLEAN; V41AC16 233 V41AC16 234 PROCEDURE UNPACKWORD(NROFELS: EPWRANGE); V41AC16 235 VAR LADDR: ADDRRANGE; T: REGNR; V41AC16 236 BEGIN V41AC16 237 XRGS[K].XCONT := OTHER; NEEDB(T); V41AC16 238 IF CONFSRC THEN V41AC16 239 BEGIN V41AC16 240 GEN30(SBBPK,T,0,NROFELS,ABSR); V41AC16 241 (*B-S CONTAINS NUMBER OF ELEMENTS LEFT TO UNPACK*) V41AC16 242 GEN30(GE,S,T,0,PROGR); LPL := PC; V41AC16 243 GEN15(SBBPB,T,S,0); NOOP; INS(IC,LPL); V41AC16 244 GEN15(SBBPB,T,T,R) V41AC16 245 END V41AC16 246 ELSE V41AC16 247 GEN30(SBBPK,T,R,NROFELS,ABSR); V41AC16 248 NOOP; LADDR := IC; V41AC16 249 CASE LMODE OF COMP 6299 USRADJ: COMP 6300 BEGIN GEN15(LXJK,K,0,BITS); GEN15(BXXTCX,J,K,I) END; COMP 6301 SRADJ: COMP 6302 BEGIN GEN15(BXX,J,K,K); GEN15(LXJK,K,0,BITS); COMP 6303 GEN15(AXJK,J,0,WORDSIZE-BITS) COMP 6304 END; COMP 6305 USLADJ: COMP 6306 BEGIN GEN15(BXXTX,J,I,K); GEN15(LXJK,K,0,BITS) END COMP 6307 END; COMP 6308 GEN15(SABPB,J,R,0); GEN15(SBBPB,R,R,1); COMP 6309 GEN30(NE,R,T,LADDR,PROGR); FREEB(T) V41AC16 250 END (*UNPACKWORD*); V41AC16 251 V41AC16 252 BEGIN (*UNPACK*) V41AC16 253 EXPECTSYMBOL(LPARENT,9); V41AC16 254 VARIABLE(FSYS+[COMMA,RPARENT]); SRC := GATTR; V41AC16 255 LSP := NIL; LSP1 := NIL; LMIN := 0; LMAX := 0; V41AC16 256 FW := 1; PW := 0; EPW := 60; BITS := 1; LMODE := USRADJ; V41AC16 257 CONFSRC := FALSE; CONFDEST := FALSE; V41AC16 258 IF GATTR.TYPTR <> NIL THEN V41AC16 259 WITH GATTR.TYPTR^ DO V41AC16 260 IF FORM = ARRAYS THEN V41AC16 261 IF PCKDARR THEN V41AC16 262 BEGIN V41AC16 263 CONFSRC := CONFORMARRAY(GATTR.TYPTR); V41AC16 264 IF NOT CONFSRC THEN V41AC16 265 IF INXTYPE <> NIL THEN GETBOUNDS(INXTYPE,LMIN,LMAX); V41AC16 266 LSP1 := AELTYPE; V41AC16 267 IF (LSP1 <> NIL) AND PARTWORDELS THEN V41AC16 268 WITH LSP1^ DO V41AC16 269 BEGIN BITS := SIZE.BITS; V41AC16 270 IF FORM = SUBRANGE THEN V41AC16 271 BEGIN IF MIN.IVAL < 0 THEN LMODE := SRADJ END V41AC16 272 ELSE V41AC16 273 IF FORM IN [ARRAYS,RECORDS] THEN LMODE := USLADJ V41AC16 274 END V41AC16 275 END COMP 6340 ELSE ERROR(116) COMP 6341 ELSE ERROR(116); COMP 6342 EXPECTSYMBOL(COMMA,20); COMP 6343 VARIABLE(FSYS+[COMMA,RPARENT]); DEST := GATTR; COMP 6344 IF GATTR.TYPTR <> NIL THEN COMP 6345 WITH GATTR.TYPTR^ DO COMP 6346 IF FORM = ARRAYS THEN COMP 6347 IF NOT PCKDARR AND (AELTYPE = LSP1) THEN COMP 6348 BEGIN CONFDEST := CONFORMARRAY(GATTR.TYPTR); V41AC16 276 IF CONFDEST THEN LSP := INXTYPE^.BOUNDTYPE V41AC16 277 ELSE V41AC16 278 BEGIN LOW := 0; HIGH := 0; LSP := INXTYPE; V41AC16 279 IF LSP <> NIL THEN V41AC16 280 BEGIN GETBOUNDS(LSP,LOW,HIGH); V41AC16 281 IF NOT CONFSRC THEN V41AC16 282 IF LMAX - LMIN > HIGH - LOW THEN ERROR(307) V41AC16 283 END V41AC16 284 END; V41AC16 285 END COMP 6354 ELSE ERROR(116) COMP 6355 ELSE ERROR(116); COMP 6356 EXPECTSYMBOL(COMMA,20); COMP 6357 EXPRESSION(FSYS+[RPARENT]); COMP 6358 IF NOT COMPTYPES(GATTR.TYPTR,LSP) THEN ERROR(116); COMP 6359 IF (SRC.TYPTR <> NIL) AND (DEST.TYPTR <> NIL) COMP 6360 AND (GATTR.TYPTR <> NIL) THEN COMP 6361 BEGIN COMP 6362 IF NOT CONFSRC AND NOT CONFDEST THEN V41AC16 286 BEGIN V41AC16 287 IF GATTR.KIND = CST THEN V41AC16 288 BEGIN V41AC16 289 WITH GATTR.CVAL DO V41AC16 290 IF (IVAL < LOW) OR (IVAL > HIGH - (LMAX - LMIN)) THEN V41AC16 291 ERROR(302) V41AC16 292 END V41AC16 293 ELSE V41AC16 294 IF DEBUG THEN V41AC16 295 BEGIN V41AC16 296 LOAD(GATTR,I); V41AC16 297 CHECKBNDS(I,LOW,HIGH-(LMAX-LMIN),INXERR) V41AC16 298 END V41AC16 299 END V41AC16 300 ELSE V41AC16 301 BEGIN (*IF LMAX-LMIN > HIGH-LOW THEN OUT OF BOUNDS*) V41AC16 302 IF CONFSRC THEN V41AC16 303 BEGIN LOADDESC(SRC,N,1); LOADDESC(SRC,M,2) END V41AC16 304 ELSE V41AC16 305 BEGIN LOADCST(LMAX,N); XRGS[N].XCONT := OTHER; V41AC16 306 LOADCST(LMIN,M) V41AC16 307 END; V41AC16 308 GEN15(IXXMX,N,N,M); DECREFX(M); V41AC16 309 IF CONFDEST THEN V41AC16 310 BEGIN LOADDESC(DEST,I,1); LOADDESC(DEST,J,2) END V41AC16 311 ELSE V41AC16 312 BEGIN LOADCST(HIGH,I); LOADCST(LOW,J); V41AC16 313 XRGS[J].XCONT := OTHER V41AC16 314 END; V41AC16 315 NEEDX([6..7],M); GEN15(IXXMX,M,I,J); DECREFX(I); V41AC16 316 GEN15(IXXMX,M,M,N); GEN30(TESTX,ORD(NG),M,INXERR,TERAR); V41AC16 317 (*CHECK IF INDEX WITHIN BOUNDS*) V41AC16 318 LOAD(GATTR,K); V41AC16 319 GEN15(IXXPX,M,M,J); GEN15(IXXMX,M,M,K); V41AC16 320 GEN15(IXXMX,J,K,J); GEN15(BXXPX,M,M,J); V41AC16 321 GEN30(TESTX,ORD(NG),M,INXERR,TERAR); DECREFX(M) V41AC16 322 (*REGISTER STATUS: XK=INDEX,XJ=INDEX-LOW,XN=LMAX-LMIN*) V41AC16 323 END; V41AC16 324 IF SRC.TYPTR^.PARTWORDELS THEN V41AC16 325 BEGIN V41AC16 326 (*LOAD DESTINATION ADDRESS (DEST[GATTR]) INTO B-R:*) V41AC16 327 NEEDB(R); V41AC16 328 IF CONFDEST THEN V41AC16 329 BEGIN DECREFX(K); V41AC16 330 LOADADDRESS(DEST,I); GEN15(IXXPX,I,J,I); V41AC16 331 GEN15(SBXPB,R,I,0); DECREFX(I); DECREFX(J); V41AC16 332 END V41AC16 333 ELSE V41AC16 334 BEGIN V41AC16 335 DEST.CWDISPL := DEST.CWDISPL - LOW; V41AC16 336 IF GATTR.KIND = CST THEN V41AC16 337 BEGIN DEST.CWDISPL := DEST.CWDISPL + GATTR.CVAL.IVAL; V41AC16 338 LOADADDRESS(DEST,I) V41AC16 339 END V41AC16 340 ELSE V41AC16 341 BEGIN LOADADDRESS(DEST,I); LOAD(GATTR,J); V41AC16 342 OPERATION(IXXPX,K,I,J); I := K V41AC16 343 END; V41AC16 344 GEN15(SBXPB,R,I,0); DECREFX(I) V41AC16 345 END; V41AC16 346 NEEDX([6,7],J); ARGS[J].ACONT := UNSPECADDR; V41AC16 347 IF LMODE = USRADJ THEN LOADMSK(WORDSIZE-BITS,I) V41AC16 348 ELSE V41AC16 349 IF LMODE = USLADJ THEN LOADMSK(BITS,I); V41AC16 350 EPW := SRC.TYPTR^.ELSPERWORD; V41AC16 351 IF CONFSRC THEN V41AC16 352 BEGIN V41AC16 353 NEEDX([1..5],K); V41AC16 354 LOADADDRESS(SRC,P); DECREFX(P); V41AC16 355 NEEDB(S); GEN15(SAXPB,K,P,0); V41AC16 356 GEN15(SBXPB,S,N,1); V41AC16 357 NOOP; LADDR1 := IC; V41AC16 358 UNPACKWORD(EPW); V41AC16 359 GEN30(SBBPK,S,S,-EPW,ABSR); GEN15(SAAPB,K,K,1); V41AC16 360 GEN30(LT,0,S,LADDR1,PROGR) V41AC16 361 END V41AC16 362 ELSE V41AC16 363 BEGIN V41AC16 364 FW := (LMAX - LMIN + 1) DIV EPW; V41AC16 365 PW := (LMAX - LMIN + 1) - FW * EPW; V41AC16 366 IF FW > 0 THEN V41AC16 367 BEGIN V41AC16 368 IF (FW > 1) OR (PW > 0) THEN V41AC16 369 BEGIN NEEDB(Q); LOADADDRESS(SRC,K); GEN15(SBXPB,Q,K,0); V41AC16 370 DECREFX(K) V41AC16 371 END; V41AC16 372 IF FW > 1 THEN V41AC16 373 BEGIN NEEDX([0..7],T); GEN15(SXBPB,T,4,0); V41AC16 374 GEN30(SBBPK,4,Q,FW,ABSR); V41AC16 375 NOOP; LADDR := IC V41AC16 376 END; V41AC16 377 IF (FW = 1) AND (PW = 0) THEN LOAD(SRC,K) V41AC16 378 ELSE V41AC16 379 BEGIN NEEDX([1..5],K); ARGS[K].ACONT := UNSPECADDR; V41AC16 380 GEN15(SABPB,K,Q,0) V41AC16 381 END; V41AC16 382 UNPACKWORD(EPW); V41AC16 383 IF FW > 1 THEN V41AC16 384 BEGIN GEN15(SBBPB,Q,Q,1); GEN30(NE,Q,4,LADDR,PROGR); V41AC16 385 GEN15(SBXPB,4,T,0); DECREFX(T) V41AC16 386 END V41AC16 387 END; V41AC16 388 IF PW > 0 THEN V41AC16 389 BEGIN V41AC16 390 IF FW > 0 THEN V41AC16 391 IF FW = 1 THEN GEN15(SABPB,K,Q,1) V41AC16 392 ELSE GEN15(SABPB,K,Q,0) V41AC16 393 ELSE LOAD(SRC,K); V41AC16 394 UNPACKWORD(PW) V41AC16 395 END V41AC16 396 END V41AC16 397 END V41AC16 398 ELSE (* NOT PARTWORDELS *) V41AC16 399 BEGIN V41AC16 400 IF CONFDEST THEN V41AC16 401 BEGIN DECREFX(K); V41AC16 402 INDEXUNPACKEDARRAY(DEST,GATTR,J) V41AC16 403 END V41AC16 404 ELSE INDEXUNPACKEDARRAY(DEST,GATTR,LOW); V41AC16 405 GATTR := SRC; COMP 6427 DEST.TYPTR := GATTR.TYPTR; COMP 6428 ASSIGNTO(DEST) COMP 6429 END COMP 6430 END; COMP 6431 CLEARREGS; COMP 6432 EXPECTSYMBOL(RPARENT,4) COMP 6433 END (*UNPACK*); COMP 6434 COMP 6435 PROCEDURE NEWDISPOSE(FEXT: EXTERNALNAME); COMP 6436 VAR LSP,LSP1: STP; LVAL: VALU; LSIZE: ADDRRANGE; I: REGNR; COMP 6438 LELTYPE: STP; COMP 6439 LFTYPE,LDBG: BOOLEAN; COMP 6440 LXRGS: XRGSTATUS; COMP 6441 COMP 6442 BEGIN (* NEWDISPOSE *) COMP 6443 EXPECTSYMBOL(LPARENT,9); COMP 6444 IF LKEY = DISPOSEKW THEN EXPRESSION(FSYS+[COMMA,RPARENT]) COMP 6445 ELSE (* NEW, MNEW *) COMP 6446 BEGIN NEEDX([6],I); (* PREVENT USE OF X6 *) COMP 6447 VARIABLE(FSYS+[COMMA,RPARENT]); DECREFX(6); COMP 6448 END; COMP 6449 LSP := NIL; LSIZE := 0; LELTYPE := NIL; COMP 6450 LFTYPE := FALSE; COMP 6451 LDBG := FALSE; COMP 6452 IF GATTR.TYPTR <> NIL THEN COMP 6453 WITH GATTR.TYPTR^ DO COMP 6454 IF FORM = POINTER THEN COMP 6455 BEGIN LDBG := DBG; COMP 6456 LELTYPE := ELTYPE; COMP 6457 IF LELTYPE <> NIL THEN WITH LELTYPE^ DO COMP 6458 BEGIN LSIZE := FULLWORDS(SIZE); COMP 6459 IF FORM = RECORDS THEN V41CC07 298 IF FIELDLST <> NIL THEN LSP := FIELDLST^.VARPART V41CC07 299 ELSE LSP := NIL; V41CC07 300 LFTYPE := FTYPE; COMP 6461 IF LFTYPE AND (LKEY = MNEWKW) THEN ERROR(116) COMP 6462 END COMP 6463 END COMP 6464 ELSE ERROR(116); COMP 6465 WHILE SY = COMMA DO COMP 6466 BEGIN INSYMBOL; CONSTANT(FSYS+[COMMA,RPARENT],LSP1,LVAL); COMP 6467 IF LSP <> NIL THEN V41CC07 301 WITH LSP^ DO V41CC07 302 BEGIN V41CC07 303 IF (TAGTYPE <> NIL) AND (LSP1 <> NIL) THEN V41CC07 304 IF LSP1^.FORM <= SUBRANGE THEN V41CC07 305 IF COMPTYPES(TAGTYPE,LSP1) THEN V41CC07 306 BEGIN V41CC07 307 LSP1 := FINDVARIANT(LSP,LVAL); V41CC07 308 IF LSP1 <> NIL THEN V41CC07 309 WITH LSP1^ DO V41CC07 310 BEGIN LSP := VARPART; V41CC07 311 LSIZE := FULLWORDS(SIZE) V41CC07 312 END V41CC07 313 ELSE V41CC07 314 BEGIN ERROR(158); V41CC07 315 LSIZE := FULLWORDS(SIZE); LSP := NIL V41CC07 316 END V41CC07 317 END V41CC07 318 ELSE ERROR(116) V41CC07 319 ELSE ERROR(159) V41CC07 320 END V41CC07 321 ELSE ERROR(158) V41CC07 322 END (*WHILE*); V41CC07 323 IF LDBG THEN FEXT := SUCC(FEXT); COMP 6488 IF LKEY = DISPOSEKW THEN COMP 6489 BEGIN COMP 6490 LOAD(GATTR,I); COMP 6491 IF LFTYPE THEN (* DECOMMISSION FILE VARIABLES *) COMP 6492 BEGIN COMP 6493 IF LDBG THEN CHECKPTRREF(I); COMP 6494 GEN15(SBXPB,2,I,0); DECREFX(I); COMP 6495 DECOMMISSIONFILES(LELTYPE,FALSE,0); COMP 6496 LC := LC - 1; COMP 6497 GEN15(SXBMB,1,2,ORD(LDBG)); COMP 6498 IF LDBG THEN FEXT := PRED(FEXT) COMP 6499 END COMP 6500 ELSE BXIXJ(1,I); COMP 6501 RJTOEXT(EX[FEXT]) COMP 6502 END COMP 6503 ELSE (* NEW, MNEW *) COMP 6504 BEGIN SAVEREFXRGS(LXRGS); COMP 6505 IF LSIZE >= MAXADDR THEN ERROR(262); COMP 6506 GENINC(SXBPK,1,0,LSIZE+ORD(LDBG)); COMP 6507 RJTOEXT(EX[FEXT]); COMP 6508 IF DEBUG THEN COMP 6509 BEGIN (* INITIALIZE WITH GARBAGE *) COMP 6510 GENINC(SBBPK,7,0,LSIZE); COMP 6511 RJTOEXT(EX[INVEX]) COMP 6512 END; COMP 6513 RELOADREFXRGS(LXRGS); COMP 6514 STORE(GATTR,6); COMP 6515 IF LFTYPE THEN (* COMMISSION FILE VARIABLES *) COMP 6516 COMMISSIONFILES(LELTYPE,FALSE,0,NIL) COMP 6517 END; COMP 6518 EXPECTSYMBOL(RPARENT,4) COMP 6519 END (*NEWDISPOSE*) ; COMP 6520 COMP 6521 PROCEDURE MARKRELEASE(FEXT: EXTERNALNAME); COMP 6522 VAR I: REGNR; LSYS: SETOFSYS; COMP 6523 BEGIN (* MARKRELEASE *) COMP 6524 EXPECTSYMBOL(LPARENT,9); COMP 6525 LSYS := FSYS + [RPARENT]; COMP 6526 IF LKEY = MARKKW THEN VARIABLE(LSYS) COMP 6527 ELSE EXPRESSION(LSYS); COMP 6528 IF GATTR.TYPTR <> NIL THEN COMP 6529 BEGIN COMP 6530 IF GATTR.TYPTR <> MARKERPTR THEN ERROR(116); COMP 6531 IF LKEY = MARKKW THEN COMP 6532 BEGIN COMP 6533 IF GATTR.DCLPCKD THEN ERROR(142); COMP 6534 LOADADDRESS(GATTR,I) COMP 6535 END COMP 6536 ELSE LOAD(GATTR,I); COMP 6537 BXIXJ(1,I) COMP 6538 END; COMP 6539 RJTOEXT(EX[FEXT]); COMP 6540 EXPECTSYMBOL(RPARENT,4) COMP 6541 END (* MARKRELEASE *); COMP 6542 COMP 6543 PROCEDURE FILEFUNCS; COMP 6544 VAR LATTR: ATTR; LBIT: BITRANGE; V41AC08 49 BEGIN COMP 6546 IF SY = LPARENT THEN COMP 6547 BEGIN INSYMBOL; VARIABLE(FSYS+[RPARENT]); COMP 6548 EXPECTSYMBOL(RPARENT,4) COMP 6549 END COMP 6550 ELSE DEFAULTFILE(GATTR,INPUTPTR,175); COMP 6551 IF GATTR.TYPTR <> NIL THEN COMP 6552 WITH GATTR, TYPTR^ DO COMP 6553 IF FORM = FILES THEN COMP 6554 BEGIN COMP 6555 IF LKEY = EOLNKW THEN COMP 6556 BEGIN IF NOT TEXTFILE THEN ERROR(125); COMP 6557 CWDISPL := CWDISPL + TXTEFET + EFETPTR; V41CC04 30 IF DEBUG THEN COMP 6559 BEGIN LATTR := GATTR; COMP 6560 IF WORDACC <> DRCT THEN COMP 6561 XRGS[VWDISPL].REFNR := XRGS[VWDISPL].REFNR + 1; COMP 6562 LATTR.CWDISPL := CWDISPL - EFETPTR; V41CC04 31 LOAD(LATTR,I); COMP 6564 ROTATEX(I,I,59-EEOSF); V41AC08 50 GEN30(TESTX,ORD(NG),I,EOLERR,TERAR); DECREFX(I) COMP 6565 END COMP 6566 END COMP 6567 ELSE COMP 6568 CWDISPL := CWDISPL + EFETOFFSET[TEXTFILE]; V41CC04 32 LOAD(GATTR,I); LBIT := EEOSF; V41AC08 51 IF LKEY = EOSKW THEN COMP 6572 BEGIN IF NOT SEGFILE THEN ERROR(125) END COMP 6573 ELSE COMP 6574 IF (LKEY = EOFKW) AND SEGFILE THEN LBIT := EEOF; V41AC08 52 ROTATEX(I,I,59-LBIT); V41AC08 53 TYPTR := BOOLPTR; KIND := COND; CONDCD := PL; CDR := I; COMP 6580 END COMP 6581 ELSE ERROR(125); COMP 6582 END (* FILEFUNCS *); COMP 6583 COMP 6584 PROCEDURE INLINEFUNCS; COMP 6585 VAR I,J,K,L: REGNR; COMP 6586 LSYS: SETOFSYS; COMP 6587 GINT,GREAL: BOOLEAN; COMP 6588 LMIN,LMAX: INTEGER; V41CC21 12 LATTR: ATTR; V41CC21 13 BEGIN EXPECTSYMBOL(LPARENT,9); COMP 6589 LSYS:=[RPARENT]; COMP 6590 IF LKEY IN [TRUNCKW,RELVALUEKW] THEN (* MAY HAVE 2 ARGS *) V410C01 9 LSYS := [COMMA,RPARENT]; V41CC21 15 EXPRESSION(FSYS+LSYS); LOAD(GATTR,I); COMP 6593 IF LKEY IN [ODDKW,TRUNCKW..SQRKW,UNDEFINEDKW..CARDKW] THEN COMP 6594 NEEDX([0..7],K); (*FUNCTION NEEDING ANOTHER X REGISTER*) COMP 6595 GINT := COMPTYPES(GATTR.TYPTR,INTPTR); COMP 6596 IF (LKEY IN [ODDKW,CHRKW]) AND NOT GINT THEN ERROR(125); COMP 6597 GREAL := GATTR.TYPTR = REALPTR; COMP 6598 IF (LKEY IN [ROUNDKW,TRUNCKW,UNDEFINEDKW,EXPOKW]) AND NOT GREAL COMP 6599 THEN ERROR(125); COMP 6600 CASE LKEY OF COMP 6601 ODDKW: COMP 6602 BEGIN GEN15(BXX,K,I,I); COMP 6603 GEN15(LXJK,K,0,59(*WORDSIZE-1*)); COMP 6604 GEN15(BXXMX,K,I,K); DECREFX(I); COMP 6605 WITH GATTR DO COMP 6606 BEGIN TYPTR := BOOLPTR; KIND := COND; CONDCD := PL; COMP 6607 CDR := K COMP 6608 END COMP 6609 END; COMP 6610 UNDEFINEDKW: COMP 6611 BEGIN GEN15(SXBPB,K,1,0); COMP 6612 GEN30(TESTX,ORD(XID),I,IC+1+ORD(PC.CP >= 3),PROGR); COMP 6613 GEN30(TESTX,ORD(XOR),I,IC+1,PROGR); COMP 6614 GEN30(SXBPK,K,0,0,ABSR); NOOP; COMP 6615 GATTR.TYPTR := BOOLPTR; COMP 6616 END; COMP 6617 ROUNDKW: COMP 6618 BEGIN LOADCST(0,J); DECREFX(J); COMP 6619 NEEDX([0..7],K); NEEDX([0..7],L); COMP 6620 GEN15(PXBX,K,0,J); GEN15(FXXPX,L,I,K); GEN15(DXXPX,K,I,K); COMP 6621 GEN15(RXXPX,K,L,K); DECREFX(L); GEN15(UXBX,K,0,K); COMP 6622 LOADCST(0,J); GEN15(IXXPX,K,K,J); DECREFX(J) COMP 6623 END; COMP 6624 TRUNCKW: COMP 6625 BEGIN COMP 6626 NEEDB(J); DECREFX(I); GEN15(UXBX,K,J,I); COMP 6627 IF (SY = COMMA) AND (OPTS.DIALECT = P6000) THEN V41DC05 479 BEGIN EXTENSION(326); INSYMBOL; EXPRESSION(FSYS+[RPARENT]); COMP 6629 IF GATTR.TYPTR <> NIL THEN COMP 6630 IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN COMP 6631 IF GATTR.KIND = CST THEN COMP 6632 BEGIN GEN30(SBBPK,J,J,GATTR.CVAL.IVAL,ABSR); COMP 6633 GATTR.KIND:=EXPR COMP 6634 END COMP 6635 ELSE BEGIN LOAD(GATTR,I); GEN15(SBXPB,J,I,J); DECREFX(I) COMP 6636 END COMP 6637 ELSE ERROR(125) COMP 6638 END; COMP 6639 GEN15(LXBX,K,J,K); FREEB(J); COMP 6640 LOADCST(0,I); GEN15(IXXPX,K,K,I) COMP 6641 END; COMP 6642 EXPOKW: COMP 6643 BEGIN NEEDB(J); COMP 6644 GEN15(UXBX,K,J,I); GEN30(SXBPK,K,J,47,ABSR); COMP 6645 FREEB(J) COMP 6646 END; COMP 6647 ABSKW: COMP 6648 BEGIN IF (GINT OR GREAL) THEN COMP 6649 BEGIN GEN15(BXX,K,I,I); GEN15(AXJK,K,0,59(*WORDSIZE-1*)); COMP 6650 GEN15(BXXMX,K,K,I) COMP 6651 END COMP 6652 ELSE ERROR(125) COMP 6653 END; COMP 6654 SQRKW: COMP 6655 BEGIN IF GINT THEN COMP 6656 GEN15(DXXTX,K,I,I) COMP 6657 ELSE COMP 6658 IF GREAL THEN COMP 6659 GEN15(RXXTX,K,I,I) COMP 6660 ELSE ERROR(125) COMP 6661 END; COMP 6662 ORDKW: COMP 6663 BEGIN IF GATTR.TYPTR <> NIL THEN COMP 6664 IF GATTR.TYPTR^.FORM > POINTER THEN ERROR(125) COMP 6665 ELSE COMP 6666 IF GATTR.TYPTR^.FORM > SUBRANGE THEN V41AC20 45 IF OPTS.DIALECT = P6000 THEN EXTENSION(327) V41DC05 480 ELSE ERROR(125) V41DC05 481 END; COMP 6668 CHRKW: COMP 6669 GATTR.TYPTR := CHARPTR; COMP 6670 PREDKW, COMP 6671 SUCCKW: COMP 6672 BEGIN IF GATTR.TYPTR <> NIL THEN COMP 6673 IF GATTR.TYPTR^.FORM > SUBRANGE THEN ERROR(125); COMP 6674 LOADCST(2*ORD(LKEY=SUCCKW)-1,J); COMP 6675 DECREFX(J); NEEDX([0..7],K); COMP 6676 GEN15(IXXPX,K,I,J) COMP 6677 END; COMP 6678 RELVALUEKW: V410C01 10 BEGIN V41CC21 17 IF GATTR.TYPTR <> NIL THEN V41CC21 18 IF GATTR.TYPTR^.FORM > SUBRANGE THEN V41CC21 19 BEGIN ERROR(125); GATTR.TYPTR := NIL END V41CC21 20 ELSE V41CC21 21 IF GATTR.TYPTR^.FORM = SUBRANGE THEN V41CC21 22 GATTR.TYPTR := GATTR.TYPTR^.RANGETYPE; V41CC21 23 LATTR := GATTR; V41CC21 24 IF SY = COMMA THEN V41CC21 25 BEGIN V41CC21 26 INSYMBOL; EXPRESSION(FSYS+[RPARENT]); V41CC21 27 IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN ERROR(125) V41CC21 28 END V41CC21 29 ELSE ERROR(20); V41CC21 30 LOAD(GATTR,J); OPERATION(IXXPX,K,I,J); V41CC21 31 GATTR := LATTR; GATTR.EXPREG := K; V41CC21 32 END; V41CC21 33 CARDKW: COMP 6679 BEGIN IF GATTR.TYPTR <> NIL THEN COMP 6680 IF GATTR.TYPTR^.FORM <> POWER THEN ERROR(125); COMP 6681 GEN15(CXX,K,I,I) COMP 6682 END COMP 6683 END (*CASE*); COMP 6684 IF LKEY IN [ROUNDKW,TRUNCKW,ABSKW,SQRKW,PREDKW,SUCCKW, COMP 6685 UNDEFINEDKW,EXPOKW,CARDKW] THEN COMP 6686 (* FUNCTIONS RETURNING RESULT IN K REGNR *) COMP 6687 BEGIN DECREFX(I); GATTR.EXPREG := K END; COMP 6688 IF LKEY IN [ROUNDKW,TRUNCKW,ORDKW,EXPOKW,CARDKW] THEN COMP 6689 (* FUNCTIONS FORCING INTEGER RESULT *) COMP 6690 GATTR.TYPTR := INTPTR; COMP 6691 IF DEBUG AND (GATTR.TYPTR <> NIL) THEN V41CC21 34 IF LKEY IN [CHRKW,PREDKW,SUCCKW,RELVALUEKW] THEN V410C01 11 IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN V41CC21 36 BEGIN GETBOUNDS(GATTR.TYPTR,LMIN,LMAX); V41CC21 37 CHECKBNDS(GATTR.EXPREG,LMIN,LMAX,ASSERR) V41CC21 38 END; V41CC21 39 EXPECTSYMBOL(RPARENT,4) COMP 6692 END (* INLINEFUNCS *); COMP 6693 COMP 6694 PROCEDURE SETFUNCTIONRESULT(VAR LXRGS: XRGSTATUS; TYP: STP); COMP 6695 VAR I: REGNR; COMP 6696 BEGIN (* SETFUNCTIONRESULT *) COMP 6697 XRGS := LXRGS; COMP 6698 IF XRGS[6].XCONT <> AVAIL THEN COMP 6699 BEGIN NEEDX([0..7],I); V41EC02 8 IF I = 5 THEN (* X5 MAY BE USED TO RESTORE X6 *) V41EC02 9 BEGIN NEEDX([0..7],I); DECREFX(5) END; V41EC02 10 GEN15(BXX,I,6,6) V41EC02 11 END V41EC02 12 ELSE I := 6; COMP 6701 CLEARREGS; COMP 6702 WITH XRGS[I] DO COMP 6703 BEGIN XCONT := OTHER; REFNR := 1 END; COMP 6704 RELOADREFXRGS(LXRGS); COMP 6705 WITH GATTR DO COMP 6706 BEGIN KIND := EXPR; EXPREG := I; TYPTR := TYP END COMP 6707 END (* SETFUNCTIONRESULT *); COMP 6708 V41AC15 18 PROCEDURE EOIFUNC; V41AC15 19 VAR LXRGS: XRGSTATUS; I: REGNR; V41AC15 20 BEGIN V41AC15 21 SAVEREFXRGS(LXRGS); NEEDX([1],I); (* RESERVE X1 *) V41AC15 22 IF SY = LPARENT THEN V41AC15 23 BEGIN INSYMBOL; VARIABLE(FSYS+[RPARENT]); V41AC15 24 EXPECTSYMBOL(RPARENT,4) V41AC15 25 END V41AC15 26 ELSE DEFAULTFILE(GATTR,INPUTPTR,175); V41AC15 27 IF GATTR.TYPTR <> NIL THEN V41AC15 28 WITH GATTR, TYPTR^ DO V41AC15 29 IF FORM = FILES THEN V41AC15 30 LOADFILEWORD(GATTR,TRUE,EFET) (* SA1 EFET *) V41AC15 31 ELSE ERROR(125); V41AC15 32 RJTOEXT(EX[EOIEX]); V41AC15 33 SETFUNCTIONRESULT(LXRGS,BOOLPTR) V41AC15 34 END (* EOIFUNC *) ; V41AC15 35 COMP 6709 PROCEDURE CLOCKF; COMP 6710 VAR LXRGS: XRGSTATUS; COMP 6711 BEGIN SAVEREFXRGS(LXRGS); RJTOEXT(EX[CLOCKEX]); COMP 6712 SETFUNCTIONRESULT(LXRGS,INTPTR) COMP 6713 END (*CLOCKF*) ; COMP 6714 COMP 6715 PROCEDURE ARITHFUNCS(FEXT: EXTERNALNAME); COMP 6716 VAR LXRGS: XRGSTATUS; I,K: REGNR; COMP 6717 BEGIN EXPECTSYMBOL(LPARENT,9); COMP 6718 SAVEREFXRGS(LXRGS); CLEARREGS; COMP 6719 EXPRESSION(FSYS+[RPARENT]); COMP 6720 LOAD(GATTR,I); COMP 6721 IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN COMP 6722 BEGIN PACKANDNORM(I); GATTR.TYPTR := REALPTR END; COMP 6723 BXIXJ(1,I); COMP 6724 IF GATTR.TYPTR <> REALPTR THEN ERROR(125); COMP 6725 IF LKEY IN [SINKW,COSKW] THEN GEN15(SBBPB,3,ORD(LKEY=COSKW),0); COMP 6726 RJTOEXT(EX[FEXT]); COMP 6727 SETFUNCTIONRESULT(LXRGS,REALPTR); COMP 6728 EXPECTSYMBOL(RPARENT,4) COMP 6729 END (* ARITHFUNCS *); COMP 6730 COMP 6731 PROCEDURE CALLUSERDECLARED; COMP 6732 VAR NXT,LCP: CTP; LSP,LSP1: STP; LKIND: IDKIND; COMP 6733 L,M: LEVRANGE; I,K: REGNR; PARAM: ATTR; COMP 6734 LXPAR: 0..MAXPARAMSINREGS; COMP 6735 PVDISP,LDSP,LPSMARK: ADDRRANGE; LXRGS: XRGSTATUS; COMP 6736 LMIN,LMAX: INTEGER; FTN: BOOLEAN; COMP 6737 PASS: (VAL,VARADDR,ARRDESC,PROCDESC); COMP 6738 LLC: INTEGER; COMP 6739 COMP 6740 FUNCTION CONFORMABLE(FSP1,FSP2: STP; FDISPL: SHRTINT): BOOLEAN; COMP 6741 (* DECIDE WHETHER THE STRUCTURE DEFINED BY THE ACTUAL ARRAY COMP 6742 PARAMETER FSP2 IS CONFORMABLE TO THE FORMAL CONFORMANT COMP 6743 ARRAY PARAMETER FSP1. RUNTIME TESTS MAY BE REQUIRED. *) COMP 6744 VAR CONF: BOOLEAN; LSP1,LSP2: STP; I,J,K: REGNR; COMP 6745 LMIN1,LMIN2,LMAX1,LMAX2: INTEGER; COMP 6746 BEGIN (* CONFORMABLE *) COMP 6747 CONF := TRUE; COMP 6748 IF FSP1 <> FSP2 THEN COMP 6749 IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN COMP 6750 BEGIN CONF := FALSE; COMP 6751 IF (FSP1^.FORM = ARRAYS) AND (FSP2^.FORM = ARRAYS) THEN COMP 6752 IF FSP1^.CONFORMANT THEN COMP 6753 IF CONFORMABLE(FSP1^.AELTYPE,FSP2^.AELTYPE,FDISPL+3) AND COMP 6754 (FSP1^.PCKDARR = FSP2^.PCKDARR) THEN COMP 6755 BEGIN CONF := TRUE; COMP 6756 LSP1 := FSP1^.INXTYPE; LSP2 := FSP2^.INXTYPE; COMP 6757 IF (LSP1 <> NIL) AND (LSP2 <> NIL) THEN COMP 6758 IF LSP1^.BOUNDTYPE <> NIL THEN COMP 6759 BEGIN GETBOUNDS(LSP1^.BOUNDTYPE,LMIN1,LMAX1); COMP 6760 IF FSP2^.CONFORMANT THEN COMP 6761 BEGIN COMP 6762 CONF := COMPTYPES(LSP1^.BOUNDTYPE,LSP2^.BOUNDTYPE); COMP 6763 IF LSP2^.BOUNDTYPE <> NIL THEN COMP 6764 BEGIN GETBOUNDS(LSP2^.BOUNDTYPE,LMIN2,LMAX2); COMP 6765 IF (LMIN2 > LMAX1) OR (LMAX2 < LMIN1) THEN COMP 6766 CONF := FALSE (* DISJOINT RANGES *) COMP 6767 ELSE COMP 6768 IF ((LMAX2 > LMAX1) OR (LMIN2 < LMIN1)) AND COMP 6769 DEBUG THEN COMP 6770 BEGIN COMP 6771 IF LMAX2 > LMAX1 THEN COMP 6772 BEGIN LOADDESC(GATTR,K,FDISPL+1); COMP 6773 LOADCST(LMAX1,I); COMP 6774 OPERATION(IXXMX,K,I,K) COMP 6775 END; COMP 6776 IF LMIN2 < LMIN1 THEN COMP 6777 BEGIN LOADDESC(GATTR,J,FDISPL+2); COMP 6778 LOADCST(LMIN1,I); COMP 6779 OPERATION(IXXMX,J,J,I); COMP 6780 IF LMAX2 > LMAX1 THEN GEN15(BXXPX,K,K,J) COMP 6781 ELSE K := J COMP 6782 END; COMP 6783 DECREFX(K); COMP 6784 GEN30(TESTX,ORD(NG),K,INXERR,TERAR) COMP 6785 END COMP 6786 END COMP 6787 END COMP 6788 ELSE COMP 6789 IF LSP2 <> NIL THEN COMP 6790 BEGIN GETBOUNDS(LSP2,LMIN2,LMAX2); COMP 6791 CONF := COMPTYPES(LSP1^.BOUNDTYPE,LSP2) AND COMP 6792 (LMIN2 >= LMIN1) AND (LMAX2 <= LMAX1) COMP 6793 END COMP 6794 END COMP 6795 END COMP 6796 END; COMP 6797 CONFORMABLE := CONF COMP 6798 END (* CONFORMABLE *); COMP 6799 COMP 6800 FUNCTION COMPPARAMS(FSP1,FSP2: STP; VARPARAM: BOOLEAN): BOOLEAN; COMP 6801 (* DECIDE WHETHER THE STRUCTURES DEFINED BY FSP1 AND FSP2 ARE COMP 6802 PARAMETER COMPATIBLE. FSP1 DESCRIBES THE TYPE OF THE FORMAL COMP 6803 PARAMETER, FSP2 DESCRIBES THE TYPE OF THE ACTUAL PARAMETER. COMP 6804 VARPARAM=TRUE IF THE FORMAL PARAMETER IS A VAR PARAMETER. *) COMP 6805 BEGIN (* COMPPARAMS *) COMP 6806 IF FSP1 = FSP2 THEN COMPPARAMS := TRUE COMP 6807 ELSE COMP 6808 IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN COMP 6809 IF (FSP1^.FORM = FILES) AND (FSP2^.FORM = FILES) THEN COMP 6810 COMPPARAMS := FSP1^.BASEFILE = FSP2^.BASEFILE COMP 6811 ELSE COMP 6812 IF VARPARAM THEN COMPPARAMS := FALSE COMP 6813 ELSE COMPPARAMS := COMPTYPES(FSP1,FSP2) COMP 6814 ELSE COMPPARAMS := TRUE COMP 6815 END (* COMPPARAMS *); COMP 6816 COMP 6817 FUNCTION COMPPROCS(FCP1,FCP2: CTP) : BOOLEAN; COMP 6818 (* DECIDE WHETHER PROCS/FUNCS IDENTIFIED BY FCP1 AND FCP2 ARE COMP 6819 COMPATIBLE. THE PARAMETER LISTS MUST BE CONGRUOUS, AND FOR COMP 6820 FUNCTIONS, THE RESULT TYPES MUST BE IDENTICAL. *) COMP 6821 VAR LCP1,LCP2: CTP; COMP: BOOLEAN; COMP 6822 COMP 6823 FUNCTION EQUIVALENT(FSP1,FSP2: STP): BOOLEAN; COMP 6824 (* DECIDE WHETHER THE CONFORMANT-ARRAY-SCHEMAS (OR SUBTYPES) COMP 6825 DEFINED BY FSP1 AND FSP2 ARE EQUIVALENT. *) COMP 6826 VAR COMP: BOOLEAN; COMP 6827 BEGIN (* EQUIVALENT *) COMP 6828 COMP := TRUE; COMP 6829 IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN COMP 6830 IF FSP1 <> FSP2 THEN COMP 6831 BEGIN COMP := FALSE; COMP 6832 IF (FSP1^.FORM = ARRAYS) AND (FSP2^.FORM = ARRAYS) THEN COMP 6833 IF FSP1^.CONFORMANT AND FSP2^.CONFORMANT THEN COMP 6834 IF EQUIVALENT(FSP1^.AELTYPE,FSP2^.AELTYPE) AND COMP 6835 (FSP1^.PCKDARR = FSP2^.PCKDARR) THEN COMP 6836 IF (FSP1^.INXTYPE <> NIL) AND (FSP2^.INXTYPE <> NIL) THEN COMP 6837 COMP := EQUIVALENT(FSP1^.INXTYPE^.BOUNDTYPE, COMP 6838 FSP2^.INXTYPE^.BOUNDTYPE) COMP 6839 ELSE COMP := TRUE COMP 6840 END; COMP 6841 EQUIVALENT := COMP COMP 6842 END (* EQUIVALENT *); COMP 6843 COMP 6844 BEGIN (* COMPPROCS *) COMP 6845 IF (FCP1 <> NIL) AND (FCP2 <> NIL) THEN COMP 6846 BEGIN LCP1 := FCP1^.PARAMLIST; LCP2 := FCP2^.PARAMLIST; COMP 6847 COMP := FCP1^.IDTYPE = FCP2^.IDTYPE; COMP 6848 WHILE COMP AND (LCP1 <> NIL) AND (LCP2 <> NIL) DO COMP 6849 BEGIN COMP 6850 IF LCP1^.KLASS = LCP2^.KLASS THEN COMP 6851 IF LCP1^.KLASS IN [PROC,FUNC] THEN COMP 6852 COMP := COMPPROCS(LCP1,LCP2) COMP 6853 ELSE COMP 6854 COMP := EQUIVALENT(LCP1^.IDTYPE,LCP2^.IDTYPE) AND COMP 6855 (LCP1^.VARPARAM = LCP2^.VARPARAM) AND COMP 6856 (LCP1^.FIRSTINPARMGROUP = LCP2^.FIRSTINPARMGROUP) COMP 6857 ELSE COMP := FALSE; COMP 6858 LCP1 := LCP1^.NEXT; LCP2 := LCP2^.NEXT COMP 6859 END; COMP 6860 COMPPROCS := COMP AND (LCP1 = LCP2) COMP 6861 END COMP 6862 ELSE COMPPROCS := TRUE COMP 6863 END (* COMPPROCS *); COMP 6864 COMP 6865 PROCEDURE CNFPARAM(VAR FATTR: ATTR; VAR FI: REGNR); COMP 6866 (* LOAD PARAMETER OF CONFORMANT ARRAY INTO X.FI, BUILDING THE COMP 6867 DESCRIPTOR IF NECESSARY. ASSUMES FATTR.KIND = VARBL. *) COMP 6868 VAR I,J: REGNR; LCSP: CTAILP; LATTR: ATTR; COMP 6869 COMP 6870 PROCEDURE NODOUBLEREFX(VAR FJ: REGNR; FI: REGNR); COMP 6871 BEGIN COMP 6872 IF XRGS[FI].REFNR = 1 THEN FJ := FI COMP 6873 ELSE COMP 6874 BEGIN NEEDX([0..7],FJ); GEN15(BXX,FJ,FI,FI); DECREFX(FI) END; COMP 6875 XRGS[FJ].XCONT := OTHER COMP 6876 END (* NODOUBLEREFX *); COMP 6877 COMP 6878 PROCEDURE BUILDCSTDESC(FSP: STP; VAR FP:CTAILP); COMP 6879 (* BUILD A CONSTANT DESCRIPTOR. *) COMP 6880 VAR MIN,MAX: INTEGER; P1,P2:CTAILP; COMP 6881 BEGIN FP := NIL; COMP 6882 IF FSP <> NIL THEN COMP 6883 IF FSP^.FORM = ARRAYS THEN COMP 6884 BEGIN BUILDCSTDESC(FSP^.AELTYPE,P2); COMP 6885 GETBOUNDS(FSP^.INXTYPE,MIN,MAX); COMP 6886 MNEW(P1); WITH P1^ DO BEGIN NXTCSP := P2; CSVAL := MIN END; COMP 6887 MNEW(P2); WITH P2^ DO BEGIN NXTCSP := P1; CSVAL := MAX END; COMP 6888 MNEW(FP); WITH FP^ DO COMP 6889 BEGIN NXTCSP := P2; CSVAL := FULLWORDS(FSP^.SIZE) END COMP 6890 END COMP 6891 END (* BUILDCSTDESC *); COMP 6892 COMP 6893 BEGIN (* CNFPARAM *) COMP 6894 WITH FATTR DO COMP 6895 IF TYPTR <> NIL THEN COMP 6896 BEGIN COMP 6897 IF KIND = VARBL THEN COMP 6898 IF PCKD THEN COMP 6899 BEGIN COMP 6900 LOAD(FATTR,I); COMP 6901 MAKETEMP(LATTR,FATTR.TYPTR,1); COMP 6902 STORE(LATTR,I); COMP 6903 LOADADDRESS(LATTR,I) COMP 6904 END COMP 6905 ELSE LOADADDRESS(FATTR,I) COMP 6906 ELSE LOADADDRESS(FATTR,I); COMP 6907 IF NXT^.FIRSTINPARMGROUP THEN COMP 6908 BEGIN COMP 6909 IF TYPTR^.CONFORMANT THEN COMP 6910 BEGIN (* ACCESS TO PARAMETER WORD ACCORDING TO DRCT *) COMP 6911 MAKEVARBLATTR(LATTR,INTPTR,VLEVEL,TYPTR^.DESCADDR); COMP 6912 LOADADDRESS(LATTR,J); NODOUBLEREFX(J,J) COMP 6913 END COMP 6914 ELSE COMP 6915 BEGIN BUILDCSTDESC(TYPTR,LCSP); COMP 6916 NEEDX([0..7],J); GEN30(SXBPK,J,0,0,PROGR); COMP 6917 ENTERCST(LCSP); COMP 6918 END; COMP 6919 (* PACK DESCRIPTOR ADDRESS AND ARRAY ADDRESS INTO X.J *) COMP 6920 GEN15(LXJK,J,0,18); GEN15(BXXPX,J,J,I); DECREFX(I) COMP 6921 END COMP 6922 ELSE J := I COMP 6923 END COMP 6924 ELSE NEEDX([0..7],J); COMP 6925 FI := J COMP 6926 END (* CNFPARAM *); COMP 6927 COMP 6928 PROCEDURE LOADPFDESCRIPTOR(FCP: CTP; VAR FI: REGNR); COMP 6929 VAR LATTR: ATTR; COMP 6930 BEGIN COMP 6931 MAKEVARBLATTR(LATTR,INTPTR,FCP^.PFLEV,FCP^.PFADDR); COMP 6932 LOAD(LATTR,FI) COMP 6933 END (* LOADPFDESCRIPTOR *) ; COMP 6934 COMP 6935 BEGIN (* CALLUSERDECLARED *) COMP 6936 LPSMARK := PSMARK; COMP 6937 WITH FCP^ DO COMP 6938 BEGIN NXT := PARAMLIST; LKIND := PFKIND; COMP 6939 IF KLASS = FUNC THEN COMP 6940 BEGIN SAVEREFXRGS(LXRGS); COMP 6941 IF PSSTORE <> PSMARK THEN COMP 6942 BEGIN COMP 6943 FOR I := 0 TO 7 DO COMP 6944 BEGIN COMP 6945 WITH ARGS[I] DO COMP 6946 IF ACONT = SIMPADDR THEN COMP 6947 IF ALEV = 0 THEN ACONT := UNSPECADDR; COMP 6948 WITH XRGS[I] DO COMP 6949 IF XCONT = SIMPVAR THEN COMP 6950 IF XLEV = 0 THEN XCONT := AVAIL COMP 6951 END; COMP 6952 GEN30(SBBPK,6,6,(PSSTORE-PSMARK),ABSR); COMP 6953 PSMARK := PSSTORE COMP 6954 END; COMP 6955 END (* IF *) ; COMP 6956 LLC := LC; FTN := FALSE; LDSP := 0; COMP 6957 IF LKIND = ACTUAL THEN COMP 6958 BEGIN FTN := PFDECL = FTNDECL; COMP 6959 IF FTN THEN (* ALLOCATE THE PARAMETER VECTOR *) COMP 6960 BEGIN LCP := NXT; PVDISP := LC; LDSP := PVDISP; COMP 6961 WHILE LCP <> NIL DO COMP 6962 BEGIN LCP := LCP^.NEXT; LC := LC + 1 END; COMP 6963 LC := LC + 1; (* SENTINEL *) COMP 6964 IF LC > LCMAX THEN LCMAX := LC COMP 6965 END COMP 6966 END; COMP 6967 END; COMP 6968 LXPAR := 0; COMP 6969 IF SY = LPARENT THEN COMP 6970 BEGIN COMP 6971 REPEAT PASS := VAL; COMP 6972 IF NXT = NIL THEN COMP 6973 BEGIN COMP 6974 IF (FCP <> UPRCPTR) AND (FCP <> UFCTPTR) THEN ERROR(126) COMP 6975 END COMP 6976 ELSE COMP 6977 IF NXT^.KLASS IN [PROC,FUNC] THEN PASS := PROCDESC; COMP 6978 INSYMBOL; COMP 6979 IF PASS = PROCDESC THEN COMP 6980 BEGIN COMP 6981 IF SY <> IDENT THEN COMP 6982 BEGIN ERROR(2); SKIP(FSYS+[COMMA,RPARENT]); COMP 6983 NEEDX([0..7],I) COMP 6984 END COMP 6985 ELSE COMP 6986 BEGIN COMP 6987 IF NXT^.KLASS = PROC THEN SEARCHID([PROC],LCP) COMP 6988 ELSE COMP 6989 BEGIN SEARCHID([FUNC],LCP); COMP 6990 END; COMP 6991 IF LCP^.PFDECKIND = PREDECLARED THEN COMP 6992 BEGIN ERROR(164); NEEDX([0..7],I) END COMP 6993 ELSE COMP 6994 BEGIN IF LCP^.PFXOPT <> NXT^.PFXOPT THEN ERROR(179); COMP 6995 IF NOT COMPPROCS(LCP,NXT) THEN ERROR(128); COMP 6996 IF LCP^.PFKIND = ACTUAL THEN COMP 6997 BEGIN (*SET UP DESCRIPTOR:*) COMP 6998 WITH LCP^ DO COMP 6999 BEGIN COMP 7000 IF FTN AND (PFDECL<>FTNDECL) THEN ERROR(173) COMP 7001 ELSE COMP 7002 IF NOT FTN AND (PFDECL=FTNDECL) THEN ERROR(174); COMP 7003 NEEDX([0..7],I); COMP 7004 SEARCHEXTID(EPT); COMP 7005 GEN30(SXBPK,I,0,0,ABSR); COMP 7006 IF (PFLEV <> 1)AND NOT FTN THEN (*ADD SURR. BASE ADR*) COMP 7007 BEGIN COMP 7008 LOADBASE(PFLEV,K); COMP 7009 GEN15(LXJK,K,0,18); GEN15(BXXPX,I,I,K); COMP 7010 DECREFX(K) COMP 7011 END COMP 7012 END; COMP 7013 END (*LCP^.PFKIND = ACTUAL*) COMP 7014 ELSE COMP 7015 BEGIN (* LOAD DESCRIPTOR: *) COMP 7016 IF FTN THEN ERROR(173); COMP 7017 LOADPFDESCRIPTOR(LCP,I) COMP 7018 END; COMP 7019 END; COMP 7020 END (*SY = IDENT*); COMP 7021 GATTR.TYPTR := INTPTR; COMP 7022 INSYMBOL; COMP 7023 CHECKCONTEXT(FSYS+[COMMA,RPARENT],6,[]) COMP 7024 END (*PASS = PROCDESC*) COMP 7025 ELSE COMP 7026 BEGIN COMP 7027 IF NXT <> NIL THEN COMP 7028 BEGIN LSP := NXT^.IDTYPE; COMP 7029 IF NXT^.FIRSTINPARMGROUP THEN LSP1 := NIL; COMP 7030 IF NXT^.VARPARAM THEN COMP 7031 BEGIN VARIABLE(FSYS+FACBEGSYS+[COMMA,RPARENT]); COMP 7032 IF NOT (SY IN [COMMA,RPARENT]) THEN COMP 7033 BEGIN ERROR(142); COMP 7034 EXPRESSION(FSYS+[COMMA,RPARENT]); COMP 7035 GATTR.TYPTR := NIL COMP 7036 END COMP 7037 ELSE COMP 7038 IF GATTR.TYPTR <> NIL THEN COMP 7039 BEGIN COMP 7040 IF GATTR.DCLPCKD THEN ERROR(142); COMP 7041 IF GATTR.TAGF THEN ERROR(187) COMP 7042 END; COMP 7043 PASS := VARADDR COMP 7044 END COMP 7045 ELSE COMP 7046 BEGIN EXPRESSION(FSYS+[COMMA,RPARENT]); COMP 7047 IF (GATTR.TYPTR <> NIL) AND (LSP <> NIL) THEN COMP 7048 BEGIN COMP 7049 IF CONFORMARRAY(GATTR.TYPTR) THEN V41AC20 47 IF OPTS.DIALECT = P6000 THEN EXTENSION(322) V41DC05 482 ELSE ERROR(224); V41AC20 49 IF FULLWORDS(LSP^.SIZE) <> 1 THEN COMP 7051 PASS := VARADDR; COMP 7052 IF PASS = VAL THEN COMP 7053 BEGIN COMP 7054 IF LSP = REALPTR THEN COMP 7055 BEGIN COMP 7056 IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN COMP 7057 BEGIN LOAD(GATTR,I); PACKANDNORM(I); COMP 7058 GATTR.TYPTR := REALPTR; GATTR.EXPREG := I COMP 7059 END COMP 7060 END COMP 7061 ELSE COMP 7062 IF LSP^.FORM = POWER THEN CHECKSET(LSP,I,306) COMP 7063 ELSE COMP 7064 IF (LSP <> INTPTR) AND (LSP^.FORM <= SUBRANGE) COMP 7065 THEN CHECKORDINAL(LSP,I,306) COMP 7066 END COMP 7067 END (* GATTR.TYPTR <> NIL *) COMP 7068 END; COMP 7069 IF NXT^.CONFORMNT THEN COMP 7070 BEGIN PASS := ARRDESC; COMP 7071 IF LSP1 = NIL THEN LSP1 := GATTR.TYPTR COMP 7072 ELSE COMP 7073 IF GATTR.TYPTR <> LSP1 THEN ERROR(127); COMP 7074 IF NXT^.FIRSTINPARMGROUP THEN COMP 7075 IF NOT CONFORMABLE(LSP,GATTR.TYPTR,0) THEN ERROR(142) COMP 7076 END COMP 7077 ELSE COMP 7078 IF NOT COMPPARAMS(LSP,GATTR.TYPTR,NXT^.VARPARAM) COMP 7079 THEN ERROR(142) COMP 7080 END COMP 7081 ELSE (* NXT = NIL *) COMP 7082 BEGIN EXPRESSION(FSYS+[COMMA,RPARENT]); COMP 7083 GATTR.TYPTR := NIL COMP 7084 END; COMP 7085 IF GATTR.TYPTR <> NIL THEN COMP 7086 CASE PASS OF COMP 7087 VAL : LOAD(GATTR,I); COMP 7088 VARADDR : LOADADDRESS(GATTR,I); COMP 7089 ARRDESC : CNFPARAM(GATTR,I) COMP 7090 END COMP 7091 ELSE NEEDX([0..7],I) COMP 7092 END (*PASS <> PROCDESC*) ; COMP 7093 IF FTN THEN COMP 7094 BEGIN COMP 7095 IF PASS = VAL THEN COMP 7096 BEGIN (* SAVE VALUE IN A TEMPORARY *) COMP 7097 MAKETEMP(PARAM,GATTR.TYPTR,1); COMP 7098 STORE(PARAM,I); LOADADDRESS(PARAM,I) COMP 7099 END; COMP 7100 MAKEVARBLATTR(PARAM,GATTR.TYPTR,LEVEL,LDSP); COMP 7101 STORE(PARAM,I) COMP 7102 END COMP 7103 ELSE (* NOT FTN *) COMP 7104 IF LXPAR < FCP^.PFXOPT THEN COMP 7105 BEGIN LXPAR := SUCC(LXPAR); BXIXJ(PARAMREGS[LXPAR],I) END COMP 7106 ELSE STOREPARAM(LDSP,I); COMP 7107 LDSP := LDSP + 1; COMP 7108 IF NXT <> NIL THEN NXT := NXT^.NEXT COMP 7109 UNTIL SY <> COMMA; COMP 7110 EXPECTSYMBOL(RPARENT,4) COMP 7111 END (*IF LPARENT*); COMP 7112 FOR I := 1 TO LXPAR DO UNROTATEX(PARAMREGS[I]); V41AC08 54 IF FTN THEN COMP 7114 BEGIN COMP 7115 GEN15(BXXMX,6,6,6); COMP 7116 GENINC(SABPK,6,5,LDSP); (* SET APLIST SENTINEL *) COMP 7117 GENINC(SABPK,1,5,PVDISP); (* LOAD FIRST WORD OF APLIST *) COMP 7118 RJTOEXT(EX[SPEEX]); (* SAVE PASCAL ENVIRONMENT *) COMP 7119 SEARCHEXTID(FCP^.EPT); COMP 7120 GEN30(RJ,0,0,0,ABSR); (* CALL FORTRAN ROUTINE *) COMP 7121 GEN30(PS,0,0,400000B,PROGR); (* FTN TRACEBACK INFO *) COMP 7122 RJTOEXT(EX[RPEEX]) (* RESTORE PASCAL ENVIRONMENT *) COMP 7123 END COMP 7124 ELSE (* NOT FTN *) COMP 7125 BEGIN COMP 7126 IF NXT <> NIL THEN ERROR(126); COMP 7127 IF PSMARK+ARPS+PFLC+LDSP > PSMAX THEN COMP 7128 PSMAX := PSMARK+ARPS+PFLC+LDSP; COMP 7129 IF LKIND = ACTUAL THEN COMP 7130 WITH FCP^ DO COMP 7131 BEGIN (* LOAD STATIC LINK OF CALLED PROCEDURE *) COMP 7132 IF PFLEV <> 1 THEN COMP 7133 IF PFLEV IN LEVELS THEN GEN15(SXBPB,5,BRG[PFLEV],0) COMP 7134 ELSE COMP 7135 IF PFLEV+1 IN LEVELS THEN GEN15(SABPB,5,BRG[PFLEV+1],0) COMP 7136 ELSE GEN15(MXJK,5,0,LEVEL-PFLEV-1); COMP 7137 RJTOEXT(EPT) COMP 7138 END COMP 7139 ELSE (* LKIND <> ACTUAL *) COMP 7140 BEGIN COMP 7141 LOADPFDESCRIPTOR(FCP,I); COMP 7142 BXIXJ(5,I); COMP 7143 RJTOEXT(EX[VPEEX]); COMP 7144 END; COMP 7145 END; COMP 7146 LC := LLC; COMP 7147 PSSTORE := PSMARK; COMP 7148 IF FCP^.KLASS = FUNC THEN COMP 7149 BEGIN COMP 7150 IF LPSMARK <> PSMARK THEN COMP 7151 BEGIN PSMARK := LPSMARK; COMP 7152 GEN30(SBBPK,6,6,(PSMARK-PSSTORE),ABSR); COMP 7153 END; COMP 7154 SETFUNCTIONRESULT(LXRGS,FCP^.IDTYPE) COMP 7155 END; COMP 7156 SETLINENUM := TRUE COMP 7157 END (* CALLUSERDECLARED *); COMP 7158 COMP 7159 BEGIN (*CALL*) COMP 7160 IF FCP^.PFDECKIND = USERDECLARED THEN CALLUSERDECLARED COMP 7161 ELSE COMP 7162 BEGIN COMP 7163 LKEY := FCP^.KEY; COMP 7164 CASE LKEY OF COMP 7165 ABSKW, COMP 7166 CARDKW, COMP 7167 CHRKW, COMP 7168 EXPOKW, COMP 7169 ODDKW, COMP 7170 RELVALUEKW, V410C01 12 ORDKW, COMP 7171 PREDKW, COMP 7172 ROUNDKW, COMP 7173 SQRKW, COMP 7174 SUCCKW, COMP 7175 TRUNCKW, COMP 7176 UNDEFINEDKW: INLINEFUNCS; COMP 7177 ARCTANKW: ARITHFUNCS(ATANEX); COMP 7178 COSKW, COMP 7179 SINKW: ARITHFUNCS(SINCOEX); COMP 7180 EXPKW: ARITHFUNCS(EXPEX); COMP 7181 LNKW: ARITHFUNCS(LNEX); COMP 7182 SQRTKW: ARITHFUNCS(SQRTEX); COMP 7183 CLOCKKW: CLOCKF; COMP 7184 DATEKW: TIMEDATE(DATEEX); COMP 7185 TIMEKW: TIMEDATE(TIMEEX); COMP 7186 DISPOSEKW: NEWDISPOSE(DISPEX); COMP 7187 NEWKW: NEWDISPOSE(NEWEX); COMP 7188 MNEWKW: NEWDISPOSE(MNEWEX); COMP 7189 MARKKW: MARKRELEASE(MARKEX); COMP 7190 RELEASEKW: MARKRELEASE(RELEASEEX); COMP 7191 EOFKW, COMP 7192 EOLNKW, COMP 7193 EOSKW: FILEFUNCS; COMP 7194 EOIKW: EOIFUNC; V41AC15 36 GETKW: FILEPROCS(GETBEX); COMP 7195 GETSEGKW: FILEPROCS(GETSEX); COMP 7196 GETFILEKW: FILEPROCS(GETFEX); V41AC15 37 PUTKW: FILEPROCS(PUTBEX); COMP 7197 PUTSEGKW: FILEPROCS(PUTSEX); COMP 7198 PUTFILEKW: FILEPROCS(PUTFEX); V41AC15 38 RESETKW: FILEPROCS(RESETEX); COMP 7199 REWRITEKW: FILEPROCS(REWRTEX); COMP 7200 HALTKW: HALT; COMP 7201 MESSAGEKW: MESSAGE; COMP 7202 PACKKW: PACK; COMP 7203 PAGEKW: PAGE; COMP 7204 READKW, COMP 7205 READLNKW: READ; COMP 7206 UNPACKKW: UNPACK; COMP 7207 WRITEKW, COMP 7208 WRITELNKW: WRITE COMP 7209 END (*CASE*) COMP 7210 END COMP 7211 END (*CALL*) ; COMP 7212 COMP 7213 PROCEDURE EXPRESSION; COMP 7214 VAR LATTR: ATTR; LOP: OPERATOR; WRDS,LADDR: ADDRRANGE; COMP 7215 BTS: BITRANGE; I,J,K,L,M,N,R,II,JJ: REGNR; COMP 7216 LOPCD: OPCODE; TOPLEVEL: BOOLEAN; COMP 7217 LVENTOUT:BOOLEAN; LOW,HIGH:INTEGER; COMP 7218 LPL1,LPL2: PLACE; COMP 7219 IREG,JREG : REGNR; COMP 7220 USEDBITS: 0..WORDSIZE; COMP 7221 COMP 7222 PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS); COMP 7223 VAR LATTR: ATTR; LOP: OPERATOR; SIGN: (NONE,POS,NEG); COMP 7224 LINT,GINT,LOPPLUS: BOOLEAN; COMP 7225 I,J,K: REGNR; COMP 7226 COMP 7227 PROCEDURE BOOLOP(VAR FATTR: ATTR; FOP: OPERATOR); COMP 7228 (*GENERATE CODE FOR (FOP IN [ANDOP,OROP])*) COMP 7229 (*RESULTING ATTRIBUTES IN GATTR*) COMP 7230 VAR I,J,K,L: REGNR; IND1,IND2,SHFT: INTEGER; COMP 7231 COMP 7232 PROCEDURE LDOPD(VAR FATTR: ATTR; VAR FI: REGNR;VAR FIND: INTEGER); COMP 7233 (*LOAD OPERAND DESCRIBED BY FATTR INTO X-FI AND SET INDICATOR COMP 7234 FIND TO DISTINGUISH BETWEEN 5 CASES: COMP 7235 VALUE OF FIND: 0 1 2 3 4 COMP 7236 X-FI CONTAINS: LOGICAL ZR NZ PL NG*) COMP 7237 VAR I,J: REGNR; COMP 7238 BEGIN COMP 7239 WITH FATTR DO COMP 7240 IF KIND = COND THEN COMP 7241 BEGIN COMP 7242 IF CONDCD IN [ZR,NZ] THEN COMP 7243 BEGIN LOADCST(0,J); DECREFX(J); NEEDX([0..7],I); COMP 7244 GEN15(IXXMX,I,J,CDR); COMP 7245 IF CONDCD = ZR THEN GEN15(BXXMX,I,CDR,I) COMP 7246 ELSE GEN15(BXXMCX,I,CDR,I); COMP 7247 DECREFX(CDR); FI := I COMP 7248 END COMP 7249 ELSE FI := CDR; COMP 7250 FIND := ORD(CONDCD) + 1 COMP 7251 END COMP 7252 ELSE COMP 7253 BEGIN LOAD(FATTR,FI); FIND := 0 END COMP 7254 END (*LDOPD*) ; COMP 7255 COMP 7256 BEGIN (*BOOLOP*) LDOPD(FATTR,I,IND1); LDOPD(GATTR,J,IND2); COMP 7257 IF IND2 < IND1 THEN (*TRANSPOSE OPS*) COMP 7258 BEGIN K := I; I := J; J := K; COMP 7259 K := IND1; IND1 := IND2; IND2 := K COMP 7260 END; COMP 7261 IF (IND1=0)AND (IND2 IN [3,4]) THEN COMP 7262 BEGIN COMP 7263 IF FOP =ANDOP THEN COMP 7264 BEGIN K := J; SHFT := 1 END COMP 7265 ELSE COMP 7266 BEGIN K := I; SHFT := 59 END; COMP 7267 WITH XRGS[K] DO COMP 7268 IF REFNR = 1 THEN COMP 7269 BEGIN GEN15(LXJK,K,0,SHFT); XCONT := OTHER END COMP 7270 ELSE COMP 7271 BEGIN ROTATEX(L,K,SHFT); V41AC08 55 IF FOP = ANDOP THEN J := L ELSE I := L COMP 7274 END COMP 7275 END; COMP 7276 NEEDX([0..7],K); COMP 7277 (*SET RESULT ATTRIBUTES:*) COMP 7278 WITH GATTR DO COMP 7279 BEGIN TYPTR := BOOLPTR; COMP 7280 IF IND1 = 0 THEN COMP 7281 BEGIN KIND := EXPR; EXPREG := K END COMP 7282 ELSE COMP 7283 BEGIN KIND := COND; CONDCD := PL; CDR := K END COMP 7284 END; COMP 7285 IF (IND2 = 4) AND (IND1 = 4) THEN GATTR.CONDCD := NG; COMP 7286 GEN15(BOOLOPCD[FOP=ANDOP,IND1=4,IND2=4],K,I,J); COMP 7287 IF (FOP = OROP)AND (IND1 = 0)AND (IND2 <> 0) THEN COMP 7288 BEGIN COMP 7289 WITH GATTR DO COMP 7290 BEGIN KIND := COND; CONDCD := PL; CDR := K END; COMP 7291 IF IND2 IN [1,2] THEN GEN15(LXJK,K,0,59) COMP 7292 END; COMP 7293 DECREFX(I); DECREFX(J) COMP 7294 END (*BOOLOP*) ; COMP 7295 COMP 7296 PROCEDURE TERM(FSYS: SETOFSYS); COMP 7297 VAR LATTR: ATTR; LOP: OPERATOR; COMP 7298 I,J,K,L: REGNR; LREC: CSTREC; COMP 7299 LINT,GINT,OPISDIV,LCST: BOOLEAN; V41AC09 6 COMP 7301 PROCEDURE FACTOR(FSYS: SETOFSYS); COMP 7302 VAR LCP: CTP; LSP: STP; I,J,K,L,M: REGNR; LCSTATTR,LATTR: ATTR; COMP 7303 VARPART,EXITLOOP: BOOLEAN; N: INTEGER; COMP 7304 BEGIN COMP 7305 IF NOT (SY IN FACBEGSYS) THEN COMP 7306 BEGIN ERROR(58); SKIP(FSYS+FACBEGSYS); COMP 7307 GATTR.TYPTR := NIL COMP 7308 END; COMP 7309 REPEAT COMP 7310 IF SY IN FACBEGSYS THEN COMP 7311 BEGIN COMP 7312 CASE SY OF COMP 7313 (*ID*) IDENT: COMP 7314 BEGIN SEARCHID([KONST,VARS,BOUNDID, COMP 7315 FIELD,TAGFIELD,FUNC],LCP); COMP 7316 INSYMBOL; COMP 7317 IF LCP = UVARPTR THEN COMP 7318 IF SY = LPARENT THEN LCP := UFCTPTR; COMP 7319 CASE LCP^.KLASS OF COMP 7320 KONST: COMP 7321 WITH LCP^, GATTR DO COMP 7322 BEGIN TYPTR := IDTYPE; KIND := CST; COMP 7323 CVAL := VALUES COMP 7324 END; COMP 7325 VARS, COMP 7326 TAGFIELD, COMP 7327 FIELD: COMP 7328 SELECTOR(FSYS,LCP); COMP 7329 BOUNDID: COMP 7330 BEGIN COMP 7331 WITH LCP^ DO COMP 7332 MAKEVARBLATTR(GATTR,IDTYPE,BLEV,BADDR); COMP 7333 LOAD(GATTR,I) COMP 7334 END; COMP 7335 FUNC: COMP 7336 CALL(FSYS,LCP) COMP 7337 END COMP 7338 END; COMP 7339 (*CST*) INTCONST: COMP 7340 BEGIN COMP 7341 WITH GATTR DO COMP 7342 BEGIN TYPTR := INTPTR; KIND := CST; COMP 7343 CVAL.IVAL := IVAL COMP 7344 END; COMP 7345 INSYMBOL COMP 7346 END; COMP 7347 REALCONST: COMP 7348 BEGIN COMP 7349 WITH GATTR DO COMP 7350 BEGIN TYPTR := REALPTR; KIND := CST; COMP 7351 CVAL.RVAL := RVAL COMP 7352 END; COMP 7353 INSYMBOL COMP 7354 END; COMP 7355 CHARCONST: COMP 7356 BEGIN COMP 7357 WITH GATTR DO COMP 7358 BEGIN TYPTR := CHARPTR; KIND := CST; COMP 7359 CVAL.IVAL := IVAL COMP 7360 END; COMP 7361 INSYMBOL COMP 7362 END; COMP 7363 STRINGCONST: COMP 7364 BEGIN COMP 7365 WITH GATTR DO COMP 7366 BEGIN STRINGTYPE(TYPTR); KIND := CST; COMP 7367 CVAL.VALP := CONSTP COMP 7368 END; COMP 7369 INSYMBOL COMP 7370 END; COMP 7371 (*NIL*) NILSY: COMP 7372 BEGIN COMP 7373 WITH GATTR DO COMP 7374 BEGIN COMP 7375 TYPTR := NILPTR; KIND := CST; COMP 7376 CVAL.IVAL := NILP COMP 7377 END; COMP 7378 INSYMBOL COMP 7379 END; COMP 7380 (*(*) LPARENT: COMP 7381 BEGIN INSYMBOL; EXPRESSION(FSYS+[RPARENT]); COMP 7382 EXPECTSYMBOL(RPARENT,4) COMP 7383 END; COMP 7384 (*NOT*) NOTSY: COMP 7385 BEGIN INSYMBOL; FACTOR(FSYS); COMP 7386 IF COMPTYPES(GATTR.TYPTR,BOOLPTR) AND COMP 7387 (GATTR.TYPTR <> NIL) THEN COMP 7388 WITH GATTR DO COMP 7389 IF KIND = COND THEN COMP 7390 CASE CONDCD OF COMP 7391 ZR: CONDCD := NZ; COMP 7392 NZ: CONDCD := ZR; COMP 7393 PL: CONDCD := NG; COMP 7394 NG: CONDCD := PL COMP 7395 END COMP 7396 ELSE COMP 7397 BEGIN LOAD(GATTR,I); LOADMSK(59,J); COMP 7398 DECREFX(I); DECREFX(J); COMP 7399 NEEDX([0..7],K); GEN15(BXXMCX,K,I,J); COMP 7400 GATTR.EXPREG := K COMP 7401 END COMP 7402 ELSE COMP 7403 BEGIN ERROR(135); GATTR.TYPTR := NIL END COMP 7404 END; COMP 7405 (*[*) LBRACK: COMP 7406 BEGIN INSYMBOL; COMP 7407 MNEW(LSP,POWER); COMP 7408 WITH LSP^ DO COMP 7409 BEGIN ELSET := NIL; FORM := POWER; COMP 7410 PCKDSET := [PCKD, UNPCKD]; COMP 7411 FTYPE := FALSE; COMP 7412 WITH SIZE DO COMP 7413 BEGIN WORDS := 1; BITS := 0 END COMP 7414 END; COMP 7415 VARPART := FALSE; COMP 7416 WITH LCSTATTR DO COMP 7417 BEGIN TYPTR := LSP; KIND := CST; CVAL.PVAL := [ ] COMP 7418 END; COMP 7419 IF SY = RBRACK THEN INSYMBOL COMP 7420 ELSE COMP 7421 BEGIN COMP 7422 (*LOOP UNTIL SY <> COMMA:*) COMP 7423 REPEAT EXPRESSION(FSYS+[COMMA,DOTDOT,RBRACK]); COMP 7424 IF GATTR.TYPTR <> NIL THEN COMP 7425 IF GATTR.TYPTR^.FORM > SUBRANGE THEN COMP 7426 BEGIN ERROR(136); GATTR.TYPTR := NIL END COMP 7427 ELSE COMP 7428 IF NOT COMPTYPES(LSP^.ELSET,GATTR.TYPTR) COMP 7429 THEN ERROR(137); COMP 7430 IF SY = DOTDOT THEN COMP 7431 BEGIN LATTR := GATTR; INSYMBOL; COMP 7432 EXPRESSION(FSYS+[COMMA,RBRACK]); COMP 7433 IF GATTR.TYPTR <> NIL THEN COMP 7434 IF GATTR.TYPTR^.FORM > SUBRANGE THEN COMP 7435 BEGIN ERROR(136); GATTR.TYPTR := NIL COMP 7436 END COMP 7437 ELSE COMP 7438 IF NOT COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN COMP 7439 ERROR(137); COMP 7440 IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) COMP 7441 THEN COMP 7442 BEGIN COMP 7443 IF (LATTR.KIND = CST)AND (GATTR.KIND = CST) COMP 7444 THEN COMP 7445 BEGIN COMP 7446 IF (LATTR.CVAL.IVAL<0)OR (GATTR.CVAL COMP 7447 .IVAL > 58) THEN ERROR(304) COMP 7448 ELSE COMP 7449 FOR N := LATTR.CVAL.IVAL TO GATTR COMP 7450 .CVAL.IVAL DO COMP 7451 LCSTATTR.CVAL.PVAL := LCSTATTR COMP 7452 .CVAL.PVAL+[N] COMP 7453 END COMP 7454 ELSE COMP 7455 BEGIN LOAD(LATTR,I); COMP 7456 IF DEBUG THEN CHECKBNDS(I,0,58,ASSERR); COMP 7457 LOAD(GATTR,J); COMP 7458 IF DEBUG THEN CHECKBNDS(J,0,58,ASSERR); COMP 7459 K := I; DECREFX(K); COMP 7460 NEEDX([0..7],I); GEN15(IXXMX,I,J,K); COMP 7461 NEEDX([0..7],K); GEN15(MXJK,K,0,1); COMP 7462 NEEDB(L); GEN15(SBXPB,L,I,0); COMP 7463 GEN15(AXBX,K,L,K); GEN15(SBXPB,L,J,1); COMP 7464 GEN15(AXJK,I,0,59); GEN15(LXBX,K,L,K); COMP 7465 GEN15(BXXTCX,I,K,I); COMP 7466 DECREFX(J); DECREFX(K); FREEB(L); COMP 7467 IF VARPART THEN COMP 7468 BEGIN GEN15(BXXPX,M,I,M); DECREFX(I) COMP 7469 END COMP 7470 ELSE COMP 7471 BEGIN M := I; VARPART := TRUE END COMP 7472 END COMP 7473 END COMP 7474 END (* SY = DOTDOT *) COMP 7475 ELSE COMP 7476 IF GATTR.TYPTR <> NIL THEN COMP 7477 IF GATTR.KIND = CST THEN COMP 7478 BEGIN COMP 7479 IF (GATTR.CVAL.IVAL<0)OR (GATTR.CVAL.IVAL COMP 7480 > 58) THEN ERROR(304) COMP 7481 ELSE COMP 7482 LCSTATTR.CVAL.PVAL := LCSTATTR.CVAL.PVAL COMP 7483 +[GATTR.CVAL.IVAL] COMP 7484 END COMP 7485 ELSE COMP 7486 BEGIN LOAD(GATTR,I); COMP 7487 IF DEBUG THEN CHECKBNDS(I,0,58,ASSERR); COMP 7488 NEEDB(J); COMP 7489 GEN15(SBXPB,J,I,0); DECREFX(I); COMP 7490 NEEDX([0..7],I); GEN15(SXBPB,I,1,0); COMP 7491 GEN15(LXBX,I,J,I); FREEB(J); COMP 7492 IF VARPART THEN COMP 7493 BEGIN GEN15(BXXPX,M,I,M); DECREFX(I) END COMP 7494 ELSE COMP 7495 BEGIN M := I; VARPART := TRUE END COMP 7496 END; COMP 7497 IF GATTR.TYPTR <> NIL THEN COMP 7498 BEGIN IF GATTR.TYPTR = REALPTR THEN ERROR(136); COMP 7499 LSP^.ELSET := GATTR.TYPTR COMP 7500 END; COMP 7501 EXITLOOP := SY <> COMMA; COMP 7502 IF NOT EXITLOOP THEN INSYMBOL COMP 7503 UNTIL EXITLOOP; COMP 7504 EXPECTSYMBOL(RBRACK,12) COMP 7505 END; COMP 7506 IF VARPART THEN COMP 7507 BEGIN COMP 7508 IF LCSTATTR.CVAL.PVAL <> [ ] THEN COMP 7509 BEGIN LOAD(LCSTATTR,I); GEN15(BXXPX,M,I,M); COMP 7510 DECREFX(I) COMP 7511 END; COMP 7512 WITH GATTR DO COMP 7513 BEGIN TYPTR := LSP; KIND := EXPR; EXPREG := M COMP 7514 END COMP 7515 END COMP 7516 ELSE GATTR := LCSTATTR COMP 7517 END COMP 7518 END (*CASE*) ; COMP 7519 CHECKCONTEXT(FSYS,6,FACBEGSYS) COMP 7520 END (*IF*) COMP 7521 UNTIL SY IN FSYS COMP 7522 END (*FACTOR*) ; COMP 7523 COMP 7524 BEGIN (*TERM*) COMP 7525 FACTOR(FSYS+[MULOP]); COMP 7526 WHILE SY = MULOP DO COMP 7527 BEGIN LATTR := GATTR; LOP := OP; COMP 7528 INSYMBOL; FACTOR(FSYS+[MULOP]); K := 0; COMP 7529 LINT := COMPTYPES(LATTR.TYPTR,INTPTR); COMP 7530 GINT := COMPTYPES(GATTR.TYPTR,INTPTR); COMP 7531 IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) THEN COMP 7532 CASE LOP OF COMP 7533 (***) MUL: IF LINT AND GINT THEN COMP 7534 BEGIN COMP 7535 IF LATTR.KIND = CST THEN COMP 7536 EXPREP(LATTR.CVAL.IVAL,LREC) COMP 7537 ELSE LREC.CKIND := NOP; COMP 7538 IF LREC.CKIND = NOP THEN COMP 7539 BEGIN LOAD(LATTR,I); COMP 7540 IF GATTR.KIND = CST THEN COMP 7541 EXPREP(GATTR.CVAL.IVAL,LREC) COMP 7542 END COMP 7543 ELSE LOAD(GATTR,I); COMP 7544 IF LREC.CKIND = NOP THEN COMP 7545 BEGIN LOAD(GATTR,J); OPERATION(DXXTX,K,I,J); COMP 7546 LOADCST(0,I); COMP 7547 GEN15(IXXPX,K,K,I); DECREFX(I) COMP 7548 END COMP 7549 ELSE COMP 7550 OPTMULT(I,LREC,NOT (XRGS[I].XCONT IN [SIMPVAR, COMP 7551 INDVAR]),K) COMP 7552 END COMP 7553 ELSE COMP 7554 BEGIN LOAD(LATTR,I); LOAD(GATTR,J); COMP 7555 IF LINT THEN COMP 7556 BEGIN PACKANDNORM(I); COMP 7557 LATTR.TYPTR := REALPTR COMP 7558 END COMP 7559 ELSE COMP 7560 IF GINT THEN COMP 7561 BEGIN PACKANDNORM(J); COMP 7562 GATTR.TYPTR := REALPTR COMP 7563 END; COMP 7564 IF (LATTR.TYPTR = REALPTR) COMP 7565 AND (GATTR.TYPTR = REALPTR) THEN COMP 7566 OPERATION(RXXTX,K,I,J) COMP 7567 ELSE COMP 7568 IF (LATTR.TYPTR^.FORM = POWER) COMP 7569 AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) COMP 7570 THEN COMP 7571 OPERATION(BXXTX,K,I,J) COMP 7572 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END COMP 7573 END; COMP 7574 (*/*) RDIV: BEGIN LOAD(LATTR,I); LOAD(GATTR,J); COMP 7575 IF LINT THEN COMP 7576 BEGIN PACKANDNORM(I); COMP 7577 LATTR.TYPTR := REALPTR COMP 7578 END; COMP 7579 IF GINT THEN COMP 7580 BEGIN PACKANDNORM(J); COMP 7581 GATTR.TYPTR := REALPTR COMP 7582 END; COMP 7583 IF (LATTR.TYPTR = REALPTR) COMP 7584 AND (GATTR.TYPTR = REALPTR) THEN COMP 7585 BEGIN OPERATION(RXXDX,K,I,J); COMP 7586 IF DEBUG THEN COMP 7587 BEGIN GEN30(TESTX,ORD(XID),K,DIVERR,TERAR); COMP 7588 GEN30(TESTX,ORD(XOR),K,DIVERR,TERAR) COMP 7589 END COMP 7590 END COMP 7591 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END COMP 7592 END; COMP 7593 (*DIV*) IDIV, COMP 7594 (*MOD*) IMOD: BEGIN OPISDIV := LOP = IDIV; COMP 7595 IF LINT AND GINT THEN COMP 7596 BEGIN LOAD(LATTR,I); COMP 7597 LREC.CKIND := NOP; LCST := GATTR.KIND = CST; V41AC09 7 IF LCST THEN V41AC09 8 BEGIN COMP 7600 IF GATTR.CVAL.IVAL = 0 THEN ERROR(300) COMP 7601 ELSE COMP 7602 IF NOT OPISDIV AND (GATTR.CVAL.IVAL < 0) THEN COMP 7603 ERROR(301) COMP 7604 ELSE EXPREP(GATTR.CVAL.IVAL,LREC) COMP 7605 END; COMP 7606 IF LREC.CKIND = PUREP THEN COMP 7607 BEGIN NEEDX([0..7],K); GEN15(BXX,K,I,I); COMP 7608 GEN15(AXJK,K,0,LREC.EXP); COMP 7609 IF NOT OPISDIV THEN COMP 7610 BEGIN GEN15(LXJK,K,0,LREC.EXP); COMP 7611 LOADCST(GATTR.CVAL.IVAL,J) COMP 7612 END; COMP 7613 DECREFX(I) COMP 7614 END COMP 7615 ELSE COMP 7616 BEGIN LOAD(GATTR,J); COMP 7617 IF DEBUG THEN COMP 7618 BEGIN COMP 7619 IF NOT LCST THEN V41AC09 9 IF OPISDIV THEN V41AC09 10 GEN30(TESTX,ORD(ZR),J,DIVERR,TERAR) V41AC09 11 ELSE V41AC09 12 BEGIN LOADCST(0,K); DECREFX(K); NEEDX([0..7],L); V41AC09 13 GEN15(IXXMX,L,K,J); DECREFX(L); V41AC09 14 GEN30(TESTX,ORD(PL),L,MODERR,TERAR) V41AC09 15 END; V41AC09 16 PACKOFL(I) COMP 7626 END; COMP 7627 IF OPISDIV THEN DECREFX(I); COMP 7628 NEEDX([0..7],K); GEN15(PXBX,K,0,I); NEEDX([0..7],M); COMP 7629 GEN15(PXBX,M,0,J); GEN15(NXBX,M,0,M); COMP 7630 GEN15(FXXDX,K,K,M); DECREFX(M); COMP 7631 NEEDB(L); GEN15(UXBX,K,L,K); GEN15(LXBX,K,L,K); COMP 7632 FREEB(L); COMP 7633 IF OPISDIV THEN DECREFX(J) COMP 7634 ELSE COMP 7635 BEGIN COMP 7636 IF LREC.CKIND <> NOP THEN COMP 7637 OPTMULT(K,LREC,TRUE,K) COMP 7638 ELSE GEN15(DXXTX,K,J,K); COMP 7639 DECREFX(I) COMP 7640 END COMP 7641 END; COMP 7642 IF OPISDIV THEN COMP 7643 BEGIN LOADCST(0,J); GEN15(IXXPX,K,K,J) END COMP 7644 ELSE COMP 7645 BEGIN GEN15(IXXMX,K,I,K); NEEDX([0..7],L); COMP 7646 GEN15(BXX,L,K,K); GEN15(AXJK,L,0,59); COMP 7647 GEN15(BXXTX,L,L,J); GEN15(IXXPX,K,K,L); DECREFX(L) COMP 7648 END; COMP 7649 DECREFX(J); GATTR.TYPTR := INTPTR COMP 7650 END COMP 7651 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END COMP 7652 END; COMP 7653 (*AND*) ANDOP:IF COMPTYPES(LATTR.TYPTR,BOOLPTR)AND COMP 7654 COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN COMP 7655 BOOLOP(LATTR,ANDOP) COMP 7656 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END COMP 7657 END (*CASE*) COMP 7658 ELSE GATTR.TYPTR := NIL; COMP 7659 IF LOP <> ANDOP THEN COMP 7660 WITH GATTR DO COMP 7661 BEGIN KIND := EXPR; EXPREG := K END; COMP 7662 END (*WHILE*) COMP 7663 END (*TERM*) ; COMP 7664 COMP 7665 BEGIN (*SIMPLEEXPRESSION*) COMP 7666 SIGN := NONE; COMP 7667 IF OP IN [PLUS,MINUS] THEN COMP 7668 BEGIN COMP 7669 IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG; COMP 7670 INSYMBOL COMP 7671 END; COMP 7672 TERM(FSYS+[ADDOP]); COMP 7673 IF SIGN <> NONE THEN COMP 7674 IF COMPTYPES(GATTR.TYPTR,INTPTR) OR COMP 7675 (GATTR.TYPTR = REALPTR) THEN COMP 7676 BEGIN COMP 7677 IF SIGN = NEG THEN COMP 7678 IF GATTR.KIND = CST THEN COMP 7679 GATTR.CVAL.IVAL := -GATTR.CVAL.IVAL COMP 7680 ELSE COMP 7681 BEGIN LOAD(GATTR,I); LOADCST(0,J); COMP 7682 OPERATION(IXXMX,K,J,I); GATTR.EXPREG := K COMP 7683 END COMP 7684 END COMP 7685 ELSE COMP 7686 BEGIN ERROR(134); GATTR.TYPTR := NIL END; COMP 7687 WHILE SY = ADDOP DO COMP 7688 BEGIN LATTR := GATTR; LOP := OP; COMP 7689 INSYMBOL; TERM(FSYS+[ADDOP]); K := 0; COMP 7690 LINT := COMPTYPES(LATTR.TYPTR,INTPTR); COMP 7691 GINT := COMPTYPES(GATTR.TYPTR,INTPTR); COMP 7692 IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) THEN COMP 7693 CASE LOP OF COMP 7694 (*+*) PLUS, COMP 7695 (*-*) MINUS: COMP 7696 BEGIN LOAD(LATTR,I); LOAD(GATTR,J); COMP 7697 LOPPLUS := LOP = PLUS; COMP 7698 IF LINT AND GINT THEN COMP 7699 IF LOPPLUS COMP 7700 THEN OPERATION(IXXPX,K,I,J) COMP 7701 ELSE OPERATION(IXXMX,K,I,J) COMP 7702 ELSE COMP 7703 BEGIN COMP 7704 IF LINT THEN COMP 7705 BEGIN PACKANDNORM(I); COMP 7706 LATTR.TYPTR := REALPTR COMP 7707 END COMP 7708 ELSE COMP 7709 IF GINT THEN COMP 7710 BEGIN PACKANDNORM(J); COMP 7711 GATTR.TYPTR := REALPTR COMP 7712 END; COMP 7713 IF (LATTR.TYPTR = REALPTR) COMP 7714 AND (GATTR.TYPTR = REALPTR) THEN COMP 7715 BEGIN IF LOPPLUS COMP 7716 THEN OPERATION(RXXPX,K,I,J) COMP 7717 ELSE OPERATION(RXXMX,K,I,J); COMP 7718 GEN15(NXBX,K,0,K) COMP 7719 END COMP 7720 ELSE COMP 7721 IF (LATTR.TYPTR^.FORM = POWER) COMP 7722 AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN COMP 7723 IF LOPPLUS COMP 7724 THEN OPERATION(BXXPX,K,I,J) COMP 7725 ELSE OPERATION(BXXTCX,K,I,J) COMP 7726 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END COMP 7727 END; COMP 7728 END; COMP 7729 (*OR*) OROP: COMP 7730 IF COMPTYPES(LATTR.TYPTR,BOOLPTR)AND COMP 7731 COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN COMP 7732 BOOLOP(LATTR,OROP) COMP 7733 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END COMP 7734 END (*CASE*) COMP 7735 ELSE GATTR.TYPTR := NIL; COMP 7736 IF LOP <> OROP THEN COMP 7737 WITH GATTR DO COMP 7738 BEGIN KIND := EXPR; EXPREG := K END COMP 7739 END (*WHILE*) COMP 7740 END (*SIMPLEEXPRESSION*) ; COMP 7741 COMP 7742 PROCEDURE CHECKREAL; COMP 7743 (* TEST RESULT OF REAL EXPRESSION. *) COMP 7744 (* ASSUMES DEBUG IS TRUE *) COMP 7745 BEGIN (* CHECKREAL *) COMP 7746 WITH GATTR DO COMP 7747 IF KIND = EXPR THEN COMP 7748 IF TYPTR = REALPTR THEN COMP 7749 BEGIN GEN15(NXBX,EXPREG,0,EXPREG); NOOP END COMP 7750 (* CAUSE MODE EXIT FOR BAD OPERAND AND PREVENT CHANGING COMP 7751 NXBX INSTRUCTION BY BXIXJ AND PREVENT AN SA0 INSTRUCTION COMP 7752 FROM BEING GENERATED IN THE SAME WORD. THIS ENSURES COMP 7753 THAT THE LINE NUMBER REPORTED BY PMD WILL BE CORRECT. *) COMP 7754 END (* CHECKREAL *); COMP 7755 COMP 7756 BEGIN (*EXPRESSION*) COMP 7757 TOPLEVEL := TOPEXPR; COMP 7758 TOPEXPR := FALSE; COMP 7759 SIMPLEEXPRESSION(FSYS+[RELOP]); COMP 7760 IF SY = RELOP THEN COMP 7761 BEGIN COMP 7762 IF DEBUG THEN CHECKREAL; COMP 7763 IF (GATTR.TYPTR <> NIL) AND (OP = INOP) THEN V41AC17 7 IF GATTR.TYPTR^.FORM > SUBRANGE THEN ERROR(136); V41AC17 8 LATTR := GATTR; LOP := OP; V41AC17 9 INSYMBOL; SIMPLEEXPRESSION(FSYS); COMP 7765 IF DEBUG THEN CHECKREAL; COMP 7766 IF LATTR.TYPTR <> NIL THEN COMP 7767 WITH LATTR.TYPTR^ DO COMP 7768 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) AND COMP 7769 (FORM = ARRAYS) AND (SIZE.WORDS > 1) THEN COMP 7770 BEGIN COMP 7771 LOADADDRESS(LATTR,II); LOADADDRESS(GATTR,JJ) COMP 7772 END COMP 7773 ELSE COMP 7774 BEGIN COMP 7775 IF LOP = INOP THEN (* DECIDE WHETHER ELEMENT EVENTUALLY COMP 7776 OUT OF [0..63] *) COMP 7777 BEGIN LVENTOUT:=TRUE; COMP 7778 WITH LATTR DO COMP 7779 IF KIND = CST THEN COMP 7780 BEGIN IF (CVAL.IVAL >= 0) AND (CVAL.IVAL <= 63) THEN COMP 7781 LVENTOUT:=FALSE COMP 7782 END COMP 7783 ELSE IF KIND = VARBL THEN COMP 7784 IF (TYPTR <> NIL) AND (TYPTR <> INTPTR) THEN COMP 7785 IF TYPTR^.FORM < REALS THEN COMP 7786 BEGIN GETBOUNDS(TYPTR,LOW,HIGH); COMP 7787 IF (LOW >= 0) AND (HIGH <= 63) THEN LVENTOUT:=FALSE COMP 7788 END COMP 7789 END; COMP 7790 LOAD(LATTR,I); LOAD(GATTR,J); COMP 7791 END; COMP 7792 K := 0; COMP 7793 IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) THEN COMP 7794 IF LOP = INOP THEN COMP 7795 IF GATTR.TYPTR^.FORM = POWER THEN COMP 7796 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET) THEN COMP 7797 BEGIN COMP 7798 IF LVENTOUT THEN COMP 7799 BEGIN LOADMSK(54,L); DECREFX(L); NEEDX([0..7],K); COMP 7800 GEN15(BXXTX,K,I,L); GEN30(TESTX,ORD(NZ),K,IC+1,PROGR); COMP 7801 DECREFX(K) COMP 7802 END; COMP 7803 NEEDX([0..7],K); COMP 7804 NEEDB(L); GEN15(SBXPB,L,I,0); COMP 7805 DECREFX(I); DECREFX(J); GEN15(AXBX,K,L,J); COMP 7806 IF LVENTOUT THEN NOOP; COMP 7807 GEN15(LXJK,K,0,59); FREEB(L); COMP 7808 WITH GATTR DO COMP 7809 BEGIN TYPTR := BOOLPTR; CONDCD := PL END; COMP 7810 END COMP 7811 ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END COMP 7812 ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END COMP 7813 ELSE COMP 7814 BEGIN COMP 7815 IF NOT COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN COMP 7816 IF COMPTYPES(LATTR.TYPTR,INTPTR) THEN COMP 7817 BEGIN PACKANDNORM(I); COMP 7818 LATTR.TYPTR := REALPTR COMP 7819 END COMP 7820 ELSE COMP 7821 IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN COMP 7822 BEGIN PACKANDNORM(J); COMP 7823 GATTR.TYPTR := REALPTR COMP 7824 END; COMP 7825 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN COMP 7826 BEGIN COMP 7827 CASE LATTR.TYPTR^.FORM OF COMP 7828 SCALAR, COMP 7829 SUBRANGE, COMP 7830 REALS: COMP 7831 ; COMP 7832 POINTER: COMP 7833 BEGIN COMP 7834 IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131); COMP 7835 END; COMP 7836 POWER: COMP 7837 BEGIN IF LOP IN [LTOP,GTOP] THEN ERROR(132); COMP 7838 END; COMP 7839 ARRAYS: COMP 7840 IF NOT STRING(LATTR.TYPTR) THEN ERROR(134) COMP 7841 ELSE V41AC20 50 IF CONFORMARRAY(LATTR.TYPTR) THEN ERROR(225); V41CC11 8 RECORDS: ERROR(134); COMP 7843 FILES: COMP 7844 ERROR(133) COMP 7845 END; COMP 7846 CASE LATTR.TYPTR^.FORM OF COMP 7847 SCALAR, COMP 7848 SUBRANGE, COMP 7849 REALS, COMP 7850 POINTER: COMP 7851 BEGIN COMP 7852 IF LATTR.TYPTR = REALPTR THEN COMP 7853 LOPCD := FXXMX COMP 7854 ELSE COMP 7855 LOPCD := IXXMX; COMP 7856 CASE LOP OF COMP 7857 LTOP,GEOP: OPERATION(LOPCD,K,I,J); COMP 7858 LEOP,GTOP: OPERATION(LOPCD,K,J,I); COMP 7859 NEOP,EQOP: OPERATION(IXXMX,K,I,J) COMP 7860 END; COMP 7861 WITH GATTR DO COMP 7862 BEGIN TYPTR := BOOLPTR; COMP 7863 CASE LOP OF COMP 7864 LTOP,GTOP: CONDCD := PL; COMP 7865 LEOP,GEOP: CONDCD := NG; COMP 7866 NEOP: CONDCD := ZR; COMP 7867 EQOP: CONDCD := NZ COMP 7868 END COMP 7869 END COMP 7870 END ; COMP 7871 POWER: COMP 7872 BEGIN COMP 7873 CASE LOP OF COMP 7874 LTOP,GTOP: ; COMP 7875 LEOP : OPERATION(BXXTCX,K,I,J); COMP 7876 GEOP : OPERATION(BXXTCX,K,J,I); COMP 7877 NEOP,EQOP: OPERATION(BXXMX,K,I,J) COMP 7878 END; COMP 7879 WITH GATTR DO COMP 7880 BEGIN TYPTR := BOOLPTR; COMP 7881 IF LOP = NEOP THEN CONDCD := ZR ELSE CONDCD := NZ COMP 7882 END COMP 7883 END; COMP 7884 ARRAYS: COMP 7885 BEGIN COMP 7886 WITH LATTR.TYPTR^.SIZE DO COMP 7887 BEGIN WRDS := WORDS; BTS := BITS END; COMP 7888 IF WRDS = 0 THEN (*PART WORD COMPARISON*) COMP 7889 BEGIN COMP 7890 LOADMSK(BTS,L); COMP 7891 DECREFX(I); NEEDX([0..7],II); GEN15(BXXTX,II,L,I); COMP 7892 DECREFX(J); NEEDX([0..7],JJ); GEN15(BXXTX,JJ,L,J); COMP 7893 DECREFX(L); COMP 7894 GEN15(LXJK,II,0,BTS); GEN15(LXJK,JJ,0,BTS); COMP 7895 IF LOP IN [LEOP,GTOP] COMP 7896 THEN OPERATION(IXXMX,K,JJ,II) COMP 7897 ELSE OPERATION(IXXMX,K,II,JJ) COMP 7898 END COMP 7899 ELSE COMP 7900 BEGIN COMP 7901 IF WRDS > 1 THEN COMP 7902 BEGIN COMP 7903 NEEDB(L); GEN15(SBBPB,L,0,0); COMP 7904 NEEDB(R); GENINC(SBBPK,R,0,WRDS-1); COMP 7905 NOOP; LADDR := IC; COMP 7906 NEEDX([1..5],I); NEEDX([1..5],J); COMP 7907 ARGS[I].ACONT := UNSPECADDR; COMP 7908 ARGS[J].ACONT := UNSPECADDR; COMP 7909 GEN15(SAXPB,I,II,L); GEN15(SAXPB,J,JJ,L); COMP 7910 END; COMP 7911 IF LOP IN [LEOP,GTOP] THEN COMP 7912 BEGIN K := I; I := J; J := K END; COMP 7913 IREG := I; JREG := J; COMP 7914 NEEDX([0..7],K); COMP 7915 USEDBITS := WORDSIZE DIV CHARSIZE * CHARSIZE; COMP 7916 IF USEDBITS <> WORDSIZE THEN COMP 7917 BEGIN (* MASK OFF UNUSED BITS *) COMP 7918 GEN15(MXJK,K,0,USEDBITS); COMP 7919 GEN15(BXXTX,I,K,I); GEN15(BXXTX,J,K,J) COMP 7920 END; COMP 7921 IF LOP IN [LTOP,LEOP,GEOP,GTOP] THEN COMP 7922 BEGIN GEN15(BXXMCX,K,I,J); DECREFX(I); NEEDX([0..7],M); COMP 7923 GEN15(IXXMX,M,I,J); COMP 7924 NEEDX([0..7],I); GEN15(BXXTX,I,K,M); COMP 7925 NEEDX([0..7],N); COMP 7926 GEN15(BXXTCX,N,J,K); GEN15(BXXPX,K,I,N); COMP 7927 DECREFX(N); DECREFX(M); COMP 7928 END COMP 7929 ELSE COMP 7930 BEGIN GEN15(BXXMX,K,I,J); COMP 7931 GEN30(TESTX,ORD(NZ),K,0,PROGR); LPL1 := PC; COMP 7932 NEEDX([0..7],N); GEN15(SXBPB,N,1,0); COMP 7933 GEN15(BXXTX,K,K,N); DECREFX(N) COMP 7934 END; COMP 7935 DECREFX(I); DECREFX(J); COMP 7936 IF (WRDS > 1) OR (BTS <> 0) THEN COMP 7937 BEGIN IF WRDS > 1 THEN GEN15(SBBPB,L,L,1); COMP 7938 IF LOP IN [LTOP,LEOP,GEOP,GTOP] THEN COMP 7939 BEGIN GEN30(TESTX,ORD(NG),K,0,PROGR); LPL1 := PC; COMP 7940 GEN30(TESTX,ORD(NZ),M,0,PROGR); LPL2 := PC COMP 7941 END COMP 7942 ELSE IF WRDS > 1 THEN COMP 7943 BEGIN GEN30(TESTX,ORD(NZ),K,0,PROGR); COMP 7944 LPL2 := PC COMP 7945 END; COMP 7946 IF WRDS > 1 THEN COMP 7947 BEGIN GEN30(GE,R,L,LADDR,PROGR); COMP 7948 DECREFX(II); DECREFX(JJ); COMP 7949 FREEB(L); FREEB(R) COMP 7950 END; COMP 7951 END; COMP 7952 IF BTS <> 0 THEN COMP 7953 BEGIN LOADMSK(BTS,L); COMP 7954 NEEDX([1..5],I); NEEDX([1..5],J); COMP 7955 IF I = JREG THEN COMP 7956 BEGIN I := J; J := JREG END; COMP 7957 GEN15(SAAPB,I,IREG,1); ARGS[I].ACONT := UNSPECADDR; COMP 7958 GEN15(SAAPB,J,JREG,1); ARGS[J].ACONT := UNSPECADDR; COMP 7959 DECREFX(I); NEEDX([0..7],II); GEN15(BXXTX,II,L,I); COMP 7960 DECREFX(J); NEEDX([0..7],JJ); GEN15(BXXTX,JJ,L,J); COMP 7961 DECREFX(L); COMP 7962 GEN15(LXJK,II,0,BTS); GEN15(LXJK,JJ,0,BTS); COMP 7963 DECREFX(II); DECREFX(JJ); COMP 7964 GEN15(IXXMX,K,II,JJ) COMP 7965 END; COMP 7966 IF (WRDS > 1) OR (BTS <> 0) THEN COMP 7967 BEGIN NOOP; INS(IC,LPL1); COMP 7968 IF (LOP IN [LTOP,LEOP,GTOP,GEOP]) OR (WRDS > 1) THEN COMP 7969 INS(IC,LPL2) COMP 7970 END COMP 7971 ELSE IF LOP IN [EQOP,NEOP] THEN COMP 7972 BEGIN NOOP; INS(IC,LPL1) END COMP 7973 END; COMP 7974 WITH GATTR DO COMP 7975 BEGIN TYPTR := BOOLPTR; COMP 7976 CASE LOP OF COMP 7977 LTOP,GTOP: CONDCD := PL; COMP 7978 LEOP,GEOP: CONDCD := NG; COMP 7979 NEOP : CONDCD := ZR; COMP 7980 EQOP : CONDCD := NZ COMP 7981 END COMP 7982 END COMP 7983 END; COMP 7984 RECORDS, COMP 7985 FILES: COMP 7986 END (*CASE*) ; COMP 7987 END COMP 7988 ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END; COMP 7989 END (*SY <> INOP*) COMP 7990 ELSE GATTR.TYPTR := NIL; COMP 7991 WITH GATTR DO COMP 7992 BEGIN KIND := COND; CDR := K END; COMP 7993 END (*SY = RELOP*) ; COMP 7994 IF TOPLEVEL AND DEBUG THEN CHECKREAL; COMP 7995 TOPEXPR := TOPLEVEL COMP 7996 END (*EXPRESSION*) ; COMP 7997 COMP 7998 PROCEDURE GENFJMP(FADDR: ADDRRANGE); COMP 7999 (*GENERATE A FALSE JUMP TO FADDR (ON GATTR)*) COMP 8000 VAR I: REGNR; COMP 8001 BEGIN COMP 8002 WITH GATTR DO COMP 8003 IF TYPTR <> NIL THEN COMP 8004 IF KIND = COND THEN COMP 8005 BEGIN GEN30(TESTX,ORD(CONDCD),CDR,FADDR,PROGR); DECREFX(CDR) END COMP 8006 ELSE COMP 8007 BEGIN LOAD(GATTR,I); GEN30(TESTX,ORD(ZR),I,FADDR,PROGR); COMP 8008 DECREFX(I) COMP 8009 END COMP 8010 END (*GENFJMP*) ; COMP 8011 COMP 8012 PROCEDURE ASSIGNMENT(FCP: CTP); COMP 8013 VAR LATTR: ATTR; COMP 8014 BEGIN THREATEN(FCP); COMP 8015 SELECTOR(FSYS+[BECOMES],FCP); COMP 8016 IF SY = BECOMES THEN COMP 8017 BEGIN COMP 8018 LATTR := GATTR; COMP 8019 INSYMBOL; EXPRESSION(FSYS); COMP 8020 ASSIGNTO(LATTR); COMP 8021 END (*SY = BECOMES*) COMP 8022 ELSE ERROR(51) COMP 8023 END (*ASSIGNMENT*) ; COMP 8024 COMP 8025 PROCEDURE GOTOSTATEMENT; COMP 8026 LABEL 1; COMP 8027 VAR LLP: LBP; I: REGNR; LFSTOCC: LOCOFREF; COMP 8028 BEGIN COMP 8029 IF SY = INTCONST THEN COMP 8030 BEGIN LLP := FSTLABP; COMP 8031 WHILE LLP <> FLABP DO (*DECIDE WHETHER LOCALLY DECLARED*) COMP 8032 WITH LLP^ DO COMP 8033 IF LABVAL = IVAL THEN COMP 8034 BEGIN COMP 8035 IF ACCESSIBLE THEN COMP 8036 BEGIN COMP 8037 IF NOT DEFINED AND (LABSTMTLEVEL = 0) THEN (* FIRST USE *) COMP 8038 LABSTMTLEVEL := STMTLEVEL COMP 8039 END COMP 8040 ELSE ERROR(188); COMP 8041 IF DEFINED THEN GEN30(EQ,0,0,LABADDR,PROGR) COMP 8042 ELSE COMP 8043 BEGIN GEN30(EQ,0,0,0,PROGR); LFSTOCC := FSTOCC; COMP 8044 LINKOCC(LFSTOCC); FSTOCC := LFSTOCC COMP 8045 END; COMP 8046 GOTO 1 COMP 8047 END COMP 8048 ELSE LLP := NEXTLAB; COMP 8049 WHILE LLP <> NIL DO (*DECIDE WHETHER GLOBALLY DECLARED*) COMP 8050 WITH LLP^ DO COMP 8051 IF LABVAL = IVAL THEN COMP 8052 BEGIN COMP 8053 LABSTMTLEVEL := 1; COMP 8054 IF EPT = TENBLANKS THEN COMP 8055 BEGIN EPT := PASCL; COMP 8056 IF LABCNT = MAXEXTLABCNT THEN ERROR(260) V41AC03 8 ELSE COMP 8058 BEGIN LABCNT := LABCNT + 1; COMP 8059 EPT[7] := CHR(LABCNT) COMP 8060 END COMP 8061 END; COMP 8062 LOADBASE(LABLEV,I); BXIXJ(1,I); V41AC10 6 SEARCHEXTID(EPT); GEN30(SXBPK,7,0,0,ABSR); COMP 8066 EQTOEXT(EX[GTOEX]); COMP 8067 GOTO 1 COMP 8068 END COMP 8069 ELSE LLP := NEXTLAB; COMP 8070 ERROR(167); COMP 8071 1: INSYMBOL COMP 8072 END COMP 8073 ELSE ERROR(15); COMP 8074 CLEARREGS COMP 8075 END (*GOTOSTATEMENT*) ; COMP 8076 COMP 8077 PROCEDURE COMPOUNDSTATEMENT; COMP 8078 BEGIN COMP 8079 STATEMENT(FSYS+[ENDSY],TRUE); COMP 8080 EXPECTSYMBOL(ENDSY,13) COMP 8081 END (*COMPOUNDSTATEMENET*) ; COMP 8082 COMP 8083 PROCEDURE IFSTATEMENT; COMP 8084 VAR LPL1,LPL2: PLACE; I: REGNR; COMP 8085 LREGMAP, LREGMAP2: REGMAP; COMP 8086 BEGIN EXPRESSION(FSYS+[THENSY]); COMP 8087 IF NOT COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN ERROR(144); COMP 8088 GENFJMP(0); COMP 8089 LPL1 := PC; COMP 8090 SAVEREGMAP(LREGMAP); COMP 8091 EXPECTSYMBOL(THENSY,52); COMP 8092 STATEMENT(FSYS+[ELSESY],FALSE); COMP 8093 IF SY = ELSESY THEN COMP 8094 BEGIN GEN30(EQ,0,0,0,PROGR); LPL2 := PC; COMP 8095 NOOP; INS(IC,LPL1); COMP 8096 SETLINENUM := TRUE; COMP 8097 SAVEREGMAP(LREGMAP2); RESTOREREGMAP(LREGMAP); COMP 8098 INSYMBOL; STATEMENT(FSYS,FALSE); COMP 8099 NOOP; INS(IC,LPL2); COMP 8100 SETLINENUM := TRUE; COMP 8101 MERGEREGMAP(LREGMAP2); RESTOREREGMAP(LREGMAP2) COMP 8102 END COMP 8103 ELSE COMP 8104 BEGIN NOOP; INS(IC,LPL1); COMP 8105 MERGEREGMAP(LREGMAP); RESTOREREGMAP(LREGMAP) COMP 8106 END COMP 8107 END (*IFSTATEMENT*) ; COMP 8108 COMP 8109 PROCEDURE CASESTATEMENT; COMP 8110 CONST CASLABMAX = 2001; V41CC07 324 VAR LSP,LSP1: STP; FSTPTR,LCC1,LCC2: CCP; V41CC07 325 FSTLOCP: LOCOFREF; LPL: PLACE; COMP 8120 LDEBUG,EXITLOOP: BOOLEAN; COMP 8121 FIRSTBRANCH: BOOLEAN; COMP 8122 I,J,K: REGNR; COMP 8123 LREGMAP, LREGMAP2: REGMAP; COMP 8124 LADDR: ADDRRANGE; COMP 8125 LMIN,LMAX: INTEGER; COMP 8126 OTHERADDR : ADDRRANGE; COMP 8127 OTHERREL : RELOCATION; COMP 8128 OTHERCLAUSE : BOOLEAN; COMP 8129 L : REGNR; COMP 8130 EVENLABEL : BOOLEAN; COMP 8131 TABLE : INTEGER; COMP 8132 COMP 8133 PROCEDURE JUMPTABLE(FCCVAL: INTEGER; FADDR: ADDRRANGE; V41CC07 326 FREL: RELOCATION); V41CC07 327 (*GENERATE JUMPTABLE ENTRIES*) V41CC07 328 BEGIN V41CC07 329 WHILE FCCVAL > LMIN DO V41CC07 330 BEGIN V41CC07 331 IF EVENLABEL THEN V41CC07 332 GEN30(TESTX,ORD(PL),J,FADDR,FREL) V41CC07 333 ELSE GEN30(EQ,0,0,FADDR,FREL); V41CC07 334 EVENLABEL := NOT EVENLABEL; V41CC07 335 LMIN := LMIN + 1 V41CC07 336 END V41CC07 337 END (* JUMPTABLE *); V41CC07 338 V41CC07 339 PROCEDURE LOADCASECST(CVAL: INTEGER; REG: REGNR); COMP 8134 VAR LCSP: CTAILP; COMP 8135 BEGIN (* LOADCASECST *) COMP 8136 IF ABS(CVAL) >= TWOTO17 THEN COMP 8137 BEGIN MNEW(LCSP); COMP 8138 WITH LCSP^ DO COMP 8139 BEGIN NXTCSP := NIL; CSVAL := CVAL END; COMP 8140 GEN30(SABPK,REG,0,0,PROGR); COMP 8141 ENTERCST(LCSP) COMP 8142 END COMP 8143 ELSE GENINC(SXBPK,REG,0,CVAL) COMP 8144 END (* LOADCASECST *); COMP 8145 COMP 8146 BEGIN (* CASESTATEMENT *) COMP 8147 EXPRESSION(FSYS+[OFSY,COMMA,COLON]); COMP 8148 LSP := GATTR.TYPTR; FSTLOCP := NIL; COMP 8149 IF LSP <> NIL THEN COMP 8150 IF LSP^.FORM > SUBRANGE THEN COMP 8151 BEGIN ERROR(144); LSP := NIL END; COMP 8152 LOAD(GATTR,I); COMP 8153 LDEBUG := DEBUG; COMP 8154 NEEDX([1..5],J); ARGS[J].ACONT := UNSPECADDR; COMP 8155 NEEDX([1..5],K); ARGS[K].ACONT := UNSPECADDR; COMP 8156 GEN30(EQ,0,0,0,PROGR); LPL := PC; COMP 8157 DECREFX(J); DECREFX(K); COMP 8158 NEEDB(L); FREEB(L); COMP 8159 WITH XRGS[I] DO COMP 8160 BEGIN COMP 8161 IF XCONT = INDVAR THEN DECREFX(XREG); COMP 8162 XCONT := OTHER COMP 8163 END; COMP 8164 DECREFX(I); COMP 8165 SAVEREGMAP(LREGMAP); COMP 8166 EXPECTSYMBOL(OFSY,8); COMP 8167 FSTPTR := NIL; V41CC07 340 FIRSTBRANCH := TRUE; V41CC07 341 IF LSP <> NIL THEN GETBOUNDS(LSP,LMIN,LMAX); V41CC07 342 (*LOOP UNTIL SY <> SEMICOLON*) COMP 8170 REPEAT COMP 8171 NOOP; SETLINENUM := TRUE; COMP 8172 CASECONSTANTLIST(FSYS,LSP,LMIN,LMAX,356,FSTPTR,LCC1); V41CC07 343 WHILE LCC1 <> NIL DO V41CC07 344 WITH LCC1^ DO V41CC07 345 BEGIN CCADDR := IC; LCC1 := THREAD END; V41CC07 346 REPEAT STATEMENT(FSYS+[SEMICOLON,ENDSY,OTHERWISESY],FALSE); COMP 8200 IF SY IN STATBEGSYS THEN ERROR(14); COMP 8201 UNTIL NOT (SY IN STATBEGSYS); COMP 8202 GEN30(EQ,0,0,0,PROGR); LINKOCC(FSTLOCP); COMP 8203 EXITLOOP := SY <> SEMICOLON; COMP 8204 IF FIRSTBRANCH THEN COMP 8205 BEGIN SAVEREGMAP(LREGMAP2); FIRSTBRANCH := FALSE END COMP 8206 ELSE MERGEREGMAP(LREGMAP2); COMP 8207 RESTOREREGMAP(LREGMAP); COMP 8208 IF NOT EXITLOOP THEN COMP 8209 BEGIN INSYMBOL; COMP 8210 IF SY IN (FSYS+[ENDSY,OTHERWISESY]) THEN EXITLOOP := TRUE COMP 8211 END COMP 8212 UNTIL EXITLOOP; COMP 8213 CHECKCONTEXT([ENDSY,OTHERWISESY],6,FSYS); COMP 8214 OTHERCLAUSE := SY = OTHERWISESY; COMP 8215 IF OTHERCLAUSE THEN EXTENSION(328); COMP 8216 IF FSTPTR <> NIL THEN COMP 8217 BEGIN LMIN := FSTPTR^.CCMIN; V41CC07 347 LCC1 := FSTPTR; V41CC07 348 WHILE LCC1^.NEXTCC <> NIL DO V41CC07 349 LCC1 := LCC1^.NEXTCC; V41CC07 350 LMAX := LCC1^.CCMAX; V41CC07 351 SETLINENUM := FALSE; COMP 8225 NOOP; COMP 8226 INS(IC,LPL); COMP 8227 IF NOT LDEBUG OR OTHERCLAUSE THEN COMP 8228 BEGIN OTHERADDR := 0; OTHERREL := PROGR END COMP 8229 ELSE BEGIN OTHERADDR := INXERR; OTHERREL := TERAR END; COMP 8230 TABLE := 0; COMP 8231 IF LDEBUG OR OTHERCLAUSE THEN COMP 8232 BEGIN COMP 8233 IF LMIN <> 0 THEN LOADCASECST(LMIN,J) COMP 8234 ELSE J := I; COMP 8235 LOADCASECST(LMAX,K); COMP 8236 IF LMIN <> 0 THEN GEN15(IXXMX,J,I,J); COMP 8237 GEN15(IXXMX,K,K,I); COMP 8238 GEN15(BXXPX,K,K,J); COMP 8239 GEN15(LXJK,J,0,59); COMP 8240 GEN30(TESTX,ORD(NG),K,OTHERADDR,OTHERREL); LPL := PC COMP 8241 END COMP 8242 ELSE COMP 8243 BEGIN COMP 8244 IF ABS(LMIN) >= TWOTO17 THEN COMP 8245 BEGIN LOADCASECST(LMIN,J); GEN15(IXXMX,J,I,J) END COMP 8246 ELSE COMP 8247 IF LMIN < 0 THEN GEN30(SXXPK,J,I,-LMIN,ABSR) COMP 8248 ELSE COMP 8249 BEGIN LMIN := LMIN - ORD(ODD(LMIN)); COMP 8250 TABLE := -LMIN DIV 2; J := I COMP 8251 END; COMP 8252 GEN15(LXJK,J,0,59) COMP 8253 END; COMP 8254 GEN15(SBXPB,L,J,0); COMP 8255 GEN30(JP,L,0,IC+TABLE+ORD(PC.CP >= 3),PROGR); COMP 8256 NOOP; LADDR := IC + (LMAX - LMIN) DIV 2 + 1; COMP 8257 IF NOT LDEBUG OR OTHERCLAUSE THEN COMP 8258 BEGIN OTHERADDR := LADDR; COMP 8259 IF OTHERCLAUSE THEN INS(OTHERADDR,LPL) COMP 8260 END; COMP 8261 EVENLABEL := TRUE; COMP 8262 IF LMAX - LMIN < CASLABMAX THEN COMP 8263 BEGIN COMP 8264 REPEAT COMP 8265 WITH FSTPTR^ DO COMP 8266 BEGIN COMP 8267 JUMPTABLE(CCMIN,OTHERADDR,OTHERREL); V41CC07 352 JUMPTABLE(CCMAX+1,CCADDR,PROGR); V41CC07 353 LCC1 := FSTPTR; FSTPTR := NEXTCC; DISPOSE(LCC1) V41CC07 354 END COMP 8281 UNTIL FSTPTR = NIL; COMP 8282 END COMP 8283 ELSE BEGIN ERROR(157); FSTLOCP := NIL END COMP 8284 END (* FSTPTR <> NIL *); COMP 8285 NOOP; COMP 8286 IF OTHERCLAUSE THEN COMP 8287 BEGIN INSYMBOL; SETLINENUM := TRUE; COMPOUNDSTATEMENT; NOOP; COMP 8288 MERGEREGMAP(LREGMAP2) COMP 8289 END COMP 8290 ELSE EXPECTSYMBOL(ENDSY,13); COMP 8291 WHILE FSTLOCP <> NIL DO WITH FSTLOCP^ DO COMP 8292 BEGIN INS(IC,LOC); FSTLOCP := NXTREF END; COMP 8293 RESTOREREGMAP(LREGMAP2); COMP 8294 SETLINENUM := TRUE; COMP 8295 END (*CASESTATEMENT*) ; COMP 8296 COMP 8297 PROCEDURE REPEATSTATEMENT; COMP 8298 VAR LADDR: ADDRRANGE; COMP 8299 BEGIN CLEARREGS; COMP 8300 NOOP; LADDR := IC; COMP 8301 SETLINENUM := TRUE; COMP 8302 STATEMENT(FSYS+[UNTILSY],TRUE); COMP 8303 IF SY = UNTILSY THEN COMP 8304 BEGIN INSYMBOL; EXPRESSION(FSYS); COMP 8305 IF NOT COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN ERROR(144); COMP 8306 GENFJMP(LADDR) COMP 8307 END COMP 8308 ELSE ERROR(53) COMP 8309 END (*REPEATSTATEMENT*) ; COMP 8310 COMP 8311 PROCEDURE WHILESTATEMENT; COMP 8312 VAR LADDR: ADDRRANGE; LPL: PLACE; COMP 8313 LREGMAP: REGMAP; COMP 8314 BEGIN CLEARREGS; COMP 8315 NOOP; LADDR := IC; COMP 8316 SETLINENUM := TRUE; COMP 8317 EXPRESSION(FSYS+[DOSY]); COMP 8318 IF NOT COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN ERROR(144); COMP 8319 GENFJMP(0); COMP 8320 LPL := PC; COMP 8321 SAVEREGMAP(LREGMAP); COMP 8322 EXPECTSYMBOL(DOSY,54); COMP 8323 STATEMENT(FSYS,FALSE); COMP 8324 GEN30(EQ,0,0,LADDR,PROGR); NOOP; INS(IC,LPL); COMP 8325 SETLINENUM := TRUE; COMP 8326 RESTOREREGMAP(LREGMAP) COMP 8327 END (*WHILESTATEMENT*) ; COMP 8328 COMP 8329 PROCEDURE FORSTATEMENT; COMP 8330 VAR LSP: STP; LSY: SYMBOL; LADDR: ADDRRANGE; COMP 8331 LPL: PLACE; I,J,K,L: REGNR; LCP: CTP; LLC: ADDRRANGE; COMP 8332 LMIN,LMAX: INTEGER; BYPASS,LCONTROLVAR: BOOLEAN; COMP 8333 CONTROL,INITIAL,FINAL: ATTR; LREGMAP: REGMAP; COMP 8334 INITIALRANGE, FINALRANGE: BOOLEAN; V41FC02 7 COMP 8335 PROCEDURE FORBOUND(FSYS1,FSYS2: SETOFSYS; FERR: ERRINDEX; COMP 8336 VAR FATTR: ATTR; VAR RANGE: BOOLEAN); V41FC02 8 VAR L: REGNR; COMP 8338 BEGIN COMP 8339 FATTR.TYPTR := NIL; RANGE := FALSE; V41FC02 9 IF SY IN FSYS2 THEN COMP 8341 BEGIN INSYMBOL; EXPRESSION(FSYS1); COMP 8342 IF GATTR.TYPTR <> NIL THEN COMP 8343 IF GATTR.TYPTR^.FORM <= SUBRANGE THEN COMP 8344 BEGIN COMP 8345 IF CONTROL.TYPTR <> NIL THEN COMP 8346 IF COMPTYPES(CONTROL.TYPTR,GATTR.TYPTR) THEN COMP 8347 BEGIN FATTR := GATTR; COMP 8348 IF GATTR.KIND = CST THEN COMP 8349 BEGIN COMP 8350 WITH GATTR.CVAL DO COMP 8351 IF (IVAL < LMIN) OR (IVAL > LMAX) THEN V41FC02 10 BEGIN RANGE := TRUE; ERROR(357) END V41FC02 11 END COMP 8353 ELSE LOAD(FATTR,L) COMP 8354 END COMP 8355 ELSE ERROR(145) COMP 8356 END COMP 8357 ELSE ERROR(144) COMP 8358 END COMP 8359 ELSE BEGIN ERROR(FERR); SKIP(FSYS1) END COMP 8360 END (* FORBOUND *) ; COMP 8361 COMP 8362 BEGIN (* FORSTATEMENT *) COMP 8363 LLC := LC; COMP 8364 MAKEVARBLATTR(CONTROL,NIL,LEVEL,0); COMP 8365 LMIN := -MAXINT; LMAX := MAXINT; COMP 8366 IF SY = IDENT THEN COMP 8367 WITH CONTROL DO COMP 8368 BEGIN SEARCHID([VARS],LCP); COMP 8369 IF LCP <> UVARPTR THEN COMP 8370 WITH LCP^ DO COMP 8371 BEGIN COMP 8372 TYPTR := IDTYPE; COMP 8373 IF VACCESS = DRCT THEN COMP 8374 IF VLEV = LEVEL THEN COMP 8375 BEGIN CWDISPL := VADDR; COMP 8376 IF THREAT THEN ERROR(192) COMP 8377 END COMP 8378 ELSE ERROR(155); COMP 8379 LCONTROLVAR := CONTROLVAR; COMP 8380 CONTROLVAR := TRUE; COMP 8381 IF LCONTROLVAR THEN ERROR(193); COMP 8382 IF VKIND = FORMAL THEN ERROR(180) COMP 8383 END; COMP 8384 IF TYPTR <> NIL THEN COMP 8385 IF TYPTR^.FORM > SUBRANGE THEN COMP 8386 BEGIN ERROR(143); TYPTR := NIL END; COMP 8387 GETBOUNDS(TYPTR,LMIN,LMAX); COMP 8388 INSYMBOL COMP 8389 END COMP 8390 ELSE COMP 8391 BEGIN ERROR(2); COMP 8392 LCP := UVARPTR; COMP 8393 SKIP(FSYS+[BECOMES,TOSY,DOWNTOSY,DOSY]) COMP 8394 END; COMP 8395 FORBOUND(FSYS+[TOSY,DOWNTOSY,DOSY],[BECOMES],51,INITIAL, V41FC02 12 INITIALRANGE); V41FC02 13 GATTR := INITIAL; LOAD(GATTR,I); BXIXJ(6,I); COMP 8397 LSY := SY; COMP 8398 FORBOUND(FSYS+[DOSY],[TOSY,DOWNTOSY],55,FINAL,FINALRANGE); V41FC02 14 BYPASS := FALSE; COMP 8400 IF (INITIAL.TYPTR <> NIL) AND (FINAL.TYPTR <> NIL) THEN COMP 8401 BEGIN COMP 8402 BYPASS := TRUE; COMP 8403 IF (INITIAL.KIND = CST) AND (FINAL.KIND = CST) THEN COMP 8404 IF (LSY = TOSY) AND (INITIAL.CVAL.IVAL <= FINAL.CVAL.IVAL) OR COMP 8405 (LSY <> TOSY) AND (INITIAL.CVAL.IVAL >= FINAL.CVAL.IVAL) COMP 8406 THEN V41FC02 15 BEGIN BYPASS := FALSE; V41FC02 16 IF INITIALRANGE OR FINALRANGE THEN ERROR(303) V41FC02 17 END V41FC02 18 ELSE ERROR(355); (* UNREACHABLE STATEMENT *) COMP 8408 IF BYPASS THEN COMP 8409 BEGIN COMP 8410 GATTR := FINAL; LOAD(GATTR,I); COMP 8411 (* INITIAL VALUE IN X6, FINAL VALUE IN XI *) COMP 8412 NEEDX([0..7],K); DECREFX(K); COMP 8413 IF LSY = TOSY THEN GEN15(IXXMX,K,I,6) COMP 8414 ELSE GEN15(IXXMX,K,6,I); COMP 8415 GEN30(TESTX,ORD(NG),K,0,PROGR); LPL := PC; COMP 8416 SAVEREGMAP(LREGMAP); COMP 8417 IF INITIALRANGE OR FINALRANGE THEN GEN30(EQ,0,0,ASSERR,TERAR) V41FC02 19 ELSE V41FC02 20 IF ((INITIAL.KIND<>CST) OR (FINAL.KIND<>CST)) AND DEBUG THEN V41FC02 21 BEGIN V41FC02 22 IF INITIAL.KIND <> CST THEN V41FC02 23 BEGIN LOADCST(LMIN,J); DECREFX(J); NEEDX([0..7],K); V41FC02 24 IF LSY = TOSY THEN GEN15(IXXMX,K,6,J) V41FC02 25 ELSE GEN15(IXXMX,K,I,J) V41FC02 26 END; V41FC02 27 IF FINAL.KIND <> CST THEN V41FC02 28 BEGIN LOADCST(LMAX,J); DECREFX(J); NEEDX([0..7],L); V41FC02 29 IF LSY = TOSY THEN GEN15(IXXMX,L,J,I) V41FC02 30 ELSE GEN15(IXXMX,L,J,6); V41FC02 31 IF INITIAL.KIND = CST THEN K := L V41FC02 32 ELSE BEGIN GEN15(BXXPX,K,K,L); DECREFX(L) END V41FC02 33 END; V41FC02 34 GEN30(TESTX,ORD(NG),K,ASSERR,TERAR); V41FC02 35 DECREFX(K) V41FC02 36 END; V41FC02 37 IF FINAL.KIND <> CST THEN COMP 8435 BEGIN MAKETEMP(FINAL,FINAL.TYPTR,1); STORE(FINAL,I) END COMP 8436 END COMP 8437 END; COMP 8438 EXPECTSYMBOL(DOSY,54); COMP 8439 NOOP; LADDR := IC; SETLINENUM := TRUE; CLEARREGS; COMP 8440 STORE(CONTROL,6); COMP 8441 STATEMENT(FSYS,FALSE); COMP 8442 GATTR := CONTROL; LOAD(GATTR,I); COMP 8443 LOAD(FINAL,J); COMP 8444 LOADCST(2*ORD(LSY=TOSY)-1,K); COMP 8445 DECREFX(J); NEEDX([0..5],L); (* NOT (L IN [I,K,6]) *) COMP 8446 GEN15(IXXMX,L,I,J); COMP 8447 DECREFX(I); DECREFX(K); NEEDX([6],J); COMP 8448 GEN15(IXXPX,6,I,K); COMP 8449 GEN30(TESTX,ORD(NZ),L,LADDR,PROGR); COMP 8450 DECREFX(L); DECREFX(6); COMP 8451 IF BYPASS THEN COMP 8452 BEGIN NOOP; INS(IC,LPL); COMP 8453 SETLINENUM := TRUE; COMP 8454 MERGEREGMAP(LREGMAP); RESTOREREGMAP(LREGMAP) COMP 8455 END; COMP 8456 IF DEBUG THEN COMP 8457 BEGIN NEEDX([6],I); GEN15(MXJK,6,0,1); STORE(CONTROL,6) END; COMP 8458 IF LCP <> UVARPTR THEN LCP^.CONTROLVAR := LCONTROLVAR; COMP 8459 LC := LLC COMP 8460 END (*FORSTATEMENT*) ; COMP 8461 COMP 8462 PROCEDURE WITHSTATEMENT; COMP 8463 VAR LCP: CTP; OLDTOP: DISPRANGE; LLC: ADDRRANGE; LATTR: ATTR; COMP 8464 I: REGNR; EXITLOOP: BOOLEAN; COMP 8465 BEGIN OLDTOP := TOP; LLC := LC; COMP 8466 (*LOOP UNTIL SY <> COMMA:*) COMP 8467 REPEAT COMP 8468 IF SY = IDENT THEN COMP 8469 BEGIN SEARCHID([VARS,FIELD,TAGFIELD],LCP); INSYMBOL END COMP 8470 ELSE BEGIN ERROR(2); LCP := UVARPTR END; COMP 8471 SELECTOR(FSYS+[COMMA,DOSY],LCP); COMP 8472 IF GATTR.TYPTR <> NIL THEN COMP 8473 IF GATTR.TYPTR^.FORM = RECORDS THEN COMP 8474 IF TOP < DISPLIMIT THEN COMP 8475 BEGIN TOP := TOP + 1; COMP 8476 WITH DISPLAY[TOP], GATTR DO COMP 8477 BEGIN FNAME := TYPTR^.FIELDIDTREE; REGION := WREC; V41CC07 355 DCLPKD := TYPTR^.PCKDREC; COMP 8479 IF WORDACC = DRCT THEN COMP 8480 BEGIN WACC := DRCT; COMP 8481 LEV := VLEVEL; CWDSPL := CWDISPL COMP 8482 END COMP 8483 ELSE COMP 8484 BEGIN COMP 8485 LOADADDRESS(GATTR,I); COMP 8486 LEV := LEVEL; CWDSPL := LC; WACC := INDRCT; COMP 8487 MAKETEMP(LATTR,GATTR.TYPTR,1); COMP 8488 STORE(LATTR,I) COMP 8489 END; COMP 8490 IF PCKD THEN COMP 8491 BEGIN PKD := TRUE; COMP 8492 IF BITREG = NONE THEN COMP 8493 BEGIN BACC := DRCT; BDSPL := CBDISPL END COMP 8494 ELSE COMP 8495 BEGIN COMP 8496 IF CBDISPL <> 0 THEN COMP 8497 BEGIN LOADCST(CBDISPL,I); COMP 8498 OPERATION(IXXPX,I,VBDISPL,I) COMP 8499 END COMP 8500 ELSE I := VBDISPL; COMP 8501 BACC := INDRCT; BDSPL := LC; COMP 8502 MAKETEMP(LATTR,INTPTR,1); COMP 8503 STORE(LATTR,I) COMP 8504 END COMP 8505 END (*PCKD*) COMP 8506 ELSE PKD := FALSE COMP 8507 END COMP 8508 END COMP 8509 ELSE ERROR(250) COMP 8510 ELSE ERROR(140); COMP 8511 EXITLOOP := SY <> COMMA; COMP 8512 IF NOT EXITLOOP THEN INSYMBOL COMP 8513 UNTIL EXITLOOP; COMP 8514 EXPECTSYMBOL(DOSY,54); COMP 8515 STATEMENT(FSYS,FALSE); COMP 8516 (*DISPOSE LOCALLY USED X-REGISTERS*) COMP 8517 FOR I := 0 TO 7 DO COMP 8518 WITH XRGS[I] DO COMP 8519 IF XCONT = SIMPVAR THEN COMP 8520 IF (XLEV = LEVEL)AND (XADDR >= LLC) THEN XCONT := AVAIL; COMP 8521 FOR I := 0 TO 7 DO COMP 8522 WITH XRGS[I] DO COMP 8523 IF XCONT = INDVAR THEN COMP 8524 IF XRGS[XREG].XCONT = AVAIL THEN XCONT := AVAIL; COMP 8525 TOP := OLDTOP; LC := LLC COMP 8526 END (*WITHSTATEMENT*) ; COMP 8527 COMP 8528 BEGIN (*STATEMENT*) COMP 8529 IF STMTSEQUENCE THEN FSYS := FSYS + [SEMICOLON]; COMP 8530 STMTLEVEL := STMTLEVEL + 1; COMP 8531 REPEAT COMP 8532 REPEAT COMP 8533 IF SY = INTCONST THEN (*LABEL*) COMP 8534 BEGIN CLEARREGS; NOOP; COMP 8535 SETLINENUM := TRUE; COMP 8536 LLP := FSTLABP; COMP 8537 WHILE LLP <> FLABP DO COMP 8538 WITH LLP^ DO COMP 8539 IF LABVAL = IVAL THEN COMP 8540 BEGIN COMP 8541 IF DEFINED THEN ERROR(165) COMP 8542 ELSE COMP 8543 BEGIN LOCP := FSTOCC; COMP 8544 WHILE LOCP <> NIL DO COMP 8545 WITH LOCP^ DO COMP 8546 BEGIN INS(IC,LOC); LOCP := NXTREF END; COMP 8547 DEFINED := TRUE; LABADDR := IC; COMP 8548 IF (LABSTMTLEVEL > 0) AND (LABSTMTLEVEL < STMTLEVEL) THEN COMP 8549 ERROR(189); COMP 8550 LABSTMTLEVEL := STMTLEVEL COMP 8551 END; COMP 8552 GOTO 1 COMP 8553 END COMP 8554 ELSE LLP := NEXTLAB; COMP 8555 ERROR(167); COMP 8556 1: INSYMBOL; COMP 8557 EXPECTSYMBOL(COLON,5) COMP 8558 END; COMP 8559 IF NOT (SY IN FSYS+[IDENT]) THEN COMP 8560 BEGIN ERROR(6); SKIP(FSYS) END; COMP 8561 IF SY IN STATBEGSYS+[IDENT] THEN COMP 8562 BEGIN COMP 8563 LASTSY := SY; COMP 8564 IF SY = IDENT THEN COMP 8565 BEGIN COMP 8566 SEARCHID([VARS,FIELD,TAGFIELD,FUNC,PROC],LCP); COMP 8567 INSYMBOL; COMP 8568 IF LCP = UVARPTR THEN COMP 8569 IF SY IN [LPARENT]+FSYS THEN LCP := UPRCPTR; COMP 8570 IF LCP^.KLASS = PROC COMP 8571 THEN CALL(FSYS,LCP) COMP 8572 ELSE ASSIGNMENT(LCP) COMP 8573 END COMP 8574 ELSE COMP 8575 BEGIN COMP 8576 INSYMBOL; COMP 8577 CASE LASTSY OF COMP 8578 BEGINSY : COMPOUNDSTATEMENT; COMP 8579 GOTOSY : GOTOSTATEMENT; COMP 8580 IFSY : IFSTATEMENT; COMP 8581 CASESY : CASESTATEMENT; COMP 8582 WHILESY : WHILESTATEMENT; COMP 8583 REPEATSY : REPEATSTATEMENT; COMP 8584 FORSY : FORSTATEMENT; COMP 8585 WITHSY : WITHSTATEMENT COMP 8586 END COMP 8587 END; COMP 8588 CHECKCONTEXT(FSYS,6,[]) COMP 8589 END; COMP 8590 IF STMTSEQUENCE THEN COMP 8591 BEGIN EXITLOOP := NOT (SY IN STATBEGSYS); COMP 8592 IF NOT EXITLOOP THEN ERROR(14) COMP 8593 END COMP 8594 ELSE EXITLOOP := TRUE COMP 8595 UNTIL EXITLOOP; COMP 8596 IF STMTSEQUENCE THEN COMP 8597 BEGIN EXITLOOP := SY <> SEMICOLON; COMP 8598 IF NOT EXITLOOP THEN INSYMBOL COMP 8599 END COMP 8600 UNTIL EXITLOOP; COMP 8601 LLP := FSTLABP; COMP 8602 WHILE LLP <> FLABP DO COMP 8603 WITH LLP^ DO COMP 8604 BEGIN COMP 8605 IF ACCESSIBLE THEN COMP 8606 IF DEFINED THEN ACCESSIBLE := LABSTMTLEVEL <> STMTLEVEL COMP 8607 ELSE COMP 8608 IF LABSTMTLEVEL >= STMTLEVEL THEN COMP 8609 LABSTMTLEVEL := STMTLEVEL - 1; COMP 8610 LLP := NEXTLAB COMP 8611 END; COMP 8612 STMTLEVEL := STMTLEVEL - 1 COMP 8613 END (*STATEMENT*) ; COMP 8614 (*$L'PROCEDURE / FUNCTION BODY PROCESSOR.' *) COMP 8615 COMP 8616 COMP 8617 PROCEDURE HEADER(PG, FB: BOOLEAN; NAME: ALFA; COMP 8618 PARAMS, PARAMSINREGS: INTEGER); COMP 8619 (* SETS: BHWIC, BHWPC, BHWFIXES, PMDPC, PMDFIXES. *) COMP 8620 VAR PH: BOOLEAN; COMP 8621 BEGIN (* HEADER *) COMP 8622 BMSG(NAME); COMP 8623 PH := PG OR (PMD IN [PMDON,PMDOFF]); COMP 8624 BHWIC := IC; COMP 8625 GEN60((((ORD(PG)*2 + ORD(PH))*10B + (5-PARAMSINREGS))*2000B COMP 8626 + PARAMS) * 1000000000000000B); COMP 8627 BHWFIXES := 0; BHWPC := PC; COMP 8628 IF PH THEN COMP 8629 BEGIN COMP 8630 GEN60((ORD(PMD=PMDON)*2 + ORD(FB))*20000000000000000000B); COMP 8631 PMDPC := PC; COMP 8632 ALFINT.A := NAME; GEN60(ALFINT.I) COMP 8633 END; COMP 8634 PMDFIXES := 0 COMP 8635 END (* HEADER *) ; COMP 8636 V41DC06 14 PROCEDURE INITPMDFILE; V41DC06 15 (* CREATE EXTERNAL PMD FILE SINCE "OUTPUT" NOT IN PROGRAM *) V41DC06 16 (* HEADING AND PMD <> PMDNONE. EXTERNAL PMD FILE WILL BE *) V41DC06 17 (* OPENED TO "OUTPUT". *) V41DC06 18 VAR LEXFILP: EXTFILEP; LCP: CTP; V41DC06 19 BEGIN (* INITPMDFILE *) V41DC06 20 MNEW(LCP,VARS); V41DC06 21 WITH LCP^ DO V41DC06 22 BEGIN NAME.TEN := KW[OUTPUTKW]; NAME.EXT := NIL; V41DC06 23 IDTYPE := TEXTPTR; KLASS := VARS; VACCESS := DRCT; V41DC06 24 NEXT := NIL; VKIND := FORMAL; VARPARAM := FALSE; V41DC06 25 VLEV := 1; VADDR := LC; VINIT := FALSE; V41DC06 26 THREAT := FALSE; CONTROLVAR := FALSE; V41DC06 27 CONFORMNT := FALSE; FIRSTINPARMGROUP := FALSE V41DC06 28 END; V41DC06 29 PMDFILEPTR := LCP; V41DC06 30 LC := LC + TEXTPTR^.SIZE.WORDS; V41DC06 31 IF LC > MAXADDR THEN BEGIN LC := 0; ERROR(261) END; V41DC06 32 MNEW(LEXFILP); V41DC06 33 WITH LEXFILP^ DO V41DC06 34 BEGIN FILENAME := KW[OUTPUTKW]; NXTP := FEXFILP; V41DC06 35 FILECP := LCP; TERMINAL := FALSE; SYSLOC := 1 V41DC06 36 END; V41DC06 37 FEXFILP := LEXFILP V41DC06 38 END (* INITPMDFILE *); V41DC06 39 V41DC05 483 PROCEDURE CHECKLABELS; V41DC05 484 VAR LLP: LBP; V41DC05 485 BEGIN (* CHECKLABELS *) V41DC05 486 LLP := FSTLABP; V41DC05 487 WHILE LLP <> FLABP DO V41DC05 488 WITH LLP^ DO V41DC05 489 BEGIN V41DC05 490 IF NOT DEFINED THEN V41DC05 491 BEGIN ERROR(168); V41DC05 492 FLAGERROR; PUTERRMSG(' UNDEFINED LABEL: ',FALSE); V41DC05 493 IF LISTINGOPEN THEN WRITELN(LISTING,LABVAL:1); V41DC05 494 IF ERRFILEOPEN THEN WRITELN(ERRFILE,LABVAL:1) V41DC05 495 END; V41DC05 496 LLP := NEXTLAB V41DC05 497 END V41DC05 498 END (* CHECKLABELS *); V41DC05 499 COMP 8637 PROCEDURE INITPROGPARAMS; COMP 8638 VAR LEXFILP: EXTFILEP; I: REGNR; COMP 8639 BEGIN (* INITPROGPARAMS *) COMP 8640 LEXFILP := FEXFILP; COMP 8641 WHILE LEXFILP <> NIL DO COMP 8642 BEGIN V41CC20 36 EPILOGUEFLAG := TRUE; V41CC20 37 IF LEXFILP^.FILECP <> NIL THEN V41CC20 38 WITH LEXFILP^.FILECP^ DO V41CC20 39 COMMISSIONFILES(IDTYPE,TRUE,VADDR,LEXFILP); V41CC20 40 LEXFILP := LEXFILP^.NXTP V41CC20 41 END; V41CC20 42 (* CALL P.RESET (NO EFFECT IF ACTUAL FILE = INPUT) *) COMP 8655 IF INPUTPTR <> NIL THEN COMP 8656 BEGIN GEN30(SABPK,1,5,INPUTPTR^.VADDR+TXTEFET,ABSR); V41CC04 33 RJTOEXT(EX[RESETEX]) COMP 8658 END; COMP 8659 IF (OUTPUTPTR <> NIL) AND (PRNTLIMIT > 0) THEN COMP 8660 BEGIN (* SET DEFAULT LINELIMIT FOR OUTPUT *) COMP 8661 LOADCST(PRNTLIMIT,I); BXIXJ(6,I); CLEARREGS; COMP 8662 GEN30(SABPK,6,5,OUTPUTPTR^.VADDR,ABSR) COMP 8663 END COMP 8664 END (* INITPROGPARAMS *) ; COMP 8665 COMP 8666 PROCEDURE PFENTRY(VAR FPL1, FPL2: PLACE; VAR QUICKENTRY: BOOLEAN; COMP 8667 VAR EPTIC: INTEGER); COMP 8668 VAR P: 1..MAXPARAMSINREGS; COMP 8669 ALPHA: ADDRRANGE; BETA, GAMMA: PLACE; COMP 8670 I: REGNR; V41CC20 43 BEGIN (* PFENTRY *) COMP 8671 EPTIC := IC; COMP 8672 GEN30(SABPK,0,0,LINENUM,ABSR); GEN30(PS,0,0,0,ABSR); COMP 8673 QUICKENTRY := QUICKMODE; COMP 8674 IF QUICKMODE THEN COMP 8675 BEGIN COMP 8676 IF LEVEL = 2 THEN COMP 8677 BEGIN (* GLOBAL BLOCK *) COMP 8678 GEN30(SABPK,5,0,EPTIC,PROGR); COMP 8679 GEN30(SXBPK,6,0,BHWIC,PROGR); COMP 8680 GEN15(LXJK,6,0,30); COMP 8681 GEN15(SXBPB,7,5,0); COMP 8682 GENINC(SABPK,6,6,ARPS); COMP 8683 GEN15(BXXPX,7,7,5); COMP 8684 GENINC(SABPK,7,6,ARPS-1) COMP 8685 END COMP 8686 ELSE COMP 8687 BEGIN (* NON-GLOBAL BLOCK *) COMP 8688 GEN30(TESTX,ORD(PL),5,0,PROGR); BETA := PC; COMP 8689 GEN15(BXX,6,5,5); COMP 8690 GEN15(SABPB,5,5,0); COMP 8691 NOOP; ALPHA := IC; COMP 8692 GEN15(LXJK,6,0,1); COMP 8693 GEN15(SAXPB,5,5,0); COMP 8694 GEN30(TESTX,ORD(NG),6,ALPHA,PROGR); COMP 8695 NOOP; INS(IC,BETA); COMP 8696 GEN15(SXXPB,6,5,0); COMP 8697 GEN30(SABPK,5,0,EPTIC,PROGR); COMP 8698 GEN15(SXBPB,7,5,0); COMP 8699 GEN15(BXXPX,7,7,5); COMP 8700 GEN30(SXBPK,5,0,BHWIC,PROGR); COMP 8701 GENINC(SABPK,7,6,ARPS-1); COMP 8702 GEN15(LXJK,5,0,30); COMP 8703 GEN15(BXXPX,6,6,5); COMP 8704 GENINC(SABPK,6,6,ARPS) COMP 8705 END; COMP 8706 (* STORE IN-REGISTER PARAMETERS *) COMP 8707 FOR P := 1 TO PARAMSINREGS DO COMP 8708 BEGIN I := PARAMREGS[P]; COMP 8709 GEN15(BXX,6+ORD(ODD(P)),I,I); COMP 8710 GEN15(SAAPB,6+ORD(ODD(P)),6+ORD(NOT ODD(P)),1) COMP 8711 END; COMP 8712 (* ALLOCATE ACTIVATION RECORD *) COMP 8713 GEN30(SXBPK,6,0,0,ABSR); FPL1 := PC; (* LCMAX+ARPS+PSMAX *) COMP 8714 GEN15(SXBPB,7,6,0); COMP 8715 GEN15(SXBPB,5,4,0); COMP 8716 GEN15(IXXPX,7,7,6); COMP 8717 GEN15(IXXMX,5,5,7); COMP 8718 GEN30(TESTX,ORD(PL),5,0,PROGR); GAMMA := PC; COMP 8719 GEN30(SABPK,5,0,BHWIC,PROGR); COMP 8720 RJTOEXT(EX[SCOEX]); COMP 8721 NOOP; INS(IC,GAMMA); COMP 8722 GEN15(SBBPB,5,6,1); COMP 8723 GEN30(SBBPK,6,6,0,ABSR); FPL2 := PC (* LCMAX+ARPS *) COMP 8724 END COMP 8725 ELSE COMP 8726 BEGIN (* SHORT BLOCK ENTRY *) COMP 8727 GEN30(SBBPK,3,0,BHWIC,PROGR); COMP 8728 IF LEVEL = 2 THEN RJTOEXT(EX[PEGEX]) COMP 8729 ELSE RJTOEXT(EX[PENEX]) COMP 8730 END COMP 8731 END (* PFENTRY *) ; COMP 8732 COMP 8733 PROCEDURE INITAR; COMP 8734 (* INITIALIZE ACTIVATION RECORD TO GARBAGE VALUES IF DEBUG *) COMP 8735 VAR LADDR: ADDRRANGE; COMP 8736 BEGIN (* INITAR *) COMP 8737 INITARFLAG := DEBUG; COMP 8738 IF DEBUG THEN COMP 8739 BEGIN COMP 8740 LADDR := FPROCP^.FIRSTVAR - ORD(FPROCP^.KLASS = FUNC); COMP 8741 GENINC(SXBPK,6,5,LADDR); COMP 8742 GEN30(SBBPK,7,0,0,ABSR); INITARPC := PC; COMP 8743 RJTOEXT(EX[INVEX]) COMP 8744 END COMP 8745 END (* INITAR *) ; COMP 8746 COMP 8747 PROCEDURE INITPFPARAMS(FCP: CTP); COMP 8748 VAR LSZ, LDISP, LDESC: ADDRRANGE; COMP 8749 BEGIN (* INITPFPARAMS *) COMP 8750 LDISP := PFLC; COMP 8751 WHILE FCP <> NIL DO COMP 8752 WITH FCP^ DO COMP 8753 BEGIN COMP 8754 IF (IDTYPE <> NIL) AND (KLASS = VARS) THEN COMP 8755 BEGIN COMP 8756 LSZ := FULLWORDS(IDTYPE^.SIZE); COMP 8757 IF CONFORMNT THEN COMP 8758 BEGIN (* COPY CONFORMANT-ARRAY DESCRIPTOR *) COMP 8759 LDESC := IDTYPE^.DESCADDR; COMP 8760 IF FIRSTINPARMGROUP THEN COMP 8761 BEGIN COMP 8762 GENINC(SABPK,2,5,LDISP); COMP 8763 GEN30(SXBPK,1,0,LSZ,ABSR); COMP 8764 GEN15(SXXPB,6,2,0); COMP 8765 IF VARPARAM THEN (* UPDATE PARAMETER WORD *) COMP 8766 GEN15(SAAPB,6,2,0); COMP 8767 GEN15(AXJK,2,0,18); COMP 8768 GEN30(SXBPK,3,5,LDESC,ABSR); COMP 8769 RJTOEXT(EX[CPVEX]) COMP 8770 END COMP 8771 END; COMP 8772 IF NOT VARPARAM AND (LSZ <> 1) THEN COMP 8773 BEGIN (* COPY NON-SMALL VALUE PARAMETERS *) COMP 8774 IF CONFORMNT THEN COMP 8775 BEGIN COMP 8776 IF NOT FIRSTINPARMGROUP THEN GEN30(SABPK,1,5,LDESC,ABSR) COMP 8777 (* ELSE SIZE OF ARRAY LEFT IN X1 BY P.CPV *) COMP 8778 END COMP 8779 ELSE GENINC(SXBPK,1,0,LSZ); COMP 8780 IF CONFORMNT AND FIRSTINPARMGROUP THEN GEN15(BXX,2,6,6) COMP 8781 ELSE GENINC(SABPK,2,5,LDISP); COMP 8782 IF VACCESS = INDRCT THEN COMP 8783 BEGIN COMP 8784 EPILOGUEFLAG := TRUE; COMP 8785 RJTOEXT(EX[ACVEX]); (* ALLOCATE AND COPY VALUE PARAM *) COMP 8786 GENINC(SABPK,6,5,LDISP) (* UPDATE PARAM WORD *) COMP 8787 END COMP 8788 ELSE (* COPY INTO ACTIVATION RECORD *) COMP 8789 BEGIN COMP 8790 GEN30(SXBPK,3,5,VADDR,ABSR); (* DESTINATION ADDR *) COMP 8791 RJTOEXT(EX[CPVEX]); (* COPY PARAMETER VALUE *) COMP 8792 END COMP 8793 END COMP 8794 END; COMP 8795 FCP := NEXT; LDISP := SUCC(LDISP) COMP 8796 END COMP 8797 END (* INITPFPARAMS *) ; COMP 8798 COMP 8799 PROCEDURE COMMISSIONLOCALVARS(FCP: CTP); COMP 8800 BEGIN (* COMMISSIONLOCALVARS *) COMP 8801 IF FCP <> NIL THEN COMP 8802 WITH FCP^ DO COMP 8803 BEGIN COMP 8804 COMMISSIONLOCALVARS(LLINK); COMMISSIONLOCALVARS(RLINK); COMP 8805 IF (KLASS = VARS) AND (IDTYPE <> NIL) THEN COMP 8806 IF VKIND = ACTUAL THEN COMP 8807 BEGIN COMP 8808 IF VACCESS = INDRCT THEN COMP 8809 BEGIN (* ALLOCATE VERY-LARGE VARIABLE *) COMP 8810 EPILOGUEFLAG := TRUE; COMP 8811 GEN30(SXBPK,1,0,FULLWORDS(IDTYPE^.SIZE),ABSR); COMP 8812 RJTOEXT(EX[ALMEX]); (* ALLOCATE MEMORY *) COMP 8813 GEN30(SABPK,6,5,VADDR,ABSR); (* STORE ADDRESS *) COMP 8814 IF DEBUG THEN RJTOEXT(EX[INVEX]); COMP 8815 IF IDTYPE^.FTYPE THEN COMP 8816 COMMISSIONFILES(IDTYPE,FALSE,0,NIL) COMP 8817 END COMP 8818 ELSE (* VACCESS = DRCT *) COMP 8819 IF IDTYPE^.FTYPE THEN COMP 8820 BEGIN COMP 8821 EPILOGUEFLAG := TRUE; COMP 8822 COMMISSIONFILES(IDTYPE,TRUE,VADDR,NIL) COMP 8823 END COMP 8824 END COMP 8825 END COMP 8826 END (* COMMISSIONLOCALVARS *) ; COMP 8827 COMP 8828 PROCEDURE DECOMMISSIONVARS(FCP: CTP); COMP 8829 BEGIN (* DECOMMISSIONVARS *) COMP 8830 IF FCP <> NIL THEN COMP 8831 WITH FCP^ DO COMP 8832 BEGIN COMP 8833 DECOMMISSIONVARS(LLINK); DECOMMISSIONVARS(RLINK); COMP 8834 IF (KLASS = VARS) AND (IDTYPE <> NIL) THEN COMP 8835 IF NOT VARPARAM THEN COMP 8836 BEGIN COMP 8837 IF VACCESS = INDRCT THEN COMP 8838 BEGIN COMP 8839 IF IDTYPE^.FTYPE THEN COMP 8840 BEGIN COMP 8841 GEN30(SABPK,1,5,VADDR,ABSR); COMP 8842 GEN15(SBXPB,2,1,0); COMP 8843 DECOMMISSIONFILES(IDTYPE,FALSE,0) COMP 8844 END; COMP 8845 GEN30(SABPK,1,5,VADDR,ABSR); COMP 8846 RJTOEXT(EX[LIMEX]) COMP 8847 END COMP 8848 ELSE (* VACCESS = DRCT *) COMP 8849 IF IDTYPE^.FTYPE THEN COMP 8850 DECOMMISSIONFILES(IDTYPE,TRUE,VADDR) COMP 8851 END COMP 8852 END COMP 8853 END (* DECOMMISSIONVARS *) ; COMP 8854 COMP 8855 PROCEDURE PFEXIT; COMP 8856 VAR LATTR: ATTR; I: REGNR; COMP 8857 BEGIN (* PFEXIT *) COMP 8858 IF FPROCP^.KLASS = FUNC THEN COMP 8859 BEGIN (* LOAD FUNCTION RESULT *) COMP 8860 MAKEVARBLATTR(LATTR,FPROCP^.IDTYPE,LEVEL,FPROCP^.FIRSTVAR-1); COMP 8861 LOAD(LATTR,I); BXIXJ(6,I) COMP 8862 END; COMP 8863 IF QUICKMODE THEN COMP 8864 BEGIN COMP 8865 IF PC.CP = 2 THEN GEN30(SABPK,1,5,-1,ABSR) COMP 8866 ELSE GEN15(SABMB,1,5,1); COMP 8867 GENINC(SBBPK,6,5,-ARPS); COMP 8868 GEN15(SBXPB,5,1,0); COMP 8869 GEN15(LXJK,1,0,30); COMP 8870 GEN15(SBXPB,7,1,0); COMP 8871 GEN30(JP,7,0,0,ABSR) COMP 8872 END COMP 8873 ELSE EQTOEXT(EX[PEXEX]) COMP 8874 END (* PFEXIT *) ; COMP 8875 COMP 8876 PROCEDURE PMDINFO(FCP: CTP); COMP 8877 VAR LSP: STP; I,K: INTEGER; COMP 8878 COMP 8879 FUNCTION PMDTYP(FIDTYP: STP): INTEGER; COMP 8880 VAR I: INTEGER; COMP 8881 BEGIN COMP 8882 I := 0; COMP 8883 IF FIDTYP <> NIL THEN COMP 8884 BEGIN COMP 8885 IF FIDTYP^.FORM <= POINTER THEN COMP 8886 IF FIDTYP^.FORM = POINTER THEN COMP 8887 I := PMDUPTR + ORD(FIDTYP^.DBG) (* PMDUPTR+1=PMDCPTR *) COMP 8888 ELSE IF COMPTYPES(FIDTYP,INTPTR) THEN I := PMDINT COMP 8889 ELSE IF FIDTYP = REALPTR THEN I := PMDREAL COMP 8890 ELSE IF COMPTYPES(FIDTYP,CHARPTR) THEN I := PMDCHAR COMP 8891 ELSE IF COMPTYPES(FIDTYP,BOOLPTR) THEN I := PMDBOOL COMP 8892 ELSE I := PMDENUM COMP 8893 ELSE IF COMPTYPES(FIDTYP,ALFAPTR) THEN I := PMDALFA; COMP 8894 I := I * 2 COMP 8895 END; COMP 8896 PMDTYP := I COMP 8897 END (* PMDTYP *); COMP 8898 COMP 8899 BEGIN (* PMDINFO *) COMP 8900 IF FCP <> NIL THEN COMP 8901 WITH FCP^ DO COMP 8902 BEGIN PMDINFO(LLINK); COMP 8903 IF KLASS IN [VARS,BOUNDID] THEN COMP 8904 BEGIN I := PMDTYP(IDTYPE); COMP 8905 IF I <> 0 THEN COMP 8906 BEGIN COMP 8907 IF KLASS = VARS THEN COMP 8908 BEGIN K := VADDR; COMP 8909 IF VACCESS = INDRCT THEN I := I + 1 COMP 8910 END COMP 8911 ELSE K := BADDR; COMP 8912 ALFINT.A := NAME.TEN; GEN60(ALFINT.I); COMP 8913 GEN60(I * 1000000B + K) COMP 8914 END COMP 8915 END; COMP 8916 PMDINFO(RLINK) COMP 8917 END COMP 8918 END (*PMDINFO*) ; COMP 8919 COMP 8920 PROCEDURE PITINFO; COMP 8921 VAR STRUCTURES: RECORD CASE BOOLEAN OF COMP 8922 TRUE: (CVAL: INTEGER); COMP 8923 FALSE: (CNAM: ALFA) COMP 8924 END; COMP 8925 BEGIN (* PITINFO *) COMP 8926 IF MSOPTION < PSMAX THEN MSOPTION := PSMAX; COMP 8927 IF INITIALSPACE < MSOPTION+6 THEN COMP 8928 INITIALSPACE := MSOPTION+6; COMP 8929 (* ALSO FIGURE PMD STACK CHUNK AND GLOBAL BUFFERS? *) COMP 8930 WITH STRUCTURES DO COMP 8931 BEGIN SHORTNAME(EX[PITEX],CNAM); GEN60(CVAL); COMP 8932 CNAM := 'R.V.L DL '; CNAM[1] := CHR(RELNUM); COMP 8933 CNAM[3] := CHR(VERNUM); CNAM[5] := CHR(LEVNUM); COMP 8934 CNAM[6] := CHR(ASCFLAG); COMP 8935 CNAM[7] := CHR(LVERNUM); CNAM[8] := CHR(LLEVNUM); COMP 8936 CNAM[9] := COL; CNAM[10] := COL; GEN60(CVAL) COMP 8937 END; COMP 8938 GEN30(PS,0,0,0,PROGR); GEN30(PS,0,0,0,VARR); COMP 8939 GEN60( ( ORD(PMD <> PMDNONE) * 4 + V41DC06 40 ORD(EXTFILS > 0) * 2 + COMP 8941 ORD(ISSUESTAT) COMP 8942 ) * 10000000000000000000B + COMP 8943 ( ORD(MZOPTION) * 4 COMP 8944 ) * 1000000000000000000B ); COMP 8945 IF PMDFILEPTR = NIL THEN GEN60(0) V41DC06 41 ELSE V41DC06 42 BEGIN SEARCHEXTID(EX[PMDEX]); GEN30(PS,0,0,0,ABSR); V41DC06 43 GEN30(PS,0,0,PMDFILEPTR^.VADDR+TXTEFET,VARR) V41DC06 44 END; COMP 8951 GEN60( (ORD(INITIALREDUCE) * 4000000000B + INITIALSPACE) COMP 8952 * 10000000000B + MAXFL); COMP 8953 GEN60(MSOPTION*10000000000B + MXOPTION); (* STACK *) COMP 8954 GEN60( ((ORD(ALLOWINCREASE) * 4000000000B + MINDECREASE) COMP 8955 * 2 + ORD(ALLOWDECREASE)) * 4000000000B + MININCREASE) COMP 8956 END (* PITINFO *); COMP 8957 COMP 8958 PROCEDURE LGOHEAD(NAME: ALFA; BLOCKLENGTH: INTEGER); COMP 8959 TYPE STYPE= (WORD,ADRS,NAMS); COMP 8960 B18 = 0..777777B; COMP 8961 VAR PGNAME: INTEGER; I: INTEGER; LLP: LBP; COMP 8962 STRUCTURES: RECORD CASE STYPE OF COMP 8963 WORD: (CVAL: INTEGER); COMP 8964 NAMS: (CNAM: ALFA); COMP 8965 ADRS: (IDW: PACKED RECORD CN: 0..63; COMP 8966 WC: B18; LR: B18; L: B18 COMP 8967 END) COMP 8968 END; COMP 8969 BEGIN (* LGOHEAD *) V41DC05 500 WITH STRUCTURES DO COMP 8971 BEGIN CVAL := 0; IDW.CN := 77B; IDW.WC := 16B; (*PREFIX*) COMP 8972 LGO^:= CVAL; PUT(LGO); SHORTNAME(NAME,CNAM); IDW.L:= 0; COMP 8973 PGNAME:= CVAL; LGO^:= PGNAME; PUT(LGO); COMP 8974 CNAM := TODAY; LGO^ := CVAL*100B; PUT(LGO); COMP 8975 CNAM := NOW; LGO^ := CVAL*100B; PUT(LGO); COMP 8976 CNAM := OSNAME; LGO^ := CVAL; PUT(LGO); (*OPERATING SYSTEM*) COMP 8977 CNAM := COMPILERNAME; LGO^ := CVAL; PUT(LGO); (*COMPILER VERSION*) COMP 8978 CNAM := TENBLANKS; LGO^ := CVAL; PUT(LGO); (*UPDATE LEVEL*) COMP 8979 CNAM := ' I '; LGO^ := CVAL; PUT(LGO); (*HARDWARE SPEC*) COMP 8980 IF LEVEL = 1 THEN COMP 8981 IF NAME = PROGBLOCK THEN CNAM := 'PROGRAM ' COMP 8982 ELSE CNAM := 'MAIN VARS ' COMP 8983 ELSE COMP 8984 IF FPROCP^.KLASS = PROC THEN CNAM := 'PROCEDURE ' COMP 8985 ELSE CNAM := 'FUNCTION '; COMP 8986 LGO^ := CVAL; PUT(LGO); (*MODULE TYPE*) COMP 8987 IF LEVEL = 1 THEN CNAM := PROGNAME COMP 8988 ELSE CNAM := FPROCP^.NAME.TEN; COMP 8989 LGO^ := CVAL; PUT(LGO); (*MODULE NAME*) COMP 8990 FOR I := 1 TO 5 DO BEGIN LGO^ := 0; PUT(LGO) END; COMP 8991 CVAL := 0; IDW.CN := 70B; IDW.WC := 4; (*LDSET*) COMP 8992 LGO^ := CVAL; PUT(LGO); COMP 8993 CVAL := 0; IDW.WC := 100001B; LGO^ := CVAL; PUT(LGO); COMP 8994 RLIBNAME(CNAM); LGO^ := CVAL; PUT(LGO); COMP 8995 LGO^ := 00120001000000000001B; PUT(LGO); COMP 8996 LGO^ := 60000000000200400000B; PUT(LGO); COMP 8997 CVAL:= 0; IDW.CN:= 34B; (*PIDL*) COMP 8998 IF LEVEL = 1 THEN IDW.WC := 2 ELSE IDW.WC := 1; COMP 8999 LGO^ := CVAL; PUT(LGO); COMP 9000 CVAL := PGNAME; IDW.L := BLOCKLENGTH; LGO^ := CVAL; PUT(LGO); COMP 9001 IF LEVEL = 1 THEN COMP 9002 BEGIN COMP 9003 CNAM := TENBLANKS; IDW.L := 0; LGO^ := CVAL; PUT(LGO) COMP 9004 END; COMP 9005 CVAL:= 0; IDW.CN:= 36B; (*ENTR*) COMP 9006 (* COUNT NUMBER OF ADDITIONAL ENTRY POINTS *) COMP 9007 I := ORD(PITIC <> 0); COMP 9008 IF NAME <> EXTNAMES[VARR] THEN COMP 9009 BEGIN COMP 9010 LLP := FSTLABP; COMP 9011 WHILE LLP <> FLABP DO COMP 9012 WITH LLP^ DO COMP 9013 BEGIN IF EPT <> TENBLANKS THEN I := I + 1; COMP 9014 LLP := NEXTLAB COMP 9015 END COMP 9016 END; COMP 9017 IDW.WC := 2 * (I + 1); LGO^ := CVAL; PUT(LGO); COMP 9018 LGO^ := PGNAME; PUT(LGO); COMP 9019 LGO^ := 1000000B + EPTIC; COMP 9020 PUT(LGO); COMP 9021 IF PITIC <> 0 THEN COMP 9022 BEGIN SHORTNAME(EX[PITEX],CNAM); LGO^ := CVAL; PUT(LGO); COMP 9023 LGO^ := 1000000B+PITIC; PUT(LGO) COMP 9024 END; COMP 9025 IF NAME <> EXTNAMES[VARR] THEN COMP 9026 BEGIN LLP := FSTLABP; V41DC05 501 WHILE LLP <> FLABP DO V41DC05 502 WITH LLP^ DO V41DC05 503 BEGIN COMP 9030 IF EPT <> TENBLANKS THEN COMP 9031 BEGIN SHORTNAME(EPT,ALFINT.A); LGO^ := ALFINT.I; PUT(LGO); COMP 9032 IF DEFINED THEN COMP 9033 BEGIN CVAL := LABADDR; IDW.LR := 1; LGO^ := CVAL; COMP 9034 PUT(LGO) COMP 9035 END COMP 9036 END; COMP 9037 LLP := NEXTLAB V41DC05 504 END COMP 9044 END COMP 9045 END COMP 9046 END (*LGOHEAD*); COMP 9047 COMP 9048 PROCEDURE LGOEND; COMP 9049 TYPE STYP = (WORD,ADRS,HLFS,NAMS); COMP 9050 B18 = 0..777777B; B30 = 0..7777777777B; COMP 9051 HALFS= PACKED RECORD LH: B30; RH: B30 END; COMP 9052 VAR PAR: BOOLEAN; COMP 9053 STRUCTURES: RECORD CASE STYP OF COMP 9054 WORD: (CVAL: INTEGER); COMP 9055 HLFS: (HS: HALFS); COMP 9056 ADRS: (IDW: PACKED RECORD CN: 0..63; COMP 9057 WC: B18; LR: B18; L: B18 COMP 9058 END); COMP 9059 NAMS: (CNAM: ALFA) COMP 9060 END; COMP 9061 BUFF: RECORD CASE BOOLEAN OF COMP 9062 TRUE: (BUF0: INTEGER); COMP 9063 FALSE: (BHS: HALFS) COMP 9064 END; COMP 9065 WORDCNT: INTEGER; COMP 9066 COMP 9067 PROCEDURE EXTTOLGO(PTR: EXTIDP); COMP 9068 BEGIN (* EXTTOLGO *) COMP 9069 (* PTR <> NIL *) COMP 9070 WITH PTR^,BUFF,STRUCTURES DO COMP 9071 BEGIN COMP 9072 IF L <> NIL THEN EXTTOLGO(L); COMP 9073 IF R <> NIL THEN EXTTOLGO(R); COMP 9074 CNAM := EXID; COMP 9075 IF PAR THEN LGO^ := CVAL ELSE COMP 9076 BEGIN BHS.RH:= HS.LH; LGO^ := BUF0; BHS.LH := HS.RH END; COMP 9077 PUT(LGO); COMP 9078 WHILE REF <> NIL DO WITH REF^ DO COMP 9079 BEGIN COMP 9080 IF PAR THEN BHS.LH := LOC COMP 9081 ELSE BEGIN BHS.RH := LOC; LGO^ := BUF0; PUT(LGO) END; COMP 9082 PAR := NOT PAR; REF := LINK COMP 9083 END COMP 9084 END COMP 9085 END; (* EXTTOLGO *) COMP 9086 COMP 9087 BEGIN (* LGOEND *) COMP 9088 WITH STRUCTURES,BUFF DO COMP 9089 BEGIN COMP 9090 IF EXTROOT <> NIL THEN COMP 9091 BEGIN WORDCNT := EXTIDX + (EXTRX + 1) DIV 2; COMP 9092 IF WORDCNT >= 10000B THEN ERROR(256) COMP 9093 ELSE COMP 9094 BEGIN CVAL := 0; IDW.CN := 44B; IDW.WC := WORDCNT; (*LINK*) COMP 9095 LGO^ := CVAL; PUT(LGO); COMP 9096 PAR := TRUE; COMP 9097 EXTTOLGO(EXTROOT); COMP 9098 IF NOT PAR THEN COMP 9099 BEGIN BHS.RH := 0; LGO^ := BUF0; PUT(LGO) END COMP 9100 END COMP 9101 END; COMP 9102 IF LEVEL = 1 THEN COMP 9103 BEGIN COMP 9104 CVAL:= 0; IDW.CN:= 46B; IDW.WC:= 1; (*XFER*) COMP 9105 LGO^:= CVAL; PUT(LGO); COMP 9106 SHORTNAME(PROGBLOCK,CNAM); COMP 9107 IDW.L:= 0; LGO^:= CVAL; PUT(LGO) COMP 9108 END (* XFER *); COMP 9109 PUTSEG(LGO) COMP 9110 END COMP 9111 END (*LGOEND*); COMP 9112 COMP 9113 PROCEDURE LGOTEXT(EPT: ALFA); COMP 9114 TYPE B18 = 0..777777B; COMP 9115 VAR J,DISP: 0..15; CADDR: ADDRRANGE; COMP 9116 I,RCMAX: RCODERANGE; K: INTEGER; SEGP1,SEGP2: CODEP; COMP 9117 L,LCIX: INTEGER; COMP 9118 STRUCTURES: RECORD CASE BOOLEAN OF COMP 9119 TRUE: (CVAL: INTEGER); COMP 9120 FALSE: (IDW: PACKED RECORD CN: 0..63; COMP 9121 WC: B18; LR: B18; L: B18 COMP 9122 END) COMP 9123 END; COMP 9124 BEGIN (* LGOTEXT *) COMP 9125 CADDR := 0; COMP 9126 LGOHEAD(EPT,0); COMP 9127 WITH STRUCTURES, PC DO COMP 9128 BEGIN NOOP; COMP 9129 WHILE RCP < 15 DO COMP 9130 BEGIN RBUF := RBUF*16; RCP := RCP + 1 END; COMP 9131 WITH CSEGP^ DO COMP 9132 BEGIN CODE[CIX] := CBUF; RCODE[RCIX] := RBUF END; COMP 9133 SEGP1 := NIL; COMP 9134 REPEAT (* REVERSE LIST OF CODE SEGMENTS *) COMP 9135 WITH CSEGP^ DO COMP 9136 BEGIN SEGP2 := NXTSEG; NXTSEG := SEGP1; COMP 9137 SEGP1 := CSEGP; CSEGP := SEGP2 COMP 9138 END COMP 9139 UNTIL CSEGP = NIL; COMP 9140 IDW.CN := 40B; IDW.LR := 1; IDW.WC := 20B; COMP 9141 RCMAX := RCODEMAX; DISP := 15; COMP 9142 WITH PC DO COMP 9143 FOR K := 1 TO SIX DO COMP 9144 BEGIN LCIX := 1; COMP 9145 IF K = SIX THEN RCMAX := RCIX; COMP 9146 FOR I := 1 TO RCMAX DO COMP 9147 BEGIN IDW.L := CADDR; COMP 9148 IF (K = SIX) AND (I = RCMAX) THEN COMP 9149 BEGIN J := CIX MOD 15; COMP 9150 IF J <> 0 THEN COMP 9151 BEGIN DISP := J; IDW.WC := J + 1 END COMP 9152 END; COMP 9153 LGO^ := CVAL; PUT(LGO); COMP 9154 WITH SEGP1^ DO COMP 9155 BEGIN LGO^ := RCODE[I]; PUT(LGO); COMP 9156 FOR L := LCIX TO LCIX + DISP - 1 DO COMP 9157 BEGIN LGO^ := CODE[L]; PUT(LGO) END; COMP 9158 CADDR := CADDR + DISP; LCIX := LCIX + 15 COMP 9159 END COMP 9160 END; COMP 9161 SEGP1 := SEGP1^.NXTSEG COMP 9162 END (*FOR K*) COMP 9163 END (*WITH STRUCTURES,PC*) ; COMP 9164 LGOEND COMP 9165 END (*LGOTEXT*) ; COMP 9166 COMP 9167 PROCEDURE LGOVALUE; COMP 9168 VAR LWC: ADDRRANGE; COMP 9169 BEGIN (* LGOVALUE *) COMP 9170 EPTIC := ARPS; COMP 9171 PITIC := 0; COMP 9172 LGOHEAD(EXTNAMES[VARR],LCMAX+ARPS); COMP 9173 LWC := ARPS + MPLC + 1; (* ACTIVATION HEADER + RELOCATION *) COMP 9174 LGO^ := 40000000000001000000B COMP 9175 + LWC * 1000000000000B; PUT(LGO); (* TEXT *) COMP 9176 WHILE LWC <> 0 DO BEGIN LGO^ := 0; PUT(LGO); LWC := PRED(LWC) END; COMP 9177 IF VALUES <> NIL THEN COMP 9178 BEGIN RESET(VALUES^); COMP 9179 WHILE NOT EOS(VALUES^) DO COMP 9180 BEGIN LGO^ := VALUES^^; PUT(LGO); GET(VALUES^) END; COMP 9181 REWRITE(VALUES^) COMP 9182 END; COMP 9183 PUTSEG(LGO) COMP 9184 END (* LGOVALUE *); COMP 9185 COMP 9186 BEGIN (* BODY *) COMP 9187 SETLINENUM := FALSE; COMP 9188 DP := FALSE; RCIX := 0; RCP := 15; COMP 9189 WITH PC DO BEGIN SIX := 1; CIX := 0; CP := 4 END; COMP 9190 MNEW(CSEGP); CSEGP^.NXTSEG := NIL; COMP 9191 LEVELS := [0,LEVEL]; COMP 9192 BRG[0] := 6; BRG[LEVEL] := 5; COMP 9193 IC := 0; COMP 9194 EXT := NIL; EXTROOT := NIL; EXTIDX := 0; EXTRX := 0; COMP 9195 CLEARREGS; COMP 9196 EPILOGUEFLAG := FALSE; COMP 9197 IF LEVEL = 1 THEN (* PROGRAM BLOCK *) COMP 9198 BEGIN COMP 9199 HEADER(TRUE,FALSE,PROGNAME,EXTFILS,0); COMP 9200 (* BLOCK-ENTRY CODE *) COMP 9201 EPTIC := IC; COMP 9202 GEN30(SBBPK,7,0,EXTFILS,ABSR); RJTOEXT(EX[INITEX]); COMP 9203 IF PMD <> PMDNONE THEN RJTOEXT(EX[EEREX]); COMP 9204 (* PROLOGUE CODE *) COMP 9205 SETLINENUM := TRUE; COMP 9206 IF PMD <> PMDNONE THEN V41DC06 45 IF OUTPUTPTR = NIL THEN INITPMDFILE V41DC06 46 ELSE PMDFILEPTR := OUTPUTPTR; V41DC06 47 INITPROGPARAMS COMP 9207 END COMP 9208 ELSE (* PROCEDURE-BLOCK OR FUNCTION-BLOCK *) COMP 9209 BEGIN COMP 9210 (* COUNT PARAMETERS *) COMP 9211 PARAMS := 0; LCP := FPROCP^.PARAMLIST; COMP 9212 WHILE LCP <> NIL DO COMP 9213 BEGIN PARAMS := SUCC(PARAMS); LCP := LCP^.NEXT END; COMP 9214 PARAMSINREGS := FPROCP^.PFXOPT; COMP 9215 IF PARAMSINREGS > PARAMS THEN PARAMSINREGS := PARAMS; COMP 9216 (* BLOCK HEADER *) COMP 9217 HEADER(FALSE,FPROCP^.KLASS=FUNC,FPROCP^.NAME.TEN,PARAMS, COMP 9218 PARAMSINREGS); COMP 9219 (* BLOCK-ENTRY CODE *) COMP 9220 PFENTRY(ENTRYPC1,ENTRYPC2,QUICKENTRY,EPTIC); COMP 9221 (* PROLOGUE CODE *) COMP 9222 SETLINENUM := TRUE; COMP 9223 INITAR; COMP 9224 INITPFPARAMS(FPROCP^.PARAMLIST) COMP 9225 END; COMP 9226 COMMISSIONLOCALVARS(DISPLAY[LEVEL].FNAME); COMP 9227 (* STATEMENT CODE *) COMP 9228 LCMAX := LC; COMP 9229 PSMARK := 0; PSSTORE := 0; PSMAX := 0; COMP 9230 STMTLEVEL := 0; COMP 9231 STATEMENT(FSYS+[ENDSY],TRUE); COMP 9232 EXPECTSYMBOL(ENDSY,13); COMP 9233 (* EPILOGUE CODE *) COMP 9234 IF EPILOGUEFLAG THEN COMP 9235 BEGIN COMP 9236 IF LEVEL <> 1 THEN COMP 9237 BEGIN COMP 9238 SETLINENUM := FALSE; COMP 9239 NOOP; CLEARREGS; COMP 9240 BHWFIXES := BHWFIXES + IC * 10000000000B (* XITIC *) COMP 9241 END; COMP 9242 DECOMMISSIONVARS(DISPLAY[LEVEL].FNAME) COMP 9243 END; COMP 9244 (* BLOCK-EXIT CODE *) COMP 9245 IF LEVEL = 1 THEN EQTOEXT(EX[ENDEX]) ELSE PFEXIT; COMP 9246 IF ARPS + LCMAX + PSMAX > MAXADDR THEN COMP 9247 BEGIN LCMAX := PFLC; PSMAX := 0; ERROR(261) END; COMP 9248 (* LOCAL CONSTANTS *) COMP 9249 PMDFIXES := PMDFIXES + (EPTIC * 100000B + IC) * 100000B; COMP 9250 LCSP := FSTCSP; COMP 9251 WHILE LCSP <> NIL DO COMP 9252 WITH LCSP^ DO COMP 9253 BEGIN LOCP := CREF; COMP 9254 WHILE LOCP <> NIL DO COMP 9255 WITH LOCP^ DO COMP 9256 BEGIN INS(IC,LOC); LOCP := NXTREF END; COMP 9257 CREF := NIL; COMP 9258 LP := CSTP; COMP 9259 WHILE LP <> NIL DO COMP 9260 WITH LP^ DO COMP 9261 BEGIN GEN60(CSVAL); LP := NXTCSP END; COMP 9262 LCSP := NXTCSP COMP 9263 END; COMP 9264 FSTCSP := LFSTCSP; COMP 9265 (* LOCAL VARIABLE DESCRIPTIONS *) COMP 9266 IF PMD = PMDON THEN COMP 9267 BEGIN COMP 9268 PMDFIXES := PMDFIXES + IC; COMP 9269 PMDINFO(DISPLAY[LEVEL].FNAME); COMP 9270 GEN60(0) COMP 9271 END; COMP 9272 (* PROGRAM INFORMATION TABLE *) COMP 9273 IF LEVEL = 1 THEN COMP 9274 BEGIN COMP 9275 PITIC := IC; COMP 9276 PITINFO COMP 9277 END COMP 9278 ELSE PITIC := 0; COMP 9279 (* FIXUPS *) COMP 9280 INS(BHWFIXES + PSMAX * 1000000B + LCMAX + ARPS, BHWPC); COMP 9281 IF PMD = PMDON THEN INS(PMDFIXES,PMDPC); COMP 9282 IF LEVEL <> 1 THEN COMP 9283 BEGIN COMP 9284 IF QUICKENTRY THEN COMP 9285 BEGIN COMP 9286 INS(LCMAX+ARPS+PSMAX,ENTRYPC1); COMP 9287 INS(LCMAX+ARPS,ENTRYPC2) COMP 9288 END; COMP 9289 IF INITARFLAG THEN COMP 9290 INS(LCMAX-FPROCP^.FIRSTVAR+ORD(FPROCP^.KLASS = FUNC),INITARPC) COMP 9291 END; COMP 9292 (* CHECK FOR UNDEFINED LABELS: *) V41DC05 505 CHECKLABELS; V41DC05 506 (* WRITE OUT CODE SEGMENT *) COMP 9293 IF BINARYOPEN THEN V41DC05 507 IF LEVEL = 1 THEN V41DC05 508 BEGIN V41DC05 509 LGOTEXT(PROGBLOCK); V41DC05 510 LGOVALUE V41DC05 511 END V41DC05 512 ELSE LGOTEXT(FPROCP^.EPT); V41DC05 513 FSTLABP := FLABP V41DC05 514 END (* BODY *) ; COMP 9300 (*$L'PROCEDURE / FUNCTION BLOCK PROCESSOR.' *) COMP 9301 COMP 9302 COMP 9303 PROCEDURE CHECKPROGPARAMS; V41CC20 44 VAR LEXFILP: EXTFILEP; V41CC20 45 BEGIN (* CHECKPROGPARAMS *) V41DC05 515 LEXFILP := FEXFILP; V41CC20 47 WHILE LEXFILP <> NIL DO V41CC20 48 BEGIN V41CC20 49 IF LEXFILP^.FILECP = NIL THEN V41CC20 50 BEGIN ERROR(172); V41CC20 51 FLAGERROR; PUTERRMSG(' UNDECLARED FILE: ',FALSE); V41DC05 516 IF LISTINGOPEN THEN WRITELN(LISTING,LEXFILP^.FILENAME); V41DC05 517 IF ERRFILEOPEN THEN WRITELN(ERRFILE,LEXFILP^.FILENAME) V41DC05 518 END; V41CC20 54 LEXFILP := LEXFILP^.NXTP V41CC20 55 END V41CC20 56 END (* CHECKPROGPARAMS *) ; V41CC20 57 V41CC20 58 BEGIN (*BLOCK*) COMP 9304 FLABP := FSTLABP; LFSTCSP := FSTCSP; COMP 9305 BLOCKSCOPE := THISSCOPE; INORDER := TRUE; V41CC20 59 REPEAT COMP 9307 LFORWCNT := 0; V41CC20 60 IF (OPTS.DIALECT <> P6000) AND NOT INORDER THEN ERROR(22); V41DC05 519 DP := TRUE; COMP 9308 CHECKCONTEXT(BLOCKBEGSYS,18,FSYS); COMP 9309 IF SY = LABELSY THEN COMP 9310 BEGIN EPT1 := TENBLANKS; INSYMBOL; LABELDECLARATION END; COMP 9311 IF SY = CONSTSY THEN COMP 9312 BEGIN INSYMBOL; CONSTDECLARATION END; COMP 9313 IF SY = TYPESY THEN COMP 9314 BEGIN INSYMBOL; TYPEDECLARATION END; COMP 9315 IF SY = VARSY THEN COMP 9316 BEGIN INSYMBOL; VARDECLARATION END; COMP 9317 IF SY = VALUESY THEN COMP 9318 BEGIN EXTENSION(324); INSYMBOL; VALUEDECLARATION END; COMP 9319 WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO COMP 9320 BEGIN LSY := SY; EPT1 := TENBLANKS; INSYMBOL; COMP 9321 PROCEDUREDECLARATION(LSY) COMP 9322 END; COMP 9323 EXITLOOP := SY IN STATBEGSYS; COMP 9324 IF (OPTS.DIALECT = P6000) AND INORDER AND NOT EXITLOOP THEN V41DC05 520 EXTENSION(330); V41AC20 56 INORDER := FALSE; V41CC20 61 IF LFORWCNT > 0 THEN CHECKFORW(DISPLAY[LEVEL].FNAME); V41CC20 62 UNTIL EXITLOOP; V41AC20 58 IF LEVEL = 1 THEN CHECKPROGPARAMS; V41CC20 63 EXPECTSYMBOL(BEGINSY,17); COMP 9329 PMD := PMDOPT; COMP 9330 REPEAT BODY(FSYS+[CASESY]); COMP 9331 IF SY <> FSY THEN COMP 9332 BEGIN ERROR(6); SKIP(FSYS) END COMP 9333 UNTIL (SY = FSY)OR (SY IN BLOCKBEGSYS); COMP 9334 END (*BLOCK*) ; COMP 9335 (*$L'PROGRAM PROCESSOR.' *) COMP 9336 COMP 9337 COMP 9338 PROCEDURE PROGRAMME(FSYS: SETOFSYS); COMP 9339 (*SHOULD PREFERABLY SURROUND PROC BLOCK WHICH WAS NOT POSSIBLE*) COMP 9340 (*BEFORE BOOTSTRAP DUE TO COMPILER RESTRICTION ON PROC NESTING*) COMP 9341 LABEL 1; COMP 9342 VAR LEXFILP: EXTFILEP; LCP: CTP; COMP 9343 I : INTEGER; COMP 9344 BEGIN FEXFILP := NIL; COMP 9345 EXTFILS := 0; COMP 9346 IF SY = PROGRAMSY THEN COMP 9347 BEGIN EPT1 := TENBLANKS; EPT2 := TENBLANKS; INSYMBOL; COMP 9348 IF SY = IDENT THEN COMP 9349 BEGIN PROGNAME := ID.TEN; COMP 9350 IF EPT1 = ' ' THEN COMP 9351 BEGIN IF EXTON THEN PROGBLOCK := PROGNAME END COMP 9352 ELSE PROGBLOCK := EPT1; COMP 9353 IF EPT2 = ' ' THEN COMP 9354 BEGIN I := 6; WHILE PROGBLOCK[I] = ' ' DO I := I - 1; COMP 9355 EXTNAMES[VARR] := PROGBLOCK; EXTNAMES[VARR][I+1] := ';' COMP 9356 END COMP 9357 ELSE EXTNAMES[VARR] := EPT2; COMP 9358 INSYMBOL; COMP 9359 CHECKCONTEXT([SEMICOLON,LPARENT],7,FSYS); COMP 9360 IF SY = LPARENT THEN COMP 9361 BEGIN COMP 9362 REPEAT INSYMBOL; COMP 9363 IF SY = IDENT THEN COMP 9364 BEGIN COMP 9365 LCP := NIL; COMP 9366 IF (ID.TEN = KW[INPUTKW]) OR (ID.TEN = KW[OUTPUTKW]) THEN COMP 9367 BEGIN MNEW(LCP,VARS); COMP 9368 WITH LCP^ DO COMP 9369 BEGIN COPYID(LCP); IDTYPE := TEXTPTR; COMP 9370 KLASS := VARS; VACCESS := DRCT; NEXT := NIL; COMP 9371 VKIND := FORMAL; VARPARAM := FALSE; COMP 9372 VLEV := 1; VADDR := LC; VINIT := FALSE; COMP 9373 THREAT := FALSE; CONTROLVAR := FALSE; COMP 9374 CONFORMNT := FALSE; FIRSTINPARMGROUP := FALSE COMP 9375 END; COMP 9376 IF ID.TEN = KW[INPUTKW] THEN INPUTPTR := LCP COMP 9377 ELSE OUTPUTPTR := LCP; COMP 9378 ENTERID(LCP,BLCK); COMP 9379 LC := LC + TEXTPTR^.SIZE.WORDS COMP 9380 END; COMP 9381 IF EXTFILS = MAXFILES THEN ERROR(254) V41AC02 9 ELSE EXTFILS := EXTFILS + 1; V41AC02 10 LEXFILP := FEXFILP; COMP 9383 WHILE LEXFILP <> NIL DO COMP 9384 WITH LEXFILP^ DO COMP 9385 BEGIN COMP 9386 IF FILENAME = ID.TEN THEN COMP 9387 BEGIN ERROR(101); GOTO 1 END; COMP 9388 LEXFILP := NXTP COMP 9389 END; COMP 9390 1: MNEW(LEXFILP); COMP 9391 WITH LEXFILP^ DO COMP 9392 BEGIN FILENAME := ID.TEN; NXTP := FEXFILP; COMP 9393 FILECP := LCP; COMP 9394 TERMINAL := FALSE; COMP 9395 INSYMBOL; COMP 9396 IF OPTS.DIALECT = P6000 THEN V41DC05 521 BEGIN V41AC20 60 IF OP IN [RDIV,PLUS] THEN EXTENSION(329); V41AC20 61 WHILE OP IN [RDIV,PLUS] DO V41AC20 62 BEGIN V41AC20 63 IF OP = RDIV THEN TERMINAL := TRUE V41AC20 64 ELSE V41AC20 65 IF FILENAME = KW[INPUTKW] THEN V41AC20 66 INPUTPTR^.IDTYPE := STEXTPTR V41AC20 67 ELSE V41AC20 68 IF FILENAME = KW[OUTPUTKW] THEN V41AC20 69 OUTPUTPTR^.IDTYPE := STEXTPTR V41AC20 70 ELSE ERROR(6); V41AC20 71 INSYMBOL V41AC20 72 END V41AC20 73 END; COMP 9409 SYSLOC := EXTFILS + 1 COMP 9410 END; COMP 9411 FEXFILP := LEXFILP COMP 9412 END COMP 9413 ELSE ERROR(2); COMP 9414 CHECKCONTEXT([COMMA,RPARENT],6,FSYS) COMP 9415 UNTIL SY <> COMMA; COMP 9416 EXPECTSYMBOL(RPARENT,4) COMP 9417 END; COMP 9418 EXPECTSYMBOL(SEMICOLON,14) COMP 9419 END COMP 9420 ELSE BEGIN ERROR(2); SKIP(FSYS) END COMP 9421 END COMP 9422 ELSE BEGIN ERROR(3); SKIP(FSYS) END; COMP 9423 REPEAT BLOCK(FSYS,PERIOD,NIL) COMP 9424 UNTIL SY = PERIOD COMP 9425 END (*PROGRAMME*) ; COMP 9426 (*$L'INITIALIZATION ROUTINES.' *) COMP 9427 COMP 9428 COMP 9429 PROCEDURE ENTERNAME(KY: KEYWORD; KL: IDCLASS; PTR: STP); COMP 9430 VAR CP: CTP; COMP 9431 BEGIN COMP 9432 NEW(CP,PROC,PREDECLARED); COMP 9433 WITH CP^ DO COMP 9434 BEGIN NAME.TEN := KW[KY]; NAME.EXT := NIL; KLASS := KL; COMP 9435 PFDECKIND := PREDECLARED; IDTYPE := PTR; NEXT := NIL; KEY := KY COMP 9436 END; COMP 9437 ENTERID(CP,BLCK) COMP 9438 END (* ENTERNAME *); COMP 9439 V41AC19 6 PROCEDURE NONSTDTYPENTRIES; V41AC19 7 VAR SP: STP; V41AC19 8 BEGIN V41AC19 9 NEW(MARKERPTR,RECORDS); (*MARKER*) V41AC19 10 WITH MARKERPTR^ DO V41AC19 11 BEGIN FTYPE := FALSE; SIZE.WORDS := 1; SIZE.BITS := 0; V41AC19 12 FORM := RECORDS; PCKDREC := FALSE; V41CC07 356 FIELDIDTREE := NIL; FIELDLST := NIL; V41CC07 357 END; V41AC19 15 NEW(STEXTPTR,FILES); (*SEGTEXT*) V41AC19 16 WITH STEXTPTR^ DO V41AC19 17 BEGIN FILTYPE := CHARPTR; PCKDFIL := TRUE; FORM := FILES; V41AC19 18 BASEFILE := TEXTPTR; V41AC19 19 TEXTFILE := TRUE; SEGFILE := TRUE; FTYPE := TRUE; V41AC19 20 BSIZE := BUFFSZ + 1; V41AC19 21 WITH SIZE DO V41AC19 22 BEGIN V41AC19 23 IF OS = XSCOPE2 THEN WORDS := TXEFITSZ V41CC04 35 ELSE WORDS := TXEFETSZ; V41CC04 36 BITS := 0 V41AC19 26 END V41AC19 27 END; V41AC19 28 NEW(SP,SUBRANGE); (*1..ALFALENG*) V41AC19 29 WITH SP^ DO V41AC19 30 BEGIN FORM := SUBRANGE; RANGETYPE := INTPTR; FTYPE := FALSE; V41AC19 31 MIN.IVAL := 1; MAX.IVAL := ALFALENG; V41AC19 32 WITH SIZE DO V41AC19 33 BEGIN WORDS := 0; BITS := NROFBITS(ALFALENG) END; V41AC19 34 END; V41AC19 35 NEW(ALFAPTR,ARRAYS); (*ALFA*) V41AC19 36 WITH ALFAPTR^ DO V41AC19 37 BEGIN FORM := ARRAYS; FTYPE := FALSE; V41AC19 38 AELTYPE := CHARPTR; INXTYPE := SP; CONFORMANT := FALSE; V41AC19 39 PCKDARR := TRUE; PARTWORDELS := TRUE; ELSPERWORD := ALFALENG; V41AC19 40 WITH SIZE DO V41AC19 41 BEGIN WORDS := ALFALENG * CHARSIZE DIV WORDSIZE; V41AC19 42 BITS := ALFALENG * CHARSIZE MOD WORDSIZE V41AC19 43 END V41AC19 44 END V41AC19 45 END (* NONSTDTYPENTRIES *); V41AC19 46 COMP 9440 PROCEDURE NONSTDNAMENTRIES; V41AC19 47 VAR CP: CTP; K: KEYWORD; V41AC19 48 BEGIN COMP 9443 NEW(CP,TYPES); (*MARKER*) COMP 9450 WITH CP^ DO COMP 9451 BEGIN NAME.TEN := KW[MARKERKW]; NAME.EXT := NIL; COMP 9452 IDTYPE := MARKERPTR; KLASS := TYPES COMP 9453 END; COMP 9454 ENTERID(CP,BLCK); COMP 9455 NEW(CP,TYPES); (*ALFA*) COMP 9486 WITH CP^ DO COMP 9487 BEGIN NAME.TEN := KW[ALFAKW]; NAME.EXT := NIL; IDTYPE := ALFAPTR; COMP 9488 KLASS := TYPES COMP 9489 END; COMP 9490 ENTERID(CP,BLCK); COMP 9491 NEW(CP,KONST); (*COLON*) COMP 9492 WITH CP^ DO COMP 9493 BEGIN NAME.TEN := KW[COLKW]; NAME.EXT := NIL; IDTYPE := CHARPTR; COMP 9494 KLASS := KONST; NEXT := NIL; VALUES.IVAL := 0 COMP 9495 END; COMP 9496 ENTERID(CP,BLCK); COMP 9497 NEW(CP,KONST); (*PERCENT*) COMP 9498 WITH CP^ DO COMP 9499 BEGIN NAME.TEN := KW[PERKW]; NAME.EXT := NIL; IDTYPE := CHARPTR; COMP 9500 KLASS := KONST; NEXT := NIL; VALUES.IVAL := 63B COMP 9501 END; COMP 9502 ENTERID(CP,BLCK); COMP 9503 COMP 9504 FOR K := GETSEGKW TO HALTKW DO (*PROCS*) COMP 9505 ENTERNAME(K,PROC,NIL); COMP 9506 FOR K := EOSKW TO RELVALUEKW DO (*FUNCS*) V410C01 13 ENTERNAME(K,FUNC,NILPTR); COMP 9508 END (* NONSTDNAMENTRIES *); V41AC19 49 COMP 9510 PROCEDURE STDTYPENTRIES; COMP 9511 BEGIN COMP 9512 NEW(INTPTR,SCALAR,PREDECLARED); (*INTEGER*) COMP 9513 WITH INTPTR^ DO COMP 9514 BEGIN FORM := SCALAR; SCALKIND := PREDECLARED; FTYPE := FALSE; COMP 9515 WITH SIZE DO COMP 9516 BEGIN WORDS := 1; BITS := 0 END COMP 9517 END; COMP 9518 NEW(REALPTR,REALS); (*REAL*) COMP 9519 WITH REALPTR^ DO COMP 9520 BEGIN FORM := REALS; FTYPE := FALSE; COMP 9521 WITH SIZE DO COMP 9522 BEGIN WORDS := 1; BITS := 0 END COMP 9523 END; COMP 9524 NEW(CHARPTR,SCALAR,PREDECLARED); (*CHAR*) COMP 9525 WITH CHARPTR^ DO COMP 9526 BEGIN FORM := SCALAR; SCALKIND := PREDECLARED; FTYPE := FALSE; COMP 9527 WITH SIZE DO COMP 9528 BEGIN WORDS := 0; BITS := CHARSIZE END COMP 9529 END; COMP 9530 NEW(BOOLPTR,SCALAR,USERDECLARED); (*BOOLEAN*) COMP 9531 WITH BOOLPTR^ DO COMP 9532 BEGIN FORM := SCALAR; SCALKIND := USERDECLARED; FTYPE := FALSE; COMP 9533 WITH SIZE DO COMP 9534 BEGIN WORDS := 0; BITS := 1 END; COMP 9535 END; COMP 9536 NEW(NILPTR,POINTER); (*NIL*) COMP 9537 WITH NILPTR^ DO COMP 9538 BEGIN ELTYPE := NIL; FORM := POINTER; FTYPE := FALSE; COMP 9539 WITH SIZE DO COMP 9540 BEGIN WORDS := 0; BITS := 18 END COMP 9541 END; COMP 9542 NEW(TEXTPTR,FILES); (*TEXT*) COMP 9543 WITH TEXTPTR^ DO COMP 9544 BEGIN FILTYPE := CHARPTR; PCKDFIL := TRUE; FORM := FILES; COMP 9545 BASEFILE := TEXTPTR; COMP 9546 TEXTFILE := TRUE; SEGFILE := FALSE; FTYPE := TRUE; COMP 9547 BSIZE := BUFFSZ + 1; COMP 9548 WITH SIZE DO COMP 9549 BEGIN COMP 9550 IF OS = XSCOPE2 THEN WORDS := TXEFITSZ V41CC04 37 ELSE WORDS := TXEFETSZ; V41CC04 38 BITS := 0 COMP 9553 END COMP 9554 END; COMP 9555 END (*STDTYPENTRIES*); COMP 9556 COMP 9557 PROCEDURE STDNAMENTRIES; COMP 9558 VAR CP,CP1: CTP; K: KEYWORD; COMP 9559 BEGIN COMP 9560 NEW(CP,TYPES); (*INTEGER*) COMP 9561 WITH CP^ DO COMP 9562 BEGIN NAME.TEN := KW[INTEGERKW]; NAME.EXT := NIL; COMP 9563 IDTYPE := INTPTR; KLASS := TYPES COMP 9564 END; COMP 9565 ENTERID(CP,BLCK); COMP 9566 NEW(CP,TYPES); (*REAL*) COMP 9567 WITH CP^ DO COMP 9568 BEGIN NAME.TEN := KW[REALKW]; NAME.EXT := NIL; COMP 9569 IDTYPE := REALPTR; KLASS := TYPES COMP 9570 END; COMP 9571 ENTERID(CP,BLCK); COMP 9572 NEW(CP,TYPES); (*CHAR*) COMP 9573 WITH CP^ DO COMP 9574 BEGIN NAME.TEN := KW[CHARKW]; NAME.EXT := NIL; COMP 9575 IDTYPE := CHARPTR; KLASS := TYPES COMP 9576 END; COMP 9577 ENTERID(CP,BLCK); COMP 9578 NEW(CP,TYPES); (*BOOLEAN*) COMP 9579 WITH CP^ DO COMP 9580 BEGIN NAME.TEN := KW[BOOLEANKW]; NAME.EXT := NIL; COMP 9581 IDTYPE := BOOLPTR; KLASS := TYPES COMP 9582 END; COMP 9583 ENTERID(CP,BLCK); COMP 9584 NEW(CP,TYPES); (*TEXT*) COMP 9585 WITH CP^ DO COMP 9586 BEGIN NAME.TEN := KW[TEXTKW]; NAME.EXT := NIL; COMP 9587 IDTYPE := TEXTPTR; KLASS := TYPES COMP 9588 END; COMP 9589 ENTERID(CP,BLCK); COMP 9590 NEW(CP,KONST); (*MAXINT*) COMP 9591 WITH CP^ DO COMP 9592 BEGIN NAME.TEN := KW[MAXINTKW]; NAME.EXT := NIL; COMP 9593 IDTYPE := INTPTR; KLASS := KONST; COMP 9594 NEXT := NIL; VALUES.IVAL := 7777777777777777B; COMP 9595 END; COMP 9596 ENTERID(CP,BLCK); COMP 9597 CP1 := NIL; COMP 9598 FOR K := FALSEKW TO TRUEKW DO COMP 9599 BEGIN NEW(CP,KONST); (*FALSE,TRUE*) COMP 9600 WITH CP^ DO COMP 9601 BEGIN NAME.TEN := KW[K]; NAME.EXT := NIL; IDTYPE := BOOLPTR; COMP 9602 KLASS := KONST; NEXT := CP1; VALUES.IVAL := ORD(K=TRUEKW) COMP 9603 END; COMP 9604 ENTERID(CP,BLCK); CP1 := CP COMP 9605 END; COMP 9606 BOOLPTR^.FCONST := CP; COMP 9607 FOR K := GETKW TO DISPOSEKW DO (*PROCS*) COMP 9608 ENTERNAME(K,PROC,NIL); COMP 9609 FOR K := EOFKW TO SUCCKW DO (*FUNCS*) COMP 9610 ENTERNAME(K,FUNC,NILPTR); COMP 9611 FOR K := SINKW TO LNKW DO (*ARITHFUNCS*) COMP 9612 ENTERNAME(K,FUNC,REALPTR); COMP 9613 END (*STDNAMENTRIES*); COMP 9614 COMP 9615 PROCEDURE ENTERUNDECL; COMP 9616 BEGIN COMP 9617 NEW(UTYPPTR,TYPES); COMP 9618 WITH UTYPPTR^ DO COMP 9619 BEGIN NAME := EMPTYID; IDTYPE := NIL; KLASS := TYPES END; COMP 9620 NEW(UCSTPTR,KONST); COMP 9621 WITH UCSTPTR^ DO COMP 9622 BEGIN NAME := EMPTYID; IDTYPE := NIL; COMP 9623 NEXT := NIL; KLASS := KONST; VALUES.IVAL := 0 COMP 9624 END; COMP 9625 NEW(UVARPTR,VARS); COMP 9626 WITH UVARPTR^ DO COMP 9627 BEGIN NAME := EMPTYID; IDTYPE := NIL; NEXT := NIL; COMP 9628 KLASS := VARS; VACCESS := DRCT; CONFORMNT := FALSE; COMP 9629 VKIND := ACTUAL; VARPARAM := FALSE; COMP 9630 VINIT := FALSE; VADDR := 0; VLEV := 0; COMP 9631 THREAT := FALSE; CONTROLVAR := FALSE; FIRSTINPARMGROUP := FALSE COMP 9632 END; COMP 9633 NEW(UFLDPTR,FIELD); COMP 9634 WITH UFLDPTR^ DO COMP 9635 BEGIN NAME := EMPTYID; IDTYPE := NIL; COMP 9636 NEXT := NIL; KLASS := FIELD; FLDADDR := 0 COMP 9637 END; COMP 9638 NEW(UPRCPTR,PROC,USERDECLARED,ACTUAL); COMP 9639 WITH UPRCPTR^ DO COMP 9640 BEGIN NAME := EMPTYID; IDTYPE := NIL; COMP 9641 KLASS := PROC; PFDECKIND := USERDECLARED; PFKIND := ACTUAL; COMP 9642 PFXOPT:=4; COMP 9643 NEXT := NIL; PFDECL := DECL; PFLEV := 0; FIRSTVAR := PFLC; COMP 9644 PARAMLIST := NIL COMP 9645 END; COMP 9646 NEW(UFCTPTR,FUNC,USERDECLARED,ACTUAL); COMP 9647 WITH UFCTPTR^ DO COMP 9648 BEGIN NAME := EMPTYID; IDTYPE := NIL; COMP 9649 NEXT := NIL; KLASS := FUNC; PFDECKIND := USERDECLARED; COMP 9650 PFKIND := ACTUAL; PFXOPT := 4; COMP 9651 PFDECL := DECL; PFLEV := 0; FIRSTVAR := PFLC; COMP 9652 PARAMLIST := NIL COMP 9653 END COMP 9654 END (*ENTERUNDECL*) ; COMP 9655 COMP 9656 PROCEDURE CRACKCONTROLSTATEMENT; COMP 9657 CONST V41DC05 522 DEFPS6 = 63; (* DEFAULT PAGE SIZE AT 6 LINES PER INCH *) V41DC05 523 DEFPS8 = 84; (* DEFAULT PAGE SIZE AT 8 LINES PER INCH *) V41DC05 524 VAR ALTPD, PD : INTEGER; DSNAME : CH7; DEFPAGE : PAGESIZEREC; V41DC05 525 V41DC05 526 PROCEDURE CSERROR(ERR : INTEGER; KEY, VAL : CH7); V41DC05 527 BEGIN (* CSERROR *) V41DC05 528 CLOSEFILES; CSABORT(ERR,KEY,VAL) V41DC05 529 END (* CSERROR *); V41DC05 530 V41DC05 531 PROCEDURE PCS; V41DC05 532 VAR ARGL : ARGLIST; ARGC, I, DELIM, ERROR : INTEGER; V41DC05 533 KEY, VAL : CH7; EXITLOOP : BOOLEAN; P : CSPARAMS; V41DC05 534 BEGIN (* PCS *) V41DC05 535 CSARG(ARGL,ARGC); V41DC05 536 IF ARGC <> 0 THEN V41FC01 8 BEGIN I := 0; VAL := ' '; V41FC01 9 REPEAT V41FC01 10 ERROR := 1; I := I + 1; V41FC01 11 WITH ARGL[I] DO BEGIN KEY := N; DELIM := D END; V41FC01 12 P := IPM; CSPL[NOPM].PNAME := KEY; V41FC01 13 WHILE CSPL[P].PNAME <> KEY DO P := SUCC(P); V41FC01 14 IF P <> NOPM THEN ERROR := 2; V41FC01 15 WITH CSPL[P] DO V41FC01 16 IF NOT USED THEN V41FC01 17 IF DELIM IN [2,ORD('=')] THEN V41FC01 18 BEGIN I := I + 1; ERROR := 3; V41FC01 19 WITH ARGL[I] DO BEGIN VAL := N; DELIM := D END; V41FC01 20 IF VAL <> ' ' THEN V41FC01 21 IF ALLOWEQ THEN V41FC01 22 BEGIN ERROR := 0; V41FC01 23 CSPN[SETTING] := VAL; USED := TRUE V41FC01 24 END V41FC01 25 END V41FC01 26 ELSE V41FC01 27 BEGIN ERROR := 4; V41FC01 28 IF ALLOWNE THEN V41FC01 29 BEGIN ERROR := 0; V41FC01 30 IF ALTDEF <> 0 THEN CSPN[SETTING] := CSPN[ALTDEF]; V41FC01 31 USED := TRUE V41FC01 32 END V41FC01 33 END; V41FC01 34 EXITLOOP := NOT (DELIM IN [0,1,ORD(',')]) OR (I >= ARGC) OR V41FC01 35 (ERROR <> 0) V41FC01 36 UNTIL EXITLOOP; V41FC01 37 IF ERROR = 0 THEN V41FC01 38 IF NOT (DELIM IN [0,3,17B,ORD('/'),ORD('.'),ORD(')')]) THEN V41FC01 39 ERROR := 5; V41FC01 40 IF ERROR <> 0 THEN CSERROR(ERROR,KEY,VAL) V41FC01 41 END V41FC01 42 END (* PCS *); V41DC05 570 V41DC05 571 FUNCTION DTB(NUM : CH7) : INTEGER; V41DC05 572 VAR CH : CHAR; I, DIGIT, DEC, OCT : INTEGER; V41DC05 573 BEGIN (* DTB *) V41DC05 574 DEC := 0; OCT := 0; I := 1; CH := NUM[1]; V41DC05 575 IF CH IN ['0'..'9'] THEN V41DC05 576 BEGIN V41DC05 577 WHILE CH IN ['0'..'9'] DO V41DC05 578 BEGIN DIGIT := ORD(CH) - ORD('0'); V41DC05 579 DEC := DEC * 10 + DIGIT; V41DC05 580 IF DIGIT <= 7 THEN OCT := OCT * 8 + DIGIT V41DC05 581 ELSE OCT := -1; V41DC05 582 IF I = 7 THEN CH := ' ' V41DC05 583 ELSE BEGIN I := I + 1; CH := NUM[I] END V41DC05 584 END; V41DC05 585 IF CH IN ['B','D'] THEN V41DC05 586 BEGIN IF CH = 'B' THEN DEC := OCT; V41DC05 587 IF I = 7 THEN CH := ' ' ELSE CH := NUM[I+1] V41DC05 588 END V41DC05 589 END; V41DC05 590 IF CH <> ' ' THEN DEC := -1; V41DC05 591 DTB := DEC V41DC05 592 END (* DTB *); V41DC05 593 COMP 9659 PROCEDURE NEXTCHAR; COMP 9660 BEGIN (* NEXTCHAR *) COMP 9661 REPEAT CH := LINE[CHCNT]; COMP 9662 IF NOT (CH IN ['.',')']) THEN CHCNT := CHCNT + 1 COMP 9663 UNTIL CH <> ' ' COMP 9664 END (* NEXTCHAR *); COMP 9665 COMP 9666 BEGIN (* CRACKCONTROLSTATEMENT *) COMP 9667 IF EFD <> 0 THEN PCS; V41DC05 594 WITH OPTS DO V41DC05 595 BEGIN V41DC05 596 SOURCEFN := CSPN[CSPL[IPM].SETTING]; V41DC05 597 OUTPUTFN := CSPN[CSPL[LPM].SETTING]; V41DC05 598 BINARYFN := CSPN[CSPL[BPM].SETTING]; V41DC05 599 ERRORFN := CSPN[CSPL[EPM].SETTING]; V41DC05 600 LOADANDGO := CSPL[GOPM].USED; V41DC05 601 GETPAGE(DEFPAGE); ALTPD := 6 + 8 - DEFPAGE.PD; V41DC05 602 WITH CSPL[PDPM] DO V41DC05 603 IF USED THEN V41DC05 604 IF CSPN[SETTING] = ' ' THEN PD := ALTPD V41DC05 605 ELSE V41DC05 606 BEGIN PD := DTB(CSPN[SETTING]); V41DC05 607 IF NOT (PD IN [6,8]) THEN CSERROR(6,PNAME,CSPN[SETTING]) V41DC05 608 END V41DC05 609 ELSE PD := DEFPAGE.PD; V41DC05 610 EIGHTLPI := PD = 8; V41DC05 611 WITH CSPL[PSPM] DO V41DC05 612 IF USED THEN (* MUST BE EQUIVALENCED *) V41DC05 613 BEGIN PAGESIZE := DTB(CSPN[SETTING]); V41DC05 614 IF PAGESIZE < 0 THEN CSERROR(6,PNAME,CSPN[SETTING]) V41DC05 615 END V41DC05 616 ELSE V41DC05 617 BEGIN V41DC05 618 IF CSPL[PDPM].USED THEN V41DC05 619 IF EIGHTLPI THEN PAGESIZE := DEFPS8 V41DC05 620 ELSE PAGESIZE := DEFPS6 V41DC05 621 ELSE PAGESIZE := DEFPAGE.PS V41DC05 622 END; V41DC05 623 WITH CSPL[PLPM] DO V41DC05 624 BEGIN LINELIMIT := DTB(CSPN[SETTING]); V41DC05 625 IF LINELIMIT < 0 THEN CSERROR(6,PNAME,CSPN[SETTING]) V41DC05 626 END; V41DC05 627 WITH CSPL[REWPM] DO V41DC05 628 BEGIN MAKESET(CSPN[SETTING],REWINDF); V41DC05 629 IF NOT (REWINDF <= ['I','L','B','E']) THEN V41DC05 630 CSERROR(6,PNAME,CSPN[SETTING]) V41DC05 631 END; V41DC05 632 WITH CSPL[DSPM] DO V41DC05 633 BEGIN DSNAME := CSPN[SETTING]; V41DC05 634 IF DSNAME = 'P6000 ' THEN DIALECT := P6000 V41DC05 635 ELSE V41DC05 636 IF DSNAME = 'ANSI ' THEN DIALECT := ANSI V41DC05 637 ELSE V41DC05 638 IF DSNAME = 'ISO0 ' THEN DIALECT := ISO0 V41DC05 639 ELSE V41DC05 640 IF (DSNAME = 'ISO1 ') OR (DSNAME = 'ISO ') THEN V41DC05 641 DIALECT := ISO1 V41DC05 642 ELSE CSERROR(6,PNAME,CSPN[SETTING]) V41DC05 643 END V41DC05 644 END; V41DC05 645 UNPACKCS(LINE); V41DC05 646 CHCNT := 1; SOURCELENGTH := 80; NEXTCHAR; COMP 9669 REPEAT NEXTCHAR UNTIL CH IN ['/','.',')']; COMP 9670 IF CH = '/' THEN (* PROCESS OPTIONS: *) COMP 9671 BEGIN OPTIONS(NEXTCHAR); COMP 9672 IF NOT (CH IN ['.',')']) THEN CSERROR(5,' ',' ') V41DC05 647 END; COMP 9675 (* RESET CH := ' ', SO EVERYTHING IS NICE: *) COMP 9676 CH := ' ' COMP 9677 END (* CRACKCONTROLSTATEMENT *); COMP 9678 COMP 9679 PROCEDURE INITIALIZE; COMP 9680 VAR I : INTEGER; EMPTYSOURCE : BOOLEAN; V41DC05 648 BEGIN (* INITIALIZE *) COMP 9682 COMPILERNAME[8] := CHR(RELNUM); COMPILERNAME[10] := CHR(VERNUM); V41DC05 649 DATE(TODAY); TIME(NOW); CDATE(COMPILEDATE); V41DC05 650 CRACKCONTROLSTATEMENT; V41DC05 651 WITH OPTS DO V41DC05 652 BEGIN EMPTYSOURCE := SOURCEFN = '0 '; V41DC05 653 IF NOT EMPTYSOURCE THEN OPENT(SOURCE,SOURCEFN,FALSE); V41DC05 654 LISTINGOPEN := OUTPUTFN <> '0 '; V41EC08 7 IF LISTINGOPEN THEN OPENT(LISTING,OUTPUTFN,TRUE) V41EC08 8 ELSE BEGIN LISTON := FALSE; OLDLISTON := FALSE END; V41DC05 659 IF BINARYFN <> '0 ' THEN V41DC05 660 BEGIN OPENB(LGO,BINARYFN,TRUE); V41DC05 661 BINARYOPEN := TRUE V41DC05 662 END V41DC05 663 ELSE LOADANDGO := FALSE; V41DC05 664 IF ERRORFN <> '0 ' THEN V41DC05 665 IF ERRORFN <> OUTPUTFN THEN V41DC05 666 BEGIN OPENT(ERRFILE,ERRORFN,TRUE); V41DC05 667 ERRFILEOPEN := TRUE V41DC05 668 END; V41DC05 669 IF 'I' IN REWINDF THEN RESET(SOURCE); V41DC05 670 IF 'L' IN REWINDF THEN REWRITE(LISTING); V41DC05 671 IF ('B' IN REWINDF) OR LOADANDGO THEN REWRITE(LGO); V41DC05 672 IF 'E' IN REWINDF THEN REWRITE(ERRFILE); V41DC05 673 IF DIALECT <> P6000 THEN V41DC05 674 BEGIN OPTALLOWED := FALSE; V41DC05 675 EXTON := FALSE; OLDEXTON := FALSE V41DC05 676 END; V41DC05 677 PRNTLIMIT := LINELIMIT; OLDPRNTLIMIT := LINELIMIT; V41DC05 678 IF (PAGESIZE = 0) OR (PAGESIZE > 1000) THEN PAGESIZE := MAXINT V41DC05 679 ELSE IF PAGESIZE < 20 THEN PAGESIZE := 20; V41DC05 680 END; V41DC05 681 IF NOT EMPTYSOURCE THEN EMPTYSOURCE := EOS(SOURCE); V41DC05 682 IF EMPTYSOURCE THEN V41DC05 683 ABORT(' EMPTY SOURCE INPUT FILE.'); V41DC05 684 LINENUMBERS := SOURCE^ IN DIGITS; V41DC05 685 IF NOT LISTON THEN (* SUPPRESS ALL HEADERS *) LINESLEFT := MAXINT; V41DC05 686 NEXTCHSETUP(LINE,CH,CHCNT,SOURCELENGTH); V41DC05 687 NEW(IDSTART); IDEND := IDSTART; IDBREAK := NIL; V41DC05 688 I := MAXLINELEN - IDNAMEEXTLEN; V41DC05 689 WHILE I > ALFALENG DO V41DC05 690 BEGIN I := I - IDNAMEEXTLEN; V41DC05 691 NEW(IDEND^.EXTRA); IDEND := IDEND^.EXTRA V41DC05 692 END; V41DC05 693 IDEND^.EXTRA := NIL; V41DC05 694 BEGINLINE; V41DC05 695 CH := ' '; V41DC05 696 INSYMBOL; V41DC05 697 IF PMDOPT = PMDSUPPRESS THEN PMDOPT := PMDNONE; V41DC05 698 V41DC05 699 (*ENTER NAMES AND TYPES:*) V41DC05 700 (************************) V41DC05 701 V41DC05 702 TOP := 0; V41DC05 703 STDTYPENTRIES; STDNAMENTRIES; ENTERUNDECL; V41DC05 704 NONSTDTYPENTRIES; V41DC05 705 IF OPTS.DIALECT = P6000 THEN V41DC05 706 BEGIN TOP := -1; NONSTDNAMENTRIES END; V41DC05 707 TOP := 1; LEVEL := 1; V41DC05 708 CATTR.TYPTR := INTPTR; V41DC05 709 END (* INITIALIZE *); COMP 9721 COMP 9722 (*$L'ERROR MESSAGE PROCESSOR'*) COMP 9723 COMP 9724 COMP 9725 PROCEDURE EXPLAINERRORS; COMP 9726 CONST MINWARNING = 320; COMP 9727 VAR MSGSPRINTED,WARNINGSONLY: BOOLEAN; COMP 9728 INDEX: ERRINDEX; NEXT: INTEGER; COMP 9729 COMP 9730 PROCEDURE READERRORNUMBER; COMP 9731 BEGIN COMP 9732 IF EOF(ALTFILE) THEN NEXT := MAXINT COMP 9733 ELSE READ(ALTFILE,NEXT) COMP 9734 END (* READERRORNUMBER *); COMP 9735 COMP 9736 BEGIN (* EXPLAINERRORS *) COMP 9737 MSGSPRINTED := FALSE; WARNINGSONLY := TRUE; COMP 9738 SUBTITLE := BLANKTITLE; (* CLEAR SUBTITLE *) COMP 9739 FIND(ALTFILE,TENBLANKS,LANG[LANGUAGE]); COMP 9740 READERRORNUMBER; COMP 9741 FOR INDEX := 1 TO ERRMAX DO COMP 9742 IF ERLIST[INDEX] THEN COMP 9743 BEGIN COMP 9744 WHILE INDEX > NEXT DO COMP 9745 BEGIN READLN(ALTFILE); READERRORNUMBER END; COMP 9746 IF INDEX = NEXT THEN COMP 9747 BEGIN COMP 9748 IF INDEX < MINWARNING THEN WARNINGSONLY := FALSE; COMP 9749 IF NOT MSGSPRINTED THEN COMP 9750 BEGIN MSGSPRINTED := TRUE; V41DC05 710 IF LISTINGOPEN THEN V41DC05 711 BEGIN V41DC05 712 IF LISTON THEN V41DC05 713 BEGIN V41DC05 714 IF LINESLEFT < 5 THEN HEADING V41DC05 715 ELSE V41DC05 716 BEGIN WRITELN(LISTING); V41DC05 717 LINESLEFT := LINESLEFT - 2 V41DC05 718 END V41DC05 719 END; V41DC05 720 WRITELN(LISTING) V41DC05 721 END; V41DC05 722 IF ERRFILEOPEN THEN WRITELN(ERRFILE); V41DC05 723 CASE LANGUAGE OF V41DC05 724 ENGLISH: PUTERRMSG(' COMPILER ERROR MESSAGES:',TRUE); V41DC05 725 FRENCH : PUTERRMSG(' DICTIONNAIRE DES ERREURS:',TRUE); V41DC05 726 GERMAN : PUTERRMSG(' FEHLER-ZUSAMMENFASSUNG:',TRUE) V41DC05 727 END; V41DC05 728 IF LISTINGOPEN THEN V41DC05 729 BEGIN WRITELN(LISTING); V41DC05 730 IF LISTON THEN LINESLEFT := LINESLEFT - 2 V41DC05 731 END; V41DC05 732 IF ERRFILEOPEN THEN WRITELN(ERRFILE) V41DC05 733 END; V41DC05 734 LINELENGTH := 0; V41DC05 735 WHILE NOT EOLN(ALTFILE) DO V41DC05 736 BEGIN V41DC05 737 IF LINELENGTH < MAXLINELEN THEN V41DC05 738 BEGIN LINELENGTH := SUCC(LINELENGTH); V41DC05 739 LINE[LINELENGTH] := ALTFILE^ V41DC05 740 END; V41DC05 741 GET(ALTFILE) V41DC05 742 END; V41DC05 743 IF LISTINGOPEN THEN V41DC05 744 BEGIN IF LISTON AND (LINESLEFT < 1) THEN HEADING; V41DC05 745 WRITE(LISTING,INDEX:5); WRITELINE(LISTING); V41DC05 746 LINESLEFT := LINESLEFT - 1 V41DC05 747 END; V41DC05 748 IF ERRFILEOPEN THEN V41DC05 749 BEGIN WRITE(ERRFILE,INDEX:5); WRITELINE(ERRFILE) END V41DC05 750 END V41DC05 751 ELSE ABORT(' COMPILER ERROR--MISSING ERROR MESSAGES.') V41DC05 752 END; V41DC05 753 IF WARNINGSONLY AND MSGSPRINTED THEN COMP 9776 MESSAGE(' WARNINGS IN PASCAL PROGRAM.') COMP 9777 ELSE COMP 9778 BEGIN COMP 9779 IF BINARYOPEN THEN V41DC05 754 BEGIN V41DC05 755 LGO^ := 05222217222355111655B; PUT(LGO); (* 'ERRORS IN ' *) V41DC05 756 LGO^ := 20012303011455202217B; PUT(LGO); (* 'PASCAL PRO' *) V41DC05 757 LGO^ := 07220115575500000000B; PUT(LGO); (* 'GRAM. ' EOL *) V41DC05 758 PUTSEG(LGO) V41DC05 759 END; V41DC05 760 ABORT(' ERRORS IN PASCAL PROGRAM.') V41DC05 761 END COMP 9785 END (* EXPLAINERRORS *); COMP 9786 (*$L'MAIN PROGRAM.' *) COMP 9787 COMP 9788 COMP 9789 BEGIN (* PASCALCOMPILER *) COMP 9790 COMP 9791 INITIALIZE; COMP 9792 COMP 9793 (*COMPILE:*) COMP 9794 (**********) COMP 9795 COMP 9796 PROGRAMME(BLOCKBEGSYS+STATBEGSYS-[CASESY]); COMP 9799 ENDLINE; COMP 9800 IF NOT EOS(SOURCE) THEN COMP 9801 BEGIN FLAGERROR; V41DC05 762 PUTERRMSG(' LINES FOLLOWING END OF PROGRAM IGNORED.',TRUE); V41DC05 763 REPEAT BEGINLINE; ENDLINE UNTIL EOS(SOURCE) COMP 9804 END; COMP 9805 13: COMP 9806 IF ERRORS THEN EXPLAINERRORS; COMP 9809 IF LISTINGOPEN THEN V41DC05 764 IF OPTS.LOADANDGO AND LISTON THEN V41DC05 765 BEGIN WRITELN(LISTING); WRITELN(LISTING) END; V41DC05 766 CLOSEFILES; V41DC05 767 IF OPTS.LOADANDGO THEN LOADGO(LGO) V41DC05 768 END (* PASCALCOMPILER *). COMP 9815