diff --git a/SYMBOL/ESPOL_XVI_Dec76.crd b/SYMBOL/ESPOL_XVI_Dec76.crd new file mode 100644 index 0000000..6a50bb1 --- /dev/null +++ b/SYMBOL/ESPOL_XVI_Dec76.crd @@ -0,0 +1,6912 @@ +%#######################################################################00001000 +% 00001010 +% B-5700 ESPOL Compiler 00001020 +% Mark XVI.0.00 00001030 +% Oct 1, 1974 00001040 +% 00001050 +%#######################################################################00001060 +% 00001070 + COMMENT: * TITLE: B5500/B5700 Mark XVI System release * 00001072 + * FILE ID: SYMBOL/ESPOL TAPE ID: SYMBOL1/FILE000 * 00001073 + * This material is proprietary to Burroughs Corporation * 00001074 + * and is not to be reproduced, used, or disclosed * 00001075 + * except in accordance with program license or upon * 00001076 + * written authorization of the patent division of * 00001077 + * Burroughs Corporation, Detroit, Michigan 48232 * 00001078 + * * 00001079 + * COPYRIGHT (C) 1971, 1972, 1974 * 00001080 + * Burroughs Corporation * 00001081 + * AA320206 AA393180 AA332366 *; 00001082 +COMMENT#################################################################00001110 + ERROR MESSAGES 00001120 +########################################################################00001130 +% 00001140 +Error Number Routine:Error message 00002000 + 000 BLOCK: Declaration not followed by semicolon. 00003000 + 001 BLOCK: Identifier declared twice in same block. 00004000 + 002 PROCEDUREDEC: Specification part contains 00005000 + identifier not appearing in 00006000 + formal parameter part. 00007000 + 003 BLOCK: Non-identifier appears in identifier 00008000 + list declaration. 00009000 + 004 PROCEDUREDEC: Stream procedure declaration 00010000 + preceded by illegal declarator. 00011000 + 005 PROCEDUREDEC: Procedure declaration preceded 00012000 + by illegal declarator. 00013000 + 006 PROCEDUREDEC: Procedure identifier used before 00014000 + in same block(not forward). 00015000 + 007 PROCEDUREDEC: Procedure identifier not followed 00016000 + by ( or semicolon in procedure 00017000 + declaration. 00018000 + 008 PROCEDUREDEC: Formal parameter list not followed 00019000 + by ). 00020000 + 009 PROCEDUREDEC: Formal parameter part not followed 00021000 + by semicolon. 00022000 + 010 PROCEDUREDEC: Value part contains identifier 00023000 + which did not appear in formal 00024000 + parapart. 00025000 + 011 PROCEDUREDEC: Value part not ended by semicolon. 00026000 + 012 PROCEDUREDEC: Missing or illegal specification 00027000 + part. 00028000 + 013 PROCEDUREDEC: OWN used is array specification. 00029000 + 014 PROCEDUREDEC: SAVE used in array specification. 00030000 + 015 BLOCK: Declaration preceded by illegal declarator. 00031000 + 016 ARRAYDEC: Array id in declaration not followed 00032000 + by [ . 00033000 + 017 ARRAYDEC: Lower bound in array dec not 00034000 + followed by :. 00035000 + 018 ARRAYDEC: Bound pair list not followed by ]. 00036000 + 019 ARRAYSPEC: Illegal lower bound designator in 00037000 + array specification. 00038000 + 020 BLOCK: OWN appears immediately before 00039000 + identifier(no type). 00040000 + 021 BLOCK: SAVE appears immediately before 00041000 + identifier(no type). 00042000 + 022 BLOCK: STREAM appears immediately before 00043000 + identifier(the word PROCEDURE left 00044000 + out). 00045000 + 023 BLOCK: Declarator preceded illegally by 00046000 + another declaration. 00047000 + 024 PROCEDUREDEC: Label cannot be passed to function. 00048000 + 025 BLOCK: Declarator or specifier illegally 00049000 + preceded by OWN or SAVE or some 00050000 + other declarator. 00051000 + 026 FILEDEC: Missing ( in file dec. 00052000 + 027 FILEDEC: No. of buffers in file dec must be 00053000 + an unsigned integer. 00054000 + 028 FILEDEC: Illegal buffer part of save factor 00055000 + in file dec. 00056000 + 029 FILEDEC: Missing ) in file dec. 00057000 + 030 PROCEDUREDEC: Procedure type at actual declaration 00058000 + time different than at forward dec. 00059000 + 031 LISTDEC: Missing ( in listdec. 00060000 + 032 FORMATDEC: Missing ( in format dec. 00061000 + 033 SWITCHDEC: Switch dec does not have ← or 00062000 + forward after identifier. 00063000 + 034 SWITCHFILEDEC:Missing ← after filed. 00064000 + 035 SWITCHFILEDEC:Non file id appearing in declaration 00065000 + of switchfile. 00066000 + 036 SUPERFORMATDEC:Format id not followed by ← . 00067000 + 037 SUPERFORMATDEC:Missing ( at start of format phrase . 00068000 + 038 SUPERFORMATDEC:Format segment > 1022 words. 00069000 + 040 SEGMENT: Save code exceeds 4080 which kernel can h/l 00069100 +050 anywhere: Out of range of C relative addressing for constant 00069500 +051 BLOCK : Illegal F relative address exp in declaration 00069510 +052 BLOCK: Procedure whose body is not a block 00069520 +053 ARRAYDEC: Cant find right bracket in save array dec 00069530 +054 ARRAYDEC: Fill part of save array dec longer than size 00069540 +056 ARRAYDEC: Illegal dimension indicator in array dec 00069560 +057 SEGMENTSTART:Save storage not allowed with intrinsic option 00069570 + 098 IOSTMT: Illegal specifier in scope stmt: must be ≥15. 00069580 + 099 INLINE: Extra : in stream head. 00069590 + 100 anywhere: Undeclared identifier. 00070000 + 101 CHECKER: An attempt has been made to address an 00071000 + identifier which is local to one procedure and global00072000 + to another. If the quantity is a procedure name or 00073000 + an own variable this restriction is relaxed. 00074000 + 102 AEXP: Conditional expression is not of arithmetic type 00075000 + 103 PRIMARY: Primary may not begin with a quantity of this 00076000 + type. 00077000 + 104 anywhere: Missing right parenthesis. 00078000 + 105 anywhere: Missing left parenthesis. 00079000 + 106 PRIMARY: Primary may not start with declarator. 00080000 + 107 BEXP: The expression is not of boolean type. 00081000 + 108 EXPRSS: A relation may not ave conditional expressions 00082000 + as the arithmetic expressions. 00083000 + 109 BODSEC,SIMPBOD, and BODCOMP: The primary is not boolean. 00084000 + 110 BODCOMP: A non-boolean operator occurs in a boolean 00085000 + expression. 00086000 + 111 BOOPRIM: 00087000 + tional) may begin with a quantity of this type. 00088000 + 112 BOOPRIM: No expression (arithmetic, boolean, or designa- 00089000 + tional) may begin with a declaration. 00090000 + 113 PARSE: Either the syntax or the range of the literals for00091000 + a concatenate operator is incorrect. 00092000 + 114 DOTSYNTAX: Either the syntax or the range of the literals00093000 + for a partial word designator is incorrect. 00094000 + 115 DEXP: The expression is not of designational type. 00095000 + 116 IFCLAUSE: Missing then. 00096000 + 117 BANA: Missing left braket. 00097000 + 118 BANA: Missing right braket. 00098000 + 119 COMPOUNDTAIL: Missing semicolon or end. 00099000 + 120 COMPOUNDTAIL: Missing end. 00100000 + 121 ACTUALPARAPART: An indexed file may be passed by name 00101000 + only and only to a stream procedure - the stream 00102000 + procedure may not do a release on this type para- 00103000 + meter. 00104000 + 122 ACTUALPARAPART: Stream procedure may not have an 00105000 + expression passed to it by name. 00106000 + 123 ACTUALPARAPART: The actual and formal parameters do not 00107000 + agree as to type. 00108000 + 124 ACTUALPARAPART: Actual and formal arrays do not have same00109000 + number of dimensions. 00110000 + 125 ACTUALPARAPART: Stream procedures may not be passed as a 00111000 + parameter to a procedure. 00112000 + 126 ACTUALPARAPART: No actual parameter may begin with a 00113000 + quantity of this type. 00114000 + 127 ACTUALPARAPART: This type quantity may not be passed to a00115000 + stream procedure. 00116000 + 128 ACTUALPARAPART: Either actual and formal parameters do 00117000 + not agree as to number, or extra right parenthesis. 00118000 + 129 ACTUALPARAPART: Illegal parameter delimiter. 00119000 + 130 RELSESTMT: No file name. 00120000 + 131 DOSTMT: Missing until. 00121000 + 132 WHILESTMT: Missing do. 00122000 + 133 LABELR: Missing colon. 00123000 + 134 LABELR: The label was not declared in this block. 00124000 + 135 LABELR: The label has already occured. 00125000 + 136 FORMATPHRASE: Improper format editing phrase. 00126000 + 137 FORMATPHRASE: A format editing phrase does not have an 00127000 + integer where an integer is required. 00128000 + 138 FORMATPHRASE: The width is too small in E or F editing 00129000 + phrase. 00130000 + 139 TABLE: Define is nested more than eight deep. 00131000 + 140 NEXTENT: An integer in a format is greater than 1023. 00132000 + 141 SCANNER: Integer or identifier has more than 63 00133000 + characters 00134000 + 142 DEFINEGEN: A define contains more than 2047 characters 00135000 + (blank suppressed). 00136000 + 143 COMPOUNDTAIL: Extra end. 00137000 + 144 STMT: No statement may start with this type identifier. 00138000 + 145 STMT: No statement may start with this type quantity. 00139000 + 146 STMT: No statement may start with a declarator - may be 00140000 + a missing end of a procedure or a misplaced 00141000 + declaration. 00142000 + 147 SWITCHGEN: More than 256 expressions in a switch 00143000 + declaration. 00144000 + 148 GETSPACE: More than 1023 program reference table cells 00145000 + are required for this program. 00146000 + 149 GETSPACE: More than 255 stack cells are required for this00147000 + procedure. 00148000 + 150 ACTUALPARAPART: Constants may not be passed by name to 00149000 + stream procedures. 00150000 + 151 FORSTMT: Improper FOR index variable. 00151000 + 152 FORSTMT: Missing left arrow following index variable. 00152000 + 153 FORSTMT: Missing UNTIL or WHILE in STEP element. 00153000 + 154 FORSTMT: Missing DO in FOR clause. 00154000 + 155 IFEXP: Missing ELSE 00155000 + 156 LISTELEMENT: A designational expression may not be a list00156000 + element. 00157000 + 157 LISTELEMENT: A row designator may not be a list element. 00158000 + 158 LISTELEMENT: Missing right bracket in group of elements. 00159000 + 159 PROCSTMT: Illegal use of procedure or function identifier00160000 + 160 PURGE: Declared label does not occur. 00161000 + 161 PURGE: Declared forward procedure does not occur. 00162000 + 163 ZIPSTMT: Missing comma in ZIP statement 00163000 + 163 FORMATPHRASE: The width of a field is more than 63. 00164000 + 200 EMIT: Segment too large ( > 4093 syllables). 00165000 + 201 Simple variable: Partial word designator not left-most 00166000 + in a left part list. 00167000 + 202 Simple variable: Missing . or + . 00168000 + 203 Subscripted variable: Wrong number of subscripts in a non 00169000 + designator. 00170000 + 204 Subscripted variable: Missing ] in a row designator. 00171000 + 205 Subscripted variable: A row designator appears outside of 00172000 + an actual parameter list or fill statement. 00173000 + 206 Subscripted variable: Missing ]. 00174000 + 207 Subscripted variable: Missing [. 00175000 + 208 Subscripted variable: Wrong number of subscripts. 00176000 + 209 Subscripted variable: Partial word designator not left- 00177000 + most in a left part list. 00178000 + 210 Subscripted variable: Missing . or + . 00179000 + 211 Variable: Procedure id used outside of scope in left part.00180000 + 250 Stream stmt:Illegal stream statement. 00181000 + 251 Any stream stmt procedure: Missing ←. 00182000 + 252 Index: Missing + or - . 00183000 + 253 Index: Missing number or stream variable. 00184000 + 254 EMITC: Number>63 or number of labels+locals+formals>63. 00185000 + 255 DSS: Missing start in DS← lit statement. 00186000 + 256 Releases: Missing parenthesis or file identifier is not 00187000 + a formal parameter. 00188000 + 257 Gotos,Labels or Jumps: Label specified is not on the same 00189000 + nest level as a preceding appearance of the 00190000 + label. 00191000 + 258 Labels: Missing :. 00192000 + 259 Labels: Label appears more than once. 00193000 + 260 Gotos: Missing label in a GO TO or JUMP OUT statement. 00194000 + 261 Jumps: Missing OUT in JUMP OUT statement. 00195000 + 262 Nests: Missing parenthesis. 00196000 + 263 IFS:Missing SC in IF statement. 00197000 + 264 IFS: Missing relational in IF statement. 00198000 + 265 IFS: Missing alpha,DC or string in IF statement. 00199000 + 266 IFS: Missing THEN inIF statement. 00200000 + 267 FREDFIX: There are GO TO statements in which the label is 00201000 + undefined. 00202000 + 268 EMITC: A repeat index ≥64 was specified or too many 00203000 + formal parameters,locals and labels 00204000 + 269 TABLE: A constant is specified which is too large 00205000 + or too small. 00206000 + 281 DBLSTMT: Missing (. 00207000 + 282 DBLSTMT: Too many operators. 00208000 + 283 DBLSTMT: Too many operands. 00209000 + 284 DBLSTMT: Missing , . 00210000 + 285 DBLSTMT: Missing ) . 00211000 + 300 FILLSTMT: The identifier following "FILL" is not 00212000 + an array identifier. 00213000 + 301 FILLSTMT: Missing "WITH" in FILL statement. 00214000 + 302 FILLSTMT: Improper FILL element. 00215000 + 303 FILLSTMT: Non-octal character in octal fill. 00216000 + 304 FILLSTMT: Improper array row designator in fill. 00217000 + 305 FILLSTMT: Data in FILL exceeds 1023 words. 00218000 + 306 FILLSTMT: Odd number of parentheses in FILL. 00218110 + 400 MERRIMAC:Missing file id in monitor dec. 00219000 + 401 MERRIMAC:Missing left parenthesis in monitor dec. 00220000 + 402 MERRIMAC:Improper subscript for monitor list element. 00221000 + 403 MERRIMAC:Improper subscript expression delimiter in 00222000 + monitor list element. 00223000 + 404 MERRIMAC:Improper number of subscripts in monitor list 00224000 + element. 00225000 + 405 MERRIMAC:Label or switch monitored at improper level. 00226000 + 406 MERRIMAC:Improper monitor list element. 00227000 + 407 MERRIMAC:Missing right parenthesis in monitor declaration 00228000 + 408 MERRIMAC:Improper monitor declaration delimiter. 00229000 + 409 DMUP:Missing file identifier in dump declaration. 00230000 + 410 DMUP:Missing left parenthesis in dump declaration 00231000 + 411 DMUP:Subscripted variable in dump list has wrong number of00232000 + subscripts. 00233000 + 412 DMUP:Subscripted variable in dump list has wrong number of00234000 + subscripts. 00235000 + 413 DMUP:Improper array dump list element. 00236000 + 414 DMUP:Illegal dump list element. 00237000 + 415 DMUP:More than 100 labels appear as dump list elements 00238000 + in one DUMP declaration. 00239000 + 416 DMUP:Illegal dump list element delimiter. 00240000 + 417 DMUP:Illegal dump label in dump declaration. 00241000 + 418 DMUP:Missing colon in dump declaration. 00242000 + 419 DMUP:Improper dump declaration delimiter. 00243000 + 420 READSTMT:Missing left parenthesis in read statement. 00244000 + 421 READSTMT:Missing left parenthesis in read reverse 00245000 + statement. 00246000 + 422 READSTMT:Missing file in read statement. 00247000 + 423 READSTMT:Improper release indicator. 00248000 + 424 READSTMT:Improper file delimiter in read statement. 00249000 + 425 READSTMT:Improper format delimiter in read statement. 00250000 + 426 READSTMT:Improper delimiter for second parameter in read 00251000 + statement. 00252000 + 427 READSTMT:Improper row designator in read statement. 00253000 + 428 READSTMT:Improper row designator delimiter in read 00254000 + statement. 00255000 + 429 READSTMT:Missing row designator in read statement. 00256000 + 430 READSTMT:Improper delimiter preceding the list in a read 00257000 + statement. 00258000 + 431 HandleTheTailEndOfAReadOrSpaceStatement:Improper end of 00259000 + file label in read or space statement. 00260000 + 432 HandleTheTailEndOfAReadOrSpaceStatement:Improper parity 00261000 + label in read or space statement. 00262000 + 433 HandleTheTailEndOfAReadOrSpaceStatement:Missing 00263000 + bracket in read or space statement. 00264000 + 434 SPACESTMT:Missing left parenthesis in space statement. 00265000 + 435 SPACESTMT:Improper file identifier in space statement. 00266000 + 436 SPACESTMT:Missing comma in space statement. 00267000 + 437 SPACESTMT:Missing right parenthesis in space statement. 00268000 + 438 WRITESTMT:Missing left parenthesis in a write statement. 00269000 + 439 WRITESTMT:Improper file identifier in a write statement. 00270000 + 440 WRITESTMT:Improper delimiter for first parameter in a 00271000 + write statement. 00272000 + 441 WRITESTMT:Missing right bracket in carriage control part 00273000 + of a write statement. 00274000 + 442 WRITESTMT:Illegal carriage control delimiter in a write 00275000 + statement. 00276000 + 443 WRITESTMT:Improper second parameter delimiter in write 00277000 + statement. 00278000 + 444 WRITESTMT:Improper row designator in a write statement. 00279000 + 445 WRITESTMT:Missing right parenthesis after a row designator00280000 + in a write statement. 00281000 + 446 WRITESTMT:Missing row designator in a write statement. 00282000 + 447 WRITESTMT:Improper delimiter preceeding a list in a write 00283000 + statement. 00284000 + 448 WRITESTMT:Improper list delimiter in a write statement. 00285000 + 449 READSTMT:Improper list delimiter in a read statement. 00286000 + 450 LOCKSTMT:Missing left parenthesis in a lock statement. 00287000 + 451 LOCKSTMT:Improper fiel part in a lock statement. 00288000 + 452 LOCKSTMT:Missing comma in a lock statement. 00289000 + 453 LOCKSTMT:Improper unit disposition part in a lock 00290000 + statement. 00291000 + 454 LOCKSTMT:Missing right parenthesis in a lock statement. 00292000 + 455 CLOSESTMT:Missing left parenthesis in a close statement. 00293000 + 456 CLOSESTMT:Improper file part in a close statement. 00294000 + 457 CLOSESTMT:Missing comma in a close statement. 00295000 + 458 CLOSESTMT:Improper unit disposition part in a close 00296000 + statement. 00297000 + 459 CLOSESTMT: 00298000 + 460 RWNDSTMT:Missing left parentheses in a REWIND statement. 00299000 + 461 RWNDSTMT:Improper file part in a REWIND statement. 00300000 + 462 RWNDSTMT:Missing right parenthesis in a rewind statement. 00301000 + 463 BLOCK:A monitor declaration appears in the specification 00302000 + part of a procedure. 00303000 + 464 BLOCK:A dump declaration appears in the specification part00304000 + of a procedure. 00305000 + 465 INLINE: Missing parameter identifier in inside stream 00305001 + statement parameter list. 00305002 +500 .ID: Needs double period for prte if past 512 00305100 + 520 TABLE: String longer than one word (48 bits). 00305200 + 521 TABLE: String contains a non-permissible character. 00305300 + 600 DOLLARCARD: Number expected. 00400000 + 601 DOLLARCARD: Option identifier expected. 00401000 + 602 DOLLARCARD: Too many user-defined options. 00403000 + 603 DOLLARCARD: Unrecognized word or character. 00404000 + 604 DOLLARCARD: Mismatched parentheses. 00405000 + 605 DOLLARCARD: $ in card column 1 for omit card 00406000 + 610 READACARD: Sequence error. 00410000 + 611 READACARD: Error limit has been exceeded. 00411000 + ; 00490000 +begin comment Outermost block; 00500000 + integer errorcount; comment number of error msgs. MCP will type 00501000 + syntax err at EOJ if this is non-zero, must be @R+25;00502000 + integer savetime; comment save-factor for code file,given by MCP. 00503000 + If compile & go =0, for syntax, =-1. Must be at R+26;00504000 + integer cardnumber; % seq # of card being processed. 00504100 + integer cardcount; % number of cards processed, 00504150 + boolean buildline; 00504700 + comment RR1-RR11 are used in some procedures in 00505000 + place of locals to save stack space; 00506000 + real RR1,RR2,RR3,RR4,RR5,RR6,RR7,RR8,RR9,RR10,RR11; 00507000 + comment Some of the RRi are used to pass file information 00508000 + to the main block; 00509000 + comment EXAMIN returns the character at absolute address NCR; 00510000 + real stream procedure examin(ncr); value ncr; 00511000 + begin si←NCR;DI←LOC EXAMIN;DI←DI+7; DS←CHR end; 00512000 + integer stream procedure getf(q);value q; 00523000 + begin SI←LOC getf; SI←SI-7;DI←LOC Q;DI←DI+5; 00524000 + skip 3 DB; 9(if SB then DS←set else DS←reset; skip sb); 00525000 + DI←LOC q;SI←q;DS←WDS;SI←Q;getf←SI 00526000 + end getf; 00527000 + comment start setting up file parameters; 00528000 + if examin(RR11←getf(3)+"Y08") ≠12 then RR1←5 else 00529000 + begin rr1←2;RR2←150 end; 00530000 + if examin(RR11+5) ≠ 12 then RR3←4 else 00531000 + begin RR3←2; RR4←150 end; 00532000 + if examin(RR11+10)=12 then 00533000 + begin RR5←2;RR6←10;RR7←150 end else 00534000 + begin RR5←1;RR6←56;RR7←10 end; 00535000 + if examin(RR11+15)=12 then 00536000 + begin RR8←10;RR9←150 end else 00537000 + begin RR8←56;RR9←10 end; 00538000 + begin comment main block; 01000000 + integer opinx; % used for indexing into options array. 01000800 + boolean setting; % used by dollarcard for options setting. 01000802 + integer newinx, addvalue, basenum, totalno; 01000860 + define oparsize = 200 #; 01000902 + array options[0:oparsize]; 01000904 + boolean optionword; 01000910 + define checkbit = 1#, 01000920 + debugbit = 2#, 01000930 + deckbit = 3#, 01000940 + formatbit = 4#, 01000950 + intbit = 5#, 01000960 + listabit = 6#, 01000970 + listbit = 7#, 01000980 + listpbit = 8#, 01000990 + mcpbit = 9#, 01001000 + mergebit = 10#, 01001010 + nestbit = 11#, 01001020 + newbit = 12#, 01001030 + newinclbit = 13#, 01001040 + omitbit = 14#, 01001050 + printdollarbit = 15#, 01001060 + prtbit = 16#, 01001070 + punchbit = 17#, 01001080 + purgebit = 18#, 01001090 + segsbit = 19#, 01001100 + seqbit = 20#, 01001110 + seqerrbit = 21#, 01001120 + singlbit = 22#, 01001130 + stuffbit = 23#, 01001140 + voidbit = 24#, 01001150 + voidtbit = 25#, 01001160 + useropinx = 26#; 01001170 + comment If a new compiler-defined option is added, change useropinx 01001180 + and add option in defines elow, in dollarcard, and in 01001190 + fill statement in initialization of compiler; 01001200 + define checktog = optionword.[checkbit:1] #, 01001210 + debugtog = optionword.[debugbit:1] #, 01001220 + decktog = optionword.[deckbit:1] #, 01001230 + formatog = optionword.[formatbit:1] #, 01001240 + intog = optionword.[intbit:1] #, 01001250 + listatog = optionword.[listabit:1] #, 01001260 + listog = optionword.[listbit:1] #, 01001270 + listptog = optionword.[listpbit:1] #, 01001280 + mcptog = optionword.[mcpbit:1] #, 01001290 + mergetog = optionword.[mergebit:1] #, 01001300 + nestog = optionword.[nestbit:1] #, 01001310 + newtog = optionword.[newbit:1] #, 01001320 + newincl = optionword.[newinclbit:1] #, 01001330 + omitting = optionword.[omitbit:1] #, 01001340 + printdollartog = optionword.[printdollarbit:1] #, 01001350 + prtog = optionword.[prtbit:1] #, 01001360 + punchtog = optionword.[punchbit:1] #, 01001370 + purgetog = optionword.[purgebit:1] #, 01001380 + segstog = optionword.[segsbit:1] #, 01001390 + seqtog = optionword.[seqbit:1] #, 01001400 +comment seqtog indicates resequencing is to be done; 01001410 + seqerrtog = optionword.[seqerrbit:1] #, 01001420 + singltog = optionword.[singlbit:1] #, 01001430 + stufftog = optionword.[stuffbit:1] #, 01001440 + voiding = optionword.[voidbit:1] #, 01001450 + voidtape = optionword.[voidtbit] #, 01001460 + dummy = #; 01001470 + boolean noheading; % true if datime has not yet been called. 01001480 + boolean newbase; % New basenum found on a new $-card. 01001490 + boolean lastcrdpatch; % Normally false, set to true when the 01001500 + % last card from symbolic library read 01001510 + % is patched from the card reader. 01001520 + integer xmode; % Tells dollarcard how to set options. 01001530 + boolean dollartog; % True if scanning a dollar card. 01001540 + integer errmax; % Compilation stops if exceeded. 01001550 + boolean seqxeqtog; % Give seq. no. when ds-ing obj. 01001560 +boolean lister; % Listog or listatog or debugtog. 01001570 +alpha medium; % Input is: T,C,P,CA,CB,CC. 01001580 +integer myclass; % Used in dollarcard evaluation. 01001590 +real batman; % used in dollarcard evaluation. 01001600 +array special[0:31]; 01003000 + comment This array holds the internal code for the special 01004000 + characters: it is filled during initialization. 01005000 + 01006000 +array info [0:127,0:255]; 01007000 + comment info contains all the information about a given identifier 01008000 + or reserved word. The first word of a given entry is 01009000 + the internal code ( or elbat word as it is usually 01010000 + called). The second word contains the forward bit (in 01011000 + [1:1]) for procedures, the link to previous entry (in 01012000 + [4:8]), the number of characters in the alpha representa- 01013000 + tion (in [12:6]), and the first 5 characters of alpha. 01014000 + Succeding words contain the remaining charactors of alpha,01015000 + followed by any additional information. The elbat word 01016000 + and the alpha for any quantity are not split across a row 01017000 + of info. For purposes of finding an identifier or 01018000 + reserved word the quantities are scattered into 125 01019000 + diferent lists or stacks. Which stack contains a quantity 01020000 + is given by taking NAAAAA mod 125 where N is the number 01021000 + of characters and AAAAA is the first 5 characters of 01022000 + alpha, filled in with zeros from the right if needed. 01023000 + This number is called the scramble number or index. 01024000 + The first row of info is used for other purposes. The 01025000 + reserved word occupy the second row. It is filled during 01026000 + initialization; 01027000 +comment info format 01028000 + Following is a description of the format of all types of entires 01029000 + entered in info: 01030000 + The first word of all entries is the elbat word. 01031000 + The incr field ([27:8]) contains an increment which when 01032000 + added to the current index into info yelds an index to any 01033000 + additional info (if any) for this entry. 01034000 + e.g. If the index is IX then INFO[(IX+INCR).LINKR,(IX+INCR). 01035000 + LINKC] will contain the first word of additional info. 01036000 + The link field of the elbat word in info is different from 01037000 + that of the entry in elbat put in by table.The entry in elbat 01038000 + points to its own location (relative) in info. 01039000 + The link in info points to the previous entry e.g.,the 01040000 + link from stackhead which the current entry replaced. 01041000 + For simplicity,I will consider info to be a one dimensional 01042000 + array,so that the breaking up of the links into row and column 01043000 + will not detract from the discussion. 01044000 + Assume that three identifiers A,B,and C "scramble" into 01045000 + the same stackhead location in the order of appearance. 01046000 + Further assume there are no other entries connected to 01047000 + this stackhead index. Let this stackhead location be 01048000 + S[L] 01049000 + Now the declaration 01050000 + BEGIN REAL A,BC is encountered 01051000 + if the next available info space is called nextinfo 01052000 + then A is entered as follows:(assume an elbat word T has been 01053000 + constructed for A) 01054000 + T,LINK← S[L]. (which is ero at first). 01055000 + info[nextinfo]←T. S[L]←nextinfo. 01056000 + nextinfo←nextinfo+number of words in this 01057000 + entry. 01058000 + Now S[L] points to the entry for A in info and the entry 01059000 + itself contains the stop flag zero. 01060000 + B is entered similarily to A. 01061000 + Now S[L} points to the entry for B and it points to the 01062000 + entry for A. 01063000 + Similarily,after C is entered 01064000 + S[L] points to C,whose entry ponts to B whose entry 01065000 + points to A. 01066000 + The second word of each entry in info is made up as follows: 01067000 + FWDPT =[1:1],this tells whether a procedure was declared 01068000 + forward. It is reset at the time of its actual 01069000 + full declaration. 01070000 + PURPT =[4:8] This gives a decrement which gives the relative 01071000 + index to the previous info entry when subtracted 01072000 + from the current entry index. 01073000 + [12:6] tells the number of characters in the entry.(<64) 01074000 + [18:30] contains the first five alpa characters of the entry 01075000 + and succeeding words contain all overflow if needed. 01076000 + these words contain 8 characters each,left justified. 01077000 + Thus,an entry for SYMBOL followed by an entry 01078000 + for X would appear as follows: 01079000 + info[I] = elbatwrd (made for SYMBOL) 01080000 + I+1 = OP6SYMBO (P depends on previous entry) 01081000 + I+2 = L 01082000 + I+3 = elbatwrd (made for X) 01083000 + I+4 = 031X 01084000 + This shows that info[I-P] would point to the beginning of 01085000 + the entry before SYMBOL, and 01086000 + info[I+3-3] points to the entry for SYMBOL. 01087000 + All entries of identifiers have the information described above 01088000 + that is,the elbat word followed by the word containing the first 01089000 + five characters of alpha,and any additional words of alpha if 01090000 + necessary. 01091000 + This is sufficient for entries of the following types, 01092000 + REAL 01093000 + BOOLEAN 01094000 + INTEGER 01095000 + ALPHA 01096000 + FILE 01097000 + FORMAT 01098000 + LIST 01099000 + other entries require additional information. 01100000 + arrays: 01101000 + The first word of additional info contains the number of 01102000 + dimensions(in the low order part),[40:8] 01103000 + Each succeeding word contains information about each lower 01104000 + bound in order of appearance,one word for each lower bound. 01105000 + These words are made up as follows: 01106000 + [23:12] =Add operator syllable (0101) or 01107000 + sub operator syllable (0301) corresponding 01108000 + respectively to whether the lower bound is 01109000 + to be added to the subscript in indexing or 01110000 + subtracted. 01111000 + [35:11] =11 bit address of lower bound,if the lower bound 01112000 + requires a PRT or stack cell,otherwise the bit 01113000 + 35 is ignored and the next ten bits([36:10]) 01114000 + represent the actual value of the lower bound 01115000 + [46:2] =00 or 10 Depending on whether the [35:11] value 01116000 + is literal or operand respectively. 01117000 + Procedures: 01118000 + The first word of additional info contains the number of 01119000 + parameters [40:8] 01120000 + If a stream procedure then this word contains also in 01121000 + [13:11] ending PRT address for labels, 01122000 + [ 7:6] No of labels requiring PRT addresses,and [1:6] number 01123000 + of locals. 01124000 + Succeeding words (one for each formal parameter,in order 01125000 + of appearance in formal parapart) are 01126000 + elbat words specifying type of each parameter and whether 01127000 + value or not([10:1]). 01128000 + The address([16:11]) is the F- address for each. 01129000 + If the parameter is an array then the incr field([27:8]) 01130000 + contains the number of dimensions,otherwise incr is meaningless. 01131000 + Link([35:13]) is meaningless. 01132000 + If a stream procedure then the class of each parameter is 01133000 + that of local id or file id, depending on whether or not a release01134000 + is done in the stream procedure. 01135000 + Labels: 01136000 + At declaration time the additional info contains 0. The sign 01137000 + bit tells whether or not the definition point has been reached. 01138000 + If sign = 0, then [36:12] contains an address in codearray of a 01139000 + list of forward reference to this label. The end of list flag is 01140000 + 0. If sign =9, then [36:12] contains L for this label. 01141000 + Switches: 01142000 + The field [36:12] contains L for the beginning of switch declar- 01143000 + ation. [24:12] contains L for first simple reference to switch. 01144000 + If switch is not simple, it is marked formal. Here simple means 01145000 + no possibility of jumping out of a block. ;01146000 + define mon =[ 1: 1]#, 01147000 + class =[ 2: 7]#, 01148000 + formal=[ 9: 1]#, 01149000 + vo =[10: 1]#, 01150000 + lvl =[11: 5]#, 01151000 + address=[16:11]#, 01152000 + incr =[27: 8]#, 01153000 + link =[35:13]#, 01154000 + linkr =[35: 5]#, 01155000 + linkc =[40: 8]#, 01156000 + comment These defines are used to pick apart the elbat word. 01157000 + mon is the bit which is on if the quantity is monitored. 01158000 + class is the principal identification of a given 01159000 + quantity. 01160000 + formal is the bit which is on if the quantity is a formal 01161000 + parameter. 01162000 + vo is the value-own bit. If formal = 1 then the bit 01163000 + distinguishes value parameters from others. If 01164000 + formal = 0 then the bit distinguishes own variables 01165000 + from others. 01166000 + lvl gives the level at which a quantity was declared. 01167000 + address gives the stack or PRT address. 01168000 + incr gives a relative link to any additional information 01169000 + needed, relative to the location in info. 01170000 + link contains a link to the location in info if the 01171000 + quantity lies in elbat, otherwise it links to the 01172000 + next item in the stack. Zero is an end flag. 01173000 + linkr and linkc are subdivisions of link.; 01174000 + comment Classes for all quantities - octal class is in comment; 01175000 + comment Classes for identifiers; 01176000 + define unknownid =00#, comment 000; 01177000 + stlabid =01#, comment 001; 01178000 + loclid =02#, comment 002; 01179000 + definedid =03#, comment 003; 01180000 + listid =04#, comment 004; 01181000 + frmtid =05#, comment 005; 01182000 + superfrmtid =06#, comment 006; 01183000 + realsubid =07#, comment 007; 01184000 + subid =08#, comment 010; 01185000 + switchid =09#, comment 011; 01186000 + procid =10#, comment 012; 01187000 + intrnsicprocid =11#, comment 013; 01188000 + strprocid =12#, comment 014; 01189000 + boostrprocid =13#, comment 015; 01190000 + realstrprocid =14#, comment 016; 01191000 + alfastrprocid =15#, comment 017; 01192000 + intstrprocid =15#, comment 017; 01193000 + booprocid =17#, comment 021; 01194000 + realprocid =18#, comment 022; 01195000 + alfaprocid =19#, comment 023; 01196000 + intprocid =19#, comment 023; 01197000 + booid =21#, comment 025; 01198000 + realid =22#, comment 026; 01199000 + alfaid =23#, comment 027; 01200000 + intid =23#, comment 027; 01201000 + booarrayid =25#, comment 031; 01202000 + realarrayid =26#, comment 032; 01203000 + alfaarrayid =27#, comment 033; 01204000 + intarrayid =27#, comment 033; 01205000 + nameid =30#, comment 036; 01205200 + intnameid =31#, comment 037; 01205400 + labelid =32#, comment 040; 01206000 + comment classes for primary beginners; 01207000 + truthv =33#, comment 041; 01208000 + nonlitno =34#, comment 042; 01209000 + litno =35#, comment 043; 01210000 + strngcon =36#, comment 044; 01211000 + leftparen =37#, comment 045; 01212000 + polishv =38#, comment 046; 01212100 + astrisk =39#, comment 047; 01212200 + comment class for all declarators; 01213000 + declarators =40#, comment 050; 01214000 + comment classes for statement beginners 01215000 + doublev =42#, comment 052; 01222000 + forv =43#, comment 053; 01223000 + whilev =44#, comment 054; 01224000 + dov =45#, comment 055; 01225000 + untilv =46#, comment 056; 01226000 + elsev =47#, comment 057; 01227000 + endv =48#, comment 060; 01228000 + semicolon =50#, comment 062; 01230000 + ifv =51#, comment 063; 01231000 + gov =52#, comment 064; 01232000 + ioclass =53#, comment 065; 01233000 + beginv =54#, comment 066; 01234000 + comment classes for stream reserved words; 01235000 + siv =55#, comment 067; 01236000 + diq =56#, comment 070; 01237000 + civ =57#, comment 071; 01238000 + tallyv =58#, comment 072; 01239000 + dsv =59#, comment 073; 01240000 + skipv =60#, comment 074; 01241000 + jumpv =61#, comment 075; 01242000 + dbv =62#, comment 076; 01243000 + sbv =63#, comment 077; 01244000 + togglev =64#, comment 100; 01245000 + scv =65#, comment 101; 01246000 + locv =66#, comment 102; 01247000 + dcv =67#, comment 103; 01248000 + localv =68#, comment 104; 01249000 + litv =69#, comment 105; 01250000 + trnsfer =70#, comment 106; 01251000 + comment classes for various miscellaneous quantities; 01252000 + commentv =71#, comment 107; 01253000 + forwardv =72#, comment 110; 01254000 + stepv =73#, comment 111; 01255000 + thenv =74#, comment 112; 01256000 + tov =75#, comment 113; 01257000 + valuev =76#, comment 114; 01258000 + withv =77#, comment 115; 01259000 + colon =78#, comment 116; 01260000 + comma =79#, comment 117; 01261000 + crosshatch =80#, comment 120; 01262000 + lftbrket =81#, comment 121; 01263000 + period =82#, comment 122; 01264000 + rtbrket =83#, comment 123; 01265000 + rtparen =84#, comment 124; 01266000 + ampersand =85#, comment 125; 01266500 + comment classes for operators; 01267000 + hexop =86#, comment 126; 01268000 + bitop =87#, comment 127; 01269000 + isolate =88#, comment 130; 01270000 + operator =89#, comment 131; 01271000 + notop =90#, comment 132; 01272000 + assignop =91#, comment 133; 01273000 + eqvop =92#, comment 134; 01274000 + orop =93#, comment 135; 01275000 + andop =94#, comment 136; 01276000 + relop =95#, comment 137; 01277000 + addop =96#, comment 140; 01278000 + mulop =97#, comment 141; 01278500 +% string =99#, comment 143; 01278600 + comment subclasses for declarations (kept in address); 01279000 + ownv =01#, comment 01; 01280000 + savev =02#, comment 02; 01281000 + boov =03#, comment 03; 01282000 + realv =04#, comment 04; 01283000 + alfav =05#, comment 05; 01284000 + intv =05#, comment 05; 01285000 + labelv =07#, comment 07; 01286000 + dumpv =08#, comment 10; 01287000 + subv =09#, comment 11; 01288000 + outv =10#, comment 12; 01289000 + inv =11#, comment 13; 01290000 + monitorv =12#, comment 14; 01291000 + switchv =13#, comment 15; 01292000 + procv =14#, comment 16; 01293000 + arrayv =15#, comment 17; 01294000 + namev =16#, comment 20; 01295000 + filev =17#, comment 21; 01296000 + streamv =18#, comment 22; 01297000 + definev =19#, comment 23; 01298000 +define ddes = 8#, 01299000 + ades = 28#, 01299010 + pdes = 29#, 01299020 + ldes = 30#, 01299030 + char = 31#, 01299040 + factop = astrisk#, 01299100 + operators = hexop#, 01299200 + fileid = 0#, 01299300 + maxintrinsic = 150#, % used in building intable @ 09414120 01299400 + intrinsicadr = (maxintrinsic div 30)#; % reserves seg for intable01299500 + real time1; 01300000 +boolean astog; 01300100 +boolean saf; 01300200 +integer scram; 01301000 + comment scram contains then scramble index for the last identifier 01302000 + or reserved word scanned; 01303000 +alpha array accum[0:10]; 01304000 + comment accum holds the alpha and character count of the last 01305000 + scanned item in a form compatible with its appearance 01306000 + in info, that is accum[1] = 00NAAAAA, accum[i] , i> 1, 01307000 + has any additional characters. accum[0] is used for 01308000 + the elbit word by the enter routines; 01309000 +array stackhead[0:125]; 01310000 + comment stackhead[n] contains an index into info giving the top 01311000 + item in the n-th stack; 01312000 +integer count; 01313000 + comment count contains the number of characters of the last item 01314000 + scanned; 01315000 +alpha q; 01316000 + comment q contains accum[1] for the last identifier or reserved 01317000 + word scanned; 01318000 +array elbat[0:75]; integer i, nxtelbt; 01319000 + comment elbat is an array holding elbat words for recently scanned 01320000 + quantities. The table routine maintains this array. 01321000 + (elbat is table spelled backwards.) The table routine 01322000 + guaranties that elbat always contains the elbat words 01323000 + for the last 10 quantities scanned. nxtelbt is an index 01324000 + pointing to te next available word in elbat. I is an 01325000 + index used by the rest of the compiler to fetch things 01326000 + from elbat. I is also maintained by the table routine; 01327000 +integer elclass; 01328000 + comment elclass usually contains elbat[i].class; 01329000 +integer fcr, ncr, lcr,tlcr,clcr; 01330000 +integer maxtlcr; 01331000 + comment fcr contains absolute address of the first character of 01332000 + the card image currently being scanned, ncr the address 01333000 + of the next character to be scanned, and lcr the last 01334000 + charactor in the tape and card buffers. maxtlcr 01335000 + is the maximum of tlcr when the input is blocked; 01336000 + array ten[-46:69]; 01340000 + define prtbase=129#,prtop=896#; comment page and top of prt; 01341000 +array prt[prtbase:prtop]; 01342000 +integer diskadr,coradr; comment globals for progdescblok; 01343000 +integer sgavl;comment next available segment number; 01369000 +integer sgno;comment this is the current segment number; 01370000 + array cop,wop[0:127]; 01371000 + comment The emit routines place each syllable into the edoc array 01372000 + as specified by "l". 01373000 + If the debugtog is true cop and wop are filled with 01374000 + the bcd for the operators,otherwise they are not used; 01375000 +real lastentry ; 01376000 + comment lastentry is used by emitnum and constantclean. It points 01377000 + into info[0,*] at the next available cell for constants; 01378000 +boolean mrclean; 01379000 + comment No constanclean action takes place while mrclean is 01380000 + false, this feature is used by block because of the 01381000 + possibility the constantclean will use info[nextinfo] 01382000 + during an array declaration ; 01383000 +real gt1,t2,gt3,gt4,gt5; 01384000 +integer gti1; 01384500 + comment these variables are used for temporary storage; 01385000 +integer result; 01386000 + comment This variable is used for a dual purpose by the table 01387000 + routine and the scanner. The table routine uses this 01388000 + variable to specify scanner operations and the scanner 01389000 + uses it to inform the table routine of the action taken; 01390000 +integer lastused; 01391000 + comment lastused is a variable that controls the action of 01392000 + readcard, the routine which reads cards and initializes 01393000 + or prepares the card for the scanner. 01394000 + Lastused Last card read from 01394500 + -------- ------------------- 01394600 + 1 Card reader only, no tape 01395000 + 2 Card reader, tape and card merge 01396000 + 3 Tape, tape and card merge 01397000 + 4 Initialization only, card only. 01398000 +; 01398300 +boolean linktog; 01399000 + comment linktog is false if the last thing emitted is a link, 01400000 + otherwide it is true; 01401000 +integer level,frstlevel,sublevel,mode; 01402000 + comment These variables are maintained by the block routine to keep 01403000 + track of levels of definition. Level gives the depth of 01404000 + nesting in definition, where each block and each procedure 01405000 + gives rise to a new level. Sublevel gives the level of 01406000 + the parameters of the procedure currently being compiled. 01407000 + Frstlevel is the level of the parameters of the most 01408000 + global of the procedures currently being compiled. Mode 01409000 + is the current depth of the procedure in which we are 01410000 + nested (at compile time); 01411000 +boolean errortog; 01412000 + comment Errortog is true if messages are currently acceptable to the 01413000 + error routines, errorcount is the count of error messages;01414000 +boolean endtog; comment endtog tells the table to allow 01415000 + comment to be passed back to compoundtail; 01416000 +boolean streamtog; 01417000 + comment streamtog is true if we are compiling a stream statement. It01418000 + is used to control compoundtail; 01419000 +define fs = 1#, fp = 2#, fl = 3#, fr=4#; 01420000 + comment These defines are used when calling the variable routine. 01421000 + Their purposes is to tell variable who is calling. 01422000 + Their meaning is: 01423000 + fs means from statement, 01424000 + fp means from primary, 01425000 + fl means from list, 01426000 + fr means from for; 01427000 +integer l; 01428000 + comment l is the location of the next syllable to be emitted; 01429000 +define blockctr = 16#, junk = 17 #, xitr = 18 #, lstrtn = 19#; 01430000 +define atype =3#, btype=atype#,dtype=atype#; 01452000 +boolean tb1; 01457000 + comment tb1 is a temporary boolean variable; 01458000 +integer jumpctr; 01459000 + comment jumpctr is a variable used for communication between block 01460000 + and gengo. It gives highest level to which jump has 01461000 + been made from within a the presently being compiled 01462000 + segment. The block compiles code to increment and decre- 01463000 + ment the blockctr on the basis of jumpctr at completion 01464000 + of compilation of a segment - i.e. the blockctr is tallied 01465000 + if level = jumpctr; 01466000 + 01467000 + 01468000 + 01469000 + 01470000 +real stlb; 01471000 + comment stlb is used by variable and actulaparapart to communicate 01472000 + the lower bound information for the last dimension of the 01473000 + array involved in a row designator. The format of the 01474000 + information is that of info. Stlb is also sometimes used 01475000 + for temporary storage; 01476000 +define bumpl = l+l+2#; 01477000 + comment bumpl is used mostly to prepare a forward jump; 01478000 +define idmax = labelid#; 01479000 + comment idmax is the maximum class number for identifiers; 01480000 +integer definectr,defineindex; 01481000 + real joinfo, comment points to pseudo label for jump outs; 01482000 + lprt, comment shows location of the last label in the prt ; 01483000 + nextlevel, comment counts nesting for go and jump outs; 01484000 + jumplevel; comment number of levels to be jumped out; 01485000 +comment the reals above are for stream statement; 01486000 +array macro[0:35]; 01487000 + comment macro is filled with syllables for stream statement; 01488000 +real p, comment contains number of formats for stream procs; 01489000 + z; comment contains 1st word of info for stream functions; 01490000 + array newtapbuf[0:9]; 01490510 + save array definearray[0:23]; 01491000 + comment These variables are used to control action of the define. 01492000 + Definectr counts depth of nesting of define=# pairs. 01493000 + The crosshatch part of the table routine uses definectr 01494000 + to determine the meaning of a crosshatch. Defineindex is 01495000 + the next available cell in the definearray. The define- 01496000 + array holds the alpha of the define being recreated and 01497000 + the previous values of lastused, lcr, and ncr; 01498000 +integer beginctr; 01499000 + comment beginctr gives the number of unmatched begins. It is used 01500000 + for error control only; 01501000 + integer diala,dialb; 01502000 + comment These variables give the last value to which A and B were 01503000 + dialed. This gives some local optimization. Emitd 01504000 + worries about this. Other routines cause a loss of memory 01505000 + by setting diala and dialb to zero; 01506000 +boolean rrb1; comment rrb1--rrbn are boolean variables that serve the 01522000 + same function as rr1--rrn for real variables. See 01523000 + comment at rr1; 01524000 + boolean rrb2; comment see comment at rrb1 declaration; 01525000 +define arraymonfile = [27:11]#; comment arraymonfile is the define for 01526000 + the address of the file descriptor in 01527000 + the first word of additional info; 01528000 +define svarmonfile = [37:11]#; comment monitorfile is the define for 01529000 + the address of the file descriptor in 01530000 + info for monitored simple variables; 01531000 +define nodimpart = [40:8]#; comment the first additional word of info 01532000 + for arrays contains the number of dimensions01533000 + in nodimpart; 01534000 +define lablmonfile = [13:11]#; comment lablmonfile designates the bit 01535000 + position in the first word of additional 01536000 + info that contains the monitor file 01537000 + address for labels; 01538000 +define switmonfile = [13:11]#; comment switmonfile designates the bit 01539000 + position in the first word of additional 01540000 + info that contains the monitor file 01541000 + address for labels; 01542000 +define funcmonfile = [27:11]#; Comment Funcmonfile designates the bit 01543000 + position in the first word of additional 01544000 + info that contains the monitor ile 01545000 + address for labels; 01546000 +define dumpee = [2:11]#; comment the dumpee field in the first 01547000 + additional word of info for labels contains 01548000 + the address of the counter that is incremented 01549000 + each time the label is passed if that label 01550000 + appears in a dump declaration; 01551000 +define dumpor = [24:11]#; comment the dumpor field in the first 01552000 + additional word of info for labels contains 01553000 + the address of the routine that is generated 01554000 + from the dump declaration that in turn calls 01555000 + the printi routine; 01556000 +define subop=48#; 01556500 + file out code disk serial(1:1)(1,1023); 01556900 +file in card(rr1,10,rr2); 01557000 +file out line disk serial[20:2400](rr3,15,rr4,save 10); 01557000 + array lin[0:20]; comment print output built in lin; 01559010 +integer da; 01559020 +save file out newtape disk serial[20:2400](rr5,rr6,rr7,save 1); 01560000 +file in tape "ocrding"(2,rr8,rr9); 01561000 +save array cbuff,tbuff[0:9]; % input buffers. 01561056 +file out codisk disk serial [20:600] (2,30,300); 01561300 +file out disk disk [1:2100] "MCP""DISK"(3,30,300,save 99); 01561400 +define mcptype = 63#, 01561410 + dcintype = 62#, 01561420 + tssintype = 61#; 01561430 +comment ESPOL code files are uniquely typed in their file 01561440 + headers. Header[4],[36:6] is the field used to contain 01561450 + the type; 01561460 +file out deck 0 (2,10); 01561500 +fiel stuff disk serial[20:150](2,10,30,save 15); 01561600 +array twxa[0:16]; 01561700 + real c; 01562000 + comment c contains actual value of last constant scanned; 01563000 + real t; 01564000 + comment t is a temporary cell; 01565000 + integer tcount; 01566000 + real stackct; 01566010 + comment tcount is a variable which holds a previous value of count 01567000 + for the use of convert; 01568000 + define lastsequence = 145#, 01569000 + lastseqrow = 2#; 01570000 + 01571000 + 01572000 + 01573000 + 01574000 + 01575000 + 01576000 + 01577000 + 01578000 + 01579000 + 01580000 + 01581000 + 01582000 + 01583000 +real fouled; 01583100 + 01584000 +boolean 01585000 + functog, comment tells whether procedure being declared is a 01586000 + function; 01587000 + p2, comment generally tells whether own was seen; 01588000 + p3, comment tells whether save was seen; 01589000 + vonf, comment value or own field of elbat word; 01590000 + formalf, comment formal field of elbat word; 01591000 + ptog, comment tells that formal parapart is being processed;01592000 +spectog, 01593000 + stopentry, comment this makes the entry procedure enter only 01594000 + one io and then exit; 01595000 + ajump; comment tell whether a jump is hanging; 01596000 +boolean stopdefine; 01597000 +integer maxsave; 01598000 + comment this contains the size of the maximum save array 01599000 + declared. It is used to help determine storage requirements 01600000 + for the program parameter block for the object program; 01601000 + real 01602000 + klassf, comment class in low order 7 bits; 01603000 + addrsf, comment address in low order 11 bits; 01604000 + levelf, comment lvl in low order 5 bits; 01605000 + linkf, comment link in low order 13 bits; 01606000 + incrf, comment incr on low order 8 bits; 01607000 + proinfo, comment contains elbat word for procedure being 01608000 + declared; 01609000 + g, comment global temporary for block; 01610000 + typev, comment used to carry class of identifier 01611000 + being declared; 01612000 + proadd, comment contains address of procedure being 01613000 + declared; 01614000 + mark , comment contains index into info where first word 01615000 + of additional info for a procedure entry; 01616000 + pj, comment formal parameter counter; 01617000 + j, comment array counter; 01618000 + lastinfo, comment index to last entry in info; 01619000 + nextinfo, comment index for next entry in info; 01620000 + firstx, comment relative add of first executable code 01621000 + in block,initialized to 4095 each time; 01622000 + savel; comment save location for fixups in block; 01623000 +integer ncii; comment this contains the count of constants 01624000 + entered in info at any given time; 01625000 +procedure unhook; forward; 01626000 +procedure makeupaccum;forward; 01627000 +define purpt=[4:8]#,secret=2#; 01628000 + comment These defines give the names of the word mode operators. The 01629000 + numbers refer to the appropriate section of the product specs. The 01630000 + full name is also given; 01631000 + define 01632000 + add = 16#, comment (0101) 7.4.2.1 Add; 01633000 + bbc = 22#, comment (0131) 7.4.5.4 Branch backward conditional;01634000 + bbw = 534#, comment (4131) 7.4.5.2 Branch backward; 01635000 + bfc = 38#, comment (0231) 7.4.5.3 Branch forward conditional; 01636000 + bfw = 550#, comment (4231) 7.4.5.1 Branch forward; 01637000 + cdc = 168#, comment (1241) 7.4.10.4 Construct descriptor call; 01638000 + chs = 134#, comment (1031) 7.4.7.11 Change sign; 01639000 + coc = 40#, comment (0241) 7.4.10.3 Construct operand call; 01640000 + com = 130#, comment (1011) 7.4.10.5 Communication operator; 01641000 + del = 10#, comment (0045) 7.4.9.3 Delete; 01642000 + dup = 261#, comment (2025) 7.4.9.2 Duplicate; 01643000 + eql = 581#, comment (4425) 7.4.4.3 Equal; 01644000 + lbc = 278#, comment(2131) 7.4.5.9 Go backward conditional; 01645000 + lbu = 790#, comment(6131) 7.4.5.7 Go backward (word); 01646000 + geq = 21#, comment (0125) 7.4.4.2 Greater than or equal to; 01647000 + lfc = 294#, comment(2231) 7.4.5.8 Go forward conditional; 01648000 + lfu = 806#, comment(6231) 7.4.5.6 Go forward (word); 01649000 + gtr = 37#, comment (0225) 7.4.4.1 Greater than; 01650000 + idv = 384#, comment (3001) 7.4.2.5 Integer divide; 01651000 + inx = 24#, comment (0141) 7.4.10.2 Index; 01652000 + isd = 532#, comment (4121) 7.4.6.3 Integer store destructive; 01653000 + isn = 548#, comment (4221) 7.4.6.4 Integer store non-destruct; 01654000 + leq = 533#, comment (4125) 7.4.4.4 Less than or equal to; 01655000 + lnd = 67#, comment (0415) 7.4.3.1 Logical and; 01656000 + lng = 19#, comment (0115) 7.4.3.4 Logical negate; 01657000 + lod = 260#, comment (2021) 7.4.10.1 Load operator; 01658000 + lor = 35#, comment (0215) 7.4.3.2 Logical or; 01659000 + lqv = 131#, comment (1015) 7.4.3.3 Logical equivalence; 01660000 + lss = 549#, comment (4225) 7.4.4.5 Less than; 01661000 + mks = 72#, comment (0441) 7.4.8.1 Mark stack 01662000 + mul = 64#, comment (0401) 7.4.2.3 Multiply 01663000 + neq = 69#, comment (0425) 7.4.4.6 Not equal to; 01664000 + nop = 11#, comment (0055) 7.4.7.1 No operation; 01665000 + prl = 18#, comment (0111) 7.4.10.6 Program release; 01666000 + prte= 12#, comment (0061) 7.4.10.0 Extend PRT; 01667000 + rdv = 896#, comment (7001) 7.4.2.6 Remainder divide; 01668000 + rtn = 39#, comment (0235) 7.4.8.3 Return normal; 01669000 + rts = 167#, comment (1235) 7.4.8.4 Return special; 01670000 + snd = 132#, comment (1021) 7.4.6.2 Store non-destructive; 01671000 + ssp = 582#, comment (4431) 7.4.7.10 Set sign plus; 01672000 + std = 68#, comment (0421) 7.4.6.1 Store destructive; 01673000 + sub = 48#, comment (0301) 7.4.2.2 Subtract; 01674000 + xch = 133#, comment (1025) 7.4.9.1 Exchange; 01675000 + xit = 71#, comment (0435) 7.4.9.2 Exit; 01676000 + zp1 = 322#, comment (2411) 7.4.10.8 Conditional halt; 01677000 + sci =1003#, comment (7655) Scan out initialize; 01677050 + san =1004#, comment (7661) System attention needed 01677100 + scs =1019#, comment (7755) Scan out stop; 01677150 +comment These defines are used by EMITD; 01678000 +define 01679000 + dia = 45#, comment (xx55) 7.4.7.1 Dial A; 01680000 + dib = 49#, comment (xx61) 7.4.7.2 Dial B; 01681000 + trb = 53#, comment (xx65) 7.4.7.3 Transfer bits; 01682000 +real maxstack,stackctr; 01683000 +integer maxrow; 01684000 + comment This contains the maximum row size of all non-save 01685000 + arrays declared. Its use is like that of maxsave; 01686000 +integer segsizemax; comment contains max segment size; 01687000 +integer f; 01688000 + real nlo,nhi,tlo,thi; 01689000 + boolean optog; 01690000 + comment The above things are temp storage for double nos;01691000 +boolean dollar2tog; 01691500 +define fzero=896#; 01692000 +real t1,t2,n,k,akkum; 01693000 +boolean stopgsp; 01694000 +integer bup; 01695000 +boolean inlinetog; 01695500 + comment Unique global temp for block; 01696000 +array gta1[0:10]; 01697000 + boolean array sprt[0:31]; 01698000 + comment SPRT is to be considered to be an array of 32 32 bit 01699000 + fields. The 32 bits are in the low order part of each 01700000 + word. The bit is on if and only if the corresponding 01701000 + PRT cell has a permanent assignment; 01702000 + integer prti,prtimax; 01703000 + comment PRTIMAX gives next PRT cell available for permanent assign-01704000 + ment. PRTI gives next PRT cell possibly available for 01705000 + temporary assignment; 01706000 +define alphasize = [12:6]#; Comment alphasize is the define for the bit01707000 + position in the second word of info which 01708000 + contains the length of alpha; 01709000 +define edocindex = L.[36:3],L.[39:7]#; Comment edocindex s the word 01710000 + portion of L split into a row and01711000 + column index for edoc; 01712000 +define cplus1 = 769#; comment see comment at cplus2 define; 01713000 +define cplus2 = 770#; comment cplus1 and cplus2 are explicit constants 01714000 + used in the generation of Crelative code; 01715000 + procedure flag(errnum); value errnum; integer errnum; forward; 01716000 + alpha procedure b2d(b); value b;real b; forward; 01717000 + real procedure take(w) value w; integer w; forward; 01717700 + boolean macroid; 01717800 + real procedure fixdefineinfo(t); value t; real t; forward; 01717900 + procedure err (errnum); value errnum; integer errnum; forward; 01718000 + integer procedure git(l); value l; real l; forward; 01719000 + array calla[0:31,0:255]; 01720000 + define call[call1]=calla[(gt3←call1).linkr,gt3.linkc]#; 01721000 + real callx,callinfo,nestctr,nestcur; 01722000 + boolean nestog; 01723000 + array nestprt[prtbase:prtop]; 01724000 + array sortprt[0:prtop-prtbase]; 01725000 +comment "blanket" blanks out n+1 words in "there"; 01737300 +stream procedure blanket(n,there); value n; 01737350 + begin 01737400 + di:=there; ds:=8 lit" "; si:=there; ds:=n wds; 01737450 + end blanket; 01737500 +stream procedure changeseq(val,oldseq); value oldseq; 01741200 + begin di:=oldseq; si:=val; ds:=8 dec end changeseq; 01741300 +stream procedure sequenceerror(l); 01742100 + begin di:=l; ds:=16 lit"SEQUENCE ERROR "; end sequenceerror; 01742110 +stream procedure getvoid(vp,ncr,lcr,seq); value ncr,lcr; 01756000 + begin 01757000 + label l,exit; 01758000 + local n; 01759000 + si:=ncr; di:=vp; ds:=8 lit "0"; 01761000 + 2(34(if sc=" " then si:=si+1 else jump out 2 to l)); 01762000 + go to exit; % No void range given, return zero. 01763000 +l: 01764000 + if sc="%" then go to exit; % Still no range. 01764500 + if sc=""" then 01765000 + begin 01766000 + si:=si+1; di:=lcr; ds:=1 lit """; % stopper for scan 01767000 + ncr:=si; % temp. storage, since ncr is "local" to getvoid. 01768000 + 8(if sc=""" then jump out else 01769000 + begin tally:=tally+1; si:=si+1; end); 01770000 + end 01771000 + else begin 01772000 + ncr:=si; % temp. storage, since ncr is "local" to getvoid. 01773000 + di:=lcr; ds:=1 lit " "; % stopper for scan 01774000 + 8(if sc=" " then jump out else 01775000 + begin tally:=tally+1; si:=si+1 end); 01776000 + end; 01777000 + si:=ncr; di:=vp; di:=ci+8; % Restore pointers. 01780000 + n:= tally; di←di-n; cd:=n chr; 01781000 +exit: 01782000 + end of getvoid; 01784000 +real voidcr,voidplace,voidtcr,voidplace; 01785000 +format 01800000 + bug(x24,4(a4,x2)); 01802000 +procedure datime; 01820000 + begin 01821000 + integer h,min,q; alpha n1,n2; 01822000 + alpha stream procedure dater(date); value date; 01823000 + begin 01824000 + di:=loc dater; si:=loc date; si:=si+2; 01825000 + 2(ds:=2 chr; ds:=lit"/"); ds:=2 chr; 01826000 + end of dater; 01827000 + h:=time1 div 216000; min:=(time1 div 3600) mod 60; 01828000 + n1:=disk.mfid; n2:=disk.fid; 01828500 + write(line, 01829000 + "%" then go comments; 02107500 + if sc < ";" then go comments; 02108000 +comment characters between % and semicolon are handled by word- 02108500 + mode part of comment routine; 02109000 + end; 02109500 + go finis; 02110000 +idbldr: 02110500 + tally:=63; ds=lit "1"; 02111000 + comcount(tally:=tally+1; 02111500 + if sc=alpha then si:=si+1 else jump out to exit); 02112000 + tally:=tally+1; 02112500 + if sc=alpha then 02113000 + begin 02113500 +error: 02114000 + di:=di-1; ds:=lit "4"; go exit; 02114500 + end; 02115000 + else go exit; 02115500 +comment If we arrive at error we have more than 63 characters 02116000 + in an identifier or number; 02116500 +numbers: 02117000 + tally:=63; ds:=lit "3"; 02117500 + comcount(tally:=tally+1; 02118000 + if sc <"0"then jump out to exit; si:=si+1); 02118500 + go error; 02119000 +exit: 02119500 + st1:=tally; % "st1" contains number of characters we are 02120000 + % going to move into the "accumulator". 02120500 + tally:=tally+countv; st2:=tally; 02121000 + di:=count; si:=loc st2; ds:=wds; 02121500 +comment this code updated "count"; 02122000 + di:=accum; si:=si-3; ds:=3 chr; 02122500 +comment This code places "count" in "accum" as well; 02123000 + di:=di+countv; % position "di" past characters already 02123500 + % in the "accumulator", if any. 02124000 + si:=ncrv; ds:=st1 chr; 02124500 +comment Move characters into "accum"; 02125000 +finis: 02125500 + di:=ncr; st1:=si; si:=loc st1; ds:=wds; 02126000 +comment Reset "ncr" to location of next character to be scanned; 02126500 + end of scan; 02127000 + label l; 02127500 +l: 02128000 + scan(ncr,count,accum[1],63-count,result, 02128500 + result,count,0,ncr,0); 02129000 + if ncr=lcr then 02129500 + begin 02130000 + readacard; 02130500 + go to l; % go directly to l, do not pass go, 02135500 + % do not collect $200; 02136000 + end; 02136500 + end scanner; 02137000 +define writeline = if singltog then write(line,15,lin[*]) 02181000 + else write(line[dbl],15,lin[*])#, 02181250 + printcard = begin 02182500 + editline(lin,fcr,l div 4,l,[4612],medium,omitting); 02182750 + if noheading then datime; writeline; 02183000 + end#; 02183250 +stream procedure editline(line,ncr,r,l,symbol,omit); 02183500 + value ncr,r,l,symbol,omit; 02183750 + begin 02184000 + di := line; ds := 16 lit " "; 02184250 + si := ncr; ds := 9 wds; 02184500 + ds := 8 lit " "; 02184750 + ds := wds; % sequence number. 02185000 + ds:=lit" "; si:=loc symbol; si:=si+6; 02185250 + ds:=2 chr; ds:=lit" "; 02185500 + si←loc r; ds←4 dec; ds←lit ":"; 02185750 + si←loc l; ds←1 dec; 02186000 + ds←6 lit " "; 02186250 + omit(di:=di-12; ds:=8 lit" OMIT"); 02186750 + end editline; 02187000 +comment compare compares sequence numbers of tape and card. If 02187250 + tape is smaller then result = 0 else if card is smaller 02187500 + result = 1 else result = 2; 02187750 +real stream procedure(tape,card); value tape,card; 02188000 + begin 02188250 + si:= tape; di := card; 02188500 + if 8 sc ≥ dc then 02188750 + begin 02189000 + si := si-8; di := di-8; tally := 1; 02189250 + if 8 sc = dc then tally := 2 02189500 + end; 02189750 + compare := tally 02190000 + end compare; 02190250 +procedure outputsource; 02190500 + begin 02190750 + label lcard,ltape,away; 02191000 + switch sw:=lcard,lcard,ltape,away,lcard,ltape; 02191250 + if seqtog then % resequencing. 02191500 + begin 02191750 + if totalno = -10 or newbase then 02192000 + begin 02192250 + newbase := false; gti1:= totalno:=basenum 02192500 + end 02192750 + else gti1:= totalno:= totalno + addvalue; 02193000 + changeseq(gti1,lcr); 02193250 + end; 02193500 + if newtog then 02193750 + if writnew(lin,fcr) then write(newtape,10,lin[*]); 02194000 + if omitting then if not listatog then go away; 02194250 + go sw[lastused]; 02194500 +lcard: 02194750 + if lister or listptog then printcard; 02195000 + go away; 02195250 +ltape: 02195500 + if lister then printcard; 02195750 +% go away; 02196000 +away: 02196250 + end outputsource; 02196500 +procedure readacard; 02196750 +comment readacard reads card from either the card reader or the 02197000 + tape merging as requested and creating a new tape and 02197250 + listing if requested. Readacard also inserts a percent 02197500 + sign as an end of card sentinel in column 73 and sets 02197750 + fcr,ncr,lcr,tlcr, and clcr; 02198000 + begin 02198250 + procedure readtape; 02198500 + begin 02201500 +label endreadtape, eoft; 02201510 +read (tape, 10, tbuff[*])[eoft]; 02201750 + lcr:=mkabs(tbuff[9]); 02202000 +go to endreadtape; 02202010 +eoft: 02202020 +definearray[25]:="ND;END."& "E"[1:43:5]; 02202030 +definearray[34]:="9999" & "9999"[1:25:23]; 02202040 +tlcr:= mkabs(definearray[34]); 02202050 +putseqno (definearray[33],tlcr-8); 02202060 +turnonstoplight("%", tlcr-8); 02202070 +endreadtape: 02202250 + end readtape; 02202500 + procedure seqcompare(tlcr,clcr, lib); value lib; boolean lib; 02202750 + real tlcr, clcr ; 02203000 + begin 02203250 + medium:="C "; % Card reader. 02203500 + if gt1:=compare(tlcr,clcr)=0 then % Tape has low sequence numb02203750 + begin 02204000 + lcr:=tlcr; lastused:=3; 02204250 + medium:="T "; % Tape input. 02204500 + end 02204750 + else begin 02205000 + if gt1 ≠ 1 then % Tape and card have same seq 02205250 + begin 02205500 + medium:="P "; % card patches tape. 02205750 + readtape; 02206000 + end; 02206250 + lcr:=clcr; 02206500 + lastused:=2; 02206750 + end; 02207000 + end of seqcompare; 02207250 + label cardonly, cardlast, tapelast, exit, firsttime, 02207500 + eof, usetheswitch, 02207750 + compar, testvoid, xit; 02208000 + switch usesswitch:=cardonly,cardlast,tapelast,firsttime; 02208250 + if errorcount≥errmax then err(611); % err limit exceeded - stop. 02208500 +usetheswitch: 02208750 + dollar2tog:=false; 02209000 + go to usesswitch(lastused); 02209250 + move(1,info[lastused,linkr,lastused,linkc], 02209500 + definearray[defineindex-2]); 02209750 + lastused := lastused + 1; 02210000 + ncr := lcr-1; 02210250 + go to xit; 02210500 +firsttime: 02210750 + read(card,10,cbuff[*]); 02211000 + fcr:=ncr:=(lcr:=mkabs(cbuff[9]))-9; 02211250 + medium:="C "; 02214100 + if examin(fcr)≠"$" and lister then printcard; 02214200 + putseqno(info[lastseqrow,lastsequence],lr); 02214250 + turnonstoplight("%",lr); 02214500 + go xit; 02214750 +comment We have just initialized card input; 02215000 +cardonly: 02215250 + read(card,1,cbuff[*]); 02215500 + lr := mkabs(cbuff[9]); go exit; 02215750 +cardlast: 02216000 + read(card,10,cbuff[*])[eof]; 02216250 + clcr := mkabs(cbuff[9]); 02216500 + go compar; 02216750 +eof: 02217000 + definearray[25]:="ND;END."&"E"[1:43:5]; 02217250 + definearray[34]:="9999"&"9999"[1:25:23]; 02217500 + clcr:=mkabs(definearray[34]); 02217750 + putseqno(definearray[33],clcr-8); 02218000 + turnonstoplight("%",clcr-8); 02218250 +% 02218400 + go compar; 02218500 +comment This release the previous card form the card reader and 02218750 + sets up clcr; 02219000 +tapelast: 02219250 + readtape; 02219500 +comment This releases the previous card form tape and sets up tlcr; 02219750 +compar: 02224250 + seqcompare(tlcr,clcr,false); 02224500 +exit: 02225000 + ncr := fcr:= lcr - 9; 02225250 +comment Sets up ncr and fcr; 02225500 + if examin(fcr)≠"$" then % $-cards cont"t count. 02225750 + if compare(mkabs(info[lastseqrow,lastsequence]),lcr)=1 then 02226000 + begin 02226250 + flag(610); % sequence error. 02226500 + sequenceerror(lin); 02226750 + end; 02227000 + cardnumber:=conv(info[lastseqrow,lastsequence-1],5,8); 02228000 + if lastused=3 then 02228050 + begin 02228075 + if voidtape then go usetheswitch; 02228100 + if voidtcr≠0 then 02228125 + if compare(lcr,voidtcr)=0 then go usetheswitch; 02228150 + end; 02228175 + if examin(fcr)="$" then 02228350 + begin 02228500 + if listptog or printdollartog then printcard; 02228750 + ncr:=ncr+32768; dollarcard; 02229000 +comment dont forget that ncr is not word mode, but char. mode pointer; 02229250 + go usetheswitch; 02229500 + end; 02229750 + if examin(fcr)=" " then 02230000 + if dollar2tog:=examin(fcr+32768)="$" then 02230100 + begin 02230250 + outputsource; 02230500 + ncr:=ncr+65536; % scan past " $" (character mode). 02230750 + dollarcard; 02231000 + end; 02231250 + if voiding then go usetheswitch; 02231500 + if voidcr≠0 then 02231750 + if compare(lcr,voidcr)>0 then voidcr:=voidplace:=0 02232000 + else go usetheswitch; 02232250 + if voidtape then go testvoid; 02232500 + if voidcr≠0 then 02233000 + if compare(lcr,voidtcr)>0 then voidtcr:=voidplace:=0 else 02233500 +testvoid: if lastused=3 then go usetheswitch; 02234000 + cardcount:=cardcount+1; 02234500 + if dollar2tog then go usetheswitch; 02234600 + putseqno(info[lastseqrow,lastsequence],lcr); 02234750 + outputsource; 02235000 + if omitting then go usetheswitch; 02235250 +% 02235500 + turnonstoplight("%",lcr); 02235750 +xit: 02237750 + end readacard; 02238000 +real procedure convert; 02248000 + begin real t; integer n; 02249000 + tlo←0; thi← 02250000 + t← conv(accum[1],tcount,n←(count-tcount)mod 8); 02251000 + for n← tcount←n step 8 until count- 1 do 02252000 + if dptog then 02253000 + begin 02254000 + double(thi,tlo,100000000.0,0,×,conv(accum[1],n,8),0,+,←,←,02255000 + thi,tlo); 02256000 + t←thi; 02257000 + end else 02258000 + t← t×100000000+ conv(accum[1],n,8); 02259000 + convert←t; 02260000 + end; 02261000 +real stream procedure fetch(f); value f; 02262000 + begin si:=f; si:=si-8; di:=loc fetch; ds:=wds end fetch; 02263000 +procedure dumpinfo; 02264000 + begin 02264050 + array a[0:14]; integer jeden.dwa; 02264100 + stream procedure octalwords(s,d,n); value n; 02264400 + begin 02264450 + si:=s; di:=d; 02264500 + n(2(8(ds:=3 reset; 3(if sb then ds:=1 set else 02264550 + ds:=1 reset; skip 1 sb)); ds:=1 lit " ");ds:=2 lit" "); 02264600 + end of octalwords; 02264650 + stream procedure alphawords(s,d,n); value n; 02264700 + begin 02264750 + si:=s; di:=d; 02264800 + n(2(4(ds:=1 lit" "; ds:=1 chr); ds:=1 lit" "); ds:=2 lit" "); 02264850 + end of alphawords; 02264900 + if noheading then datime;write(line[dbl],); 02264950 + for jeden:=0 step 6 until 71 do 02265000 + begin 02265050 + blanket(14,a); octalwords(elbat[jeden],a,6); 02265100 + write(line[dbl],15,a[*]); 02265150 + end; 02265200 + blanket(14,a); octalwords(elbat[72],a,4); 02265250 + write(line[dbl],15,a[*]); 02265300 + for jeden:=0 step 1 until nextinfo div 256 do 02265350 + begin 02265400 + write(line[dbl],,jeden); 02265450 + for dwa:=0 step 6 until 251 do 02265500 + begin 02265550 + blanket(14,a); alphawords(info[jeden,dwa],a,6); 02265600 + write(line,15,a[*]); 02265650 + blanket(14,a); octalwords(info[jeden,dwa],a,6); 02265700 + write(line[dbl],15,a[*]); 02265750 + end; 02265800 + blanket(14,a); alphawords(info[jeden,252],a,4); 02265850 + write(line,15,a[*]); 02265900 + blanket(14,a); octalwords(info[jeden,252],a,4); 02265950 + write(line[dbl],15,a[*]); 02266000 + end; 02266050 + end of dumpinfo; 02266100 +define skan = begin 02277000 + count:=result:=accum[1]:=0; 02278000 + scanner; 02279000 + q:=accum[1]; 02280000 + end #; 02281000 +comment Dollarcard handles the compiler control cards. 02282000 + All compiler- and user-defined options are kept 02283000 + in the array "options". 02284000 + Each option has a two-word entry: 02285000 + 02286000 + Word Contains 02287000 + ---- -------- 02288000 + 1 Entry form accum[1]: 00XZZZZ, where 02289000 + X is the size of the id and 02290000 + ZZZZZ is the first five chars of the id. 02291000 + 2 Push-down, 47 bit tack containing the 02292000 + history of the settings of this option. 02293000 + 02294000 + In "findoption", all compiler defined options are usually 02295000 + located based upon a unique number assigned to each. 02296000 + For all user-defined options, a sequential table search is 02297000 + initiated using "useropinx" as the initial index into the 02298000 + "options" array. If the number of compiler defined options 02299000 + is changed, then "useropinx" must be accordingly changed. 02300000 + The number of user define options allowed can be 02301000 + changed by changing the define "oparsize". 02302000 + The variable "optionword" contains the current true or false 02303000 + setting of all of the compiler-defined options, one bit per 02304000 + option. 02305000 + ; 02306000 +boolean procedure findoption(bit); value bit; integer bit; 02307000 + begin 02308000 + label found; 02309000 + real id; 02310000 + opinx:=2×bit-4; 02311000 + while id:=options[opinx:=opinx+2]≠0 do 02312000 + if q=id then go found; 02313000 + options[opinx]:=q; % new user-defined option. 02314000 +found: 02315000 + if opinx +1>oparsize then flag(602) else % too many user options 02316000 + findoption:=boolean(options[opinx+1]); 02317000 + end findoption; 02318000 +procedure dollarcard; 02319000 + begin 02320000 + stream procedure restoreseqnum(lcr,info); value lcr; 02320200 + begin 02320400 + di:=lcr; si:=info; ds:=wds; 02320600 + end; 02320800 + procedure switchit(xbit); value xbit; integer xbit; 02321000 + begin 02322000 + boolean b,t; 02323000 + integer saveinx; 02324000 + label xmode0,xmode1,xmode2,xmode3,xmode4,along; 02325000 + switch sw:=xmode0,xmode1,xmode2,xmode3,xmode4; 02326000 + setting:=findoption(xbit); skan; 02327000 + go sw[xmode+1]; 02328000 +xmode0: % first option on card, butnot set, reset or pop. 02329000 + optionword:=boolean(0); 02330000 + for saveinx:=1 step 2 until oparsize do options[saveinx]:=0; 02331000 + xmode:=lastused:=1; % card input only. 02332000 +xmode1: % not first option and not being set, reset or popped. 02333000 + options[opinx+1]:=real(true); 02334000 + if xbit9 or endtog then go complete; 02680000 + nhi:nlo:=0; 02681000 + c:=0; go fpart; 02682000 +atsign: 02683000 + result:=0; scanner % scan past "@". 02684000 + if cont>17 then go argh; % 16 chars, + "@". 02685000 + if octize(accum[1],c,17-count,count-1) then 02686000 + begin q:=accum[1]; flag(521); go scanagain end; 02686500 + go numberend; 02687000 +comment Dot and atsign enter number conversion at correct spot; 02689000 +quote: 02690000 + count:=0; 02691000 + t:=if streamtog then 63 02692000 + else if real(streamtog)>1 then 8 else 7; 02692500 + do begin 02693000 + result:=5; scanner; 02694000 + if count>t then 02695000 + begin q:=accum[1]; flag(520); go scanagain end; 02696000 + end until examin(ncr) = """; 02697000 + q:=accum[1]; result:=5; scanner; count:=count-1; 02698000 + if count<0 then count:=count+64; 02699000 + accum[1]:=q; result:=4; 02700000 +strngxt: t:=c:=0; 02701000 + if count < 8 then 02703000 +moveit: 02704000 + movecharacters(count,accum[1],3,c,8-count); 02705000 + t.class:=strngcon; 02705100 + go complete; 02705200 +comment crosshatch handles two situations: 02707000 + The crosshatch at the end of define declarations and 02708000 + the crosshatch at end of alpha representing defined ids. 02709000 + The two cases are processed differently. The first case 02710000 + merely places the crosshatch in ELBAT. The second case 02711000 + causes an exit from scanning the alpha for the defined id. 02712000 + For a full discussion see definegen; 02713000 +crosshatch: 02714000 + if definectr≠0 then go complete; 02715000 + putseqno(gt1,lcr); 02716000 + turnonstoplight(0,lcr); 02717000 + if defineindex = 0 then go argh; 02718000 + lcr:=(gt1:=definearray[defineindex-1]) div 262144; 02719000 + ncr:=gt1 mod 262144; 02720000 + gt2:=0&(t:=definearray[defineindex:=defineindex-3])[33:18:15]; 02721000 + lastused:=t.[33:15]; 02722000 + for gt1:=1 step 1 until gt2 do 02723000 + begin 02723500 + stackhead[(t:=take(lastinfo+1)).[12:36] mod 125]:= 02724000 + take(lastinfo).link; 02725000 + lastinfo:=(nextinfo:=lastinfo)-t.purpt; 02726000 + end; 02727000 + go scanagain; 02728000 +dollar: comment this code handles control cards; 02729000 + dollarcard; 02730000 +percent: if ncr ≠ fcr then readacard; 02731000 + go scanagain; 02737000 +comment: Most percent digns acting at end of card sentinels get to 02738000 + percent. Percent reads the next card and starts over. A 02739000 + side effect is that all characters on a card are ignored 02740000 + after a free percent sign (one not embedded in a string or 02741000 + comment); 02742000 +comment Might be funny comma - handle here; 02743000 +rtparen: result:=7; scanner; 02744000 + if examin(ncr) = """ then 02745000 + begin 02746000 + result:=0; scanner; 02747000 + do begin 02748000 + result:=5; scanner; 02749000 + end until examin(ncr) = """; 02750000 + result:=0; scanner; 02751000 + result:=7; scanner; 02752000 + if examin(ncr) ≠ "(" then go to argh; 02753000 + result:=0; scanner; q:=accum[1]; 02754000 + t:=spacial[24]; 02755000 + end; 02756000 + result:=2; go complete; 02757000 +ipart: tcount:=0; c:=convert; 02758000 +% result:=7; scanner; % deblank. 02759000 +% if definectr=0 then 02760000 +% if (c=3 or c=4) and examin(ncr)=""" then %octal or hex string.02761000 +% begin integer siz; 02762000 +% result:=5; scanner; %skip quote. 02763000 +% count:=q; 02764000 +% do begin 02765000 +% result:=5; scanner; 02766000 +% if count > siz:=48 div c then % > 1 word long. 02767000 +% begin err(420); go scanagain end; 02768000 +% end until examin(ncr)="""; 02769000 +% q:=accum[1]; result:=5; scanner; count:=count-1; 02770000 +% if c=3 then % octal string 02771000 +% if octize(accum[1],accum[4],16-count,count) then 02772000 +% flag(521) % non octal characater in string. 02773000 +% else else if hexize(accum[1],accum[4],12-count,count) then 02774000 +% flag(521); % non character in hex string. 02775000 +% if count < siz then 02776000 +% begin 02777000 +% c:=accum[4]; go finishnumber; 02778000 +% end; 02779000 +% t.incr:=count:=8; t.class:=string; 02780000 +% movecharacters(8,accum[4],0,accum[1],3); 02781000 +% go complete; 02782000 +% end octal or hex string; 02783000 + if dptog then 02784000 + begin nhi:=thi; nlo:=tlo; end; 02785000 + if examin(ncr)="." then 02786000 + begin 02787000 + result:=0; scanner; 02788000 + c:=1.0x c; 02789000 +fpart: tcount:=count; 02790000 + if examin(ncr)≤9 then 02791000 + begin 02792000 + result:=0; scanner; 02793000 + if dptog then 02794000 + begin 02795000 + double(convert,tlo,ten[(count-tcount)mod 12], 02796000 + 0,/,:=,thi,tlo); 02797000 + for t:=12 step 12 until count - tcount do 02798000 + double(thi,tlo,ten[12],0,/,:=,thi,tlo); 02799000 + double(thi,tlo,nhi,nlo,+,:=,nhi,nlo); 02800000 + c:=nhi 02801000 + end 02802000 + else c:=ten[tcount-count]×convert+c; 02803000 + end 02804000 + end; 02805000 + result:=7; scanner; 02806000 + if examin(ncr)="@" then 02807000 + begin 02808000 + result:=0; scanner; 02809000 +epart: tcount:=count; 02810000 + c:=c×1.0; 02811000 + result:=7; scanner; 02812000 + if t:=examin(ncr)>9 then 02813000 + begin 02815000 + result:=0; scanner; 02816000 + tcount:=count; 02817000 + end; 02818000 + result:=0; scanner; 02820000 + q:=accum[1]; 02822000 + if gt1:=t:=(if t="-"then -convert else convert)≤46 or 02823000 + t>69 then flag(269); 02824000 + else begin 02825000 + t:=ten[t]; 02826000 + if abs(0&c[42:3:6]&c[1:2:1]+0&t[42:3:6]&t[1:2:1] 02827000 + +12) >63 then flag(269) 02828000 + else if dptog then 02829000 + if gt1<0 then 02830000 + begin 02831000 + gt1:=-gt1; 02832000 + double(nhi.nlo,ten[gt1 mod 12],0,/,:=,nhi,nlo); 02833000 + for gt2:=12 step 12 until gt1 do 02834000 + double(nhi,nlo,ten[12],0,/,:=,nhi,nlo); 02835000 + end; 02836000 + else begin 02837000 + double(nhi,nlo,ten[gt1 mod 12],0,*,:=,nhi,nlo); 02838000 + for gt2:=12 step 12 until gt1 do 02839000 + double( nhi,nlo,ten[12],0,*,:=,nhi,nlo); 02840000 + end; 02841000 + else c:=c×t; 02842000 + end; 02843000 + end; 02844000 +numberend: 02845000 + q:=accum[1]; result:=3; 02846000 +finishnumber: 02847000 + t:=0; 02848000 + if c.[1:37]=0 then 02849000 + begin t.class:=litno ; t.address:=c end 02850000 + else t.class:=nonlitno ; 02851000 + go complete; 02852000 +comment The code between ident and compost does a lookup in info. 02853000 + If quantity is not found the ELBAT word expects to be 02854000 + zero. The scramble for appropriate stack is first thing 02855000 + to be done, then the loop between compost and 02859000 + rose is entered. The last thing done for any 02860000 + identifier which is found is to stuff the location 02861000 + of the elbatword in info into the linfiled. This 02862000 + allows reference back to info for additional data, 02863000 + should this be required. 02864000 +ident: t:=stackhead[scram:=(q:=accum[1])mod 125]; 02865000 +rose: gt1:=t.linkr; 02875000 + if(gt2:=t.linkc)+gt1= 0 then 02876000 + begin t:=0; go complete end; 02877000 + if t = info[gt1, gt2] then begin 02877010 + t:=0; go to complete end; 02877020 + t:=info[gt1,gt2]; 02878000 + if info[gt1,gt2+1]&0[1:1:11] ≠ 0 then goto rose; 02879000 + if count ≤ 5 then go compost ; 02880000 + if not equal(count-5,accum[2],info[gt1,gt2+2])then go rose; 02881000 +compost: t:=t>1[35:43:5]>2[40:40:8]; 02882000 +comment Check here for comments and defined ids; 02883000 + if not endtog then 02884000 + begin 02885000 + if gt1:=t.class = commentv then 02886000 + begin 02887000 + while examin(ncr) ≠ ";" do 02888000 + begin result:=6; count:=0; scanner; end; 02889000 + result:=0;scanner;go scanagain 02890000 + end; 02891000 + end; 02892000 + if stopdefine then go complete; 02893000 + if gt1 ≠ definedid then go complete; 02894000 +comment setup for defined ids - see definegen for more detals; 02895000 + if t.address≠0 then t:=fixdefineinfo(t); 02896000 + if defineindex = 24 then 02898000 + begin flag(139);go argh end; 02899000 + definearray[defineindex]:=lastused&t.address [18:33:15]; 02900000 + lastused:=git(t); 02901000 + definearray[defineindex+2]:=262144×lcr+ncr; 02902000 + lcr:=(ncr:=mkabs(definearray[defineindex+1]))+1; 02903000 + putseqno(gt4,lcr); 02904000 + turnonstoplight("%",lcr); defineindex:=defineindex+3; 02905000 + go percent; 02906000 +complete: 02909000 + elbat[nxtelbt]:=t; 02910000 + stopdefine:=false; comment allow defines again; 02911000 + if nxtelbt:=nxtelbt + 1 > 74 then 02912000 + if not macroid then 02913000 + begin 02914000 +comment elbat is ful: adjust it; 02915000 + move(10,elbat[65],elbat); 02916000 + i:=i-65; p:=p-65; nxtelbt:=10; 02917000 + end 02918000 + end; 02919000 + if table:=elbat[p].class ≠ commentv then 02920000 + begin 02921000 +comment special handling of constants for sake of for statements; 02922000 + c:=info[0,elbat[p].address]; 02923000 + elbat[p].class:=table:=nonlitno 02924000 + end; 02925000 + stopdefine:=false; comment allow define; 02926000 + end table ; 02927000 +boolean procedure boolprim; forward; 02955000 +procedure boolcomp(b); boolean b; forward; 02955500 +integer procedure next; 02956000 + begin 02956500 + label exit; 02957000 + integer t; 02957500 + define error = begin flag(603); go exit end#; 02958000 + skan; 02958500 + if result=3 then error; % Numbers not allowed. 02959000 + if result=2 then % Special character. 02959500 + begin 02960000 + t:=if q="1,0000" or q="1%0000" then 20 % Fake out boolexp. 02960500 + else ((t:=q.[18:6]-2) & t[42:41:3]); 02961000 + if t=11 or t=19 or t=20 then batman:=spacial[t] % (,),or ; 02961500 + else flag(603); 02962000 + go exit 02962500 + end special characters; 02963000 +comment Look for boolean operators, then options; 02963500 + t:= if q="3NOT00" then notop 02964000 + else if q="3AND00" then andop 02964500 + else if q="2OR000" then orop 02965000 + else if q="3EQV00" then eqvop 02965500 + else 0; 02966000 + if t≠0 then batman.class:=t 02966500 + else batman:=1 & booid[2:17] & real(findoption(1))[1:1]; % option. 02967000 +exit: 02967500 + next:=myclass:=batman.class; 02968000 + end next; 02968500 + boolean procedure boolexp; 02969000 + begin 02969500 + boolean b; 02970000 + b:=boolprim; 02970500 + while myclass≥eqvop and myclass≤andop do boolcomp(b); 02971000 + boolexp:=b; 02971500 + end boolexp; 02972000 + boolean procedure boolprim; 02972500 + begin 02973000 + boolean b,knot; 02973500 + define skipit = myclass:=next #; 02974000 + if knot:=(next=notop) then skipit; 02974500 + if myclass=leftparen then 02975000 + begin 02975500 + b:=boolexp; 02976000 + if myclass≠rtparen then flag(604); 02976500 + end 02977000 + else if myclass≠booid then flag(601) 02977500 + else b:=batman<0; 02978000 + if knot then b:=not b; skipit; 02978500 + boolprim:=b; 02979000 + end boolprim; 02979500 + procedure boolcomp(b); boolean b; 02980000 + begin 02980500 + real opclass; 02981000 + boolean t; 02981500 + opclass:=myclass; 02982000 + t:=boolprim; 02982500 + while opclass 1023 then emito(prte); 04018000 + emit(2 & address [36:38:10]) end emitv; 04019000 +comment emitn emits a descriptor call. If the adddress is for the 04020000 + second half of the PRT, then it also emits a PRTE; 04021000 +procedure emitn(address); value address; integer address ; 04022000 + begin if address > 1023 then emito(prte); 04023000 + emit(3 & address[36:38:10]) end emitn; 04024000 +comment emitpair emits a LITC address followed by operator. If the 04025000 + address is for the second half of the PRT, then it also 04026000 + emits PRTE; 04027000 +procedure emitpair(address,operator); 04028000 + value address,operator; 04029000 + integer address,operator; 04030000 + begin 04031000 + emitl(address); 04032000 + if address > 1023 then emito(prte); 04033000 + emito(operator) end emitpair; 04034000 + comment adjust adjust L to the beginning of a word and fills in the 04080000 + intervening space with NOPs. It checks STREAMTOG to decide04081000 + which sort of NOP to use; 04082000 + procedure adjust; 04083000 + begin 04084000 + 04085000 +while l.[46:2]≠0 do emit(45); 04086000 + end adjust; 04087000 + procedure emitlng; 04098000 + begin label e; 04099000 + if not linktog then go to e; 04100000 + comment go to e if last thin is a link; 04101000 + if get(l) ≠ 0 then go to e; 04102000 + comment Either last expression was conditional or there is no 04103000 + lng or relational operator; 04104000 + if gt1 ← get(l-1) == 77 then l ← l - 1; 04105000 + comment Last thing was an LNG - so cancel it; 04106000 + else if gt1.[42:6]=21 and gt1.[37:2]=0 then % aha 04107000 + comment Last thing was a relational; 04108000 + begin l←l-1; emito(real(boolean(gt1.[36:10]) eqv 04109000 + boolean(if gt1.[40:2] = 0 then 511 else 463))) 04110000 + comment Negate the relational; end else 04111000 + e: emito(lng) end emitlng 04112000 + comment emitb emits a branch operator and its associated number; 04113000 +procedure emitb(branch,from,towards); 04114000 + value branch,from towards; 04115000 + integer branch,from,towards; 04116000 + begin 04117000 + integer tl; 04118000 + tl ← l; 04119000 + if towards > fouled then fouled ← towards; 04119500 + l ← from - 2; 04120000 + gt1 ← towards-from; 04120100 + if towards.[46:2] = 0 04120200 + then begin 04120300 + branch ← branch&1[39:47:1]; 04120400 + gt1 ← towards div 4 - (from-1) div 4 end; 04120500 + emitnum(abs(gt1)); 04121000 + emito(branch&(real(gt1≥ 0)+1)[42:46:2]); 04122000 + 04123000 + l ← tl 04124000 + end emitb; 04125000 + comment debugword formats two fields for debugging output in 04126000 + octal, namely : 04127000 + 1. 4 characters for the L register, 04128000 + 2.16 characters for the word being emitted. ; 04129000 +stream procedure debugword( seq,code,feil); value seq,code ; 04130000 + begin 04131000 + di←feil; si← loc seq; si← si+4; ds ← 4 chr; 04132000 + ds ← 2 lit" "; 04133000 + si ← loc code ; 04134000 + 16( ds ← 3 reset; 3( if sb then ds←set else 04135000 + ds ← reset ; skip 1 sb)); 04136000 + 29(ds ← 2 lit" " ); 04137000 + end ; 04138000 + comment emitword places the parameter,"word",into EDOC. If 04139000 + debugging is required, "l" and "word" are ouptut on 04140000 + the printer file in octal foramt. ; 04141000 + procedure emitword (word); value word; real word; 04142000 + begin 04143000 + adjust; 04144000 + if l≥ 4088 then begin err(200); l←0; end 04145000 + else begin 04146000 + move(1,word, code(l div 4+1)); 04147000 + if debugtog then 04148000 + begin debugword(b2d(l),word,lin); 04149000 + writeline end; 04150000 + fouled ← l ← l+4; end 04151000 + end emitword; 04152000 + comment Constantclean is called after an unconditional branch has 04153000 + been emitted. If any constants have been accumulated by 04154000 + emitnum in info[0,*], constantclean will fix the chain 04155000 + of C-relative OPDC s left by emitnum. If C-relative 04156000 + addressing is impossible (e.e. the address 04157000 + if greater than 127 words) then the constant along wiht 04158000 + the 1st link of the OPDC chain is entered in info. 04159000 + At purge time the remaining OPDC s are emitted with 04160000 + F -relative addressing and code emitted to store the 04161000 + constants into the proper F-relative cells. ; 04162000 +procedure constantclean ; 04163000 + if mrclean then 04164000 + begin 04165000 + integer j,templ,d,link; 04166000 + boolean crel; 04167000 + label allthu ; 04168000 + 04169000 + for j ← 1 step 2 until lastentry do 04170000 + begin 04171000 + adjust; templ←l; l←info[0,255-j+1); 04172000 + crel ← false; 04173000 + do begin 04174000 + if d←(templ-l+3)div 4≥128 then 04175000 + if mode ≠ 0 then 04175500 + begin flag(50); go to allthu end; 04176000 + 04177000 + 04178000 + 04179000 + 04180000 + 04181000 + link←get(l); 04182000 + crel ← true; 04183000 + if mode ≠ 0 then emitv(d+/68) else 04184000 + emitv(real(templ≥2048)×1024+templ div 4); 04184500 + end until l← link = 4095 ; 04185000 + allthu: l← templ; 04186000 + if crel then emitword( info[0,255-j ]); 04187000 + end; 04188000 + lastentry ← 0; 04189000 + end ; 04190000 + comment emitnum handles the emission of code for constants,both 04191000 + explicit and implicit. In every case,emitnum will 04192000 + produce code to get the desired constant on top of 04193000 + the stack. If the number is a literal a simple LITC 04194000 + syllable is produced. However,non-literals are kept 04195000 + in the zero-th row of info with the syllable 04196000 + position,l. The first emitnum on a particular 04197000 + constant casues the values of l and the constant 04198000 + to be stored in info[0,*] (Note:items are stored 04199000 + in reverse starting with info[0,255],etc.). Then 04200000 + its the job of constantclean to emit the actual 04201000 + OPDC (see constantclean procedure for details) ; 04202000 +procedure emitnum( c ); value c; real c; 04203000 + begin label finished,found ; real n; 04204000 + if c.[1:37]=0 then emitl(c) 04205000 + else 04206000 + begin 04207000 + fouled ← l; 04207500 + for n ← 1 step 2 until lastentry do 04208000 + if info[0,255-n] = c then go to found; 04209000 + info[0,255 -lastentry] ← l; 04210000 + info[9,255 -lastentry-1]← c ; 04211000 + emitn(1023); 04212000 + if mode=0 then emito(nop); 04212100 + linktog←false; 04213000 + if lastentry ← lastentry+2 ≥ 128 then 04214000 + begin 04215000 + c ← bumpl; 04216000 + constantclean; 04217000 + emitb(bfw,c,l); 04218000 + end; 04219000 + go to finished; 04220000 + found: emit(info[0,255 -n+1]); 04221000 + linktog←false; 04222000 + info[0,255-n+1]← l-1; 04223000 + if mode=0 then emito(nop); 04223100 + end; 04224000 + finished:end emitnum ; 04225000 + comment search performs a binary search on the COP and WOP 04226000 + arrays. Given the operator bits search yields the BCD 04227000 + mneumonic for that operator. If the operator cannot 04228000 + be found search yields blanks. 04229000 + Note: DIA,DIB,RTRB are returned as blanks. ; 04230000 +alpha procedure search (q,key); value key;; array q[0]; real key ; 04231000 + begin label l; 04232000 + comment gt1 and gt2 are initialized assuming that Q is ordered 04233000 + by pairs (argument,function,argument,function,etc.) 04234000 + and that the first argument is in Q[4]. Furthermore 04235000 + the length of Q is 128. ; 04236000 + integer n,i ; 04237000 + n ← 64 ; 04238000 + for i ← 66 step if q[i]1 then fillit(lin,pors,gs,0,info[n.linkr,n.linkc]) 05325470 +else fillit(lin,pors,gs,abs(n),n); 05325480 + if noheading then datime; writeline; 05325490 + end writeprt; 05325500 + comment GETSPACE makes assignments to variables and descriptors in 05326000 + the stack and PRT. Permanent tells whether it is a 05327000 + permanently assigned cell (always in PRT) or not. Non 05328000 + permenent cells are either in stack or PRT acording to 05329000 + mode. Care is taken to reuse non permanent PRT cells; 05330000 +integer procedure getspace(permanent,l); value permanent,l; 05331000 + boolean permanent; integer l; 05333000 + begin label l1,l2,exit; 05334000 + stream procedure doit(c,a,i,s); value c,a; 05334100 + begin local n; 05334200 + di←s; ds←8 lit" "; si←s; ds←9 wds; 05334300 + si←i; si←si+2;di←loc n; di←di+7; ds←chr; 05334400 + di←s;si←loc c; 2(ds←4 dec); 05334500 + si←i; si←si+3; ds←n chr; 05334600 + end; 05334700 + boolean m,q; 05343000 + integer row,col,gs; 05344000 +if not(streamtog and (level>2))then 05344400 + if stepi=relop then 05344500 + begin 05344510 + if stepi>idmax 05344520 + then 05344530 + begin 05344540 + if elclass=adop 05344550 + then 05344560 + if elbat[i].address=subop 05344570 + then gs←fzero else gs←512; 05344580 + else 05344590 + begin gs←0;i←i-1 end; 05344600 + if stepi≠litno then flag(51); 05344610 + if elbat[i],address≥512 then gs←1024; 05344615 + gs←gs+elbat[i].address 05344620 + end 05344630 + else 05344640 + begin 05344650 + gs←elbat[i].address; 05344660 + if gs=0 then flag(51); 05344661 + if gs≥fzero and gs≤1023 then gs←-gs; 05344662 + if stepi≠adop then i←i-1else 05344670 + begin 05344680 + stepit; 05344690 + gs←elbat[i].address+ 05344700 + (if elbat[i-1].address=subop 05344710 + then -gs else +gs); 05344720 + end; 05344730 + gs←abs(gs); 05344740 + end; q←gs<512 or gs>1023; 05344750 + go to exit 05344760 + end else i←i-1; 05344770 + if mode = 0 or permanent 05345000 + then begin 05346000 + if prtimax > 1023 then flag(148); 05347000 + if astog then flag(505); 05348000 + prti ← 05349000 + prtimax←(gs←prtimax)+1; 05350000 + if stufftog then if (m←(level=1 and klassf>19)) or 05350100 + (level≥3 and elbat[i].class=labelid) then begin 05350120 + if not m then 05350140 + doit(labelid,gs,info[(elbat[i]).linkr, 05350160 + (elbat[i].linkc+1)],twxa[0]) else 05350180 + doit(klassf,gs,info[(lastinfo+1),linkr,(lastinfo+1),linkc]05350200 + ,twxa[0]); write(stuff,10,twxa[*]) end; end 05350300 + else begin 05369000 + if stackctr > 767 then flag(149); 05370000 + stackctr ← (gs ← stackctr)+1; q ← false; 05371000 + go to exit end; 05372000 + l2: if gs ≥ 512 then gs + gs+1024; 05373000 + q ← true; 05374000 + exit: getspace ← gs; 05375000 + if gs≥nextctr and gs 1023 then gs ← gs-1024; 05376000 + if prtog then writeprt(if q then "PRT " else "STACK",l,b2d(gs)); 05376100 + end getspace; 05378000 +real procedure depth(i); value i; real i; 05400000 + begin real j,k,t,s,m; 05401000 + if t←nestprt[i]<0 then 05402000 + begin depth←call[t.[22:13]-1].[35:13]; 05402100 + if nestprt[i].[2:1]=0 then nestcur←nestcur+1; 05402200 + nestptr[i].[2:1]←1; 05402300 + end 05402400 + else if t.[9:13]≠0 then depth←t.[9:13] 05403000 + else begin m←0; nestprt[i]←-t; 05404000 + j←t.[22:13]; k←call[j-1].[22:13]; 05405000 + for j←j step 1 until k do 05406000 + if s←depth(call[j])>m then m←s; 05407000 + m←depth+m+call[t.[22:13]-1].[35:13]; 05409000 + if nestcur≠0 then 05409100 + if nestptr[i].[2:1]=0 then else 05409200 + begin t←t&m[9:35:13]; nestcur←nestcur-1 end 05409300 + else t←t&m[9:35:13]; 05409400 + nestptr[i]←t; 05409500 + end; 05410000 + end; 05411000 +procedure nestsort(l,u); value l,u; real l,u; forward; 05411100 +procedure sortnest; 05412000 + begin array a[0:14]; 05413000 + real i,j,k,t; 05414000 + real p,q; 05414100 + stream procedure nestform(i,n,l,a) value i,n; 05415000 + begin local s; 05416000 + d1←a; 15(ds←8 lit " "); 05417000 + di←loc s; di←di+7; si←l; si←si+10; ds←chr; 05418000 + di←a; di←di+i; a←di; 05419000 + di←di+6; ds← s chr; 05420000 + di←a; si←loc n; ds←4 dec; 05421000 + di←a; ds←3 fill; 05422000 + end; 05423000 + for i←prtbase step 1 until prtop do 05424000 + if nestptr[i]≠0 then 05425000 + begin sortprt[q]←1;q←q+1 end; 05425100 + nestsort(0,q←q-1); 05425200 + for p←0 step 1 until q do 05425300 + begin i←sortprt[p]; t←nestptr[i]; 05425400 + nestform(0,depth(i),info[t.linkr,t.linkc),a); 05426000 + write(line[dbl],15,a[*]); 05427000 + j←t.[22:13]; k←call[j-1].[22:13]; 05428000 + for j←j step 1 until k do 05429000 + begin i←call[j]; 05430000 + t←nestptr[i]; 05430500 + nestform(32,depth(i),info[t.linkr,t.linkc],a); 05431000 + write(line,15,a[*]); 05432000 + end; 05433000 + write(line[dbl]); 05434000 + end; 05435000 + end; 05436000 +procedure nestsort(l,u); value l,u; real l,u; 05437000 + begin real i,j,k,m; 05438000 + label again,top,bottom,exit; 05439000 + if l≠u then 05440000 + begin m← (u+l) div 2; 05441000 + nestsort(l,m); 05442000 + nestsort(m1:,u); 05443000 + i←k+l; j←m+1 05444000 + again: if i>m then go to top; 05445000 + if j>u then go to bottom; 05446000 + gt1←nestptr[sortprt[i].[33:15]].link; 05447000 + gt2←nestptr[sortprt[j].[33:15]].link; 05448000 + if info[gt1.linkr,(gt1+1).linkc].[18:30]≤ 05449000 + info[gt2.linkr,(gt2+1).linkc).[18:30] then 05450000 + go to bottom; 05451000 + top: sortprt[k].[18:15]←sortptr[j]; 05452000 + j←j+1; 05453000 + if k←k+1≤u then go to again else go to exit; 05454000 + bottom: sortprt[k].[18:15]←sortprt[i]; 05455000 + i←i+1; 05456000 + if k←k+1≤u then go to again else go to exit; 05457000 + exit: for i←l step 1 until u do 05458000 + sortptr[i]←sortptr[i].[18:15]; 05459000 + end; 05460000 + end; 05461000 +comment Routines in this section compile code for all expressions; 06000000 +comment AEXP is the arithemtic expression routine; 06001000 +procedure aexp; 06002000 + begin 06003000 + if elclass = ifv 06004000 + then begin if ifexp ≠ atype then error(102) end 06005000 + else begin arithsec; simparith end 06006000 + end aexp; 06007000 +comment ARITHSEC compiles first primary in an arithmetic expressions. 06008000 + in paricular it handles p, +p, -P and -P×Q where P 06009000 + and Q are primaries; 06010000 +procedure arithsec; 06011000 + begin 06012000 + if elclass = adop 06013000 + then begin 06014000 + stepit; 06015000 + if elbat[i-1].address ≠ sub then primary 06016000 + else begin 06017000 + primary; 06018000 + endtog ← linktog; emito(chs); 06021000 + linktog ← endtog; endtog ← false end end 06022000 + else primary end arithsec; 06023000 + comment SIMPARITH comiles simple arithmetic expressions on the 06024000 + assumption that an arithmetic primary has already been 06025000 + compiled. It also handles the case of a concatenate 06026000 + where actualparapart caused the variable routine to 06027000 + compile only pat of a primary. Most of the work of 06028000 + SIMPARITH is doen by ARITHCOMP, an artificial routine 06029000 + which does the hierarchy analysis using recursion. 06030000 + ARITHCOMP is a subroutine only to get this recursion; 06031000 +procedure simparith; 06032000 + begin 06033000 + while elclass = ampersand 06034000 + do begin stepit; primary; parse end; 06035000 + while elclass ≥eqvop do arithcomp end; 06036000 +comment ARITHCOMP is the guts of the arithmetic expression routine 06037000 + analysis. It calls PRIMARY at appropriate times and 06038000 + emits the arithmetic operators. The hierarchy analysis 06039000 + is opbtained by recursion; 06040000 +procedure arithcomp; 06041000 + begin integer operator, opclass; 06042000 + do begin 06043000 + operator ← 1 & elbat[i] [36:7:10]; 06044000 + comment This sets up the operator which will be emitted. The high 06045000 + order ten bits of the operator are located in [17:10] 06046000 + of the elbat word; 06047000 + opclass ← elclass; 06048000 + stepit; primary; 06049000 + begin 06051000 + while opclass < elclass do arithcomp; 06052000 + comment The classes are arranged in order of hierarchy; 06053000 + emit(operator); 06054000 + emit(0); l ← l-1; 06054100 + stackct ← 1; 06054150 + end; 06054200 + end until opclass ≠ elclass end arithcomp; 06055000 + integer procedure exprss; begin aexp; exprss ← atype end; 06057000 +procedure polish(expect); value expect; real expect; 06060000 + begin label exit; 06061000 + label el; 06061900 + real count,t1, t2; 06062000 + boolean s; 06063000 + real sss; integer z; 06063500 + stream procedure writeout(c,n,l); value c,n; 06064000 + begin di ← l; ds ← 2 lit "S="; 06065000 + si ← loc c; si ← si+7; ds ← chr; 06066000 + si ← loc n; ds ← dec; 06067000 + 58(ds←2lit " "); 06067500 + end; 06068000 + sss← stackctr; 06068500 + if stepi ≠ leftparen then go to exit; 06069000 + do begin 06070000 + if stepi ≥ operators then 06071000 + begin t1 ← (t2 ← elbat[i]).address; 06072000 + s ← s or count - t2.[11:3] < 0; 06074000 + count ← t2.[14:2]+count-2; 06075000 + if elclass ≥ operator then 06076000 + begin if t1 ≠ 0 then emito(t1); 06077000 + else begin 06078000 + t1 ← t2.link+2; 06079000 + t2 ← t2.incr+t1; 06080000 + for t1 ← t1 step 1 until t2 do 06081000 + emit(take(t1)); 06082000 + end; 06083000 + end else begin t2 ← elclass; 06084000 + if stepi ≠ litno then 06085000 + begin err(500); go to exit end; 06086000 + if t2 = bitop then emit(t1&C 06087000 + [36:42:6]) else 06088000 + if t2 =hexop then emit(t1& 06089000 + (t2←c div 6)[36:45:3]&(c-t2×6) 06090000 + [39:45:3]) else 06091000 + if t2 = isolate then 06092000 + begin t2 + c; 06093000 + if stepi ≠ litno 06094000 + then begin err(500); 06095000 + go to exit end; 06096000 + 06097000 + 06098000 + 06099000 + emit(z←((t2+c-1)div 6-c div 06099100 + 6+1)×512+(48-t2-c)mod 6×64+ 06099200 + 37); 06100000 + end end; 06101000 + stepit; 06102000 + s ← s or count < 0; 06103000 + end else begin 06104000 + if elclass = labelid then 06104100 + begin t1:=2; 06104200 + el: gt4 ← take(t2←git(elbat[i])); 06104300 + put(l,t2); 06104400 + if gt4 = 0 then gt4 ← l; 06104500 + if (gt4:=l-gt4)div 4 ≥ 128 then 06104510 + begin gt4:=0;flag(50);end; 06104520 + emit(gt4×4+t1); 06104600 + stepit; 06104700 + end else 06104800 + if elclass ≠ period then aexp else begin 06105000 + t2←0; 06106000 + if stepi=period then 06106100 + begin t2←1; stepit end; 06106200 + if elclass>idmax then 06106300 + begin err(500); go to exit end; 06107000 + if elclass = labelid then 06107100 + begin t1 ← 0; go to el end; 06107200 + if t1 ← elbat[i].address = 0 then 06108000 + begin err(100); go to exit end; 06109000 + emitl(t1); 06110000 + if t1>1023 then 06110100 + if t2=0then flag(500) 06110200 + else emito(prte); 06110300 + stepit; 06111000 + end; count ← count+1; 06112000 + end; 06113000 + end until elclass ≠ comma; 06114000 + if elclass ≠ rtparen then 06115000 + begin err(104); go to exit end; 06116000 + stepit; 06117000 + if false then 06118000 + begin count ← count-expect; 06119000 + writeout(if count < 0 then "-" else 06120000 + if count = 0 then " " else "+", 06121000 + abs(count),lin[0]); 06122000 + writeline; 06123000 + end; 06124000 + exit: stackctr ← sss; end; 06125000 +procedure primary; 06126000 + begin label 06127000 + l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, 06128000 + l11, l12, l13, l14, l15, l16, l17, l18, l19, l20, 06129000 + l21, l22, l23, l24, l25, l26, l27, l28, l29, l30, 06130000 + l31, l32, l33, l34, l35, l36, l37, l38, l39; 06131000 + switch s ← 06132000 + l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, 06133000 + l11, l12, l13, l14, l15, l16, l17, l18, l19, l20, 06134000 + l21, l22, l23, l24, l25, l26, l27, l28, l29, l30, 06135000 + l31, l32, l33, l34, l35, l36, l37, l38, l39; 06136000 + label exit,rp,ldot,lamper; 06137000 + go to s[elclass]; 06138000 + if elclass = lftbrket then 06139000 + begin stepit; variable(fl); 06140000 + if elclass ≠ rtbrket then 06141000 + begin err(118); go to exit end; 06142000 + stepit; 06143000 + go to ldot; 06144000 + end; 06145000 + if elclass = notop then 06146000 + begin stepit; primary; 06147000 + emitlng; emit(0); l←l-1; 06148000 + go to exit; 06149000 + end; 06150000 + if elclass = unknownid then err(100); 06151000 +l1:l2:l3:l4:l5:l6:l8:l9:l10:l12:l13:l16:l17:l20,l21:l24:l25:l28:l29: 06152000 +l32: 06153000 + err(103); go to exit; 06154000 + l7: 06155000 + subhand(false); go to ldot; 06156000 + l11: 06157000 + impfun; stackct ← stackct-1; go to ldot; 06158000 + l14:l15: 06159000 + strmprocstmt; go to ldot; 06160000 + l18:l19: 06161000 + procstmt(false); go to ldot; 06162000 + l22:l23:l26:l27:l30:l31: 06163000 + variable(fp); go to lamper; 06164000 + l33:l35: 06165000 + emit(0&elbat[i] [36:17:10]); stepit; go to lamper; 06166000 + l34:l36: 06167000 + emitnum(c); stepit; go to lamper; 06168000 + l38: 06169000 + polisher(1); go to ldot; 06170000 + l39: 06171000 + stepit; primary; stackct ← stackct -1; 06172000 + emito(lod); goto ldot; 06172500 + l37: 06173000 + stepit; aexp; 06174000 + stackct ← stackct -1; 06174500 + if elclass ≠ rtparen then 06175000 + begin err(104); go to exit end; 06176000 + stepit; 06177000 + ldot:dot: 06178000 + lamper: 06179000 + stackct ← stackct +1; 06179500 + while elclass = ampersand do 06180000 + begin stepit; primary; parse end; 06181000 +exit: end primary; 06182000 +procedure impfun; 06183000 + begin real t1,t2; 06184000 + t1 ← (t2 ← elbat[i]).address; 06185000 + pana; 06186000 + if t1 ≠ 0 then emito(t1); 06187000 + else begin 06188000 + t1 ← t2.link+t2.incr+1; 06189000 + t2 ← t2.link+2; 06190000 + for t2 ← t2 step 1 until t1 do emit(take(t2)); 06191000 + end; 06192000 + end; 06193000 +procedure subhand(from); value from; boolean from; 06194000 + begin label exit; 06195000 + real t1; 06196000 + t1 ← takefrst; 06197000 + if elclass ≠ subid and from then 06198000 + begin if stepi ≠ assignop then 06199000 + begin flag(503); go to exit end; 06200000 + stepit; 06201000 + aexp; 06202000 + emito(xch); 06203000 + go to exit; 06204000 + end; 06205000 + emitl((l+6) div 4-(t1.[24:12]-1) div 4); 06206000 + emitb(bbw,bumpl,t1.[36:12]); 06207000 + stepit; 06208000 + adjust; 06208500 +exit: end subhand; 06209000 +comment IFEXP compiles conditional expressions. It reports the type 06292000 + of the expressions as EXPRSS reports; 06293000 +integer procedure ifexp; 06294000 + begin integer type,thenbranch,elsebranch; 06295000 + ifclause; 06296000 + stackct ← 0; 06296500 + thenbranch ← bumpl; 06297000 + comment save L for later fixup; 06298000 + ifexp ← type ← exprss; comment compile 1st exprss; 06299000 + stackct ← 0; 06299500 + elsebranch ← bumpl; 06300000 + emitb(bfc,thenbranch,l); 06301000 + if elclass ≠ elsev then err(155) else begin 06302000 + stepit; 06303000 + aexp; stackct ← 1; 06305000 + comment this compiles proper type second exprss; 06306000 + emitb(bfw,elsebranch,l); 06307000 + emit(1); l ← l-1; 06308000 + comment this is used by emitlng to cleanup code. Compare with 06309000 + boosec, boocomp, and relation; 06310000 + end end ifexp; 06311000 +comment PARSE compiles code for the concatenate; 06312000 +procedure parse; 06313000 + begin integer first,second,third; 06314000 + label exit; 06315000 + if elclass = lftbrket then 06316000 + if stepi = litno then 06317000 + if stepi = colon then 06318000 + if stepi = litno then 06319000 + if stepi = colon then 06320000 + if stepi = litno then 06321000 + if stepi = rtbrket then 06322000 + comment If test are passed then syntax is correct; 06323000 + if (first ← elbat[i-5].address) × 06324000 + (second ← elbat[i-3].address) × 06325000 + (third ← elbat[i-1].address) ≠ 0 then 06326000 + if first + third ≤48 then 06327000 + if second+ third ≤48 then 06328000 + comment If test are passed then ranges of literals are O.K.; 06329000 + begin 06330000 + stepit; 06331000 + emitd(second,first,third); 06332000 + stackct ← 1; 06332500 + go to exit end; 06333000 + err(113); comment Error if syntax or range fails; 06334000 + exit: end parse; 06335000 +comment DOT compiles code for partial word designators, except for 06336000 + those cases handled by the variable routine; 06337000 +procedure dot; 06338000 + begin integer first,second; label exit; 06339000 + if elclass = period then begin 06340000 + if dotsyntax(first,second) then go to exit; 06341000 + 06342000 + 06343000 + emiti(0,first,second); 06344000 + stepit; 06345000 + exit: end end dot; 06346000 +procedure ifclause; 06409000 + begin stepit; bexp; 06410000 + if elclass ≠ thenv then err(116) else stepit end ifclaus;06411000 +comment pana compiles the construct: (); 06412000 +procedure pana; 06413000 + begin 06414000 + if stepi ≠ leftparen then err(105) 06415000 + else begin stepit; aexp; if elclass ≠ rtparen then 06416000 + err(104) else stepit end end pana; 06417000 +comment bana compiles the construct: []; 06418000 +procedure bana; 06419000 + begin 06420000 + if stepi ≠ lftbrket then err(117) 06421000 + else begin stepit; aexp; if elclass ≠ rtbrket then 06422000 + err(118) else stepit end end bana ; 06423000 + comment this section contains the statement routines; 07000000 + comment compoundtail compiles compoundtails. It also eliminates 07001000 + comments following ends. After any error, error messages 07002000 + are suppressed. Compoundtail is partially responsible 07003000 + for restoring the ability to write error messages. Some 07004000 + care is also taken to prevent reading beyond the "END."; 07005000 +procedure compoundtail; 07006000 + begin label another; 07007000 + i ← i-1; beginctr ← beginctr+1; 07008000 +another: errortog ← true; comment Allow error messages; 07009000 + stepit; 07010000 + if streamtog then streamstmt else stmt; 07011000 + if elclass = semicolon then go to another; 07012000 + if elclass ≠ endv 07013000 + then begin 07014000 + err(119); go to another end; 07015000 + endtog←true; 07016000 + do stopdefine←true until 07017000 + stepi≤endv and elclass≥untilv 07018000 + or not endtog; 07019000 + endtog←false; 07020000 + if beginctr ← beginctr-1 ≠ 0 eqv elclass = period 07021000 + then begin 07022000 + if beginctr = 0 then 07023000 + begin flag(143); beginctr ← 1; go another end; 07024000 +flag (120); 07025000 +fcr:= (lcr:=mkabs(cbuff[9]))-9; 07025010 + if lister then printcard; 07025020 +fcr:= (lcr:=mkabs(tbuff[9]))-9 end; 07025030 + if elclass = period then 07026000 + begin 07027000 + gt5 ← "NO;END,"&"E"[1:43:5]; 07028000 + move(1,gt5,cbuff[0]); 07029000 + lastused←4; 07030000 + elbat[i←i-2] ←special[20]; 07031000 + elclass ← semicolon end; 07032000 + end compoundtail; 07033000 + real axnum 07034000 + procedure actualparapart(sbit,index); value sbit,index; 07035000 + boolean sbit; real index; 07036000 + begin label exit,common,another,pol; 07037000 + real pctr,sclass,aclass; 07038000 + stream procedure writeax(line,accum,n,seq); value n; 07038100 + begin di ← line; 15(ds ← 8 lit " "); 07038200 + di ← line; si ← seq; si ← si-16; ds ← wds; 07038300 + di ← di+4; ds ← 20 lit "ACCIDENTAL ENTRY AT "; 07038400 + si ← accum; si ← si+3; ds ← n chr; 07038500 + si ← seq; di ← seq; di ← di-16; ds ← wds; 07038600 + end; 07038700 + boolean vbit,idbit; 07039000 + pctr ← 1; 07040000 + another: aclass ← stepi&0[47:47:1]; 07041000 + stackct ← 0; 07041200 + gt1 ← take(index+pctr); 07042000 + vbit ← boolean(gt1.vo); 07043000 + sclass ← gt1.class&0[47:47:1]; 07044000 + if vbit then begin aexp; go to common end; 07045000 + if sbit then sclass ← nameid; 07046000 + idbit ← booid < aclass and aclass < labelid; 07047000 + if sclass = nameid then 07048000 + begin 07049000 + if idbit then variable(fl); 07050000 + else 07051000 + pol: if elclass = polishv then polisher(1) 07052000 + else err(if elclass=0 then 0 else 123); 07053000 + go to common; 07054000 + end; 07055000 + if sclass = realarrayid then 07056000 + if aclass = realarrayid then 07057000 + begin variable(fl); go to common end 07058000 + else go to pol; 07059000 + if sclass ≠ realid then 07060000 + begin flag(503); 07061000 + aexp; 07062000 + errortog ← true; 07063000 + go to common; 07064000 + end; 07065000 + gt1 ← table(i+1); 07066000 + if gt1 = comma or gt1 = rtparen then 07067000 + begin if idbit then 07068000 + begin if aclass = realid and 07069000 + boolean(elbat[i].formal)then begin 07070000 + checker (elbat[i]); 07070500 + emitpair(elbat[i],address,lod); 07071000 + stepit; end 07072000 + else variable(fl); 07073000 + go to common end; 07074000 + if elclass ≤ strngcon and elclass > labelid 07075000 + then begin primary; goto common end; 07076000 + end; 07077000 + emito(nop); emito(nop); 07078000 + sclass ← l; 07079000 + adjust; 07080000 + aclass ← l.[36:10]; 07081000 + if idbit then 07082000 + begin variable(fl); 07083000 + if elclass < ampersand then go to common; 07084000 + 07084500 + simparith; 07085000 + end else aexp; 07086000 + if lister then 07086100 + begin accum[1] ← q; 07086200 + writeax(lin[0],accum[1],q.[12:6], 07086300 + info[lastseqrow,lastsequence]); 07086400 + writeline; 07086500 + end; 07086600 + axnum ← axnum+1; 07086700 + emito(rts); 07087000 + emitb(bfw,sclass,l); 07088000 + emitnum(aclass); 07089000 + emitpair(take(proinfo).address,lod); 07090000 + emito(inx); 07091000 + emitn(512); 07092000 + emitd(33,18,15); 07093000 + emit(0); 07093100 + emitd(5,5,1); 07093200 + common: pctr ← pctr+1; 07094000 + if elclass = comma then go to another; 07095000 + if elclass ≠ rtparen then 07096000 + begin err(129); go to exit end; 07097000 + if take(index).nodimpart+1 ≠ pctr then 07098000 + begin err(128); go to exit end; 07099000 + stepit; 07100000 + stackct ← 0; 07100500 +exit: end actual parapart; 07101000 +procedure procstmt(from); value from; boolean from; 07391000 + begin 07392000 + real hole,address; 07393000 + real j; label ok; 07393100 + label exit; 07394000 + scatterelbat; 07395000 + hole← elbat[i]; 07396000 + address ← addrsf; 07397000 + if nestog then 07397100 + if mode≠0 then 07397200 + if table(i+1)≠assignop then 07397210 + begin for j←callinfo step 1 until callx do 07397300 + if call[j]=address then go to ok; 07397400 + call[callx←callx+1]←address; 07397500 + ok: end; 07397600 + checker(hole); 07398000 + if elclass ≠procid then 07399000 + if not formalf then 07400000 + if table(i+1) = assignop then 07401000 + begin variable(2-real(from)); go to exit end; 07402000 + comment Call variable to handle this assignment operation; 07403000 + if elclass ≠ procid eqv from 07404000 + then begin err(159); go to exit end; 07405000 + comment It is procedure if and only if we come form stmt; 07406000 + stepit; 07407000 + emito(mks); 07408000 + if elclass = leftparen 07409000 + then actualparapart(false,git(hole)) 07410000 + else if formalf then l ← l-1; 07411000 + else if take(git(hole)).nodimpart≠0 then err(128); 07412000 + emitv(address); 07413000 +exit: end procstmt; 07425000 +procedure strmprocstmt; 07426000 + begin real whole,fix,t1; 07427000 + 07428000 + 07429000 + whole ← elbat[i]; fix ← -1; 07430000 + if elclass ≠ strprocid then emit(0); 07431000 + if whole. lvl ≠ 1 then 07432000 + begin fix ← l; l ← l+1 end; 07433000 + emito(mks); 07434000 + t1 ← takefrst.[1:6]; 07435000 + for gt1 ← 1 step 1 until t1 do emit(0); 07436000 + if stepi ≠ leftparen then err(128) 07437000 + else begin actualparapart(true,git(whole)); 07438000 + if fix < 0 then emitv(whole,address) 07439000 + else begin t1 ← l; l ← fix; 07440000 + whole ← take(git(whole)); 07441000 + emitnum(t1+2-whole.[16:12]); 07442000 + l ← t1; 07443000 + emitb(bbw,bumpl,whole.[28:12]); 07444000 + end; 07445000 + end end strmprocstmt; 07446000 +integer procedure bae; 07458000 + begin bae ← bumpl; constantclean; adjust end bae; 07459000 +comment relsestmt compiles the release statement; 07460000 +comment dostmt handles the do statement; 07481000 +procedure dostmt; 07482000 + begin integer tl; 07483000 + fouled ← l; 07483500 + 07484000 + stepit; t1←l; stmt; if elclass ≠untilv then err(131) 07485000 + else begin 07486000 + stepit; bexp; emitb(bbc,bumpl,tl) end 07487000 + end dostmt; 07488000 +comment whilestmt compiles the while statement; 07489000 +procedure whilestmt; 07490000 + begin integer back,front; 07491000 + fouled ← l; 07491500 + 07492000 + stepit; back ← l; bexp; front ← bumpl; 07493000 + if elclass ≠ dov then err(132) else 07494000 + begin stepit; stmt; emitb(bbw,bumpl,back); 07495000 + constantclean; emitb(bfc,front,l) end end whilestmt; 07496000 +comment gostmt compiles go to statements. Gostmt looks at the 07497000 + expression. If it is simple enough we go directly, 07498000 + otherwise a call on the MCP is generated in order to get 07499000 + storage returned. See dexp and gengo; 07500000 +procedure gostmt; 07501000 + begin 07502000 + real elbw; 07503000 + label gomcp,exit; 07504000 + if stepi = tov then stepit; 07505000 + if elclass = labelid then tb1 ← true 07506000 + else if elclass = switchid then tb1 ← false 07507000 + else begin if elclass = polishv then 07511000 + begin polisher(1); emito(bfw) end 07512000 + else err(501); 07513000 + go to exit; 07514000 + end; 07515000 + if not local(elbat[i]) then 07516000 + begin 07516100 + if tb1 then 07516200 + begin emitv(gnat(elbat[i])); 07516300 + emito(bfw); 07516400 + stepit; 07516500 + go to exit end; 07516600 + begin err(501); go to exit end; 07517000 + end; 07517500 + if tb1 then begin gogen(elbat[i],bfw); stepit; 07518000 + constantclean; go exit end 07519000 + else begin 07520000 + elbw ← elbat[i]; 07521000 + 07522000 + bana; 07523000 + emito(dup); 07524000 + emito(add); 07525000 + emito(bfw); 07526000 + gt3 ← take(gt4←git(elbw))+gt4; 07527000 + for gt4 ← gt4+1 step 1 until gt3 do 07528000 + gogen(take(gt4),bfw); 07529000 + end; 07530000 +exit: end gostmt; 07531000 +procedure gogen(labelbat,branchtype); 07535000 + value labelbat,branchtype; 07536000 + real labelbat,branchtype; 07537000 + begin 07538000 + if boolean(gt1←take(gt2←git(labelbat))).[1:1] 07539000 + then emitb(branchtype,bumpl,gt1.[36:12]) 07540000 + comment labelr sets the sign of the additional info for a label 07541000 + negative when the label is encountered. So this means 07542000 + that we now know where to go; 07543000 + else begin emit(gt1); emit(branchtype); 07544000 + put(gt1&l(36:36:12],gt2) end end gogen; 07545000 +comment simpgo is used only by the if stmt routine. It determines if 07546000 + a statement is a simple go to statement; 07547000 +boolean procedure simpgo; 07548000 + begin label exit; 07549000 + if elclass = gov 07550000 + then begin 07551000 + if stepi = tov then stepit; 07552000 + if elclass = labelid then 07553000 + if local(elbat[i]) then 07554000 + begin simpgo ← true; go exit end; 07555000 + i ← i-1; elclass ← gov end; 07556000 + exit: end simpgo; 07557000 +comment ifstmt compiles if statements. Special care is taken to 07558000 + optimize code in the neighbourhood of the jumps. To some 07559000 + extent supperfulous branching is avoided; 07560000 +procedure ifstmt; 07561000 + begin real t1,t2; label exit; 07562000 + ifclause; 07563000 + if simpgo 07564000 + then begin 07565000 + t1 ← elbat[i]; 07566000 + if stepi = elsev 07567000 + then begin 07568000 + stepi; 07569000 + if simpgo 07570000 + then begin 07571000 + gogen(elbat[i],bfc); gogen(t1,bfw); 07572000 + stepit; go to exit end else begin emitlng;gogen(t1,bfc); 07573000 + stmt ; go to exit end end ; 07574000 + emitlng; gogen(t1,bfc); 07575000 + go exit end; 07576000 + t1 ← bumpl; stmt; 07577000 + if elclass ≠ elsev then 07578000 + begin if l-t1>1023 then adjust; emitb(bfc,t1,l); 07579000 + go exit end; 07579100 + stepit; 07580000 + if simpgo 07581000 + then begin 07582000 + t2 ← l; l ←t1-2;gogen(elbat[i],bfc); l ← t2; 07583000 + stepit; go exit end; 07584000 + t2 ← bumpl; constantclean; 07585000 + if l-t1>1023 then adjust; emitb(bfc,t1,l); stmt; 07585100 + if l-t2>1023 then adjust; emitb(bfw,t2,l); 07586000 +exit: end ifstmt; 07587000 + comment labelr handles labeled statements. It piuts l into the 07588000 + additional info and makes its sign negative. It compiles 07589000 + at the same time all the previous forward references set 07590000 + up for it by gogen. (The additional info links to a list 07591000 + in the code array of all forward references); 07592000 + procedure labelr; 07593000 + begin label exit, round; 07594000 +define elbatword=rr9#,link=gt2#,index=gt3#,additional 07595000 + =gt4#,nextlink=gt5#; 07596000 + real oldl; 07596500 + do begin oldl ← l; 07597000 + if stepi ≠ colon then 07597500 + begin err(133); go to exit end; 07598000 + if not local(elbatword + elbat[i-1]) 07599000 + then begin flag(134); go to round end; 07600000 + if stepi = colon then 07600100 + begin i ← i-1; adjust end else 07600200 + if elclass = litno then l ← 4×c else 07600300 + if elclass=astrisk then 07600400 + begin if mode ≠ 0 or astog then 07600410 + flag(505); 07600420 + astog ← true; 07600430 + l ← 4×prti; 07600440 + end else 07600450 + i ← i-2; 07600500 + if stepi ≠ colon then 07600600 + begin err(133); go to exit end; 07600700 + if l < oldl then 07600800 + begin flag(504); go to round end; 07600900 + gt1 ← table(i+1); 07600950 + link ← (additional ← take(index ← git(elbatword))) 07601000 + .[36:12]; 07602000 + if additional < 0 then 07603000 + begin flag(135); go to round end; 07604000 + fouled ← l; 07604010 + if table(i+1) = colon then 07604020 + begin 07604030 + if link≠0 then begin oldl ← l; 07604040 + do begin nextlink ← get(link); 07604050 + l ← link; 07604060 + if oldl.[36:10]-l.[36:10]≥128 07604067 + then flag(50) else 07604068 + emit(oldl-link&0[46:46:2]+ 07604070 + 0&nextlink[46:46:2]+3072); 07604080 + l ← l-1; 07604085 + end until link←link-nextlink div 4=l; 07604090 + l ← oldl; end; stepit; 07604100 + do if stepi ≤ strngcon and elclass ≥ 07604110 + nonlitno then emitword(c) 07604120 + else begin err(500); i ← i-1 end 07604130 + until stepi ≠ comma; 07604140 + i ← i-1; 07604150 + end else 07604160 + while link ≠ 0 07605000 + do begin 07606000 + nextlink ← get(link-2); 07607000 + if l-link>1023 then adjust; 07607100 + emitb(get(link-1),link,l); 07608000 + link ← nextlink end; 07609000 + put(-additional&l[36:36:12],index); 07610000 + round: errortog ← true end until stepi ≠ labelid; 07645000 + exit: end labelr; 07646000 +procedure fillstmt(size)); value size; integer size; 07647000 + begin 07647500 +comment "coct" performs the octal convert for the fill statement. 07648000 + If there are any non-octal digits, this procedure returns 07648500 + a zero and then the 3 low-order bits of the bad digit are 07649000 + reset and ignored and error number 303 is printed. "coct" 07649500 + allows flag bits to be set, whereas "octize" does not. 07650000 + N Number of characters to be converted. 07650500 + SKBIT Number of its to skip before starting conversion. 07651000 + This is because the no. of chars. may be less than 07651500 + 8 and it must be right justified in cd(codefile). 07652000 + ACC Address of the accum where alpha info is kept. 07652500 + ; 07653000 + real stream procedure coct(n,skbit,acc,cd);value n,skbit; 07653500 + begin 07654000 + si:=acc; si:=si+6; di:=cd; ds:=8 lit"00000000"; 07654500 + di:=cd ; skip skbit db;tally:=1; 07655000 + n(if sc>"7"then tally:=0; skip 3 sb; 07655500 + 3(if sb then ds:=1 set else skip 1 db;skip 1 sb)); 07656000 + coct:=tally; 07656500 + end coct; 07657000 + real t2; 07657500 + label l1; 07658000 + stream procedure zeero(d); 07658500 + begin 07659000 + di:=0;ds:=8 lit"00000000"; 07659500 + si:=d;31(32(ds:=wds)); ds:=30 wds; 07660000 + end zeero; 07660500 + streamtog:=boolean(2); 07661000 + segmentstart(true); 07661500 + if stepi≠assignop then zeero(code(1)) 07662000 +else begin 07662500 + for t2:=1 step 1 until size do 07663000 + begin 07663500 + if stepi>idmax then 07664000 + begin 07664500 + if elclass≠litno and elclass≠nonlitno then 07665000 + if elclass≠strngcon then 07665500 + if elclass=adop and 07666000 + (stepi=nonlitno or elclass=litno) then 07666500 + c:=c & elbat[i-1][1:21:1] 07667000 + else begin error(302); go to l1 end; 07667500 + if elclass=strngcon and count=8 then 07668000 + movecharacters(8,accum[1],3,code(t2),0) 07668500 + else move(1,c,code(t2)) 07669000 + end 07669500 + else if count≤19 and accum[1].[18:18]="OCT" then 07670000 + begin 07670500 + if coct(count-3,48-(count-3)×3,accum[1], 07671000 + code(t2))=0 then flag(303) 07671500 + end 07672000 + else begin error(302); go to l1 end; 07672500 + if stepi≠comma then go to l1 07673000 + end; 07673500 + error(54); 07674000 + end; 07674500 +l1: 07675000 + right(size×4); 07675500 + streamtog:=false; 07676000 + segment(size,0); 07676500 + progdescbldr(addrsf,true,size,ddes); 07677000 + end fillstmt; 07677500 + procedure stmt; 07711000 + begin label 07712000 + l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, 07713000 + l11, l12, l13, l14, l15, l16, l17, l18, l19, l20, 07714000 + l21, l22, l23, l24, l25, l26, l27, l28, l29, l30, 07715000 + l31, l32, l33, l34, l35, l36, l37, l38, l39, l40, 07716000 + l41, l42, l43, l44, l45, l46, l47, l48, l49, l50, 07717000 + l51, l52, l53, l54; 07718000 + switch s ← 07719000 + l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, 07720000 + l11, l12, l13, l14, l15, l16, l17, l18, l19, l20, 07721000 + l21, l22, l23, l24, l25, l26, l27, l28, l29, l30, 07722000 + l31, l32, l33, l34, l35, l36, l37, l38, l39, l40, 07723000 + l41, l42, l43, l44, l45, l46, l47, l48, l49, l50, 07724000 + l51, l52, l53, l54; 07725000 + label again,exit; 07726000 + stackct ← 0; 07726990 + again: go to s[elclass]; 07727000 + if elclass = colon then 07727010 + begin stepit; gt1 ← l; 07727020 + if elclass = colon then 07727030 + begin adjust; i ← i-1 end 07727040 + else if elclass = litno then l ← 4×c 07727050 + else i ← i-1; 07727060 + if l < gt1 or stepi ≠ colon then 07727070 + begin err(504); go to exit end; 07727080 + stepit; 07727090 + go to again; 07727100 + end; 07727110 + if elclass = 0 then flag(100); flag(145); 07728000 +l1:l2:l3:l4:l5:l6;l9:l11:l13:l14:l15:l16;l17:l20:l21:l25:l28:l29:l24: 07729000 +l33:l34:l35:l36;l37:l39: 07730000 + err(144); go to exit; 07731000 + l7:l8: 07732000 + subhand(true); go to exit; 07733000 + l10:l18:l19: 07734000 + procstmt(true); go to exit; 07735000 + l12: 07736000 + strmprocstmt; go to exit; 07737000 + l22:l23:l26:l27:l30:l31: 07738000 + variable(fs); go to exit; 07739000 + l32: 07740000 + labelr; go to again; 07741000 + l38: 07742000 + polisher(0); go to exit; 07743000 + l40: 07744000 + if elbat[i].address = streamv then 07745000 + begin inline; go to exit end; 07746000 + flag(146); 07747000 + if table(i-2) = endv and mode > 0 then 07748000 + begin i ← i-2; elclass ← endv; go to exit end; 07749000 + i ← i-1; errortog ← true;block(false); 07750000 + elclass ← table(i←i-1); go to exit; 07751000 + l42: 07752000 + dblstmt; go to exit; 07753000 + l43: 07754000 + forstmt; go to exit; 07755000 + l44: 07756000 + whilestmt; go to exit; 07757000 + l45: 07758000 + dostmt; go to exit; 07759000 + l51: 07760000 + ifstmt; go to exit; 07761000 + l52: 07762000 + gostmt; go to exit; 07763000 + l53: 07764000 + iostmt; go to exit; 07765000 + l54: 07766000 + if stepi = declarators then 07767000 + begin 07768000 + if elbat[i].address = streamv then if stepi = % 6 07768100 + leftparen then % 6 07768110 + begin % 6 07768120 + elclass←table(i←i-1) ; 07768130 + compoundtail ; 07768140 + go to exit ; 07768160 + end else i ← i - 1; % 6 07768170 + i ← i - 1; % 6 07768180 + block(false); end else compoundtail; 07768200 + l46:l47:l48:l50: 07769000 + l49:l41: 07770000 + exit: end stmt; 07771000 + 07991000 + procedure iostmt; 07993000 + if stepi ≠ litno or (gt1←elbat[i].address>15 then err(98)else 07994000 + begin emit(elbat[i-1].address>1[41:47:1]>1[36:44:3]); 07995000 + stepit 07996000 + end scope statement; 07997000 +procedure forstmt; 08008000 + begin 08009000 + own real b,stmtstart,rego,returnstore,addres,v,vret, 08010000 + bret; 08011000 + own boolean signa,signb,signc, int, 08012000 + constana,constanb,constanc; 08013000 + define simpleb = signc#, formalv = signa#, 08014000 + simplev = constana#, a = v #, q = rego#, 08015000 + opdc = true#, desc = false#, k = bret#; 08016000 + label exit; 08017000 +comment plug emits either an operand call on a variable or a call on a 08018000 + constant depending on the requirements; 08019000 +procedure plug(c,a); value c,a; real a; boolean c; 08020000 + if c then emitnum(a) else emitv(a,address); 08021000 +comment simple determines if an arithmetic expression is + or - a 08022000 + constant or a simple variable. It makes a through report 08023000 + on its activity. It also makes provision for the rescan 08024000 + of elbat (this is the action with k - see code in the 08025000 + table routine for further details); 08026000 +boolean procedure simple(b,a,s); boolean b,s; real a; 08027000 + begin 08028000 + s ← if stepi ≠ adop then false else elbat[i].address 08029000 + = sub; 08030000 + if elclass = adop then stepit; 08031000 + if elclass ≥ nonlitno and elclass ≤ strngcon 08032000 + then begin k ← k+1; simple ← true; 08033000 + elbat[i] ← 0&commentv(2:41:7]&k[16:37:11]; 08034000 + info[0,k] ← a + c; b ← true end 08035000 + else begin 08036000 + b ← false; a ← elbat[i]; 08037000 + simple ← realid ≤ elclass and elclass ≤ intid end; 08038000 + stepit end simple; 08039000 +comment test emits the step-until element tst; 08040000 +procedure test; 08041000 + begin 08042000 + if not constanb then 08043000 + begin emito(sub); if simpleb then emitv(b,address) 08044000 + else begin 08045000 + emitl(2+l-bret); 08046000 + emitb(bbw,bumpl,b); 08047000 + end; 08048000 + emito(mul); emit(0) end; 08049000 + emito(if signb then geq else leq); emit (0); l←l-1; 08050000 + end test; 08051000 +boolean procedure simpi(all); value all; real all; 08052000 + begin 08053000 + checker(vret←all); 08054000 + addres ← all.address; 08055000 + formalv ← all.[9:2] = 2; 08056000 + if t ← all.class > intarrayid or t < booid or 08057000 + gt1 ← (t.booid) mod 4 < 1 then 08058000 + err(real(t ≠ 0) × 51 + 100); 08059000 + int ← gt1 = 2; 08060000 + simpi ← t ≤ intid end simpi; 08061000 +comment store emits the code for the store into the for index; 08062000 +procedure store(s); value s; boolean s; 08063000 + begin 08064000 + if formally then begin emito(xch); s ← false end 08065000 + else begin 08066000 + emitl(addres); 08067000 + if addres > 1023 then emito(prte) end; 08068000 + t ← (real(s)+1)×16; 08069000 + emito((if int then t+512 else 4×t)+4) end store; 08070000 +comment call effects a call on the index; 08071000 +procedure call(s); value s; boolean s; 08072000 + begin 08073000 + if simplev 08074000 + then if s then emitv(addres) else emitn(addres) 08075000 + else begin 08076000 + emitl(2+l-vret); 08077000 + emitb(bbw,bumpl,v); 08078000 + if s then emito(lod) end end call; 08079000 +procedure forlist(numle); value numle; boolean numle; 08080000 + begin 08081000 +procedure fix(store,back,forwart,start); 08082000 + value store,back,forwart,start; 08083000 + real store,back,forwart,start; 08084000 + begin 08085000 + emitb(get(forwart-1),forwart,start); 08086000 + if returnstore ≠ 0 08087000 + then begin 08088000 + l ← store; emitnum(b-back); 08089000 + emitpair(returnstore,std) end end fix; 08090000 + integer backfix, forwardbranch, foot, storefix; 08091000 + label brnch,exit; 08092000 + storefix ← l; q ← real(mod=0)+3; 08093000 + for k ← 1 step 1 until q do emito(nop); 08094000 + if numle 08095000 + then begin 08096000 + backfix ← l; 08097000 + if formally then call(desc) end 08098000 + else backfix ← v + real(simplev)-1; 08099000 + 08100000 + aexp; 08101000 + comment pick up first arithmetic expression; 08102000 + if elclass = stepv 08103000 + then begin 08104000 + comment here we have a step element; 08105000 + backfix ← bumpl; 08106000 + comment leave room for forward jump; 08107000 + if formally then call(desc); call(opdc); 08108000 + comment fetch index; 08109000 + if i > 70 then begin nxtelbt ← 1; i ← 0 end 08110000 + else rego ← i; 08111000 + if simpleb ← simple(constanb,b,signb) and 08112000 + (elclass = untilv or elclass = whilev) 08113000 + then begin 08114000 + comment we have a simple step function; 08115000 + plug(constanb ,b); 08116000 + end else begin 08117000 + comment the step function is not simple: we construct a 08118000 + subroutine; 08119000 + i ← if i < 4 then 0 else rego; stepit; 08120000 + signb ← constanb ← false; 08121000 + emit(0); b ← l; 08122000 + aexp; emito(xch); 08123000 + bret ← l; 08124000 + emito(bfw) end; 08125000 + emito(real(signb)×32+add); 08126000 + emitb(bfw,backfix,l); 08127000 + if elclass = untilv 08128000 + then begin comment step-until element; 08129000 + store(true); if formalv then call(opdc); 08130000 + stepit; aexp; test end 08131000 + else begin comment step-while element; 08132000 + if elclass ≠ whilev then 08133000 + begin err(153); go to exit end; 08134000 + stepit; store(false); bexp end end 08135000 + else begin 08136000 + comment we do not have a step element; 08137000 + store(false); 08138000 + if elclass = whilev 08139000 + then begin 08140000 + comment we have a while element 08141000 + stepit; bexp end 08142000 + else begin 08143000 + comment one expression element; 08144000 + if elclass ≠ comma then begin 08145000 + emitb(bfw,bumpl,l+2); backfix ← l end 08146000 + else backfix ← l + 2; 08147000 + l ← l + 1; emit(bfw); go to brnch end end; 08148000 + comment this is the common point; 08149000 + if elclass = comma then emitlng; l ← l + 1; 08150000 + emit(bfc); 08151000 +branch: forwardbranch ← l; diala ← dialb ← 0; 08152000 + if elclass = comma 08153000 + then begin 08154000 + stepit; 08155000 + forlist(true); 08156000 + fix(storefix,backfix,forwardbranch,stmtstart) end 08157000 + else begin 08158000 + if elclass ≠ dov 08159000 + then begin err(154); rego←l; go exit end; 08160000 + stepit; 08161000 + if numle then foot := getspace(false,-1); % temp. 08162000 + stmt; 08163000 + 08164000 + if numle then begin 08165000 + emitv(returnstore ← foot); emito(bbw) end 08166000 + else begin 08167000 + emitb(bbw,bumpl,backfix); returnstore ← 0 end; 08168000 + stmtstart ← forwardbranch; b ← l; 08169000 + constantclean; rego ← l; 08170000 + fix(storefix,backfix,forwardbranch,l) end; 08171000 +exit: end forlist; 08172000 +real t1,t2,t2,t4; 08173000 + nxtelbt ← 1; i ← 0; 08174000 + stepit; 08175000 + if simpi(vret+elbat[i]) 08176000 + then begin 08177000 + if stepi ≠ assignop then begin err(152); go exit end; 08178000 + t1 ← l; if formalv then emitn(addres); 08179000 + k ← 0; 08180000 + if simple(constana,a,signa) then 08181000 + if elclass = stepv then 08182000 + if simple(constanb,b,signb) then 08183000 + if elclass = untilv then 08184000 + if simple(constanc,q,signc) then 08185000 + if elclass = dov then 08186000 + begin 08187000 + plug(constana,a); 08188000 + if signa then emito(chs); 08189000 + returnstore ← bumpl; adjust; constantclean; 08190000 + stmtstart ← l; 08191000 + stepit; 08192000 + t1 ← ((((4096 × returnstore+stmtstart)x2+ 08193000 + real(constanb))×2+ 08194000 + real(constanc))×2+ 08195000 + real(signb))×2+ 08196000 + real(signc); 08197000 + t2 ← vret; 08198000 + t3 ← b; 08199000 + t4 ← q; 08200000 + stmt; 08201000 + signc ← boolean(t1.[47:1]); 08202000 + signb ← boolean(t1.[46:1]); 08203000 + constanc ← boolean(t1.[45:1]); 08204000 + constanb ← boolean(t1.[44:1]); 08205000 + stmtstart ← t1.[20:12]; 08206000 + returnstore ← t1.[20:12]; 08207000 + vret ← t2; 08208000 + b ← t3; 08209000 + q ← t4; 08210000 + simplev ← simpi(vret); 08211000 + if formalv then emitn(addres); emitv(addres); 08212000 + plug(constanb,b); 08213000 + emito(if signb then sub else add); 08214000 + emitb(bfw,returnstore,l); 08215000 + store(true); 08216000 + if formalv then call(opdc); 08217000 + plug(constanc,q); 08218000 + if signc then emito(chs); 08219000 + simpleb ← true; test; emitlng; 08220000 + emitb(bbc,bumpl,stmtstart); 08221000 + go to exit end; 08222000 + i ← 2; k ← 0; 08223000 + simplev ← simpi(vret); 08224000 + v ← t1 end 08225000 + else begin 08226000 + emit(0); v ← l; simplev ← false; formalv ← true; 08227000 + variable(fr); emito(xch); vret ← l; emito(bfw); 08228000 + if elclass≠assignop then begin err(152); go exit end;08229000 + end; 08230000 + stepit; forlist(false); l + rego; 08231000 + exit: k ← 0 end forstmt; 08232000 +real procedure reed; 08999000 + begin 08999025 + label eof; integer i,j,k; 08999050 + stream procedure move(n,f,t); value n,t; 08999075 + begin si:=f; di:=t;ds:=n wds end move; 08999100 + j:=-1; 08999125 + read(codisk[no])[eof]; 08999150 + reed:=i:=fetch(mkabs(codisk(1))); 08999175 + k:=mkabs(code(0))-1); 08999200 + while i-j>30 do 08999225 + begin 08999250 + move(30,codisk(0),k); k:=k+30;j:=j+30; 08999275 + read(codisk); 08999300 + end; 08999325 + move(i-j,codisk(0),k); 08999350 + read(codisk)[eof]; 08999375 +eof: 08999400 +end reed; 08999425 +procedure right(l); value l; integer l; 08999450 + begin 08999475 + integer i,j; 08999500 + i:=(l+7) div 4; 08999525 + move(1,i,codisk(0)); 08999550 + move(29,code(0),codisk(1)); 08999575 + write(codisk); 08999600 + j:=29; 08999625 + while i-j>0 do 08999650 + begin 08999675 + move(30,code(j),codisk(0)); 08999700 + write(codisk); 08999725 + j:=j+30; 08999750 + end; 08999775 + end right; 08999800 + comment The program rouitne does the initialization and the wrapup 09000000 + for the rest of the compiler. The main program of the compiler09001000 + is simply a call on the program routine; 09002000 + procedure program; 09003000 + begin 09004000 + stream procedure mdesc(wd,toloc);value wd; 09005000 + begin di←loc wd; ds← set;si← loc wd; di←toloc;ds←wds end; 09006000 + define startintrsc=426#; 09024000 + label l1; 09025000 + listog=lister=boolean(1-errorcount.[46:1]]; 09028000 +comment Listog is not set by default on timesharing; 09028010 + noheading := true; 09028050 + errorcount := 0; 09028900 + errmax:=999; % May be changed in dollarcard, 09028910 + basenum=10000; addvalue:=1000; newbase:=true; 09028920 +comment Default values for "$SEQ" option; 09028930 + lastused := 4;% For initilaization. 09029000 + nextinfo ← lastinfo ← lastseqrow×256+lastsequence+1; 09033000 + putnbump(0); 09034000 + gt1 ← -" "; 09034100 + mdesc(gt1,info[lastseqrow,lastsequence]); 09034200 + blanket(0,info[lastseqrow,lastsequence]); % For "$ check".09034500 + readacard; % Initialization of ncr,fcr, and lcr, and 09035000 + % reads first cardinto card buffer. 09036000 + lastused := 1; % assumes card only until told differently.09037000 + nxtelbt ← 1; 09038000 + prti←prtimax←prtbase; 09039000 + mrclean ← true; 09040000 +comment Start filling tables needed to compile a program; 09040100 + fill ten[*] with 09041000 + oct1771110463422054, oct1761332600326467, oct1751621340414205, 09042000 + oct1742165630517247, oct1732623176643120, oct1723370036413744, 09043000 + oct1714266046116735, oct1705343457542525, oct1676634373473252, 09044000 + oct1651040347241213, oct1641250441111455, oct1631522551333770, 09045000 + oct1622047303622767, oct1612451164567564, oct1603175421725521, 09046000 + oct1574034726313046, oct1565044113775657, oct1556255136775233, 09047000 + oct1547730366574502, oct1521171646433362, oct1511430220142257, 09048000 + oct1501736264172732, oct1472325741231521, oct1463013331500045, 09049000 + oct1453616220020057, oct1444561664024072, oct1435716241031111, 09050000 + oct1427301711237333, oct1401116227350722, oct1371341675243107, 09051000 + oct1361632254513731, oct1352200727636717, oct1342641115606502, 09052000 + oct1333411341150223, oct1324313631402270, oct1315376577702746, 09053000 + oct1306676337663537, oct1261045602764047, oct1251257143561061, 09054000 + oct1241532774515275, oct1232061573640554, oct1222476132610706, 09055000 + oct1213215561353071, oct1204061115645707, oct1175075341217270, 09056000 + oct1166314631463146, oct1141000000000000, oct1131200000000000, 09057000 + oct1121440000000000, oct1111750000000000, oct1102342000000000, 09058000 + oct1073032400000000, oct1063641100000000, oct1054611320000000, 09059000 + oct1045753604000000, oct1037346545000000, oct1011124027620000, 09060000 + oct0001351035564000, oct0011643245121000, oct0022214116345200,09061000 + oct0032657142036440, oct0043432772446150, oct0054341571157602,09062000 + oct0065432127413543, oct0076740555316473, oct0111053071060221,09063000 + oct0121265707274266, oct0131543271153343, oct0142074147406234, 09064000 + oct0152513201307703, oct0163236041571663, oct0174105452130240, 09065000 + oct0205126764556310, oct0216354561711772, oct0231004771627437, 09066000 + oct0241206170175347, oct0251447626234641, oct0261761573704011, 09067000 + oct0272356132665013, oct0303051561442216, oct0313664115752661, 09068000 + oct0324641141345435, oct0336011371636745, oct0347413670206536, 09069000 + oct0361131664625027, oct0371360241772234, oct0401654312370703, 09070000 + oct0412227375067064, oct0422675274304701, oct0433454553366062, 09071000 + oct0444367706263476, oct0455465667740415, oct0467003245730521, 09072000 + oct0501060411731665, oct0511274514320242, oct0521553637404312, 09073000 + oct0532106607305375, oct0542530351166674, oct0553256443424453, 09074000 + oct0564132154331566, oct0575160607420123, oct0606414751324150, 09075000 + oct0621012014361120, oct0631214417455344, oct0641457523370635, 09076000 + oct0651773450267005, oct0662372362344606, oct0673071057035747, 09077000 + oct0703707272645341, oct0714671151416632, oct0726047403722400, 09078000 + oct0737461304707100, oct0751137556607072, oct0761367512350710, 09079000 + oct0771665435043072; 09080000 +comment This is the fill for the second row of info: 09081000 + The first items are stream reserved words, 09082000 + then ordinary reserved words, 09083000 + then intrinsic functons; 09084000 + fill info[1,*] with 09085000 + oct0670000600000002, "2SI000", %256 09086000 + oct0700001040000002, "2DI000", %258 09087000 + oct0710001460000002, "2CI000", %260 09088000 + oct0720001630000002, "5TALLY", %262 09089000 + oct0730000530000002, "2DS000", %264 09090000 + oct0740000150000002, "4SKIP0", %266 09091000 + oct0750001620000002, "4JUMP0", %268 09092000 + oct0760000740000002, "2DB000", %270 09093000 + oct0770000500000002, "2SB000", %272 09094000 + oct1010000730000002, "2SC000", %274 09095000 + oct1020001160000002, "3LOC00", %276 09096000 + oct1030001170000002, "2DC000", %278 09097000 + oct1040001430000002, "5LOCAL", %280 09098000 + oct1050000340000002, "3LIT00", %282 09099000 + oct1060001036400002, "3SET00", %284 09100000 + oct1060001066500002, "5RESET", %286 09101000 + oct1060001020500002, "3WDS00", %288 09102000 + oct1060001357700002, "3CHR00", %290 09103000 + oct1060001057300002, "3ADD00", %292 09104000 + oct1060001617200002, "3SUB00", %294 09105000 + oct1060000727600002, "3ZON00", %296 09106000 + oct1060000417500002, "3NUM00", %298 09107000 + oct1060000766700002, "3OCT00", %300 09108000 + oct1060000176600002, "3DEC00", %302 09109000 + oct1004000260000003, "6TOGGL", "E0000000", %304 09110000 + oct0130311060000002, "3ABS00", %307 09110001 + oct1360441030000002, "3AND00", %309 09112000 + oct0500000170000002, "5ARRAY", %311 09112100 + oct0660000000000002, "5BEGIN", %313 09112200 + oct0500000040000003, "7BOOLE", "AN000000", %315 09112300 + oct1070000000000003, "7COMME", "NT000000", %318 09112400 + oct0500000230000003, "6DEFIN", "E0000000", %321 09112500 + oct1410446000000002, "3DIV00", %324 09112600 + oct0550000000000002, "2DO000", %326 09112700 + oct0520000000000003, "6DOUBL", "E0000000", %328 09112800 + oct0570000000000002, "4ELSE0", %331 09112900 + oct0600000000000002, "3END00", %333 09113000 + oct1340442030000002, "3EQV00", %335 09113100 + oct0410000000000002, "5FALSE", %337 09113200 + oct0130310030000002, "4FLAG0", %339 09113300 + oct0530000000000002, "3FOR00", %341 09113400 + oct1100000000000003, "7FORWA", "RD000000", %343 09113500 + oct0640000000000002, "2GO000", %346 09113600 + oct0130316060320002, "4HUNT0", %348 09113700 + oct0630000000000002, "2IF000", %350 09113800 + oct0500000040000002, "4REAL0", %352 09113900 + oct0500000050000003, "7INTEG", "ER000000", %354 09114000 + oct0500000070000002, "5LABEL", %357 09114100 + oct0360002000000003, "6MEMOR", "Y ", %359 09114200 + oct1410456000000002, "3MOD00", %362 09114300 + oct0500000140000003, "7MONT0", "OR ", %364 09114400 + oct0130301060000002, "4NABS0", %367 09114500 + oct0500000200000002, "4NAME0", %369 09114600 + oct0130304030000002, "5NFLAG", %371 09114700 + oct1320300230000002, "3NOT00", %373 09114800 + oct1250440430000002, "2OR000", %375 09114900 + oct0500000020000002, "4SAVE0", %377 09115000 + oct0500000010000002, "3OWN00", %379 09115100 + oct0460000000000003, "6POLIS", "H ", %381 09115200 + oct0500000160000003, "9PROCE", "DURE ", %384 09115300 + oct0130300000160011, "4SIGN0", %387 09115400 + oct2025, comment DUP ; 09115500 + oct0000, comment LITC 0; 09115600 + oct0425, comment NEQ ; 09115700 + oct1025, comment XCH ; 09115800 + oct0155, comment DIA 1; 09115900 + oct0161, comment DIB 1; 09116000 + oct0165, comment TRB 1; 09116100 + oct1110000000000002, "4STEP0", %396 09116200 + oct0500000220000003, "6STREA", "M ", %398 09116300 + oct0500000110000003, "#SUBRO", "UTINE ", %401 09116400 + oct0500000150000003, "6SWITC", "H ", %404 09116500 + oct1120000000000002, "4THEN0", %407 09116600 + oct1130000000000002, "2TO000", %409 09116700 + oct0410000010000002, "4TRUE0", %411 09116800 + oct0560000000000002, "5UNTIL", %413 09116900 + oct1140000000000002, "5VALUE", %415 09117000 + oct0540000000000002, "5WHILE", %417 09117100 + oct1310440200000002, "3ADD00", %419 09117200 + oct1310240270000002, "3BRT00", %421 09117300 + oct1310453050000002, "3CCX00", %423 09117400 + oct1310442500000002, "3CDC00", %425 09117500 + oct1310457050000002, "3CFX00", %427 09117600 + oct1310302060000002, "3CHS00", %429 09117700 + oct1310440500000002, "3COC00", %431 09117800 + oct1310242020000002, "3COM00", %433 09117900 + oct1310302060000002, "3CSB00", %435 09118000 + oct1310240120000002, "3DEL00", %437 09118100 + oct1260100550000002, "3DIA00", %439 09118200 + oct1260100610000002, "3DIB00", %441 09118300 + oct1310344050000002, "3DUP00", %443 09118400 + oct1310451050000002, "3EQL00", %445 09118500 + oct1310443050000002, "3FCX00", %447 09118600 + oct1310447050000002, "3FFX00", %449 09118700 + oct1310440250000002, "3GEQ00", %451 09118800 + oct1310440450000002, "3GTR00", %453 09118900 + oct1310104420000002, "3HLB00", %455 09119000 + oct1310104420000002, "3HP200", %457 09119050 + oct1310446000000002, "3IDV00", %459 09119100 + oct1310251020000002, "3IIO00", %461 09119200 + oct1310250220000002, "3INA00", %463 09119300 + oct1310250420000002, "3INB00", %465 09119400 + oct1310100420000002, "3INT00", %467 09119500 + oct1310440300000002, "3INX00", %469 09119600 + oct1310244220000002, "3IOR00", %471 09119700 + oct1310250220000002, "3IP100", %473 09119800 + oct1310250420000002, "3IP200", %475 09119900 + oct1310145060000002, "3IPS00", %477 09120000 + oct1310410240000002, "3ISD00", %479 09120100 + oct1310450440000002, "3ISN00", %481 09120200 + oct1310100420000002, "3ITI00", %483 09120300 + oct1310450250000002, "3LEQ00", %485 09120400 + oct1310505300000002, "3LLL00", %487 09120500 + oct1310441030000002, "3LND00", %489 09120600 + oct1310300230000002, "3LNG00", %491 09120700 + oct1310304040000002, "3LOD00", %493 09120800 + oct1310440430000002, "3LOR00", %495 09120900 + oct1310442030000002, "3LQV00", %497 09121000 + oct1310450450000002, "3LSS00", %499 09121100 + oct1310101100000002, "3MKS00", %501 09121200 + oct1310441000000002, "3MUL00", %503 09121300 + oct1310441050000002, "3NEQ00", %505 09121400 + oct1310100130000002, "3NDP00", %507 09121500 + oct0650006550000002, "6SCOPO", "N......."; %509 09121600 + fill info[2,*] with 09121650 + oct131030000020004., "3RDF00", %512 09121700 + oct0000, comment litc 0; 09121800 + oct2141, comment FXS ; 09121900 + oct131030000020004., "3RDS00", %516 09122000 + oct0004, comment litc 1; 09122100 + oct2141, comment FXS ; 09122200 + oct1310456000000002, "3RDV00", %520 09122300 + oct1310304030000002, "3RFB00", %522 09122400 + oct1310240470000002, "3RND00", %524 09122500 + oct1310145060000002, "3RRR00", %526 09122600 + oct1310311060000002, "3RSB00", %528 09122700 + oct1310242470000002, "3RSP00", %530 09122800 + oct1310141020000002, "3RTM00", %532 09122900 + oct1310240470000002, "3RTN00", %534 09123000 + oct1310141020000002, "3RTR00", %536 09123100 + oct1310242470000002, "3RTS00", %538 09123200 + oct1310310030000002, "3SFB00", %540 09123300 + oct1310442040000002, "3SND00", %542 09123400 + oct1310301060000002, "3SSB00", %544 09123500 + oct1310316060000002, "3SSF00", %546 09123600 + oct1310301060000002, "3SSN00", %548 09123700 + oct1310311060000002, "3SSP00", %550 09123800 + oct1310401040000002, "3STD00", %552 09123900 + oct1310240000020004, "3STF00", %554 09124000 + oct0010, comment litc 2; 09124100 + oct2141, comment FXS ; 09124200 + oct1310442040000002, "3STN00", %558 09124300 + oct1310240000020004, "3STS00", %560 09124400 + oct0014, comment litc 3; 09124500 + oct2141, comment FXS ; 09124600 + oct1310440600000002, "3SUB00", %564 09124700 + oct1310344060000002, "3TFB00", %566 09124800 + oct1270440650000002, "3TFR00", %568 09124900 + oct1310155060000002, "3TIO00", %570 09125000 + oct1310344060000002, "3TOP00", %572 09125050 + oct1270440650000002, "3TRB00", %574 09125100 + oct1300300000000002, "3VFI00", %576 09125200 + oct1310502050000002, "3XCH00", %578 09125300 + oct1310101070000002, "3XIT00", %580 09125400 + oct1310105020000002, "3ZIP00", %582 09125500 + oct1310105020000002, "3ZP100", %584 09125600 + oct1270500750000002, "3CFE00", %586 09125700 + oct1270500750000002, "3FCE00", %588 09125800 + oct1270500710000002, "3CFL00", %590 09125900 + oct1270500710000002, "3FCL00", %592 09126000 + oct1310440210000002, "3DLA00", %594 09126100 + oct1310440210000002, "3ADL00", %596 09126200 + oct1310440610000002, "3DLS00", %598 09126300 + oct1310440610000002, "3SDL00", %600 09126400 + oct1310441010000002, "3DLM00", %602 09126500 + oct1310441010000002, "3MDL00", %604 09126600 + oct1310442010000002, "3DLD00", %606 09126700 + oct1310442010000002, "3DDL00", %608 09126800 + oct0460000000000002, "1P0000", %610 09126900 + oct0360002000020002, "1M0000", %612 09127000 + oct1310240000020004, "3PRL00", %614 09127100 + oct0111, comment PRL; 09127200 + oct0055, comment NOP; 09127300 + oct0650006610000003, "7SCOPO", "FF......", %618 09127400 + oct0030000000040003, "2LB.00", "[# ", %621 09127500 + oct0030000000040003, "2RB.00", "]# ", %624 09127600 + oct0030000000040003, "3GTR00", "># ", %627 09127700 + oct0030000000040003, "3GEQ00", "≥# ", %630 09127800 + oct0030000000040003, "3EQL00", "=# ", %633 09127900 + oct0030000000040003, "3NEQ00", "≠# ", %636 09128000 + oct0030000000040003, "3LEQ00", "≤# ", %639 09128100 + oct0030000000040003, "3LSS00", "<# ", %642 09128200 + oct0030000000040003, "5TIME0", "×# ", %645 09128300 + oct1310117530000002, "3SCI00", %688 09128400 + oct1310117540000002, "3SAN00", %650 09128500 + oct1310157730000002, "3SCS00", %652 09128600 + 09128700 + 09128800 + 09128900 + 09129000 + 09129100 + 09129200 + 09129300 + 09129400 + 09129500 + 09129600 + 09129700 + 09129800 + 09129900 + 09130000 + 09130100 + 09130200 + 09130300 + 09130400 + 09130500 + 09130600 + 09130700 + 09130800 + 09130900 + 09131000 + 09131100 + 09131200 + 09131300 + 09131400 + 09131500 + 09131600 + 09131700 + 09131800 + 09131900 + 09132000 + 09132100 + 09132200 + 09132300 + 09132400 + 09132500 + 09132600 + 09132700 + 09132800 + 09132900 + 09133000 + 09133100 + 09133200 + 09133300 + 09133400 + 09133500 + 09133600 +0; % end of INFO fill. 09133700 + for gt2←256 step gt1.link while not boolean(gt1.formal) do 09133800 + put((gt1←take(gt2))>2[35:35:13],gt2); 09133900 + for gt1←gt2 step gt2.link while gt2.link≠0 do 09134000 + put((gt2←take(gt1))&stackhead[t3←take(gt1+1).[12:36] 09134100 + mod 125][35:35:13],stackhead[gt3]+gt1); 09134200 +comment This is the fill for special characters; 09197000 +fill special[*] with 09198000 + oct1200000000200000, comment #; oct0000000000100000, comment @; 09199000 + oct0000000000000000, oct1160000000120000, comment :; 09200000 + oct1370440450002763, comment >; oct1370440250002662, comment ≥; 09201000 + oct1400440200000000, comment +; oct0000000000000000, 09202000 + oct1220000000060000, comment .; oct1210000000000000, comment [; 09203000 + oct1250000000000000, comment &; oct0450000000000000, comment (; 09204000 + oct1370450450003571, comment <; oct1330401040000000, comment ←; 09205000 + oct1410441000000000, comment ×; oct0000000000000000, 09206000 + oct0000000000040000, comment $; oct0470000000000000, comment *; 09207000 + oct1400440600000000, comment -; oct1240000000160000, comment ); 09208000 + oct0620000000000000, comment .,; oct1370450250003470, comment ≤; 09209000 + oct0000000000000000, oct1410442000000000, comment .; 09210000 + oct1170000000000000, comment ,; oct0000000000020000, comment %; 09211000 + oct1370441050002561, comment ≠; oct1370451050002460, comment =; 09212000 + oct1230000000000000, comment ]; oct0000000000140000, comment "; 09213000 + 0,0; 09214000 + fill macro[*] with 09215000 + oct0131, comment SFS A 00 ; 09216000 + oct0116, comment SFD A 01 ; 09217000 + oct0000, comment syntax error02 ; 09218000 + oct0140, comment INC A 03 ; 09219000 + oct0130, comment SRS A 04 ; 09220000 + oct0117, comment SRD A 05 ; 09221000 + oct0000, comment syntax error06 ; 09222000 + oct0000, comment syntax error07 ; 09223000 + oct00310143, comment CRF A, SFS 008 ; 09224000 + oct00160143, comment CRF A, SFD 009 ; 09225000 + oct00470143, comment CRF A, JFN 0 10 ; 09226000 + oct00400143, comment CRF A, INC 011 ; 09227000 + oct00300143, comment CRF A, SRS 012 ; 09228000 + oct00170143 comment CRF A, SRD 013 ; 09229000 + oct0000, comment syntax error14 ; 09230000 + oct0000, comment syntax error15 ; 09231000 + oct0153, comment RSA A 16 ; 09232000 + oct0104, comment RDA A 17 ; 09233000 + oct0150, comment RCA A 18 ; 09234000 + oct00420130042, comment SEC 0, CRF A, SEC 0 19 ; 09235000 + oct0122, comment SES A 20 ; 09236000 + oct0106, comment SED A 21 ; 09237000 + oct0000, comment syntax error22 ; 09238000 + oct0000, comment syntax error23 ; 09239000 + oct0056, comment TSA 0 24 ; 09240000 + oct0000, comment syntax error25 ; 09241000 + oct0000, comment syntax error26 ; 09242000 + oct0000, comment syntax error27 ; 09243000 + oct0000, comment syntax error28 ; 09244000 + oct0007, comment TDA 0 29 ; 09245000 + oct0000, comment syntax error30 ; 09246000 + oct0000, comment syntax error31 ; 09247000 + oct0115, comment SSA A 32 ; 09248000 + oct0114, comment SDA A 33 ; 09249000 + oct0154, comment SCA A 34 ; 09250000 + oct0141, comment STC A 35 ; 09251000 +fill options[*] with "5CHECK",0, % 0,1 09251208 + "6DEBUG",0, % 2,3 09251212 + "4DECK0",0, % 4,5 09251214 + "6FORMA",0, % 6,7 09251216 + "9INTRI",0, % 8,9 09251218 + "5LISTA",0, % 10,11 09251220 + "4LIST0",0, % 12,13 09251224 + "5LISTP",0, % 14,15 09251228 + "3MCP00",0, % 15,17 09251230 + "4TAPEA",0, % 16,19 09251232 + "5NEST0",0, % 20,21 09251234 + "3NEW00",0, % 22,23 09251236 + "7NEWIN",0, % 24,25 09251240 + "4OMIT0",0, % 26,27 09251244 + "1$0000",0, % 28,29 09251248 + "3PRT00",0, % 30,31 09251252 + "5PUNCH",0, % 32,33 09251256 + "5PURGE",0, % 34,35 09251260 + "4SEGS0",0, % 35,37 09251264 + "3SEQ00",0, % 38,39 09251268 + "6SEQER",0, % 40,41 09251272 + "6SINGL",0, % 42,43 09251276 + "5STUFF",0, % 44,45 09251378 + "4VOID0",0, % 45,47 09251380 + "5VOIDT",0, % 48,49 09251384 +0; 09251388 + do until stepi = beginv; 09252000 + gt1 ←-" "; 09253000 + intog ← intog and true; % 09253050 + diskadr ← if intog then intrinsicadr else 2; 09253100 + mdesc(gt1,info[lastseqrow,lastsequence]); 09253500 + mdesc(gt1,info[lastseqrow,lastsequence-1]); 09254000 + mdesc(gt1,info[lastseqrow,lastsequence-2]); 09255000 + stmt; 09275000 + lock(stuff); 09281000 + close(card,release); 09281500 + if lastused ≠ 1 then close(tape,release); 09282000 + if newtog then lock(newtape,*); 09282500 + if t←((l+3)div 4) + coradr > 4080 then flag(040); 09262600 + if not noheading then % Print these things if any 09362000 + begin % listing has been done. 09363000 + stream procedure pan(t,fiel,ner,lsq); value ner,t; 09364000 + begin di ← fiel; 44(ds←2lit" "); 09365000 + si ← lsq; ds ← wds; si ←fiel; ds ← 3 wds; 09366000 + di ← fiel; ds← 28 lit"Number of errors detected = "; 09367000 + si ← loc ner;ds←3dec; ds←22 lit ". Compilation time = "; 09368000 + si ← loc t; ds ← 4 dec; ds + 9 lit " seconds."; end; 09369000 +stream procedure pen(fil,prtsiz,base,code,disk); 09370000 + value prtsiz,base,core,disk; 09371000 + begin di←fil; ds ← 0 lit"PRT size="; si←loc prtsiz; 09372000 + ds ← 3 dec; ds←14 lit" Base address="; 09373000 + si←loc base; ds←4 dec; ds←10 lit" Core req="; 09374000 + si←loc core; ds←4 dec; ds←10 lit" Disk req="; 09375000 + si←loc disk; ds←5 dec; ds←61 lit " "; 09376000 + end pen; 09377000 + stream procedure finalax(line,n,seq); value n; 09378000 + begin ds ← line; 15(ds ← 8 lit " "); 09379000 + di ← line; ds ← 31 lit "Number of accidental entries = "; 09380000 + si ← loc n; ds ← 3 dec; di ← di+8; 09381000 + si ← seq; si ← si-16; ds ← 8 chr; 09382000 + end; 09383000 + if axnum ≠ 0 then 09384000 + begin 09384050 + finalax(lin[0],axnum,info[lastseqrow,lastsequence]); 09384100 + writeline; 09384500 + end; 09384600 + scram := (time(1)-time1)/60; 09385000 + pan(scram,lin[0],errorcount,info[lastseqrow,lastsequence-1]) 09386000 + ; 09386500 + writeline 09387000 + pen(lin[0],prtimax,t:=(l+3)div 4,t:=coradr+t, 09388000 + ((t+29)div 30+diskadr)×30); 09389000 + writeline; 09389500 + lock(line,release);end; 09390000 +if errorcount ≠ 0 then i←0/0 else 09391000 + begin 09392000 + array savinfo[0:31],0:255], 09392300 + info[0:200,0:255]; % For large MCP-s. 09392500 + integer savndx,nonsavndx,n; 09393000 + integer q,j,k,m; 09393010 + boolean tsstog; real t; 09393020 + real procedure pusher(grinch,got,xmas); value xmas; real xmas; 09393050 + array got[0]; array grinch[0,0]; 09393060 + begin 09393070 + real who,what; 09393080 + define linkr = [32:8]#; 09393090 +% 09393100 + if who:=xmas.linkc ≤ 255 then 09393110 + begin 09393120 + move(30,grinch[xmas,linkr,who],got[0]); 09393130 + pusher:=xmas + 30; 09393140 + end 09393150 + else begin 09393160 + move(what:=256-who,grinch[xmas,linkr,who],got[0]); 09393170 + xmas:=xmas + what; 09393180 + move(who:=30-what, grinch[xmas.linkr,0], got[what]); 09393190 + pusher:=xmas + who; 09393200 + end; 09393220 + end pusher; 09393230 + procedure pushee(grinch,n,b,y); value n,b,y; real n,b,y; 09393240 + array grinch[0,0]; 09393250 + begin 09393260 + real i,j,x; 09393270 + define linkr = [32:8]#; 09393280 + j:=y; 09393290 + i:=b + n; 09393300 + while b < i do 09393310 + begin 09393320 + if y:=b.linkc ≤ 255 then 09393330 + begin 09393340 + move(30,code(j),grinch[b.linkr,y]); 09393350 + j:=j + 30; 09393360 + b:=b + 30; 09393370 + end 09393380 + else begin 09393390 + move(x:=256-y,code(j),grinch[b.linkr,y]); 09393400 + b:=b + x; 09393410 + j:=j + x; 09393420 + move(y:=30-x,code(j),grinch[b.linkr,0]); 09393430 + b:=b + y; 09393440 + j:=j + y; 09393450 + end; 09393460 + end; 09393470 + end pushee; 09393480 +stream procedure fixhdr(f,n); value n; 09393700 + begin si←f; si←si-24; ds←loc f; ds←wds; 09393710 + si←f; 14(si←si+8); di←loc f; ds←wds; 09393720 + di←f; ds←di+38; si← loc n; 09393730 + si←si+7; ds←chr; 09393740 + end fixhdr; 09393750 + label eof; 09394000 + if not intog then 09394100 + begin 09394200 + l←(l+3)div 4;comment l←num. of words in outer block; 09395000 + fill savinfo[0,*] with 09395100 + oct7700000000000015, 09395200 + oct0253010477527705, 09395300 + oct0051000000000000, 09395400 + oct0441070001000062; 09395500 + q ← -1; 09395700 + pushee(saveinfo,l,4,5); 09396000 + savndx:=l; 09397000 + end; 09397100 + rewind(codisk); 09398000 + do begin if reed=0 then go to eof; 09399000 + n←fetch(mkabs(code(0)))-1; 09400000 + if boolean(fetch(mkabs(code(1)))) then 09401000 + begin 09402000 + pushee(savinfo,n,savndx,1); 09402100 + savndx:=savndx +n; 09403000 + end else begin 09404000 + if decktog then 09405000 + stackhead[q←q+1] ← 1024×nonsavndx+n; 09405500 + pushee(info,n,nonsavndx,1); 09406000 + nonsavndx:=((nonsavndx + n + 29)div 30)×30; 09407000 + end; 09408000 + end until false; 09412000 + eof: n←(savndx+29) div 30; comment number of disk segments09413000 + occupied by save procedures and arays; 09414000 + if intog and not decktog then 09414010 + begin % Intrinsic function option 09414020 + for j:=useropinx step 2 until oparsize do % is timesharing set 09414022 + if options[j] = "@TIMES" then 09414024 + begin tsstog:=boolean(options[j+1]); j:=oparsize end; 09414026 + i ← prtbase + 1; j ← 0; 09414030 + do if gt1 ← prt[i] ≠ 0 then 09414040 + begin 09414050 + j ← j + 1; 09414060 + savinfo[j,linkr,j.linkc] ← 09414070 + 0>1[8:8:10] 09414080 + >1[33:18:15]; 09414090 + end until i:=i + 1 ≥ prtimax; 09414100 + savinfo[0,0] ← j; % # of intrinsics 09414110 + savndx ← maxintrinsic; 09414120 + end else begin 09414130 + i←prtbase; do if gt1←prt[i]≠0 then 09415000 + begin if gt1.[1:5]≠ldes then 09415500 + begin if (gt1←gt1&(gt1.[33:15]+l)[33:33:15]).[6:2]≠3 then 09416000 + gt1←gt1&(gt1.[18:15]+n)[18:33:15]; 09417000 + end; 09417500 + mdesc(gt1,savinfo[i.linkr,i.linkc]); 09418000 + end else savinfo[i.linkr,i.linkc]:=0 until i:=i+1≥prtimax;09419000 + mdesc(0&1[2:47:1],savinfo[d,prtbase-1]); 09419100 + savndx ← 30 × n; 09420000 + end; 09420010 + i ← 0 ; j ← -1; 09420020 + 09420100 + if not decktog then 09421000 + begin 09421500 + do 09422000 + begin 09423000 + i:=pusher(savinfo,elbat,i); 09424000 + j:=j + 1; 09425000 + write(disk,30,elbat[*]); 09425900 + end until i ≥ savndx; 09426000 + i:=0; 09427000 + while i < nonsavndx do 09427100 + begin 09427200 + i:=pusher(info,elbat,i); 09427500 + j:=j + 1; 09428000 + write(disk,30,elbat[*]); 09429000 + end; 09430000 + n←if intog then if tsstog then 09430050 + tssintype else dcintype else mcptype; 09430060 + fixhdr(disk,n); 09430075 + lock(disk,*); 09430100 + end else 09431000 + begin elbat[0]←0; i←16; 09432000 + do begin move(8,savinfo[i.linkr,i.linkc],elbat[1]); 09433000 + elbat[9]←b2d(i+96)&1[11:47:1]&(i+96)[23:35:1]; 09434000 + write(deck,10,elbat[*]); 09435000 + end until i←i+8≥savndx; 09436000 + fill elbat[*] with 0, 09437000 + oct7500000000000012, 09438000 + oct0004535530611765, 09439000 + oct7006000404210435, 09440000 + oct7700000000000015, 09441000 + oct0253010477527705, 09442000 + oct0051000004410046, 09443000 + oct0441070001000062, 09444000 + oct0040413100000000, 09445000 + oct0001000000000101; 09446000 + write(dec,10,elbat[*]); 09447000 + elbat[0] ←0&real(decktog)[1:19:17]; 09447010 + for i ← 0 step 1 until q do 09447020 + begin k ← stackhead[i].[23:15]; 09447030 + m ← stackhead[i].[38:10]; 09447040 + for j ← 0 step 8 until m do begin 09447050 + move(8,info[j+k).linkr,(j+k).linkc], 09447060 + elbat [1]); 09447070 + elbat[9] ← b2d(j)&"310"[1:31:17]; 09447080 + write(deck,10,elbat[*]) end; 09447090 + end; 09447100 + end end end program; 09448000 +comment This section contains generators used by the block routine; 10000000 +procedure definegen(macro,j); value macro,j; boolean macro; real j; 10228000 + begin 10229000 + own integer charcount, remcount; 10230000 + comment Charcount contains number ofcharactors of the define that we 10231000 + have put into info. Remcount contains number of charact- 10232000 + ors remaining in this row of info; 10233000 +procedure putogether(char); real char; 10234000 + begin 10235000 +stream procedure packinfo(info,iskip,count,askip,accum); 10236000 + value iskip,count,askip; 10237000 + begin di ← info; di ← di + iskip; 10238000 + si ← accum;si ← si+askip; si ← si+3; 10239000 + ds ← count chr end packinfo; 10240000 + integer count,skipcount; 10241000 + if (count ← char.[12:6]) + charcount > 2047 10242000 + then begin flag(142); tb1← true end 10243000 + else begin 10244000 + if count > remcount 10245000 + then begin 10246000 + skipcount ← count-(count←remcount); 10247000 + remcount ← 2047 end 10248000 + else remcount ← remcount-count 10249000 + gt1 ← charcount div 8 + nextinfo; 10250000 + packinfo(info[gt1.linkr,gt1.linkc],charcount.[45:3], 10251000 + count,0,char); 10252000 + if skipcount ≠ 0 then 10253000 + packinfo(info[nextinfo.linkr+1,0],0,skipcount, 10254000 + count,char); 10255000 + charcount ← charcount+skipcount+count end 10256000 + end putogether 10257000 +stream procedure scan(d,s,q,n,j); value j,n,q; 10257100 + begin di←d;di←di+11;si←s;si←si+3; 10257200 + if n sc=dc then 10257300 + if sc>"0" then 10257400 + begin di←loc j; di←di+7; 10257500 + if sc≤dc then 10257600 + begin j←si;di←j;si←loc q;si←si+6;ds←chr; 10257700 + ds←s;di←di+2;ds←chr; 10257800 + end end end; 10257900 + integer lastresult; 10258000 + real k,n,elclass; 10258100 + define i=nxtelbt#; 10258200 + label final,packin; 10258300 + label back,sksc,exit; 10259000 + tb1← false; 10260000 + charcount←(nextinfo-lastinfo)×8; 10261000 + definectr ← 1; lastresult ← 2; 10262000 + remcount ← (256 - nextinfo mod 256) × 8; 10263000 + nextinfo←lastinfo; 10263100 + if j≠0 then n←take(lastinfo+1).[12:6]; 10263110 + k←0; 10263200 +back: stopdefine←true; 10263300 + elclass←table(nxtelbt); 10263400 +sksc: nxtelbt←nxtelbt-1; 10263500 + if macro then 10263600 + begin if elclass=comma then 10263700 + if k=0 then 10263800 +final: begin putogether("1#0000"); go to exit end 10263900 + else go packin; 10264000 + if elclass=leftparen or elclass=lftbrket then 10264100 + begin k←k+1; go to packin end; 10264200 + if elclass=rtparen or elclass=rtbrket then 10264300 + if k←k-1<0 then go final else go packin; 10264400 + if elclass=semicolon then 10264410 + begin flag(142);go to final end else go packin 10264420 + end; 10264500 + if j≠0 then 10264600 + if accum[1].[12:6]-1=n then 10264700 + scan(info[lastinfo, linkr ,lastinfo, linkc], 10264800 + accum[1],n+770,n,j); 10264900 +packin: 10264910 + if result = 4 10265000 + then begin 10266000 + comment insert " marks - 2130706432 is decimal for 1"0000; 10267000 + putogether(2130706432); 10268000 + putogether(accum[1]); 10269000 + putogether(2130706432) end 10270000 + else begin 10271000 + if boolean(result) and boolean(lastresult) 10272000 + then putogether("1 0000"); comment Insert blank; 10273000 + putogether(accum[1]) end; 10274000 + if tb1 then go to exit; 10275000 + lastresult ← result; 10276000 + if macro then go to back; 10276500 + if elclass=declarators and elbat[i].address = definev 10277000 + then begin definectr ← definectr+1; go back end; 10278000 + if elclass ≠ crosshatch then go back; 10279000 + if definectr ≠ 1 10280000 + then begin stopdefine ← true; 10281000 + if elclass←table(i)≠comma then 10282000 + definectr←definectr-1; go sksc end; 10283000 +exit: definectr← 0; 10284000 + nextinfo ←(charcount+7) div 8+nextinfo; 10285000 + end definegen; 10286000 +procedure dblstmt; 12002000 + begin 12003000 + real s,t; 12004000 + label l1,l2,l3,exit; 12005000 + s←0; 12006000 + if stepi≠leftparen then err(281); 12007000 + else 12008000 +l1: begin 12009000 + if stepi=comma then 12010000 + begin 12011000 + optog←true; 12012000 + if stepi=adop then stepit; 12013000 + emitnum(nlo); 12014000 + emitnum(if elbat[i-1].address =sub then -nhi else nhi); 12015000 + optog←false; 12016000 + stepit; 12017000 + go to l2; 12018000 + end; 12019000 + if table(i+1)=comma then 12020000 + begin 12021000 + if elclass=adop or elclass=mulop then 12022000 + begin 12023000 + emito(elbat[i].address+1); 12024000 + if s←s-1≤0 then flag(282); stepit; 12025000 + go to l3 12026000 + end; 12027000 + if elclass=assignop then 12028000 + begin 12029000 + if s≠1 then flag(283); s←0; stepit; 12030000 + do 12031000 + begin 12032000 + if elclass ≠comma then begin err(284);go exit end; 12033000 + stepit; 12034000 + if elclass≤intid and elclass≥realid then 12035000 + begin emitn(elbat[i].address); stepit end 12036000 + else variable(fl); 12037000 + emito(std) end until s←s+1=2 ; 12038000 + if elclass≠rtparen then err(285) else stepit; 12039000 + go to exit; 12040000 + end; 12041000 + if elclass≤intid and elclass≥booid then 12042000 + begin 12043000 + checker(t←elbat[i]); 12044000 + stepit;stepit; 12045000 + aexp; 12046000 + emitv(t.address); 12047000 + go to l2; 12048000 + end; 12049000 + end ; 12050000 + aexp; 12051000 + if elclass≠comma then begin err(284);go exit 12052000 + end; 12053000 + stepit; aexp; emito(xch); 12054000 + l2: s←s+1; 12055000 + l3: if elclass≠comma then begin err(284);go to exit end; 12056000 + go to l1; 12057000 + exit:end 12058000 + end dblstmt; 12059000 +real procedure fixdefineinfo(t); value t; real t; 12101000 + begin real k,s,p,j,el; 12102000 + stream procedure set(s,d,k,e); value k,e; 12103000 + begin si←s;si←si+11;di←d;di←di+3;ds←k chr; 12104000 + si←loc e; si←si+6; ds←2 chr; 12105000 + end; 12106000 + macroid←true; 12107000 + p←(fixdefineinfo←t).address; 12108000 + k←count; 12109000 + s←scram; 12110000 + streamtog←true & streamtog[1:3:45] ; 12110100 + stopdefine←true; 12111000 + el←table(nxtelbt); 12112000 + nxtelbt←nxtelbt-1; 12113000 + if el≠leftparen and el≠lftbrket then 12114000 + flag(141); 12115000 + else do begin j←j+1; 12116000 + set(info[t.linkr,t.linkc],accum[1],k,64×j+12); 12117000 + accum[1].[12:6]←k+2; 12118000 + accum[0]←0; 12119000 + accum[0].class←definedid; 12120000 + count←k+2; 12121000 + scram←accum[1] mod 125; 12122000 + e; 12123000 + definegen(true,0); 12124000 + end until el←elbat[nxtelbt].class≠comma; 12125000 + if el≠rtparen and el≠rtbrket or j≠p then flag(141); 12126000 + macroid←false; 12127000 + streamtog←streamtog.[1:45] ; 12127100 + end; 12128000 +procedure scatterelbat; 13197000 + begin 13198000 + real t; 13199000 + t ← elbat[i]; 13200000 + klassf ← t.class; 13201000 + formalf ← boolean(t.vo); 13202000 + vonf ← boolean(t.vo); 13203000 + levelf ← t.lvl; 13204000 + addrsf ← t.address; 13205000 + incrf ← t.incr; 13206000 + linkf ← t.link; 13207000 + end scatterelbat; 13208000 +procedure chksdb; 13209000 + if gta1[j←j-1]≠0 then flag(23); 13210000 +define 13211000 + addc=532480#, 13212000 + subc=1581056#, 13213000 + emitstore=emitpair#; 13214000 + procedure purge(stopper); 13215000 + value stopper; 13216000 + real stopper; 13217000 + begin 13218000 + integer pointer; 13219000 + label recov; define elclass = klassf#; 13220000 + real j,n,ocr,tl,add; 13221000 + pointer←lastinfo; 13222000 + while pointer ≥ stopper 13223000 + do 13224000 + begin 13225000 + if elclass←(gt1←take(pointer)).class=nonlitno 13226000 + then begin 13227000 + ncii←ncii-1; 13228000 + emitnum(take(pointer,1)); 13229000 + emitstore(maxstack,std); 13230000 + maxstack←(g←maxstack)+1); 13231000 + j←l; l←gt1.link; 13232000 + do 13233000 + begin 13234000 + gt4←get(l); 13235000 + emitv(g); 13236000 + end 13237000 + until (l←gt4)=4095; 13238000 + l←j; 13239000 + pointer←pointer-gt1.incr 13240000 + end 13241000 + else 13242000 + begin 13243000 + if not boolean(gt1.formal) 13244000 + then begin 13245000 + if elclass = labelid 13246000 + then begin 13247000 + add ← gt1.address; 13248000 + if not boolean(ocr←take(git(pointer))).[1:1] 13249000 + then if ocr.[36:12 ≠ 0 or add ≠ 0 13250000 + then begin gt1 ← 160; go to recov end; 13251000 + if add ≠ 0 then 13252000 + progdescbldr(add,true,ocr.[36:10],ldes) end 13252500 + else if false 13253000 + then begin 13254000 + if take(pointer+1) < 0 13255000 + then begin gt1 ← 162; go to recov end; 13256000 + ocr ←(j ← take(git(pointer))).[24:12]; 13257000 + n ← get( (j←j.[36:12])+4); tl ← l; 13258000 + if add ← gt1.address ≠ 0 13259000 + then begin 13260000 + if ocr = 0 13261000 + then begin l←ocr-2; callswitch(pointer); emito(bfw);end; 13262000 + l←j+11; emitl(15); emito(rts); 13263000 + for j ← 4 step 4 until n 13264000 + do begin 13265000 + emitl(gnat(get(l)×4096+get(l+1))); 13266000 + emito(rts) end end 13267000 + else begin 13268000 + l ← j+13; 13269000 + for j ← 4 step 4 until n 13270000 + do begin 13271000 + gt1 ← get(l)×4096+get(l+1); 13272000 + gogen(gt1,bfw) end;end; 13273000 + l ← tl end 13277000 + else if elclass ≥ procid and elclass ≤ intprocid 13278000 + then if take(pointer+1) <0 13279000 + then begin gt1 ← 16; 13280000 + recov: move(9,info[pointer.linkr,pointer.linkc],accum);13281000 + q ← accum[1]; flag(gt1); errortog ← true end 13282000 + end; 13283000 + gt2←take(pointer+1); 13284000 + gt3←gt2.purpt; 13285000 + stackhead[(0>2[12:12:36])mod 125]←take(pointer).link; 13286000 + pointer←pointer-gt3; 13287000 + end 13288000 + end ; 13289000 + lastinfo←pointer; 13290000 + nextinfo←stopper; 13291000 + end; 13292000 +procedure e; 13293000 +comment 13294000 + E is the procedure which places an entry in INFO and 13295000 + hooks it into STACKHEAD. The previous STACKHEAD link 13296000 + is saved in the LINK of the ELTAB word in the new entry 13297000 + E prevents an entry form overflowing a row,starting at then 13298000 + beginning of the next row isnecessary ; 13299000 + begin 13300000 + real wordcount,rinx; 13301000 + if rinx←(nextinfo←wordcount←(count+18)div 8 ).linkr ≠ 13302000 + nextinfo.linkr 13303000 +then begin put(125&(rinx×256-nextinfo)[27:40:8],nextinfo); 13304000 + nextinfo←256×rinx end; 13305000 + if spectog then 13305100 + if not macroid then 13305200 + unhook; 13305300 + 13306000 + accum[0].incr←wordcount; 13307000 + if not inlinetog or macroid then begin 13307500 + accum[0].link ←stackhead[scram];stackhead[scram]←nextinfo; 13308000 + end; 13308500 + accum[1].purpt←nextinfo-lastinfo; 13309000 +move(wordcount,accum,info[nextinfo.linkr,nextinfo.linkc]); 13310000 + lastinfo←nextinfo; 13311000 + nextinfo←nextinfo←wordcount 13312000 + end; 13313000 +procedure entry(type) 13314000 + value type; 13315000 + real type; 13316000 +comment 13317000 + ENTRY assumes that I is pointing at an identifier which 13318000 + is being declared and makes up the ELBAT entry for it 13319000 + accord to type .If the entry is an array and not 13320000 + a specification then a descriptor is placed on the stack 13321000 + for the upcoming communicate to get storage for the array(s) ; 13322000 + begin 13323000 + j←0;i←i-1; 13324000 + do 13325000 + begin 13326000 + stopdefine ←true; stepit; scatterelbat; 13327000 + if formalf←spectog 13328000 + then 13329000 + begin 13330000 + if elclass≠secret 13331000 + then flag(002); 13332000 + bup←bup+1 13333000 +; klassf←type;makeupaccum; e;j←j+1; 13333500 + end 13334000 + else 13335000 + begin 13336000 + if elclass>idmax 13337000 + then if elclass= polishv then elclass←type else flag(3); 13338000 + if levelf=level 13339000 + then flag(001); 13340000 + vonf←p2; 13341000 + formalf←ptog; 13341100 + klassf←type; makeupaccum;e; j←j+1; 13342000 + if ((formalf←ptog) or(streamtog and not stopgsp)) and not p2 13343000 + then addrsf←pj←pj+1 13344000 + else if stopgsp 13345000 + then addrsf←0 13346000 + else addrsf:=getspace(p2,lastinfo+1); 13347000 + put(take(lastinfo)& addrsf[16:37:11],lastinfo); 13348000 + end end 13349000 + 13350000 + until stepi≠comma or stopentry; gta1[0]←j 13351000 + end; 13352000 + procedure unhook; 13353000 +comment 13354000 + UNHOOK assumes that the word in ELBAT[I} points to a pseudo entry 13355000 + for aparameter,its job is to unkook that false entry so that 13356000 + E will work asnormal. 13357000 + begin 13358000 + real linkt,a,linkp; 13359000 + label l; 13360000 + linkt←stackhead[scram] ; linkp←elbat[i].link; 13361000 + if link=linkp then stackhead[scram]←take(linkt).link 13362000 + else 13363000 + l: if a←take(linkt).link=linkp 13364000 + then put((take(linkt))&(take(a))[35:35:13],linkt) 13365000 + else begin linkt←a; go to l end; 13366000 + end; 13367000 +procedure makeupaccum; 13368000 + begin 13369000 + if ptog 13370000 + then gt1←levelf else gt1←level; 13371000 + accum[0]← abs(elbat[i] & klassf[2:41:7] & real(formalf)[9:47:1] 13372000 + & real(vonf)[10:47:1] & gt1[11:43:] &addrsf[16:37:11] 13373000 + ) 13374000 + end; 13375000 +procedure arrae; 13376000 + begin 13377000 + integer saveinfo; 13378000 + label beta1; 13379000 + typev←realarrayid; 13380000 + if t1←gta1[j←j-1]=0 then j←j+1; 13381000 + else 13382000 + if t1=ownv then 13383000 + begin 13384000 + p2←true;if spectog then 13385000 + flag(13) 13386000 + end 13387000 + else 13388000 + typev←realarrayid+t1-realv; 13389000 + beta1: enter(typev); 13390000 + if elclass≠lftbrket then flag(16); 13391000 + if stepi=litno then 13392000 + begin 13393000 + saveinfo←elbat[i].address; 13394000 + if stepi≠rtbrket then flag(53); 13395000 + fillstmt(saveinfo); 13396000 +saveinfo←1; 13397000 + end 13398000 + else 13399000 + begin if elclass≠astrisk then flag(56); 13400000 + saveinfo←1; 13401000 + while stepi≠rtbrket do 13402000 + begin if elclass≠comma and 13403000 + stepi≠astrisk then flag(56); 13404000 + saveinfo←saveinfo+1 13405000 + end; stepit; 13406000 + 13407000 +end; put(take(lastinfo)&saveinfo[27:4018],lastinfo); 13408000 +j ← 1 ; gta1[0] ← 0 ; 13408500 +if elclass=comma then begin stepit;go to beta1 end 13409000 + end arrae; 13410000 + procedure putnbump(x); 13589000 + value x; 13590000 + real x; 13591000 + begin 13592000 + info[nextinfo.linkr,nextinfo.linkc]←x; 13593000 + nextinfo←nextinfo+1; 13594000 + end ; 13595000 + procedure jumpchkx; 13596000 +comment This procedure is called at the start ofany executable code 13597000 + which the blockmight emit.It determines whether any jumps 13598000 + arround nonexecutable code may be waiting and wheer it 13599000 + if the first executable code; 13600000 +if not spectog then 13601000 +begin 13602000 + if ajump 13603000 + then 13604000 + begin adjust; 13605000 + emitb(bfw,savel,l) 13606000 + end else 13607000 + if firstx=4095 13608000 + then 13609000 + begin 13610000 + adjust; 13611000 + firstx←l; 13612000 + end; 13613000 + ajump←false; 13614000 +end; 13615000 + procedure jumpchknx; 13616000 +comment JUMPCHNX determines whether any executable code has been 13617000 + emitted and if so whether it was juts previous to the 13618000 + non executable about to be emitted.if both then L is bumped 13619000 + and saved for a later branch; 13620000 +if not spectog then 13621000 +begin 13622000 + if first≠4095 13623000 + then 13624000 + begin 13625000 + if not ajump 13626000 + then 13627000 + savel←bumpl; 13628000 + ajump←true 13629000 + end;adjust 13630000 +end; 13631000 +procedure segmentstart(savecode);value savecode;boolean savecode; 13632000 + begin 13632100 + stream procedure print(savecode,adr,fiel); value savecode,adr; 13633000 + begin 13634000 + label l1; 13635000 + di:=fiel; ds:=8 lit" "; 13636000 + si:=fiel; ds:=9wds; di:=di-3; 13637000 + savecode(ds:=38 lit "START OF SAVE SEGMENT; BASE ADDRESS ="; 13638000 + jump out to l1); 13639000 + ds:=38 lit " START OF REL SEGMENT; DISK ADDRESS = "; 13640000 +l1: 13641000 + si:=loc adr; ds:=5 dec; 13642000 + end print; 13643000 + move(1,savecode,code(0)); 13651000 + if savecode and intog and not decktog then flag(57); 13651100 + if lister or segstog then 13652000 + begin 13652500 + print(savecode,if savecode then coradr else diskadr,lin[*]); 13653000 + if noheading then datime; writeline; 13653500 + end; 13654000 + end segmentstart; 13655000 +procedure segment(size,fr); value size,fr; integer size,fr; 13657000 + begin 13660000 + stream procedure print(size,fiel); value size; 13661000 + begin 13663000 + di:=fiel; ds:=8 lit" "; 13665000 + si:=fiel; ds:=14 wds; 13667000 + di:=di-16; ds:=6 lit"SIZE="; 13668000 + si:=loc size; ds:=4 dec; ds:=6 lit" WORDS" 13670000 + end print; 13673000 + stream procedure doit(c,a,i,s,f,w); value c,a,f,w; 13673100 + begin local n; 13673150 + di:=s; ds:=8 lit" "; si:=s; ds:=9 wds; 13673200 + di:=di-8; si:=loc w;ds:=4 dec; 13673250 + si:=i;si:=si+10;di:=loc n; di:=di+7; ds:=chr; 13673300 + di:=s;si:=loc f; si:=si+7; ds:=chr; si:=loc c; 13673350 + ds:=3 dec; ds:=4 dec; si:=i; si:=si+11;ds:=n chr; 13673400 + end doit; 13673450 + if lister or segstog then 13674000 + begin 13674500 + print(size,lin[*]); 13675000 + if noheading then datime; writeline; 13676000 + end; 13677000 + if stufftog then if fr>0 then if level>1 then 13677100 + begin 13677150 + klassf:=take(proinfo).class; 13677200 + if fr > 1024 then fr←fr-1024; 13677250 + doit(klassf,fr,info[proinfo.linkr,proinfo.linkc], 13677300 + twxa[0],saf,twxa[*]); 13677400 + write(stuff,10,twxa[*]); 13677500 + end; 13677600 + if size>segsizemax then segsizemax:=size; 13678000 + end segment; 13681000 + stream procedure movecode(edoc,tedoc); 13683000 + begin local t1,t2,t3; 13684000 + si←edoc;t1←si; 13685000 + si←tedoc;t2←si; 13686000 + si←loc edoc 13687000 + si←si+3; 13688000 + di←loc t3; 13689000 + di←di+5; 13690000 + skip 3 db; 13691000 + 15(if sb then ds← 1 set else ds←1 reset;skip 1 sb); 13692000 + si← loc edoc; 13693000 + di← loc t2; 13694000 + ds← 5 chr; 13695000 + 3(if sb then ds←1 set else ds←1 reset; skip 1 sb); 13696000 + di←t3; 13697000 + si←loc t2; 13698000 + ds←wds; 13699000 + di←loc t3; 13700000 + di←di+5; 13701000 + skip 3 db; 13702000 + si←loc edoc; 13703000 + si←si+3; 13704000 + 15(if sb then ds←1 set else ds←1 reset;skip 1 sb); 13705000 + si←loc tedoc; 13706000 + di← loc t1; 13707000 + ds← 5 chr; 13708000 + 3(if sb then ds←1 set else ds←1 reset;skip 1 sb); 13709000 + di←t3; 13710000 + si←loc t1; 13711000 + ds←wds; 13712000 + end; 13713000 + procedure enter(type); 13714000 + value type; 13715000 + real type; 13716000 + begin 13717000 + g←gta1[j=j-1]; 13718000 + if not spectog 13719000 + then 13720000 + begin 13721000 + if not p2 13722000 + then if p2←(g=ownv) 13723000 + then g←gta1[j←j-1]; 13724000 + if not p3 13725000 + then if p3←(g=savev) 13726000 + then g←gta1[j←j-1] 13727000 + end; 13728000 + if g≠0 then flag(25) else entry(type) 13729000 + end; 13730000 + procedure httedap(gotstorage,relad,stopper,prtad); 13731000 + value gotstorage,relad,stopper,prtad 13732000 + boolean gotstorage; 13733000 + real relad,stopper,prtad; 13734000 + begin 13735000 + if functog 13736000 + then 13737000 + begin 13738000 + emitv(513); 13739000 + emito(rtn); 13740000 + end 13741000 + else 13742000 + emito(xit); 13743000 + constantclean; 13744000 + purge(stopper); 13745000 + move(1,code(0),z); progdescbldr(prtad,boolean(z),(l+3)div 4,pdes);13746000 + end httedap; 13747000 + procedure inline; 13748000 + begin 13749000 + integer sn,ln,p,ls,j; boolean mkst; 13750000 + boolean flipflop; 13750500 + integer pn; 13750600 + label l1,l2,l3; 13751000 + pn←1 ; 13751100 + flipflop←inlinetog←true;p←0;mkst←false;ls←l;emito(nop); 13752000 + if stepi≠leftparen then flag(59); 13753000 + if table(i+1)=colon then begin stepit;go to l2 end ; 13753100 + l1: if stepi>idmax then begin flag(465); go to l2 end ; 13754000 + accum[0]←0&p[16:37:11]&loclid[2:41:7]&scram[35:35:13]; 13755000 + e;if flipflop then begin flipflop←false;ln←sn←lastinfo end; 13755500 + if stepi=comma or elclass=colon or elclass=rtparen 13756000 + then begin i←i-2;stepit end 13757000 + else if elclass≠assignop then flag(60) else stepit; 13758000 + aexp; 13759000 + l2: if elclass=colon then 13760000 + begin if mkst then flag(99); mkst←true; emito(mks); p←p+2; 13761000 + if table(i+1)≠rtparen then go to l1; stepit 13761100 + ;pn←2; 13761110 + end else p←p+1; 13761200 + if elclass=comma then go to l1; 13762000 + if elclass≠rtparen then flag(61); 13763000 + if not mkst then 13764000 + begin j←l;l←ls;emito(mks);l←j end; 13765000 + if stepi ≠ semicolon then flag(2); 13766000 + emito(584); 13766100 + 13766200 + 13766300 + 13766400 + 13766500 + l3:elbat[i]←take(sn);scatterelbat;addrsf←p←-addrsf; 13767000 + put(elbat[i]&addrsf[16:37:11]&stackhead[linkf][33:33:15],sn); 13768000 + stackhead[linkf]←sn; sn←sn←incrf; 13769000 + if addrsf≠pn then go to l3 ; 13770000 + inlinetog← false; 13770500 + pn←nextinfo; 13770600 + streamtog←true;streamwords;if stepi≠beginv then streamstmt 13771000 + else begin stepit;compoundtail end; 13772000 + streamtog←false;purge(pn);streamwords;purge(ln);emitl(16); 13773000 + 13773500 +end inline; 13774000 + comment This section contains the block routine ; 14000000 +procedure block(sop); 14001000 + value sop; 14002000 + boolean sop; 14003000 +comment SOP is true if the block was called by itself through the 14004000 + procedure declaration-otherwise it was called by statement. 14005000 + The block routine is responsible for handling the block 14006000 + structure of an ALGOL program-segmenting each block,handling 14007000 + all declarations,doing necessary bookkeeping regarding each 14008000 + block, and supplying the scanner with all necessary information 14009000 + about declared identifiers. 14010000 + It also writes each segment into the PCT; 14011000 +begin 14012000 + label ownerr,saverr,booleandec,realdec,alphadec,integerdec, 14013000 + labeldec,dumpdec,subdec,outdec,indec,monitordec, 14014000 + switchdec,proceduredec,arraydec,namedec,filedec, 14015000 + gotschk, 14016000 + streamerr,definedec,callstatement,hf,start; 14017000 + switch declsw ← ownerr,saverr,booleandec,realdec,integerdec,alphadec, 14018000 + labeldec,dumpdec,subdec,outdec,indec,monitordec, 14019000 + switchdec,proceduredec,arraydec,namedec,filedec, 14020000 + streamerr,definedec; 14021000 +define nlocs=10#,locbegin=prti#, 14022000 + lbp=[36:12]#, 14023000 + spaceitdown = begin write(line[dbl]); write(line[dbl]) end#; 14023100 + 14024000 +boolean gotstorage; 14025000 + integer pinfoo,blkad; 14026000 + comment Localto block to save where a procedure is entered 14027000 + in INFO; 14028000 +real maxstacko,lastinfot,relad,lo,tsublevel,stackctro; 14029000 +integer sgnoo,lold,savelo,prtio,ninfoo; 14030000 + integer nciio; 14031000 + integer proad ; 14032000 + integer firstxd; 14033000 +boolean functogo,ajumpo; 14034000 + beginctr←beginctr+1; 14035000 + if sop 14036000 + then begin blkad←proadd; 14037000 + if lastentry ≠ 0 14038000 + then begin gt1←bumpl; 14039000 + constantclean; 14040000 + emitb(bfw,gt1,l) 14041000 + end 14042000 + end 14043000 + else begin blkad:=getspace(true,-6); % seg. descr. 14044000 + 14045000 + 14046000 + 14047000 + end; 14048000 + 14049000 + 14050000 + firstxd←firstx; 14051000 + firstx←0; 14052000 + level←level+1; 14053000 + lold←l;functogo←functog;ajumpo←ajump;prtio←prti;sgnoo←sgno; 14054000 + savelo←level;ajump←false; l←0;ninfoo←nextinfo; 14055000 + nciio←ncii; 14056000 + ncii←0; 14057000 + stackctro←stackctr; 14058000 + 14059000 + 14061000 + elbat[i].class←semicolon; 14062000 +start: if table(i)≠semicolon 14063000 + then 14064000 + begin 14065000 + flag(0); 14066000 + i←-1 14067000 + end; 14068000 + gta1[0]←j←0; 14069000 + if spectog 14070000 + then 14071000 + begin 14072000 + if bup=pj 14073000 + then 14074000 + begin 14075000 + begin label getlp; 14076000 + if streamtog then f←0 else 14077000 + f←fzero; 14078000 + bup←lastinfo; 14079000 + do 14080000 + begin 14081000 + if not streamtog then 14082000 + bup←lastinfo; 14083000 + getlp: g←take(bup); 14084000 + if k←g.address≠pj 14085000 + then 14086000 + begin 14087000 + if bup ≠ bup:=bup- take(bup + 1).purpt then 14088000 + go to getlp 14089000 + end; 14090000 + typev←g,class; 14091000 + g.address←f←f+1; 14115000 + put(g,bup); g.incr←gt1; 14116000 + put(g,mark+pj) 14117000 + ;bup←bup-take(bup+1).purpt 14118000 + end 14119000 + until pj←pj-1=0 14120000 + end; 14121000 + spectog←false; 14122000 + go to hf 14123000 + end 14124000 + end; 14125000 + stackct ← 0; 14125500 + while stepi=declarators 14126000 + do 14127000 + begin 14128000 + gta1[j←j+1]←elbat[i].address; 14129000 + stopdefine←errortog←true; 14130000 + end; 14131000 +if j =0 then go to callstatement; 14132000 + p2←p3←false; 14133000 + go to declsw[gta1[j]]; 14134000 +ownerr:flag(20);j←j+1;go to realdec; 14135000 +saverr:flag(21);j←j+1;go to realdec; 14136000 +streamerr: if elclass = leftparen then % 6 14137000 + begin % 6 14137100 + i ← i - 1; % 6 14137200 + go to callstatement; % 6 14137300 + end; % 6 14137400 + flag(22); % 6 14137500 + j ← j + 1; % 6 14137600 + go to proceduredec; % 6 14137700 +realdec:p3←true;enter(realid);go to start; 14138000 +alphadec:p3←true;enter(alfaid);go to start; 14139000 +booleandec:p3←true;enter(booid);go to start; 14140000 +integerdec:p3←true;enter(intid);go to start; 14141000 + monitordec:if spectog 14142000 + then begin comment Error 463 means that a monitor 14143000 + declaration appears in the specification 14144000 + part of a procedure; 14145000 + flag(463); 14146000 + end; 14147000 + do until false; 14148000 + dumpdec:if spectog 14149000 + then begin comment Error 464 means a dump declaration 14150000 + appears in the specification part of a 14151000 + procedure 14152000 + flag(464); 14153000 + end; 14154000 + do until false; 14155000 +arraydec: arrae; go to start; 14156000 +filedec: index: outdec: 14158000 +gotschk:gotstorage← not spectog or gotstorage;go to start; 14160000 +namedec: if t1←gta1[j←j-1]≠arrayv then j←j+1; 14161000 + typev←nameid; 14161010 + if t1←gta1[j←j-1]=0 then j←j+1 14161020 + else 14161030 + if t1=ownv 14161040 + then 14161050 + begin 14161060 + p2←true; if spectog then 14161070 + flag(013); 14161080 + end 14161090 + else 14161100 + 14161110 + typev←nameid+t1-realv; 14161120 + enter(typev); go to start; 14162000 +subdec: 14163000 + begin real typev,t; 14163500 + if gta1[j←j-1]=realv then typev←realsubid else typev←subid; 14164000 +stopgsp←true; 14164500 + jumpchknx;entry(typev);if elclass≠semicolon then flag(57); 14165000 +stopgsp←false; 14166 + stepit; 14166000 + t←nextinfo; 14166500 +putnbump(l); stmt; emito(lfu); if typev=realsubid then 14167000 + if get(l-2)≠533 then flag(58);put(take(t)&l[24:36:12],t); 14168000 +constantclean; 14168500 + end; 14169000 + go to start; 14170000 + 14171000 + 14172000 + 14173000 + 14174000 + 14175000 + 14176000 + 14177000 + 14178000 + 14179000 + 14180000 + 14181000 + 14182000 + 14183000 + 14184000 + 14185000 + 14186000 +labeldec:if spectog and functog then flag(24); 14187000 + stopentry←stopgsp←true; 14188000 + i←i-1; 14189000 + do 14190000 + begin 14191000 + stopdefine←true; 14192000 + stepit; 14193000 + entry(labelid); 14194000 + putnbump(0); 14195000 + end 14196000 + until elclass≠comma; 14197000 + stopentry←stopgsp←false; 14198000 + go to start; 14199000 +switchdec: 14200000 + begin 14201000 + label start; 14202000 + integer gt1,gt2,gt4,gt5; 14203000 + boolean tb1; 14204000 + stopentry←not spectog;stopgsp←true; 14205000 + scatterelbat; gt1←0; tb1←false; 14206000 + entry(switchid); 14207000 + gt2←nextinfo; putnbump(0); 14217000 + do 14218000 + begin 14219000 + if stepi≠labelid or elbat[i].lvl≠level then flag(63); 14220000 + putnbump(elbat[i]);gt1←gt1+1; 14221000 + end; 14222000 + comment 14222500 + until stepi≠comma; 14223000 + 14223500 + put(gt1,gt2); 14224000 + stopentry ← stopgsp + false; 14251000 + end switchdec; 14252000 +go to start; 14253000 + definedec: 14254000 + begin label start; 14254050 + real j,k; 14254100 + boolean stream procedure parm(s,d,k,j); value k,j; 14254200 + begin si←s;si←si+2; di←d;di←di+2; 14254300 + if k SC≠dc then tally←1 14254400 + di←loc j;di←di+7; 14254500 + if sc≠dc then tally←1; 14254600 + parm←tally; 14254700 + end; 14254800 + stopentry←stopgsp←true;i←i-1; 14255000 + do 14256000 + begin 14257000 + stopdefine←true; 14258000 + stepit; move(0,accum[1],gta1); 14259000 + k←count+1; j←gta1[0]; entry(definedid); 14259010 + gta1[0]←j+"100000"; j←0; 14259015 + if elclass=leftparen or elclass=lftbrket then 14259020 + begin 14259030 + do begin stopdefine←true; 14259060 + stepit; 14259070 + if (j←j+1)>0 or parm(accum[1],gta1,k,j) or 14259080 + k>62 then begin err(141); go to start end; 14259090 + stopdefine←true; 14259100 + end until stepi≠comma; 14259110 + if elclass≠rtparen and elclass≠rtbrket then err(141); 14259120 + stopdefine←true; 14259130 + stepit; 14259140 + put(take(lastinfo)&j[16:37:11],lastinfo); 14259150 + end; 14259160 + if elclass≠relop 14260000 + then 14261000 + begin 14262000 + flag(30); 14263000 + i←i-1; 14264000 + end; 14265000 + macroid←true; 14265900 + definegen(false,j); 14266000 + macroid←false; 14266100 + end 14267000 + until stepi≠comma; 14268000 + start: stopentry←stopgsp←false; end; go to start; 14269000 +proceduredec: 14270000 + begin 14271000 + label start,start1; 14272000 + label start2; 14273000 + boolean fwdtog; comment This toggle is the forward dec indicator; 14274000 + if not spectog then functog←false; 14275000 + fwdtog←false ; 14276000 + maxstacko← maxstack; 14277000 + if g←gta1[j←j-1]=streamv 14278000 + then 14279000 + begin streamtog←true; 14280000 + if g←gta1[j←j-1]=0 then typev←strprocid 14281000 + else 14282000 + begin 14283000 + if typev←procid +g>intstrprocid or 14284000 + typev intprocid 14294000 + then flag(005) 14295000 + else begin functog←true;g←gta1[j←j-1]; 14296000 + end; 14297000 + if not streamtog then segmentstart(g=savev); 14298000 + saf ← g=savev; 14299000 + 14300000 + 14301000 + 14302000 + mode←mode+1; 14303000 + lo←proinfo; 14304000 + scatterelbat; 14305000 +comment check to see if declared forward previously ; 14306000 + if levelf=level 14307000 + then 14308000 + begin 14309000 + if g←take(linkf+1)≥0 14310000 + then flag(006); 14311000 + fwdtog←true; 14312000 + proad←addrsf; 14313000 + proinfo←elbat[i];mark←linkf+incrf;stepit 14314000 + ;put(-g,linkf+1); 14315000 + end 14316000 + else 14317000 + begin stopentry←true; p2←true; 14318000 + stopgsp←level>1 and streamtog; 14318500 + entry(typev); mark←netinfo;putnbump(0); 14319000 + stopgsp←false; 14319500 + proinfo←take(lastinfo)& lastinfo[35:35:13];proad←addrsf; 14320000 + p2←stopentry←false; 14321000 + end; 14322000 + pj←0; level←level+1; 14323000 + if streamtog then streamwords; 14324000 + if elclass=semicolon then go to start1; 14325000 + if elclass≠leftparen then flag(007); 14326000 +comment: The following 8 statements fool the scanner and block,putting 14327000 + formal parameter entries in the zero row of info; 14328000 + rr1←nextinfo; 14329000 + lastinfot←lastinfo; lastinfo←nextinfo←1; 14330000 + putnbump(0); 14331000 + ptog←true; i←i+1; 14332000 + entry(secret); 14333000 + if fwdtog then 14333100 + begin 14333200 + if gt1:=take(mark).[40:8] ≠ pj then flag(48); % Wrong 14333300 + % number of parameteres. We don"t want to clobber info. 14333400 + end 14333500 +else 14333600 + put(pj,mark); 14334000 + p←pj; 14335000 + if elclass≠rtparen 14336000 + then flag(008); 14337000 + if stepi≠semicolon 14338000 + then flag(009); 14339000 +comment Mark parameters value if there is a value part; 14340000 + if stepi=valuev 14341000 + then 14342000 + begin 14343000 + do 14344000 + if stepi≠secret 14345000 + then flag(010) 14346000 + else 14347000 + begin 14348000 + if g←elbat[i].address=0 or g>pj 14349000 + then 14350000 + flag(010); 14351000 + g←take(elbat[i]); 14352000 + put(g&1[10:47:1],elbat[1]) 14353000 + end 14354000 + until 14355000 + stepi≠comma; 14356000 + if elclass≠semicolon then 14357000 + then flag(011) 14358000 + else stepit; 14359000 + end;i←i-1; 14360000 + if streamtog 14361000 + then 14362000 + begin 14363000 + bup←pj; spectog←true;go to start; 14364000 + end 14365000 + else 14366000 + begin 14367000 + spectog←true; 14368000 + bup←0; 14369000 + if elclass≠declarators 14370000 + then flag(012) 14371000 + end; 14372000 +start:ptog←false;lastinfo←lastinfot;nextinfo←if fwdtog then rr1 else 14373000 + mark+pj+1; 14374000 +start1:pinfoo←nextinfo; 14375000 +start2: end; 14376000 + if spectog or streamtog 14377000 + then 14378000 + go to start; 14379000 +comment If SPECTOG is on then the block will process the specification 14380000 + part similary to declarations with a few necessary varaitions; 14381000 +hf: 14382000 + begin 14383000 + label start stop; 14384000 + define testlev = level>2 #; 14384100 + if streamtog 14385000 + then begin 14386000 + if testlev then jumpchknx else segmentstart(true);pj←p; 14387000 + ptog←false; 14388000 + put(take(git(proinfo))&l[28:36:12],git(proinfo)); 14388100 + if testlev then begin emito(584); end; 14389000 + if stepi=beginv 14393000 + then 14394000 + begin 14395000 + while stepi=declarators or elclass=localv 14396000 + do 14397000 + begin 14398000 + if elbat[i].address=labelv 14399000 + then 14400000 + begin 14401000 + stopdefine←stopgsp←stopentry←true; 14402000 + do begin stopdefine←true;stepit;entry(stlabid);putnbump(0) end until 14403000 + elclass≠comma;stopgsp←stopentry←false 14404000 + end 14405000 + else 14406000 + begin 14407000 + i←i+1; 14408000 + entry(loclid) 14409000 + end 14410000 + end; 14411000 + if functog then 14411100 + put((z←take(proinfo))&loclid[2:41:7] & 14411200 + (pj+2+real(testlev))[16:37:11],proinfo); 14411300 + compoundtail 14412000 + end 14413000 + else 14414000 + begin 14415000 + if functog then 14415100 + put(( z←take(proinfo))& loclid[2:41:7]& 14415200 + (pj+2+real(testlev))[16:37:11],proinfo); 14415300 + streamstmt; 14415400 + end; 14415500 + comment The following block cnstitutes the stream procedure purge; 14416000 + begin 14417000 + real nloc,nlab; 14418000 + define ses=18#,sed=6#,trw=5#; 14419000 + define loc=[36:12]#,lastgt=[24:12]#; 14420000 + j← lastinfo; 14421000 + nloc←nlab←0; 14422000 + do 14423000 + begin 14424000 + if(gt1←take(j)).class=loclid then 14425000 + begin 14426000 + if boolean(gt1.formal) then 14427000 + begin 14428000 + if gt1<0 then 14429000 + put(take(gt2←mark+p-gt1.address+1)&fileid[2:41:7] 14430000 + ,gt2); 14431000 + end 14432000 + else nloc←nloc+1; 14433000 + end 14434000 + else 14435000 + begin 14436000 + if gt1.address≠0 then nlab←nlab+1; 14437000 + if(gt3←take(git(j))).lastgt≠0 and gt3.loc = 0 then 14438000 + begin 14439000 + move(9,info[0,j],accum[0]); 14440000 + q←accum[1]; 14441000 + flag(267); 14442000 + errortog←true; 14443000 + end; 14444000 + end; 14445000 + g←(gt2+take(j+1)).purpt; 14446000 + if gt1.[2:18] ≠ stlabid×2+1 then 14447000 + stackhead[(0>2[12:12:36])mod 125]←take(j).link; 14448000 + end until j←j-g≤1; 14449000 + 14450000 + if testlev then begin emitc(1,0); emito(bfw) end 14451000 + else emit(0); 14451100 +put(take(mark)&nloc[1:42:6]&l[16:36:12]&p[40:40:8],mark); 14451200 + if functog then 14452000 + put(z, proinfo); 14457000 + streamwords; 14460000 + streamtog←false; 14461000 + if not testlev then begin progdescbldr(proad,true,(l+3)div 4,char);14461100 + segment((l+3)div 4,proinfo.address); 14461200 + right(l); l←0; 14461300 + end; 14461400 + if lister and formatog then spaceitdown; 14461500 + end; 14462000 + lastinfo←lastinfot;netinfo←mark+p+1; 14463000 + end 14464000 + else 14465000 + begin 14466000 + if stepi=forwardv 14467000 + then 14468000 + begin 14469000 + put(-take(g←proinfo.link+1),g); 14470000 + purge(pinfoo); 14471000 + stepit 14472000 + end 14473000 + else 14474000 + begin 14475000 + proadd←proad; 14476000 + tsublevel←sublevel;sublevel←level ;stackctro←stackctr; 14477000 + if mode=1 then frstlevel←level;stackctr←513+real(functog); 14478000 + if elclass = beginv then 14479000 + begin 14481000 + callinfo←(callx←callx+1)+1; 14481100 + nextctr←stackctr; 14481200 + block(true); 14482000 + ; purge(pinfoo); 14483000 + if nextog then 14483100 + begin gt1←take(proinfo).address; 14483200 + nestprt[gt1]←0&proinfo[35:35:13]&callinfo[22:35:13]; 14483300 + call(callinfo-1]←(take(git(proinfo))+nestctr-511)& 14483400 + callx[22:35:13]; 14483500 + end; 14483600 + l←0; 14483700 + go to stop end; 14484000 + begin 14485000 + flag(052); 14486000 + relad←l ; 14487000 + stmt; 14488000 + httedap(false,relad,pinfoo,proad); 14489000 + end; 14490000 + stop: 14491000 + sublevel←tsublevel; 14492000 + stackctr←stackctro; 14493000 + if lister and formatog then spaceitdown; 14493500 + end; 14494000 + end; 14495000 + proinfo←lo; 14496000 + if jumpctr=level 14497000 + then 14498000 + jumpctr←level-1; 14499000 + level←level-1; 14500000 + mode←mode-1; 14501000 + maxstack←maxstacko; 14502000 +start:end; 14503000 + go to start; 14504000 + callstatement: fouled ← l; 14505000 + jumpchkx;if sop then begin z←stackctr-513;while z←z-1≥0 14506000 + do emitl(0) end; 14506500 + if spectog then begin 14507000 + flag(12);go to hf 14508000 + end; 14509000 + beginctr ← beginctr-1; 14510000 + if errortog 14511000 + then compoundtail 14512000 + else 14513000 + begin 14514000 + stmt; 14515000 + if elclass←table(i+1)=declarators 14516000 + then 14517000 + begin 14518000 + elbat[i].class←semicolon; 14519000 + beginctr←beginctr+1; 14520000 + go to start; 14521000 + end; 14522000 + else 14523000 + compoundtail 14524000 + end; 14525000 + functog←functogo; 14599000 + if sop then httedap(false,firstx,ninfoo,blkad) 14600000 + else begin if nextog then sortnest; purge(ninfoo); end; 14601000 + segment((l+3)div 4,proadd); 14602000 + if level>1 then right(l); 14603000 + if level ← level-1 = 0 then constantclean; 14604000 + 14605000 + ajump←ajumpo; 14606000 + 14607000 + firstx←firstxd; 14608000 + savel←savelo; 14609000 + stackctr←stackctro; 14610000 + 14611000 + 14612000 +end block; 14613000 +comment This section contains the variable routine and its sidekicks; 15000000 + 15001000 + 15002000 + 15003000 + 15004000 + 15005000 + 15006000 + 15007000 + 15008000 + 15009000 + 15012000 + 15013000 + 15014000 + 15015000 + 15016000 + 15017000 + 15018000 + 15019000 + 15020000 + 15021000 + 15022000 + 15023000 + 15024000 + 15025000 + 15026000 + 15027000 + 15028000 + 15029000 + 15030000 + 15031000 + 15032000 + 15033000 + 15034000 + 15035000 + 15036000 + 15037000 + 15038000 +comment The following block handles the following cases 15039000 + of simple variables: 15040000 + 1. v ← exp ,where v is formal-cal by name. 15041000 + 2. v ← exp ,all v except formal name. 15042000 + 3. v.[s:l] ← exp ,where v is formal-call by name. 15043000 + 4. v.[s:l] ← exp ,all v except formal-name. 15044000 + 5. v.[s:l] ,all v. 15045000 + 6, v ,all v. 15046000 + Code emited for the above cases is as follows: 15047000 + 1. vn,exp,m*,xch,←. 15048000 + 2. exp,m*,vl,←. 15049000 + 3. vn,dip,cdc,exp,t,m*,xch,←. 15050000 + 4. vv,exp,t,m*,vl,← 15051000 + 5. zerol,vv,t . 15052000 + 6. vv . 15053000 + where vn = desc v 15054000 + exp= arith, or boolean expression,as required. 15055000 + m* = call on monitor routine,if required. 15056000 + vl = litc v 15057000 + vv = opdc v 15058000 + ← = store instruction(isd,isn,snd or std). 15059000 + t = bit transfer code(dia,dib,trb). 15060000 + zerol = litc 0 15061000 + dup,cdc,ch = the instructions dup,cdc,and xch. 15062000 + Of course, exp will cause recursion,in general,and thus 15063000 + the parameter P1 and the locals can not be handled in a 15064000 + global fashion. 15065000 + The parameter P1 is used to tell the variable routine 15066000 + who called it. Some of the code generation and some 15067000 + syntax checks depend upon a particlar value of P1 . 15068000 + ; 15069000 +procedure variable(p1); integer p1; 15070000 + begin 15071000 + real tall, comment ELBAT word for variable; 15072000 + t1 , comment 1st integer of partial word syntax; 15073000 + t2 , comment 2nd integer of partial word syntx; 15074000 + j ; comment subscript counter; 15075000 + label exit,l1,last,next,jazz,itup,class; 15076000 + define formalname=[9:2]=2#, longid=nameid#; 15076100 + boolean spclmon; 15076200 + tall←elbat[i] ; 15077000 + if elclass ≤ intprocid then 15078000 + begin 15079000 + if tall.link ≠proinfo.link then 15080000 + begin err(211); go to exit end; 15081000 +comment 211 variable-function identifier used outside of its scope*; 15082000 + tall←tall &(elclass+4)[2:41:7] & 513[16:37:11]; 15083000 + end; 15084000 + else checker(tall); 15085000 + if tall.class ≤intid then 15086000 + begin 15087000 + 15088000 + 15089000 + if stepi= assignop then 15090000 + begin stackct ← 1; 15091000 + if tall.formalname then 15092000 + begin 15093000 + emitn(tall.address); 15094000 + if t1≠0 then begin emito(dup);emito(cdc) end; 15095000 + end; 15096000 + else if t1≠0 then emitv(tall,address) 15097000 + ; stackct ← real(t1≠0); stepit; 15098000 + aexp; 15099000 + emitd(48-t2 ,t1 ,t2); 15100000 + 15101000 + stackct ← 0; 15101500 + gt1 ← if tall.class =intid then if p1= fs 15102000 + then isd else isn else 15103000 + if p1 = fs then std else snd ; 15104000 + if tall.formalname then 15105000 + begin 15106000 + emito(xch); if tall.address>1023 then emito(prte); 15106100 + emito(gt1); 15106200 + end 15106300 + else emitpair(tall.address,gt1); 15107000 + end 15108000 + else 15109000 + begin 15110000 + if p1=fl then begin 15110100 + if elclass < ampersand then emitn(tall,address) 15110200 + else emitv(tall,address); 15110300 + go to exit end; 15110400 + if elclass= period then 15111000 + begin if dotsyntax(t1,t2) then go to exit; 15112000 + if stepi=assignop then 15113000 + if p1←- fs then 15114000 + begin err(201);go to exit end 15115000 + else go to l1 15116000 + 15117000 + end ; 15118000 + if p1≠ fp then begin err(202); go to exit end; 15119000 +comment 202 variable- A variable appears which is not followed * 15120000 + by a left arrow or period *;15121000 +comment 201 variable- A partial word designator is not the * 15122000 + left-most of a left part list *;15123000 + emiti(tall,t1,t2); 15124000 + 15125000 + end ; 15126000 + end of simple variables 15127000 + else 15128000 + if tall.class≠labelid then 15128100 + comment The following block handles these cases of subscripted 15129000 + variables: 15130000 + 1. v[*] ,row designator for single dimension. 15131000 + 2. v[r,*] ,row designator for multi-dimension. 15132000 + 3. v[r] ,array element,name or value. 15133000 + 4. v[r].[s:l] ,partial word designator, value. 15134000 + 5. v[r] ← ,assignment to array element. 15135000 + 6. v[r].[s:l] ← ,assignment to partial word,left-most. 15136000 + R is a K-order subscript list,i.e r=r1,r2,...,rk. 15137000 + In the case of no monitoring on v, the following code 15138000 + is emitted for the above cases: 15139000 + 1. Case #1 is a special case of #2,namely,single 15140000 + dimension. The code emitted is: 15141000 + vl,LOD . 15142000 + Execution: places array descriptor in reg A. 15143000 + 2. This code is basic to the subscription process.15144000 + Each subscript generates the following sequence15145000 + of code: 15146000 + aexp,L*,if first subscript then VN else CDC 15147000 + ,LOD. 15148000 + for a K-order subscription,k-1 sequence are 15149000 + produced. The aexp in each sequence referes to 15150000 + the code produced by the arithmetic expression 15151000 + procedure for the actual subscript expressions,15152000 + L* refers to the code produced for subtracting 15153000 + non-zero lower bounds form subscript 15154000 + expression(L* yields no code for zero bounds). 15155000 + Execution: Places array row descriptor in reg A15156000 + . The specific row depends upon the 15157000 + values of the K-1 subscripts. 15158000 + For the remaining cases, 15159000 + Sequences of code are emitted as in case #2. 15160000 + However,the actual sequences are: 15161000 + Once sequence,(aexp,L*),for the 1st subscript.15162000 + K-1 sequences,(if first subscript then vn 15163000 + else CDC,LOD,aexp,L*), for the remaining 15164000 + subscripts,if K>1. 15165000 + At this point, cases #3-6 are differentiated 15166000 + and addition code,particular to each case,is 15167000 + emitted. 15168000 + 3. Add the sequence: 15169000 + If first subscript then vv else CDC. 15170000 + Execution: The array element is put in reg A. 15171000 + 4. Add the sequence: 15172000 + If first subscript the vv else CDC,zerol, 15173000 + XCH,t 15174000 + 5. Add the sequence: 15175000 + If first subscript then n else CDC,exp, 15176000 + XCH,←. 15177000 + 6. Add sequence: 15178000 + If first subscript then vn else CDC,DUP,LOD, 15179000 + EXP,t, XCH,←. 15180000 + exp,t,←,zerol,etc. have same meanings as defned in 15181000 + simple variable block. ; 15182000 + begin 15183000 + 15184000 + 15184100 + 15184200 + 15184300 + 15184400 + if stepi ≠ lftbrket then 15233000 + begin 15233002 + if elclass = period then 15233003 + begin 15233004 + if dotsyntax(t1,t2) then go to exit; 15233005 + if stepi = assignop then 15233006 + begin 15233007 + if p1≠fs then begin err(209); go exit end; 15233008 + if tall.class ≤ intarrayid then 15233009 + begin emitpair(tall.address,lod) end 15233010 + else emitn(tall.address); stackct ← stackct+1; 15233011 +jazz: stepit; aexp; 15233012 + emitd(48-t2,t1,t2); 15233013 + emitpair(tall.address, 15233014 + if p1=fs then std else snd); 15233015 + stackct ← 0; end 15233016 + else begin 15233017 +itup: emiti(tall,t1,t2); 15233018 + 15233019 + 15233020 + 15233021 + 15233022 + end; 15233023 + go to exit ; 15233024 + end; 15233025 + if elclass = assignop then go to jazz else go to itup ; 15233026 + end; 15233027 + j ← 0; 15234000 + stackct ← 0; 15234500 +comment 207 variable-Missing left bracket on subscripted variable *; 15235000 + next: if stepi = factop then 15253000 + begin 15254000 + if j+1≠ tall.incr then 15255000 + begin err(203);go exit end; 15256000 +comment 203 variable- The number of subscripts used in a row * 15257000 + row designater does not match the array * 15258000 + declaration. *;15259000 + if stepi ≠ rtbrket then 15260000 + begin err(204);go exit end; 15261000 +comment 204 variable- Compiler expects a ] in a row designater *;15262000 + 15263000 +comment 205 variable- A row designater appears oustide of a fill * 15264000 + statement or actual parameter list. *;15265000 + if j=0 then 15266000 + emitpair(tall.address,lod); 15267000 + stlb←0; 15273000 + stepit; 15274000 + go to exit; 15275000 + end of row designater portion ; 15276000 + if elclass=litno and elbat[1].address=0 and table(i+1)=rtbrket 15276010 + and tall.class≥nameid then 15276020 + begin 15276030 + i←i+1; 15276040 + if stepi=assignop then begin 15276050 +lass: if t1≠0 then emitv(tall.address); 15276060 + stepit; aexp; emitd(48-72,t1,t2); 15276070 + emitn(tall.address); 15276080 + emito(if tall.class≠nameid then 15276090 + if p1=fs then isd else isn else 15276100 + if p1=fs then std else snd); 15276110 + stackct ← 0; 15276115 + go to exit end 15276120 + else 15276130 + if elclass = period then begin 15276140 + if dotsyntax(t1,t2) then go to exit; 15276150 + if stepi = assignop then if p1=fs then go to lass 15276160 + else begin err(209); go exit end; 15276170 + end; 15276180 + if p1=fs then begin err(210); go exit end; 15276190 + 15276200 + emiti(if p1=fl then tall else tall&realid[2:41;7],t1,t2); 15276210 + 15276220 + go to exit; 15276230 + end; 15276240 + aexp; 15277000 + stackct ← 1; 15278000 + j ← j + 1; 15280000 + if elclass = comma then 15287000 + begin 15288000 +comment ***** Monitor function M4 goes here ; 15289000 + if j = 1 then emitv(tall.address) else emito(cdc); 15290000 + 15291000 + go to next; 15292000 + end of subscript comma handler ; 15293000 + if elclass ≠ rtbrket then begin err(206);go exit end; 15294000 +comment 206 variable- Missing right brakcet on subscripted variable*; 15295000 + gt1←if tall.class≥nameid then 1 else tall.incr; 15295100 + if j≠gt1 then 15296000 + begin err(208);go to exit end; 15297000 +comment 208 variable- Number of subscripts does not match with * 15298000 + array declaration. *;15299000 + if stepi = assignop then 15300000 + begin 15301000 + last: if j=1 then emitn(tall.address) else emito(cdc); 15302000 + if tall.class ≥ longid then emito(inx); 15303000 + if t1= 0 then 15304000 + begin if p1= fr then go to exit end 15305000 + else begin emito(dup);emito(lod)end; stepit; 15306000 + aexp; 15307000 + emitd(48-t2,t1,t2) ; 15308000 + emito(xch); 15309000 + if tall.address>1023 then emiti(prte); 15310000 + emito(if tall.class mod 2 = intarrayid mod 2 then 15333000 + if p1 = fs then isd else isn else 15334000 + if p1=fs then std else snd); 15335000 + stackct ← 0; 15335500 + p1←0 ; 15336000 + go to exit ; 15337000 + end of assignment statement subscripted variables; 15338000 + if elclass=period then 15339000 + begin 15340000 + if dotsyntax(t1,t2) then go to exit; 15341000 + if stepi = assignop then if p1=fs then go to last 15342000 + else begin err(209); go exit end; 15343000 + if j≠1 then emito(cdc) else if tall.class ≥ longid then 15344000 + begin emitn(tall.address);emito(inx);emito(lod) end 15344100 + else emitv(tall.address); 15344200 + end 15345000 + else 15346000 +comment ***** Monitor function M10 goes here ; 15347000 + begin comment monitor function M10; 15348000 + spclmon←p1 = fp or elclass ≥ ampersand; 15349000 + if j = 1 15350000 + then if tall.class ≥ longid then 15351000 + begin 15351100 + emitn(tall.address); emito(inx); 15351200 + if spclmon then emito(lod) l 15351300 + end else if spclmon 15351400 + then emitv(tall.address) 15352000 + else emitn(tall.address) 15353000 + else emito(if spclmon 15354000 + then coc 15355000 + else cdc); 15356000 + if p1 =fs then err(210); 15364000 + go to exit; 15365000 + end; 15366000 + if p1=fs then begin err(210); go to exit end ; 15367000 +comment 210 variable-missing left arrow or period. *; 15368000 + stackct ←0; 15369000 + if t1 ≠ 0 then begin emiti(0,t1,t2); p1 ← 0 end; 15370000 + end of subscripted variables 15376000 + else 15376100 + begin comment labelid; 15376200 + t1:=take(t2:=git(tall)); 15376300 + put(l,t2); 15376400 + if t1=0 then t1:=l; 15376500 + if (t1←l-t1) div 4 > 127 then begin t1←0;flag(50) end; 15376600 + emit(t1×4+3); 15376700 + stepit; 15376800 + end of labelid; 15376900 + exit : end of the variable routine; 15377000 +comment This section generates code for stream procedures; 16000000 +comment Do label decs upon appearance of label ; 16000050 +procedure declarelabel ; 16000100 + begin 16000200 + klassf ← stlabid; 16000300 + vonf ← formalf ← false; 16000400 + addrsf ← 0; 16000500 + makeupaccum; e; putnbump(0); 16000600 + elbat[i] ← accum[0]& lastinfo[35:35:13]; 16000700 + end; 16000800 + procedure streamstmt; 16001000 + begin 16002000 + define lftparen=leftparen#,loc=[36:12]#,lastgt=[24:12]#, 16003000 + locfld=36:36:13#,lgtfld=24:24:12#; 16004000 + define level=lvl#,addop=adop#; 16005000 + define 16006000 + jfw = 39#, comment 7.5.5.1 Jump forwarad unconditional ;16007000 + rca = 40#, comment 7.5.7.6 Recall control address ;16008000 + jrv = 47#, comment 7.5.5.2 Jump reverse unconditional ;16009000 + crf = 35#, comment 7.5.10.6 Call repeat field ;16010000 + bns - 42#, comment 7.5.5.5 Begin loop ;16011000 + nop = 1#, comment ;16012000 + ens = 41#, comment 7.5.5.6 End loop ;16013000 + tan = 30#, comment 7.5.3.7 End loop ;16014000 + bit = 31#, comment 7.5.3.8 Test for alphameric ;16015000 + jfc = 37#, comment 7.5.5.3 Test bit ;16016000 + sed = 06#, comment 7.5.7.8 Set destination address ;16017000 + rsa = 43#, comment 7.5.7.4 Recall source address ;16018000 + trp = 60#, comment 7.5.2.2 Transfer program characters ;16019000 + bss = 3#, comment 7.5.6.6 Skip source bit ;16020000 + bsd = 2#, comment 7.5.8.5 Skip destination bits ;16021000 + sec = 34#, comment 7.5.10.1 Set count ; 16022000 + jns = 38#; comment 7.5.5.7 Jump out loop ;16023000 +procedure adjust;; 16023100 + comment FIXC emist basicaly forward jumps.However in the case 16024000 + of instructions interpted as jumps because of a CRF on 16025000 + a value = 0 and the jump ≥ 64 syllables a JFW 1 and 16026000 + a RCA L (L is stack address of a pseudo label whcih 16027000 + must also be manufactured) is emitted. ; 16028000 +procedure fixc(s); value s; real s; 16029000 + begin 16030000 + real savl,d,f; 16031000 + if d← (savl←l) - (l←s)-1 ≤ 63 then emitc(d,get(s)) 16032000 + else flag(700); 16033000 + l←savl ; 16034000 + end fixc ; 16057000 + comment EMITJUMP is called by gotos and jumpchain. 16058000 + This routine will emit a jump if the distance is ≤ 63 16059000 + syllables ,otherwise, it gets a PRT cell and stuffs the 16060000 + stack address into the label entry in INFO and emits an 16061000 + RCA on this stack cell. At execution timeactual parapart 16062000 + insures us that this cell will conatin a label descriptor 16063000 + pointing to our label in question. ; 16064000 +procedure emitjump( e); value e; real e; 16065000 + begin 16066000 + real t,d; 16067000 + real addr; 16068000 + if abs( 16069000 + d←(t←take(git(e)),loc)-l-1)≥64 then 16070000 + flag(700); 16071000 + else emitc(d,if d <0 then jrv else jfw); 16079000 + end emit jump; 16080000 + comment When jumpchain is called there is a linkedlist in the code 16081000 + array where JFWs must be placed. The 1st link is pinted 16082000 + to by the loc field of each label entry in INFO.The last 16083000 + link is = 4096. ; 16084000 +procedure jumpchain( e); value e;real e; 16085000 + begin 16086000 + real savl ,link; 16087000 + savl ← l; 16088000 + l ← take(git(e)).lastgt; 16089000 + while l≠ 4095 do 16090000 + begin 16091000 + link ← get(l); 16092000 + emitjump( e); 16093000 + l ← link 16094000 + end; 16095000 + l←savl; 16096000 + end jumpchain ; 16097000 + comment NESTS compiles the next statement. 16098000 + A variable next cause the code, 16099000 + CRF V, BNS 0 ,NOP,NOP, to be generated initially. 16100000 + At the right paren the BNS is fixed wiht the length of 16101000 + the next (number of syllables) if the length ≤63,otherwise 16102000 + it is fixed with a 1 and the nops replaced wiht JFW 1, 16103000 + RCA P. THis is done becasue the value of V at execution 16104000 + may = 0 and this code causes a jump around then next. 16105000 + Jumpout info is remembered in a recursive cell and 16106000 + next level increased by one. 16107000 + When the right paen is eached,(if the statements in 16108000 + the next compiled), JOINFO is checked for the existance 16109000 + of jumpout statements in the nest,if so,the the jumps 16110000 + are fixed by faking totos into compiling the required 16111000 + jumps. 16112000 + Finally the BNS is fixed,if required,and nest level 16113000 + and JOINFO restored to their oiginal value. ; 16114000 +procedure next; 16115000 + begin 16116000 + label exit; 16117000 + real joint,bnsfix; 16118000 + if elclass≠litno then 16119000 + begin 16120000 + emitc(elbat[1].address,crf); bnsfix← l; 16121000 + emit(bns); 16122000 + end 16123000 + else emitc(elbat[i].address,bns); 16124000 + if stepi ≠ lftparen then begin err(262);go to exit end; 16125000 + nextlevel←nextlevel + 1; 16126000 + joint ← joinfo; 16127000 + joinfo ← 0; 16128000 + do begin 16129000 + stepit; errortog ← true; streamstmt 16130000 + end until elclass ≠ semicolon ; 16131000 + if elclass ≠ rtparen then begin err(262);go to exit end; 16132000 + emit ( ens); 16133000 + if joinfo ≠ 0 then 16134000 + begin 16135000 + comment Prepare to call jumpchain forjumpous; 16136000 + adjust; 16137000 + put(take(git(joinfo))&l[locfld],git(joinfo)); 16138000 + jumpchain(take(joinfo)&joinfo[35:35:13]); 16139000 + end; 16140000 + if bnsfix ≠ 0 then fixc(bnsfix); 16141000 + nextlevel ← nextlevel-1; 16142000 + joinfo ← joint ; 16143000 + exit: end nests ; 16144000 + comment LABELS handles stream labels. 16145000 + All labels are adjusted to the begining of the next 16146000 + word (in the program stream). 16147000 + If a got to has not been encountered before the label 16148000 + then the nest level field is entered and the defined bit, 16149000 + [1:1], setto one.For defined lables,if where a go to 16150000 + has appeared, a check is made that the current nest level 16151000 + matches the level of the label. 16152000 + Multiple occurances are also checed for and flagged. 16153000 + Finally,jumpchain is called to fix up any forward go tos 16154000 + and get a PRT location for any jumps ≥64 syllables. ; 16155000 +procedure labels; 16156000 + begin 16157000 + real gt1; 16157100 + adjust; 16158000 + gt1 ← elbat[i]; 16159000 + if stepi ≠ colon then err(258) 16160000 + else 16161000 + begin 16162000 + if take(gt2←git(gt1)).loc ≠ 0 then flag(259); 16163000 + if gt1>0 then 16164000 + begin 16165000 + put(-(take(gt1)&nestlevel[11:43:50),gt1); 16166000 + put(-l,gt2) 16167000 + end 16168000 + else 16169000 + begin 16170000 + if gt1.level≠nestlevel then flag(257); 16171000 + put((-l)&take(gt2)[lgtfld],gt2); 16172000 + jumpchain(gt1); 16173000 + end; 16174000 + end 16175000 + ; stepit; 16176000 + end labels ; 16177000 + comment IFS compiles if statements. 16178000 + First the test is compiled. Note that in the 16179000 + constructs "SC relop DC" and "SC relop stirng" that 16180000 + the syllable emitted is fetched for one of two fields 16181000 + in the ELBAT word for the relational operator. Otherwise 16182000 + the code is emitted straightaway. 16183000 + A test is made to see whether the statement after the 16184000 + "then" could possibly be longer that 63 syllables,and if 16185000 + so, Z nops are emitted for FIXC in case a RCA will have 16186000 + to be generated. 16187000 + This procedure does no optimization in the cases 16188000 + if then go to L,if then statement else goto l,or 16189000 + if then goto l1 else go to l2 ; 16190000 +procedure ifs; begin 16191000 + define comparecode=[42:6]#,testcode=[36:6]#; 16192000 + label ifsb,iftog,ifsc,exit; 16193000 + switch ifsw ← ifsb,iftog,ifsc; 16194000 + real addr,fix1,fix2 ; 16195000 + addr←1 ; 16196000 + go to ifsw[stepi -sbv+1] ; 16197000 + if elclass=loclid then 16198000 + begin 16199000 + emitc(elbat[1].address,crf); 16200000 + addr←0; 16201000 + end 16202000 + else 16203000 + if elclass=litno then addr ← elbat[i].address 16204000 + else begin err(250); go to exit end; 16205000 + if stepi ≠ scv then begin err(263);go to exit end; 16206000 + ifsc: if stepi ≠ relop then begin err(264);go to exit end; 16207000 + if stepi = dcv then emitc( addr,elbat[i-1].comparecode); 16208000 + else 16209000 + if elclass = strngcon then 16210000 + emitc(accum[1].[18:6],elbat[i-1].testcode) 16211000 + else 16212000 + if elclass=litno then emitc(c,elbat[i-1].testcode) else 16212500 + if elclass≤idmax and q="5ALPHA" then emitc(17,tan) 16213000 + else begin err(265); go to exit end; 16214000 + go to iftog ; 16215000 + ifsb: emitc(1,bit); 16216000 +iftog: if step ≠ thenv then begin err(266); go to exit end; 16217000 + fix1 ← l; 16218000 + emit(jfc); 16219000 + if stepi≠elsev then% 16220000 + streamstmt; 16229000 + if elclass=elsev then 16230000 + begin 16231000 + fix2 ← l; emit(jfw); 16232000 + fixc(fix1); 16233000 + stepit; 16234000 + streamstmt; 16235000 + fixc(fix2); 16236000 + end 16237000 + else fixc(fix1); 16238000 + exit:end ifs ; 16239000 + comment GOTOS handles go to and the last part of jump out to 16240000 + statements. 16241000 + If the label has been encountered then EMITJUMP is called 16242000 + an produces a JRV or RCA in the case of jumps≥64 syllabl 16243000 + es. Otherwise, a link is emitted pointing any previous 16244000 + go tos in the case of forward jumps. 16245000 + Finally, if the next level is defined then t is checked 16246000 + against the current level minus the number of levels to 16247000 + be jumped out. Oherwise,nest level is defined. ; 16248000 +procedure gotos; 16249000 + begin 16250000 + label exit; 16251000 + if stepi ≠tov then i←i-1 ; 16252000 + if stepi ≠ stlabid then elclass ≤ idmax then 16253000 + declarelabel else begin err(260); go to exit end; 16253100 + if(gt2←take(git(gt1←elbat[i]))).mon=1 16254000 + or gt2.loc≠0 then emitjump(gt1) 16255000 + else 16256000 + begin put(0&l[24:36:12],git(gt1)); 16257000 + if gt1>0 then 16258000 + begin 16259000 + put(-(take(gt1)&(nextlevel-jumplevel)[11:43:5]),gt1); 16260000 + emitn(1023); 16261000 + end 16262000 + else 16263000 + begin 16264000 + if gt1.level ≠ nextlevel-jumplevel then flag(257); 16265000 + emit(gt2.lastgt); 16266000 + end; 16267000 + end; 16268000 + jumplevel←0 ; 16269000 + exit: end gotos ; 16270000 + comment RELEASES compiles the stream release statement. 16271000 + The code generated is : 16272000 + SED file 16273000 + RSA 0. 16274000 + At execution time this causes an invalid address which is 16275000 + interpeted by the MCP to mean release the file pointed to 16276000 + by the destination address. 16277000 + Temonitor bit is set in INFO for the local variable so 16278000 + that actual parapart may be informed later that a file 16279000 + must be passed for this formal parameter; 16280000 + 16281000 + 16282000 + 16283000 + 16284000 + 16285000 + 16286000 + 16287000 + 16288000 + 16289000 + comment INDXS compile statements beginning with SI,DI,CI,TALLY 16290000 + or localids . 16291000 + Three cases present themselves, 16292000 + Leting x be either of SI,DI,CI or TALLY, they are: 16293000 + case i loclid ← x 16294000 + case ii x ← x ... 16295000 + case iii x ← either loc,loclid,SC or DC. 16296000 + The variable "index" is computed,depending upon which 16297000 + case exists,such that array element "macro[index]"contains 16298000 + the code to be emitted. 16299000 + Each element of macro has 1-3 syllables ordered from 16300000 + rght to left. Unused syllables must = 0. Each macro 16301000 + may require at most one repeat part. 16302000 + In this procedure,INDEXS,the varibale "ADDR" contains the 16303000 + proper repeat part by the time the label "generate" is 16304000 + encountered, the syllables are fetched from MACRO[type] 16305000 + one at a time and if the rpeat part ≠ 0 then"addr" is 16306000 + used as the repeat part,thus building a syllable with 16307000 + the proper address and operator . 16308000 + Note: If MACRO[type] = 0 then this signifies a syntax 16309000 + error. ; 16310000 +procedure indexs; 16311000 + begin 16312000 + label exit,generate,l,l1; 16313000 + integer tclass,index,addr,j; 16314000 + tclass ← elclass ; 16315000 + if stepi ≠ assignop then begin err(251); go to exit end; 16316000 + if tclass = loclid then 16317000 + begin 16318000 + if siv>stepi or elclass>tallyv then go to l; 16319000 + index ← 32 + elclass-siv; 16320000 + addr ← elbat[i-2].address; 16321000 + go to generate; 16322000 + end; 16323000 + if tclass = stepi then 16324000 + begin 16325000 + if stepi ≠ addop or stepi≠ litno and elclass ≠ loclid then16326000 + go to l; 16327000 + index ← tclass-siv 16328000 + +real(elbat[i-1].address=sub) × 4 16329000 + + real(elclass =loclid) × 8; 16330000 + end 16331000 + else 16332000 + begin 16333000 + index ← tclass -siv 16334000 + + ( if elclass = loclid then 16 else 16335000 + if elclass = locv then 20 else 16336000 + if elclass = scv then 24 else 16337000 + if elclass= dcv then 28 else 25); 16338000 + if elclass = locv then 16339000 + if stepi ≠ loclid then go to l; 16340000 + if elclass = litno and tclass = tallyv then 16341000 + begin emitc(elbat[i].address,sec); go to exit end; 16342000 + end ; 16343000 + addr ← elbat[i].address; 16344000 + generate: 16345000 + if macro[index]= 0 then 16346000 + l: begin err(250);go to exit end; 16347000 + j ← 8; tclass ←0 ; 16348000 + l1: movecharacters(2,macro[index],j←j-2,tclass,6 ); 16349000 + if tclass≠0 then 16350000 + begin 16351000 + emitc(if tclass≥64 then addr else 0,tclass); 16352000 + go to l; 16353000 + end; 16354000 + exit:end indexs; 16355000 + comment DSS compiles destination stream satements. 16356000 + ds← lit"string" is handled as a special case because the 16357000 + string must be scanned from right to left,repeatedly if 16358000 + necessary, and emitted tot he program stream. In 16359000 + all other cases,the ELBAT word contains the operator in 16360000 + the opcode field ; 16361000 +procedure dss; 16362000 + begin 16363000 + integer addr,j,k,l,t; 16364000 + label exit.l1; 16365000 + define opcode=[27:6]#; 16366000 + if stepi ≠ assignop then begin err(251); go to exit end; 16367000 + if stepi = loclid then 16368000 + begin 16369000 + emitc(elbat[i].address,crf ); 16370000 + addr← 0; 16371000 + if stepi = litv then go to l; 16372000 + end 16373000 + else if elclass= litno then 16374000 + begin 16375000 + addr ← elbat[i].address; stepit ; 16376000 + end 16377000 + else addr ← 1 ; 16378000 + if q = "4FILL0" then emitc(addr,10) else %e 16378500 + if elclass = trnsfer then emitc(addr,elbat[1].opcode) 16379000 + else 16380000 + if elclass = lit then 16381000 + begin 16382000 + emitc(addr,trp); 16383000 + if stepi≠strngcon then 16384000 + begin err(255);go to exit end; 16384500 + if addr mod 2 ≠ 0 then 16385000 + begin 16386000 + emit(accum[1].[18:6]); j ← 1; 16387000 + end ; 16388000 + for k ←j+2 step 2 until addr do 16389000 + begin 16390000 + for l ←6,7 do 16391000 + movecharacters(1,accum[1],2+(if j←j+1>count then j←1 16392000 + else j),t,l ); 16393000 + emit (t); 16394000 + end end 16395000 + else 16396000 + l1: err(250); 16397000 + exit:end dss ; 16398000 + comment SKIPS compiles the skip bit statement. 16399000 + If the repeat index is a localid then a CRF is eitted. 16400000 + A BSS or BSD is emitted for skip source bits (SB) 16401000 + or skip destination its (db) respectively ; 16402000 +procedure skips ; 16403000 + begin 16404000 + real addr; 16405000 + if stepi - loclid then 16406000 + begin 16407000 + emitc(elbat[i].address,crf); addr←0; stepit; 16408000 + end 16409000 + else if elclass = litno then 16410000 + begin 16411000 + addr← elbat[i].address; stepit 16412000 + end 16413000 + else addr ← 1 ; 16414000 + if elclass =sbv then emitc(addr,bss); 16415000 + else 16416000 + if elclass =dbv then emitc(addr,bsd) 16417000 + else err(250); 16418000 + end skips ; 16419000 + comment JUMPS compiles jump out and jump out to statements. 16420000 + Jump out to statements casuse jump level to be set to 16421000 + the number of levels specified. Then this number of 16422000 + JNS are emitted and GOTOS is called to compile the 16423000 + jump instruction. 16424000 + Simple jump outs are handles by emitting one JNS,entering 16425000 + a pseudo STLABID in NFO and setting ELBAT[I] such that 16426000 + the GOTOS procedure will perform the action of setting 16427000 + up the links for later fix ups. The nest statement causes 16428000 + the fix ups(if emitting of jump instructions) by calling 16429000 + go tos when the right paren in encountered. ; 16430000 +procedure jumps; 16431000 + begin 16432000 + jumplevel←1; 16433000 + if stepi≠declarators then if accum[1]≠"3OUT00" then 16434000 + flag(261); 16434100 + if stepi = litno then jumplevel← elbat[i].address 16435000 + else begin 16436000 + if elclass≠ tov and elclass≠ stlabid then 16437000 + begin 16438000 + comment Simple jump out statement; 16439000 + if joinfo = 0 then 16440000 + begin 16441000 + joinfo ← nextinfo ; 16442000 + putnbump(stackhead[0],link&(stlabid×2+1) 16443000 + [2:40:8]&2[27:40:8 ]); 16444000 + putnbump(0&(joinfo←lastinfo )[ 4:40:8]); 16445000 + putnbump (0); 16446000 + lastinfo ← joinfo; 16447000 + end; 16448000 + elbat[i← i-1]← take(joinfo)&joinfo[35:35:13]; 16449000 + end; i←i-1 ; 16450000 + end; 16451000 + for gt1← 1 step 1 until jumplevel do 16452000 + emit( jns); 16453000 + gotos; 16454000 + end jumps; 16455000 + comment STREAMSTMT envokes the appropriate procedue to handle 16456000 + the various and sundry stream procedure statements. 16457000 + The statements are broken down as follows: 16458000 + Identified by Procedue envoked 16459000 + END go to fini 16460000 + semicolon go to fini 16461000 + ) go to fini 16462000 + IF ifs 16463000 + GO gotos 16464000 + RELEASE releases 16465000 + BEGIN compoundtail 16466000 + SI,DI,CI,TALLY,LOCALID indexs 16467000 + DS dss 16468000 + SKIP skips 16469000 + JUMP jumps 16470000 + labelid labels 16471000 + literal no.,localid( nests 16472000 + Upon exiting,streamstmt assures that "i" points to 16473000 + the semicolon ,end or ) in syntactically correct programs; 16474000 + label l,l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,exit,fini,start; 16475000 + switch type ← fini,l,fini,l3,l4,l5,l6,l7,l7,l7,l7,l8,l9,l10; 16476000 + start: go to type[ elclass-endv+1]; 16477000 + if elclass= rtparen then got to fini ; 16478000 + if elclass=stlabid then go to l2 ; 16479000 + 16480000 + if elclass