!!! %option stack=30
!!! 19-Feb-82 !!!! 15/5/78
{Modified run under new subsystem so that it can support its own supervisor}
!!!!!!!!!!!%CONTROL 1; ! ... TEST ONLY SWITCHES
CONSTSTRING(5) VERSION = "4.12"
CONSTINTEGER GBASE= 426
CONSTINTEGER GMAX = 512; !???
{Changed from %CONST to %OWN to get 8.1 pass1 to accept source}
ownSHORTINTEGERARRAY PHRASE(132:255) = 326, 137, 219, 0,
386, 164, 242, 246, 216, 210, 229, 98,
378, 183, 310, 292, 268, 259, 349, 221,
367, 364, 410, 413, 416, 419, 422, 391,
405, 199, 236, 158, 382, 357, 0, 278,
285, 307, 302, 318, 321, 346, 341, 370,
425, 426, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 1, 7, 40, 49, 96, 0
CONSTBYTEINTEGERARRAY ATOMIC(105:130) =
14, 9, 4, 20, 6, 110, 111, 30,
3, 80, 59, 59, 13, 4, 13, 59,
43, 73, 79, 72, 71, 4, 2, 2,
4, 2
OWNSHORTINTEGERARRAY GRAM(0:GMAX) =
0, -32765, 4, 5, 511, 8198, 4, -32748,
-32747, -32741, -32740, -32739, -32738, -32737, 15, -32736,
-32750, 511, -32257, 15, 27, 22, -32744, 511,
8217, -32747, 511, 511, 511, 27, 33, 37,
36, 8226, -32750, 511, 16, 8230, -32737, 511,
-32726, 511, 43, 44, -32725, -32721, 27, -32725,
44, -32708, -32706, -32698, -32689, -32688, -32687, -32741,
-32675, -32686, -32741, 66, -32706, 511, -32698, -32695,
-32257, 27, -24482, -24482, -32673, 511, 71, -32694,
-32695, 511, -32695, -32257, 77, -32681, 511, 89,
-32257, 4187, -32685, 84, -32685, -32695, 511, -32695,
27, -32703, 73, -32695, 511, 8219, 8219, 12315,
97, 27, -32657, -32647, -32655, -32654, -32647, -32660,
-32653, -32651, -32646, 122, -32645, -32649, 120, -32644,
121, -32643, 126, -32645, 119, -32641, 128, -24576,
8192, 129, 130, 0, 8192, 8192, 8192, 8192,
131, 132, 133, 134, 114, 115, 135, -32649,
123, -32768, -32622, -32621, -32620, -32624, -32619, 150,
-32623, 8344, 8192, 126, 125, 154, -32613, 0,
-32612, 0, 157, 0, 20480, 150, -32607, -32606,
163, 4096, 4608, 2048, -32594, -32768, -32768, -32594,
-32594, -32593, -32593, -32591, -32591, 177, 178, -32589,
0, 180, 181, 0, 182, 0, 175, -32594,
-32768, -32768, -32594, -32594, -32594, -32574, -32574, -32573,
-32573, 195, 196, 197, 0, 198, 194, -32564,
-32564, -32562, -32562, 206, -32561, 0, 208, 0,
209, 204, -32555, -32768, 0, 214, 12503, 0,
8409, -32552, 0, -24576, 8192, -32542, 223, -32541,
-32540, 174, 0, 215, 0, -32532, -32536, 241,
-32529, -24576, -32533, 8192, -32533, -32533, 8192, -24576,
8192, 0, 243, -32526, -32768, 243, -32520, 249,
250, 254, -32516, 0, -32518, 250, 8447, 256,
-32510, 0, 0, -32507, 262, 4608, 2311, 264,
18697, -32501, 0, 10240, -32498, 271, 272, 273,
274, 125, 16659, -32491, 0, 8192, -32768, -32486,
-32485, 0, 215, 8476, 0, -32768, -32768, -32478,
-32477, 0, 215, 284, -32468, -32474, 8487, -32474,
-32467, -32468, -32468, 0, 8489, 8488, 8495, -32466,
-32462, 0, 8496, 8500, -32461, 0, -32452, 8504,
-32457, -32451, -32452, 0, 8506, 8505, 8511, -32450,
0, 8514, -32447, -32443, 0, 8515, -32434, -32440,
8521, -32440, -32430, -32429, -32429, 0, 8527, -32428,
-32428, 0, 8522, 8523, 8527, 8534, -32427, -32423,
0, 8535, 8539, -32422, 0, 350, -24223, -24222,
0, 355, 351, -24223, 0, 8550, 359, 8552,
361, 8554, 363, 8192, 365, 4462, 0, 368,
-32401, 0, 371, 4468, 373, 12662, -32392, 377,
371, 0, 379, 8572, -32390, 0, 383, 8576,
385, 8407, -32380, 0, -32378, 8448, 388, -32768,
-32768, -32370, -32370, -32369, -32369, 399, 401, -32366,
0, 0, 403, 404, 398, 406, 4503, -32359,
377, 406, 411, 4508, 365, 414, 4511, 411,
417, 4514, 414, 420, 4517, 417, 423, 4520,
420, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0
OWNBYTEINTEGERARRAY GCLASS(0:GMAX) =
255, 114, 116, 1, 89, 162, 2, 53,
54, 49, 50, 51, 52, 57, 142, 1,
118, 117, 13, 142, 152, 152, 6, 117,
142, 118, 117, 13, 59, 144, 59, 152,
83, 164, 6, 117, 128, 164, 4, 13,
1, 13, 56, 59, 56, 4, 2, 56,
59, 34, 35, 28, 29, 10, 11, 33,
42, 19, 48, 133, 35, 13, 28, 12,
119, 133, 28, 29, 11, 13, 150, 5,
12, 119, 12, 119, 133, 35, 13, 150,
119, 165, 15, 83, 4, 12, 119, 12,
133, 5, 10, 10, 119, 83, 150, 165,
1, 138, 63, 62, 61, 60, 64, 75,
74, 77, 78, 76, 94, 109, 20, 20,
95, 20, 109, 94, 109, 20, 95, 83,
161, 101, 101, 143, 159, 137, 163, 166,
101, 153, 153, 153, 102, 102, 102, 109,
94, 23, 8, 22, 21, 24, 73, 143,
15, 83, 141, 90, 91, 101, 112, 0,
4, 0, 153, 133, 147, 102, 86, 87,
88, 147, 146, 140, 70, 67, 68, 69,
71, 74, 75, 76, 77, 78, 101, 94,
0, 101, 153, 137, 153, 102, 102, 70,
67, 68, 69, 72, 71, 74, 75, 76,
77, 78, 94, 101, 145, 153, 102, 74,
75, 76, 77, 78, 94, 0, 101, 161,
153, 102, 80, 81, 115, 1, 147, 2,
134, 105, 0, 82, 145, 99, 100, 1,
32, 79, 149, 150, 151, 86, 87, 88,
43, 84, 45, 83, 43, 45, 83, 84,
83, 82, 139, 4, 2, 139, 53, 51,
59, 152, 4, 0, 59, 139, 164, 97,
4, 0, 136, 99, 100, 148, 140, 46,
140, 46, 0, 140, 99, 100, 132, 137,
46, 108, 132, 46, 0, 132, 83, 1,
9, 145, 147, 167, 106, 84, 83, 1,
9, 145, 132, 168, 43, 45, 167, 36,
38, 39, 40, 0, 170, 169, 167, 36,
38, 0, 169, 167, 36, 0, 43, 168,
37, 41, 40, 0, 172, 171, 168, 37,
0, 168, 37, 41, 0, 171, 43, 45,
168, 36, 38, 39, 40, 0, 174, 39,
40, 0, 173, 174, 172, 168, 36, 38,
0, 173, 168, 36, 0, 151, 30, 31,
0, 151, 151, 30, 0, 137, 6, 147,
4, 147, 126, 147, 1, 147, 127, 59,
4, 0, 1, 147, 113, 147, 4, 2,
98, 97, 152, 175, 4, 0, 1, 162,
113, 162, 59, 139, 4, 164, 59, 70,
69, 74, 75, 76, 77, 78, 94, 95,
0, 159, 101, 153, 102, 1, 147, 4,
127, 98, 1, 147, 107, 1, 147, 107,
1, 147, 107, 1, 147, 107, 1, 147,
107, 124, 125, 147, 107, 147, 107, 147,
107, 147, 127, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0
CONSTSHORTINTEGERARRAY KDICT(32: 538) =
0, 511, 131, 527, 131, 131, 531, 131,
535, 539, 543, 551, 555, 559, 575, 579,
129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 591, 594, 599, 619, 635, 131,
131, 652, 724, 752, 840, 876, 1020, 128,
128, 1084, 128, 128, 1296, 1320, 1344, 1384,
1408, 128, 1460, 1824, 2056, 2080, 128, 2112,
128, 128, 128, 131, 2127, 131, 131, 2151,
131, 131, 131, 131, 131, 131, 131, 131,
131, 131, 131, 131, 131, 131, 131, 131,
131, 131, 131, 131, 131, 131, 131, 131,
131, 131, 131, 131, 2155, 131, 131, -32351,
-16119, 16679, 16743, 18734, 16614, 16385, 16386, -16282,
16489, 17128, 16388, -32322, -15576, 17195, 16392, 21710,
-32465, 19369, 16550, 16387, 16397, -32196, -32451, 18542,
18798, 16804, -32323, -14138, 18670, 19284, -32195, -32450,
18606, 16868, 18862, -30642, 10578, 11457, -31922, -32429,
16823, 8912, 67, 16951, 9921, 69, -32429, 16887,
8912, 67, 17079, 68, 18910, -32187, 10841, 69,
16896, 9415, 78, 17393, -30070, -32177, 8665, 8908,
16394, -31027, 78, -31533, 84, -32183, 10194, 76,
17386, 10958, 69, 18135, 84, 16512, 8909, 10830,
16391, 16384, -32055, 10073, 9921, 8649, 16704, 9153,
10190, 8915, 17322, -28340, -31026, -31530, 88, -32055,
8916, 10066, 9793, 16768, 84, 18071, 10053, 84,
16399, 68, -32433, 21873, 70, -31034, -31540, 80,
-32059, 10194, 10567, 9921, 22001, 9938, 22065, 10697,
84, 17904, 9801, 69, 21937, 8915, 19171, -31039,
-31543, -32306, 10575, 16395, -32429, 17143, 8912, 67,
17207, 9422, 9299, 19106, 10700, 69, 17623, -26042,
10830, 9157, 10565, -28607, -29626, -30643, -31794, -32301,
-15243, 17528, 8912, 67, 23416, 9921, 69, -32301,
-15179, 17592, 8912, 67, 23480, 10305, -32301, -14734,
18040, 8912, 67, 24306, 78, -32301, -14798, 17976,
8912, 67, 24370, 10578, 11457, -31922, -32429, 18163,
8912, 67, 23539, 9921, 69, -32301, -14539, 18232,
8912, 67, 23608, 18204, -32183, 10063, 71, 17024,
10835, 17840, 10305, -32429, 16631, 8912, 67, 16695,
-32319, 10831, 18464, 8909, -32301, -16201, 16568, 8912,
67, 17015, -32050, -32302, 10071, 16448, 18975, 19219,
-31291, 8914, 9412, 8387, 8916, -32301, -15694, 17080,
8912, 67, 24050, 9938, 16832, -31419, 10959, 9428,
8910, -32301, -15886, 16888, 8912, 67, 24114, -29759,
-30909, -31408, -32173, 10964, 10066, 17495, 9813, 7892,
-32451, 17430, 17045, 8389, 84, 19041, 10575, 68,
-32088, 10182, 9938, 10817, 21810, 21521, 76, -27455,
-28474, -29491, -30642, -32301, -10123, 22648, -31540, -32178,
8912, 67, 23672, 10575, 8397, 76, 18032, 10063,
71, 17968, 9921, 69, -32301, -10059, 22712, 8912,
67, 23736, 10305, -32301, -9614, 23160, 8912, 67,
24178, 78, -32301, -9678, 23096, 8912, 67, 24242,
10578, 11457, -31922, -32429, 23283, 8912, 67, 23795,
9921, 69, -32301, -9419, 23352, 8912, 67, 23864,
-25656, -26167, -26672, -31532, -32041, 10713, 8916, 77,
16640, 10825, 9283, 16825, -28223, -28593, 9426, 9166,
-29144, -30015, -31034, -32051, 8398, 8909, -12107, 20664,
10305, -32301, -11662, 21112, 8912, 67, 24498, 78,
-32301, -11726, 21048, 8912, 67, 23922, 10578, 11457,
8398, 8909, -11467, 21304, 20496, 80, 17751, 10834,
16396, 8645, -8206, 24567, 10055, 9793, 17688, 10575,
84, 16960, -32184, 10962, 69, 17559, 10053, 16389,
78, -32180, 9428, 76, 18397, 10693, 83, 18268,
9416, 8908, 18333, -32067, -32292, -15771, 17005, 17252,
18734, 16402, 16649
!*******************************************
!* *
!* TRANSPORTABLE IMP COMPILER *
!* *
!* COPYRIGHT PETER S. ROBERTSON *
!* DEPARTMENT OF COMPUTER SCIENCE *
!* UNIVERSITY OF EDINBURGH *
!* ALL RIGHTS RESERVED *
!* *
!*******************************************
!
! THROUGHOUT THE SOURCE TEXT OF THIS PROGRAM, THE LOWER CASE
! ALPHABET IS REPRESENTED BY LETTER+32 E.G. 'A'+32
CONSTINTEGER SS0=250, SS1=251, SS2=252, SS3=253, SS4=254
CONSTINTEGER NULL=512; !???
CONSTINTEGER TRANSP = 18
CONSTINTEGER PHRASES = 132
CONSTINTEGER EQUIVS = 105
CONSTINTEGER DIRECTIVES = 86
CONSTINTEGER ANAPP=160
CONSTINTEGER GLOBAL=0
CONSTINTEGER ICONST=83, RCONST=84, SCONST=82
CONSTINTEGER LB=1, RB=2
CONSTINTEGER PRE1=49, PRE2=57
CONSTINTEGER OWN1=53, OWN2=51
CONSTINTEGER SET1=60, SET2=64
CONSTINTEGER CHECK1=66, CHECK2=72
CONSTINTEGER DEF1=60, DEF2=79
CONSTINTEGER IDENT=59, SWITCH=80, COMMENT=7
CONSTINTEGER TERMIN=13
CONSTINTEGER APPEP=153
CONSTINTEGER PAGE SIZE = 64
CONSTINTEGER STX = 2
CONSTINTEGER PAGE = 12
!*********************************************
!* OTYPE * MOD * SPECD * FORMAT * APP * LINK *
!*********************************************
! 3 2 1 1 1 8
!
! OTYPE : 1 OWN
! 2 CONST
! 3 EXTRINSIC
! 4 SYSTEM
! 5 DYNAMIC
! 6 EXTERNAL
! 7 PERM
!
!*******************************
!* LENGTH * USED * TYPE * FORM *
!*******************************
! 8 1 3 4
!
BEGIN
! ------I/O STREAM ASSIGNMENTS CHANGED TEMPORARILY------
CONSTINTEGER PRIM = 2, PROG = 1; ! INPUT STREAMS
CONSTINTEGER REPORT=3,OBJ=2, LISTING=1; ! OUTPUT STREAMS
CONSTINTEGER EOP=87; ! ENDOFPROGRAM SUBATOM
CONSTINTEGER EOF=86; ! ENDOFFILE SUBATOM
CONSTINTEGER TEXT LIMIT=255; ! MAX STRING LENGTH
CONSTBYTEINTEGERARRAY CMAP(0 : 15)= 0, 67, 68, 81, 65, 83, 80, 73,
72, 71, 79, 69, 7 0, 66, 0, 0
CONSTINTEGER STRING = 16, RECORD=17; ! STRING/RECORD SUBATOMS
CONSTINTEGER SPECIAL=55; ! SPECIAL DECLARATOR
CONSTINTEGER RFN=65; ! RECORDFORMAT NAME CLASS
CONSTINTEGER ULINE=18; ! CLASS FOR '_'
CONSTINTEGER NULL STRING=401
OWNINTEGER PERMIN = 1; ! PERM/PROG SWITCH
OWNINTEGER DIAG = 0, CONTROL = 0
OWNINTEGER BPT=0; ! CODE BUFFER POINTER
OWNSHORTINTEGERARRAY BUFFER(1 : 401)
CONSTINTEGER MCODE = 38
! %DIAGNOSE FLAGS (2¬¬N)
!
! 0 - GRAMMAR TRACE
! 1 - RECORD USE
! 2 - APP DEFN.
! 3 - RECORD DEFN.
!
ROUTINESPEC FAULT(INTEGER N)
!*********************************************
!* ALMOST THE WHOLE COMPILER ASSUMES A 16 BIT WORD. *
!*********************************************
OWNINTEGER MARK = ' '
OWNINTEGER FILE = 0; ! BEGIN OR EXTERNAL FILE ?
CONSTINTEGER DICT END = 2750
INTEGERARRAY DICT(0:DICT END)
CONSTINTEGER MAX LAB = 80
BYTEINTEGERARRAY LABINF(1 : MAX LAB)
INTEGER LIST, LREALS; ! OPTION FLAGS
INTEGER STATS; ! NUMBER OF STATEMENTS
ownINTEGER CODE = 0; ! OBJECT FILE SIZE
INTEGER LINES; ! LINES ON LISTING PAGE
INTEGER LINENUM; ! CURRENT LINE NUMBER
INTEGER LIT; ! LAST LITERAL POS
INTEGER LIT POS; ! LITERAL TEXT POINTER
INTEGER LIMIT; ! DIGIT SEARCH LIMIT
INTEGER DIGIT; ! CURRECT DIGIT
INTEGER OLD SYM; ! FIRST SYM OF NAME
INTEGER LABEL; ! CURRENT LABEL
INTEGER X; ! CURRENT TAG APP/FORMAT
ownINTEGER SYM = 0; ! CURRENT INPUT SYMBOL
INTEGER ATOM1; ! CURRENT ATOM
INTEGER ATOM2; ! VARIANT OF ATOM1
INTEGER SUBATOM; ! EXTRA INFO
INTEGER LAST; ! LAST ATOM TYPE
INTEGER SS TYPE; ! 0 LABEL, 1 DECLARATION,
! 2 FORMAL PARAMS, 3 STATEMENT
INTEGER SYMTYPE; ! -2:LETTER, -1: DIGIT
! 0:TERMINATOR, 1: OTHER
INTEGER TYPE; ! VARIABLE TYPE WANTED
INTEGER VAR TYPE; ! VARIABLE TYPE FOUND
ownINTEGER POS = 0; ! CURRENT INPUT POSITION
INTEGER ATOM POS; ! CURRENT ATOM START POSN.
INTEGER DUP; ! DUPLICATE FLAG
INTEGER OUT; ! CURRENT OUTPUT STREAM
INTEGER PREFIX, SPREFIX; ! OWN, BYTE, EXTERNAL ETC.
INTEGER CONST INT
INTEGER O TYPE
INTEGER DEC TYPE; ! CURRENT DECLARATOR
OWNINTEGERARRAY CNEST(0 :10); ! STACK FOR CONDITIONS
OWNBYTEINTEGERARRAY LINE(1 : 73); ! INPUT LINE BUFFER
CONSTINTEGER RECLEN = -300; ! -(MAX LENGTH OF ANALYSIS RECORD)
INTEGERARRAY REF, CO, SUB, LOC(RECLEN : -1)
INTEGER SS; ! SOURCE STATEMENT ENTRY
INTEGER A; ! ATOM POINTER
INTEGER P; ! PHRASE POINTER
INTEGER FAULTY; ! FAULT INDICATOR
INTEGER F TYPE; ! TYPE OF FAULT
INTEGER G LIMIT; ! END OF GRAM POINTER
INTEGER T LIMIT; ! MAX EXTENT OF DICTIONARY
INTEGER TMAX; ! CURRENT MAX TAG (FREE)
INTEGER T BASE; ! FIRST NAME AT CURRENT LEVEL
INTEGER DP; ! END OF CURRENT NAME
INTEGER RELOCATE; ! RELOCATION FOR FORMATS
INTEGER APP
SHORTINTEGERNAME PAPP; ! ==PHRASE(APPEP)
INTEGER EILAB; ! %ELSEIF LABEL
ownINTEGER MARGIN = 0
INTEGER INHIBIT; ! FLAG FOR DECLARATIONS MISPLA
ROUTINE SEND
INTEGER J
RETURN IF BPT <= 0
FAULT(22) IF BPT >= LITPOS
IF FAULTY = 0 START
SELECTOUTPUT(OBJ)
PRINTSYMBOL(BUFFER(J)) FOR J = 1,1,BPT
SELECTOUTPUT(LISTING)
FINISH
BPT=0
END
ROUTINE PUT(INTEGER N)
CODE = CODE+1
SEND IF BPT > 71
BPT=BPT+1; BUFFER(BPT)=N
END
ROUTINE ADDR(INTEGER N)
INTEGER V
V=N//10
ADDR(V) UNLESS V=0
PUT(N-V*10+'0')
END
ROUTINE OP(INTEGER C, A)
PUT(C); ADDR(A)
END
ROUTINE PRINT NAME(INTEGER N)
INTEGER D, FLAG
! ----- 'UNPACK' USES AT LEAST A 30-BIT WORD ----
ROUTINE UNPACK(INTEGER V)
INTEGER J, N, C
CYCLE J = 24,-6,0
C = (V>>J)&63
IF C # 0 START
C = C+32; ! ADD IN 32 REMOVED WHEN PACKING
IF FLAG # 0 START
IF FLAG < 0 THEN PUT(C) ELSE PRINT SYMBOL(C)
FLAG = FLAG+1
FINISH
FINISH
REPEAT
END
IF N < 0 THEN N = -N AND FLAG = -13 ELSE FLAG = 1
D=DICT(N)
UNPACK(DICT(D-2)) FOR D = N-D&255, 1, N-D>>11&3
END
ROUTINE FAULT(INTEGER N)
INTEGER ERROR POS, STREAM, SPACING, pos2
SWITCH FM(-1 : 24)
STREAM = REPORT; SELECTOUTPUT(REPORT)
ATOM POS = DUP IF DUP # 0
ERROR POS = ATOM POS
ERROR POS = 0 IF ERROR POS = POS AND N > 1
FAULTY=FAULTY+1
SPACING = MARGIN+ERROR POS+8 -2
CYCLE
IF POS > 0 AND (LIST # 0 OR STREAM = REPORT) START
WRITE(LINE NUM, 4) AND SPACE IF STREAM # REPORT
pos2 = POS
CYCLE POS = 1,1,pos2
PRINTSYMBOL('|') IF POS = ERROR POS AND STREAM=REPORT
PRINTSYMBOL(LINE(POS))
REPEAT
SYM=LINE(POS)
FINISH
NEWLINE IF SYM # NL
PRINTSYMBOL('*')
IF STREAM = REPORT START
WRITE(LINE NUM, 4); SPACE
ELSE
SPACE
IF ERROR POS # 0 START
SPACES(SPACING-1); PRINTSTRING("! ")
FINISH
FINISH
->FM(N)
FM(24): PRINTSTRING("COMPILER ERROR!"); ->F
FM(20): PRINTSTRING("TEXT TOO LONG"); ->F
FM(21): PRINTSTRING("TOO MANY NAMES"); ->F
FM(22): PRINTSTRING("TOO MANY LONG NAMES"); ->F
FM(23): PRINTSTRING("PROGRAM TOO COMPLEX"); ->F
FM(18): PRINTSTRING("ACCESS")
FAULTY = FAULTY-1 IF STREAM = REPORT
->F
FM(0): PRINTSTRING("FORM"); ->F
FM(1): PRINTSTRING("ATOM"); ->F
FM(2): PRINTSTRING("TYPE"); ->F
FM(3): PRINTSTRING("NAME"); ->F
FM(4): PRINTSTRING("SIZE"); ->F
FM(5): PRINTSTRING("CONTEXT"); ->F
FM(6): PRINTSTRING("MATCH"); ->F
FM(7): PRINTSTRING("COPY"); ->F
FM(8): PRINTSTRING("SPEC"); ->F
FM(9): PRINTSTRING("%END"); ->MISS
FM(10): PRINTSTRING("%CYCLE"); ->MISS
FM(11): PRINTSTRING("%REPEAT"); ->MISS
FM(12): PRINTSYMBOL('"'); PRINT NAME(X); PRINTSYMBOL('"'); ->MISS
FM(13): PRINTSTRING("%START"); ->MISS
FM(14): PRINTSTRING("%FINISH"); ->MISS
FM(15): PRINTSTRING("ORDER"); ->F
FM(16): PRINTSTRING("BOUNDS"); ->F
FM(17): PRINTSTRING("RESULT")
MISS: PRINTSTRING(" MISSING")
F: NEWLINE
EXIT IF STREAM = LISTING
STREAM = LISTING; SELECTOUTPUT(LISTING)
REPEAT
MARGIN = MARGIN+POS AND SPACES(MARGIN+8) IF SYM # NL
POS = 0; OUT = 0
SIGNAL 0,10 IF N >= 20
END
! ---- 'C GEN' DEPENDS ON A 32-BIT WORD ----
ROUTINE C GEN(INTEGER N)
INTEGER J, M, L
M = N; N = |M|
IF N>>16 = 0 THEN L = 4 ELSE L = 8
PUT('N'); PUT(L+1+'0'); PUT(','); PUT('Y')
PUT( (N>>J)&15+'A' ) FOR J = (L-1)*4, -4, 0
PUT('U') IF M < 0
LIT = CODE
END
INTEGERFN EVAL(INTEGER P)
CONSTBYTEINTEGERARRAY BASIS('V' : 'Z')=3,1,8,4,0
INTEGER N, J, B, S, L, MOD
N=0
RESULT = DICT(-P) IF P < 0
L=BUFFER(P); RESULT=0 IF L=0 OR L=1
B=BUFFER(P-1); RESULT=B IF L < 0
B=BASIS(B)
MOD='A'; MOD=0 IF B=8
CYCLE J=P-2,-1,P-L
S=BUFFER(J)-MOD
IF B=0 THEN N=N*10 ELSE N=N<<B
N=N+S
REPEAT
RESULT=N
END
ROUTINE COMPILE BLOCK(INTEGER LEVEL, BLOCK TYPE, C
INTEGERNAME FPP)
INTEGER J, K, XX, COUNT, ACCESS = 0
INTEGER FP; ! START OF FORMAT
INTEGER FORMAT; ! CURRENT FORMAT POINTER
INTEGER A CHAIN; ! ARRAY CHAIN
INTEGER OLD LABEL
INTEGER APARM, OLD T BASE, OLD T LIMIT
OWNINTEGER SPEC=1
OLD T BASE=T BASE
T BASE=T MAX
OLD T LIMIT=T LIMIT; OLD LABEL = LABEL
INHIBIT = INHIBIT<<1
ROUTINE DEF LAB(INTEGER L)
INHIBIT = INHIBIT!1
PUT(':'); ADDR(L)
ACCESS = 1
END
ROUTINE ANALYSE SS(INTEGER CONT)
INTEGER CLASS; ! CLASS OF ATOM WANTED
INTEGER LIM; ! LOOKUP LIMIT
OWNINTEGER TAG=0; ! CURRENT VAR TAG
OWNINTEGER DELIM = '"'
OWNINTEGER QUOTE=0; ! TEXT MODE FLAG
OWNINTEGER KEY=0; ! SYMBOL DICT KEY
ROUTINE DECLARE IDEN
INTEGER EXTRA, FF
INTEGERNAME FLAG
IF SUBATOM#0 START; ! ALREADY EXISTS
FLAG == DICT(SUBATOM)
TAG=DICT(SUBATOM-1)
IF FLAG&1024#0 START; ! SPEC GIVEN
IF TAG&15=3 START; ! LABEL REF
FLAG=FLAG!!1024 IF DECTYPE=3
RETURN
FINISH
IF DECTYPE = TAG&(¬128) OR DECTYPE=1 START; ! SAME TYPE
IF (7 <= TAG&15 <= 10 AND SPEC > 0) C
OR TAG&15 = 4 OR DECTYPE=1 START; ! VALID REDEFINITION
FLAG = FLAG!!1024; ! REMOVE SPEC BIT
DECTYPE = TAG&(¬128)
RETURN
FINISH
FINISH
FINISH
DUP=ATOM POS IF DUP=0
RETURN IF DECTYPE=0; ! LABEL
FINISH
EXTRA=DP; ! APP + FORMAT
TAG=DECTYPE
FF=0
IF DECTYPE = 0 START
TAG = 3; FF = 1024
ELSE
FF = FF!SPREFIX<<13
FINISH
IF TAG&15 >= 7 START; ! APP NEEDED
FF = FF!1024 IF SSTYPE = 2 AND TAG&15 <= 10
CONST INT = 0
UNLESS 11#TAG&15#13 START
IF SPREFIX=1 OR SPREFIX=2 C
THEN DICT(DP)=APP ELSE START
APARM=1; DICT(DP)=A CHAIN
A CHAIN=DP
FINISH
FINISH ELSE DICT(DP)=0
DP=DP+1; FF=FF!256; ! SET APP BIT
FF=FF!1024 IF SPEC < 0 AND SPREFIX < 3
FINISH
IF TAG&X'70'=X'50' START; ! RECORD
DICT(DP)=FORMAT; DP=DP+1
FF=FF!512; ! SET FORMAT BIT
FINISH
IF TAG&15=6 START; ! SWITCH
DICT(DP)=0
DP=DP+1
FINISH
TAG = TAG!128 IF SPREFIX > 3 OR PERMIN# 0
IF CONST INT # 0 START
DICT(DP) = 0; DP = DP+1
TAG = TAG&X'FFF0'+5
FINISH
EXTRA=DP-EXTRA; ! 1=APP, 2=APP+FORMAT, 0=NEITH
DICT(DP) = TAG; TYPE=TAG>>4&7
DP=DP+1
DICT(DP) = FF!(DP-T MAX-2)!EXTRA<<11
SUBATOM=DP; TMAX=DP+1
X=DP
END
ROUTINE READ SYM
IF SYM<32 START
LINE NUM = LINE NUM+1
ATOM POS = 0; POS = 0; MARGIN = 0
IF LIST = 0 START
WRITE(LINE NUM, 5)
IF QUOTE # 0 THEN PRINT SYMBOL('"') ELSE START
PRINT SYMBOL(MARK); MARK = ' '
FINISH
SPACE
FINISH
SYM TYPE=1
FINISH
CYCLE
CYCLE
READSYMBOL(SYM)
IF SYM = PAGE START
LINES = 0 AND CONTINUE IF QUOTE = 0
LINES = PAGE SIZE
FINISH
PRINTSYMBOL(SYM) IF LIST = 0
POS=POS+1 AND LINE(POS)=SYM UNLESS POS >= 73
RETURN IF QUOTE#0
EXIT IF SYM#' '
SYM TYPE=1
REPEAT
EXIT UNLESS SYM='%'
SYM TYPE=2
REPEAT
IF SYM<32 THEN SYMTYPE=0 AND MARK='+' ELSE START
SYM=SYM-32 IF 'A'+32 <= SYM <= 'Z'+32; ! ...CONVERT LOWER CASE
KEY=KDICT(SYM)
SYM TYPE=KEY&3-2 UNLESS KEY&3=0 AND SYMTYPE=2
FINISH
END
ROUTINE LOOKUP(INTEGER P)
INTEGER OLD, NEW, L, DISP, D, SIZE, FIRST
COUNT=0; SIZE = DP-TMAX+1; FIRST = DICT(T MAX)
WHILE P > LIM CYCLE
COUNT = COUNT-1
P=P-1
D=DICT(P)
DISP=D&255+2
L=D>>11&3; OLD=P-DISP; X=P; P=OLD
IF SIZE+L-DISP=0 AND DICT(OLD) = FIRST START
NEW=T MAX
CYCLE
NEW = NEW+1; OLD = OLD+1
IF NEW=DP START; ! FOUND IT
O TYPE = D>>13
TAG = DICT(X-1)
ATOM2=CMAP(TAG&15); ! FORM -> CLASS
SUB ATOM=X; VAR TYPE=TAG>>4&7
ATOM2 = 66 IF VARTYPE = 0 AND ATOM2 = 68
ATOM1 = ATOM2 AND SUBATOM = -OLD IF ATOM2 = ICONST
IF D&256#0 START; ! SET APP
PAPP=|DICT(OLD)|
IF PAPP=0 START
IF 11 <= TAG&15 <= 12 START
PAPP=PHRASE(ANAPP)
APARM=OLD<<3+1; ! 1 DIMEN
ELSE
F TYPE=8
RETURN IF SPEC < 0
ATOM1=0; ATOM2=0
FINISH
FINISH
OLD=OLD+1
FINISH ELSE PAPP=APP; ! DEFAULT APP
FORMAT=0
IF D&512#0 START
IF ATOM2=RFN THEN FORMAT=SUBATOM ELSE START
FORMAT=DICT(DICT(OLD)-2)
ATOM2=ATOM2+7
FINISH
FINISH
DICT(X-1)=DICT(X-1)!128 UNLESS SPEC < 0
SUBATOM=COUNT IF LIM > T MAX
RETURN
FINISH
EXIT IF DICT(NEW) # DICT(OLD)
REPEAT
FINISH
REPEAT
END
ROUTINE CODE DIGIT
IF LIMIT=0 START; ! MULTI CHAR
DIGIT = SYM
IF DIGIT = '''' START
QUOTE = 0
READSYM
DIGIT = -1 AND RETURN UNLESS SYM = ''''
QUOTE = 1
FINISH
READSYM
ELSE
IF '0' <= SYM <= '9' OR 'A' <= SYM <= 'F' START
IF SYM <= '9' THEN DIGIT = SYM-'0' C
ELSE DIGIT = SYM-'A'+10
IF DIGIT <= LIMIT START
DIGIT = DIGIT+'A'
READ SYM
RETURN
FINISH
FINISH
DIGIT=0; QUOTE=0
IF SYM='''' START
IF LIMIT # 9 START
DIGIT = -1; READSYM
FINISH
FINISH
FINISH
END
ROUTINE CODE ATOM
INTEGER TP
ROUTINE TPUT(INTEGER S)
POS = 0 IF S < 32
FAULT(20) IF TP = TEXT LIMIT
TP = TP+1; BUFFER(LITPOS-TP) = S
END
INTEGERNAME SS
INTEGER DTYPE, XTYPE, SRMOD, SLEN, PREFIX
INTEGER J, K, L, S, LP
CONSTBYTEINTEGERARRAY BASE SYM(1 : 4)= 'X', 'M', 'B', 'K'
CONSTSHORTINTEGERARRAY BASE INF(1:4)=
X'590F',X'5800',X'5701',X'5607'
CONSTSHORTINTEGER SPS=117; ! START OF SPEC SUB
CONSTBYTEINTEGERARRAY SPEC SUB(SPS : 127)=C
8,9,10,7,105,104,25,24,72,73,1
CONSTSHORTINTEGERARRAY P VALUE(0 : 10)=C
0,
X'1827'(2), X'1067', X'0127'(2),X'10A7',
X'00A7',X'2418',X'4418',
X'2218'
CONSTSHORTINTEGERARRAY SATOMS(1 : 12) =
! SPEC, NAME, MAP, MAPSPEC, <NULL>,
X'0035', X'3835', X'3238', X'0032', X'3835',
! ARRAY ARRAYNAME ARRAYSPEC NAMESPEC ARRAYNAMESPEC,
X'0033', X'3835', X'0033', X'3835', X'3835',
! FN, FNSPEC
X'3238', X'0032'
CONSTBYTEINTEGERARRAY SCLASS(1 : 12) =
! SPEC, NAME, MAP, MAPSPEC, <NULL>,
109, 2, 9, 118, 1,
! ARRAY, ARRAYNAME,ARRAYSPEC,NAMESPEC, ARRAYNAMESPEC,
11, 12, 111, 110, 112,
! FN, FNSPEC
8, 117
CONSTINTEGER XSPS = 109
CONSTINTEGERARRAY XMOD(XSPS : 116) = 17,18,27,28,97,98,107,108
LP=LIT POS
ATOM POS=POS; LAST=ATOM1
IF QUOTE#0 START; ! CONTINUATION OF STRING CONST
TP=0
TPUT(QUOTE>>8); TPUT(QUOTE&255)
CYCLE
READSYM
IF SYM= DELIM START
QUOTE=0
READSYM; EXIT IF SYM# DELIM
QUOTE=1
FINISH
TPUT(SYM)
REPEAT
BUFFER(LIT POS)=TP
LITPOS=LITPOS-TP-1
FINISH
SLEN=0; XTYPE=0; SRMOD=0; PREFIX=0
CYCLE
ATOM1=0; ATOM2=0; SUB ATOM=0; TAG=0
ATOM1=TERMIN AND RETURN IF SYMTYPE=0
IF SYMTYPE=-1 START; ! DIGIT
UNLESS (LAST=0 AND OUT=0) OR LAST=8START
LIMIT=9; DIGIT='Z'
NEW BASE: ATOM1=ICONST; ATOM2 = ICONST
CYCLE
LIT POS=LIT POS-1
BUFFER(LIT POS)=DIGIT
CODE DIGIT
IF DIGIT <= 0 START
IF LIMIT = 9 AND SYM = '.' AND ATOM1 = ICONST START
DIGIT = '.'
ATOM1 = RCONST; ATOM2 = RCONST
LP = LP-1
READ SYM
ELSE
ATOM1=0 IF LIMIT#9 AND DIGIT=0
BUFFER(LP)=LP-LITPOS
LIT POS=LIT POS-1
SUBATOM=LP
FAULT(23) IF LITPOS <= 0
RETURN
FINISH
FINISH
REPEAT
FINISH
FINISH
IF SYM TYPE < 0 START; ! LETTER
DP=T MAX
OLD SYM=SYM
! ---- THE FOLLOWING PACKING ROUTINE IS WORD-LENGTH DEPENDENT BUT CAN
! BE MODIFIED WITH NO OTHER SIDE-EFFECTS PROVIDED COMPLEMENTARY
! ALTERATIONS ARE MADE TO 'UNPACK' IN ROUTINE 'PRINT NAME' ----
CYCLE
SS == DICT(DP)
SS = SYM-32
READ SYM; EXIT IF SYM TYPE >= 0
OLD SYM=0
SS = (SS<<6) + (SYM-32)
READ SYM; EXIT IF SYM TYPE >= 0
SS = (SS<<6) + (SYM-32)
READ SYM; EXIT IF SYM TYPE >= 0
SS = (SS<<6) + (SYM-32)
READ SYM; EXIT IF SYM TYPE >= 0
SS = (SS<<6) + (SYM-32)
READ SYM; EXIT IF SYM TYPE >= 0
DP=DP+1
REPEAT
IF SYM='''' AND OLD SYM # 0 START
DELIM = ''''
CYCLE J=1,1,4
IF OLD SYM=BASE SYM(J) START
QUOTE = 1
K=BASE INF(J)
DIGIT=K>>8; LIMIT=K&255
READSYM
-> NEW BASE
FINISH
REPEAT
FINISH
DP=DP+1
FAULT(21) IF DP >= T LIMIT
ATOM1=IDENT; ATOM2=IDENT
LIM=T BASE; LOOKUP(T MAX)
RETURN
FINISH
IF SYM='''' OR SYM = '"' START
DELIM = SYM
QUOTE=1; ! INTO TEXT MODE
ATOM1=SCONST; ! SYMBOL, OR
ATOM2=ICONST; ! STRING
READSYM; SUB ATOM=SYM; ! FIRST CHAR
QUOTE=0 IF SUBATOM=DELIM
READSYM
IF SUBATOM=DELIM START; ! ' ' FOUND
IF SYM#DELIM START; ! NULL SYMBOL OR STRING
SUB ATOM=NULL STRING; RETURN
FINISH
! ' ' ' FOUND
QUOTE=1
READSYM; ! '' -> '
FINISH
IF SYM=DELIM START; ! FOUND DELIM %OR '?'
QUOTE=0
READ SYM; ! SKIP QUOTE
IF SYM#DELIM START
LITPOS=LITPOS-2
BUFFER(LITPOS+2)=-1
BUFFER(LITPOS+1)=SUBATOM
SUBATOM=LITPOS+2
RETURN
FINISH
FINISH
QUOTE=SUBATOM<<8+SYM; ! PRESERVE SYMBOLS
ATOM2=SCONST; ! IT MUST BE A STRING
SUBATOM=LITPOS
RETURN
FINISH
DP=KEY>>2; ! INDEX INTO DICT
READ SYM; ! GET NEXT SYMBOL
CYCLE
S=KDICT(DP)
EXIT IF S&X'4000'#0; ! END OF LIST MARKER
IF S&127#SYM OR SYMTYPE < 0 START
ATOM POS=POS AND RETURN IF S >= 0
DP=DP+1; ! ONTO ALTERNATIVE
ELSE
K = S>>7&127; READ SYM
IF S > 0 START
IF K # 0 START
ATOM POS = POS AND RETURN IF K#SYM OR SYMTYPE<0
READ SYM
FINISH
K = 1
FINISH
DP = DP+K
FINISH
REPEAT
ATOM1=S&63; ! PICK OFF CLASS
SUB ATOM=S>>6&255
EXIT IF ATOM1#0
L=P VALUE(SUBATOM)
IF L#0 START
RETURN IF PREFIX&L&63 # 0 OR (LAST # 0 AND L&1 # 0)
PREFIX=PREFIX!L>>6
XTYPE=SUBATOM IF SUBATOM <= 7
FINISH
ATOM POS=POS
REPEAT; ! ROUND FOR ANOTHER
ATOM2=KDICT(DP+1)&63 IF S < 0; ! VARIANT
IF ATOM1=STRING OR ATOM1=RECORD START
DTYPE=ATOM1
CODE ATOM
IF DTYPE=STRING START
ATOM1=0 AND RETURN UNLESS ATOM1=ICONST
SLEN=EVAL(SUBATOM); ! STRING LENGTH
UNLESS 0 < SLEN <= TEXT LIMIT START
ATOM1=0; F TYPE=4
RETURN
FINISH
SRMOD=X'40'; ! TYPE FOR STRING
ELSE
IF ATOM2=IDENT START
LIM=GLOBAL; LOOKUP(T BASE)
FINISH
UNLESS ATOM2 = RFN START
F TYPE = 3
ATOM1 = 0; ATOM2 = 0
RETURN
FINISH
SRMOD=X'50'; ! TYPE FOR RECORD
FINISH
CODE ATOM
ATOM1=0 AND RETURN IF ATOM1#RB
IF SYM TYPE=2 START; ! KEYWORD FOLLOWS
CODE ATOM
IF ATOM1 # SPECIAL AND ATOM2 # SPECIAL START
ATOM1 = 0; ATOM2 = 0; RETURN
FINISH
SUBATOM = 1 IF SUBATOM = 127; ! SPEC
FINISH ELSE SUBATOM=5; ! NULL SPECIAL
ATOM1=0 AND RETURN C
IF DTYPE=RECORD AND SUBATOM >= 11
K=SATOMS(SUBATOM)
ATOM1=K&255; ATOM2=K>>8&255
SUBATOM=SCLASS(SUBATOM)
ELSE
UNLESS PRE1 <= ATOM1 <= PRE2 START
ATOM1=0 IF PREFIX#0
RETURN
FINISH
FINISH
IF SUBATOM >= SPS START
SPEC = -1; SUBATOM = SPEC SUB(SUBATOM)
ELSE IF SUBATOM >= XSPS
IF XTYPE # 6 START
ATOM1 = 0; ATOM2 = 0; RETURN
FINISH
XTYPE = 3; ! EXTRINSIC!!
SUBATOM = XMOD(SUBATOM)
SRMOD = SRMOD-X'10' IF SRMOD # 0
FINISH
IF PREFIX&64#0 START; ! OWN DATA
UNLESS ATOM1 = OWN1 OR ATOM1 = OWN2 START; ! NON-DATA
IF XTYPE <= 3 START; ! CONSTROUTINE ?
ATOM1 = 0; RETURN
FINISH
ELSE
ATOM1=ATOM1+1; ! ONTO '%OWN' VARIANT
OUT=(SUB ATOM+SRMOD)>>4
IF SUBATOM&1 = 0 START; ! CONSTNAME ?
OUT = 1; ! ADDRESSES ARE INTEGERS
ELSE
CONST INT = 1 IF XTYPE = 2 C
AND (SUBATOM+SRMOD)&X'70' <= X'30'
FINISH
OUT = 15 IF XTYPE = 3; ! DON'T INITIALIZE EXTRINSICS
FINISH
FINISH
SUBATOM=SUBATOM+LREALS IF SUBATOM&X'70'=X'60'
SUBATOM=SUBATOM+SLEN<<8+SRMOD+(PREFIX>>3&X'70')
DEC TYPE=SUBATOM
SPREFIX=XTYPE
PREFIX=0
END
!*************************************************************
!* DEC TYPE: <EXT><EXTR><CONST><OWN><DYN><SYS><FLAG1><FLAG2> *
!*************************************************************
INTEGERFN GAPP
CONSTINTEGER PSEP = 129, PCALL = 130
INTEGER L, P, TYPE, NEXT, C
INTEGERFN CLASS(INTEGER T)
CONSTBYTEINTEGERARRAY EXPS(0 : 7)=0,147(3),140,0,146(2)
CONSTBYTEINTEGERARRAY PARM MAP(0 : 15)=0,0,137,0,0,0,0,122,
176,177,123,0,159,0,0,0
CONSTBYTEINTEGERARRAY TMOD(0:7) = 0,8(3),4,0,9,9
TYPE = T>>4
TYPE = TMOD(TYPE) AND RESULT = EXPS(T>>4) IF T&15 = 1; ! EXPRN
TYPE = 10 IF TYPE = 0
RESULT=PARM MAP(T&15); ! CORRECT CLASS FOR NAMES
END
ROUTINE SET GCELL(INTEGER C, GC, LEN)
C = C<<9; C = C+L UNLESS GC = PCALL
WHILE L#GLIMIT CYCLE
L=L+1
RETURN IF GRAM(L)=C AND GCLASS(L) = GC C
AND (TAG&X'70'#X'40' OR GRAM(L-1)=LEN)
REPEAT
IF TAG&X'70'=X'40' START
GLIMIT=GLIMIT+1; GRAM(GLIMIT)=LEN; ! SET STRING LE
FINISH
GLIMIT=GLIMIT+1; GRAM(GLIMIT)=C; GCLASS(GLIMIT) = GC
L=GLIMIT
IF DIAG&4 # 0 START
PRINTSTRING("SET"); WRITE(L, 3)
WRITE(C, 3); WRITE(GC, 3); WRITE(LEN, 3)
NEWLINE
FINISH
END
RESULT = NULL IF TBASE=TMAX
L = GBASE; P = TMAX
SET GCELL(0, PCALL, 0)
CYCLE
P = P-1
NEXT = P-DICT(P)&255-2
TAG = DICT(P-1)
C = CLASS(TAG&127)
SET GCELL(TYPE, C, TAG>>8&255)
EXIT IF NEXT <= TBASE
P = NEXT
SET GCELL(0, PSEP, 0)
REPEAT
SET GCELL(0, LB, 0)
FAULT(23) IF GLIMIT >= GMAX
RESULT=L
END
ROUTINE HEX(INTEGER N)
INTEGER J,K
CYCLE J = 1, 1, 4
K = N>>12; N = N<<4
IF K > 9 THEN K = K-10+'A' ELSE K = K+'0'
PRINTSYMBOL(K)
REPEAT
END
ROUTINE ANALYSE(INTEGER G)
SWITCH DIR(86:102)
INTEGER EXTEND, AMBIG, SUB LOCK, DOWN LOCK
INTEGER J, K, L, N, A1, NODE, NEW TYPE, T
ROUTINE REORDER
INTEGERNAME X, Y
INTEGER R
K=0
WHILE N < 0 CYCLE
R=REF(N); J=CO(N)
IF LOC(N)&X'FF' > TRANSP START; ! DROP TRANSPARENT
X == K; R=R&X'6000'; ! PICK OFF ORDER
WHILE X#0 CYCLE
Y == REF(X)
EXIT IF Y&X'6000' <= R
Y=Y-X'2000'; ! DECREMENT ORDERING CODE
X == CO(X); ! ON DOWN THE CHAIN
REPEAT
CO(N)=X; X=N
FINISH
N=J
REPEAT
IF DIAG&8 # 0 START
PRINTSTRING("REORDER N ="); WRITE(N, 3); NEWLINE
FINISH
END
ROUTINE SHOW(INTEGER Z)
WRITE(Z, 3)
PRINTSTRING(" [")
HEX(REF(Z))
SPACE; HEX(CO(Z))
SPACE; HEX(SUB(Z))
SPACE; HEX(LOC(Z))
PRINTSYMBOL(']'); NEWLINE
END
EXTEND=0; SUB LOCK = 0; DOWN LOCK = 0
A=0; A1=0; N=0; NODE=0
AMBIG=0
P = RECLEN
L1: J=GRAM(G); K = GCLASS(G); ->EOP IF K = 0
NEW TYPE = J>>9&15
NEW TYPE = TYPE IF NEW TYPE = 0
IF DIAG&1 # 0 START
WRITE(G, 4); WRITE(K, 3)
WRITE(ATOM1, 3); WRITE(ATOM2, 3); WRITE(SUBATOM, 3)
WRITE(TYPE, 2); WRITE(FORMAT, 3)
NEWLINE
FINISH
IF K >= PHRASES START; ! PHRASE
P=P+1; F TYPE=4 AND -> ERROR IF P=A
REF(P)=J; CO(P)=N
LOC(P)=TYPE<<8+K
TYPE=NEW TYPE
SHOW(P) IF DIAG&8 # 0
N=-P
G=PHRASE(K)
-> L1
FINISH
CLASS=K
CLASS=ATOMIC(CLASS) IF CLASS >= EQUIVS
->DIR(CLASS) IF CLASS >= DIRECTIVES
IF ATOM2=IDENT AND (DEF1 <= CLASS <= DEF2 OR CLASS = ICONST)START
LIM=GLOBAL; LOOKUP(T BASE)
FINISH
IF SET1 <= CLASS <= SET2 AND C
(OTYPE#2 OR ATOM2=68 OR ATOM2=70) START
CLASS = CLASS+7; TYPE = TAG>>4&7
FINISH
NEW TYPE=TYPE
IF CLASS=ATOM1 OR CLASS=ATOM2 START
IF CLASS = IDENT START
DECLARE IDEN
TYPE = 15 IF NEWTYPE = 15
FINISH
IF CHECK1 <= CLASS <= CHECK2 START
IF VAR TYPE#TYPE START
UNLESS VARTYPE <= 3 AND (TYPE=8 OR TYPE=9) START
UNLESS VARTYPE >= 6 AND TYPE=9 START
UNLESS TYPE = 10 START
F TYPE = 2; ->ALT
FINISH
FINISH
FINISH
FINISH
F TYPE=0
FINISH
ENTRY: A=A-1; F TYPE=4 AND -> ERROR IF A=P
REF(A)=J; CO(A)=N
LOC(A)=TYPE<<8+K
TYPE=NEW TYPE
SUB(A)=SUBATOM
SHOW(A) IF DIAG&8 # 0
->DONE IF J&511 = 511; ! END OF SS
-> NEXT IF AMBIG=0; ! NOT AMBIGUOUS
G=AMBIG; AMBIG=0; -> L1
FINISH
ALT: G=G+1; -> L1 IF J < 0; ! TRY ALTERNATIVE
NEXT: IF NODE=A1 START; ! LAST NODE FOR THIS ATOM
EXTEND=0; SUB LOCK=0; DOWN LOCK = 0
-> ERROR IF NODE=A; ! NO NEW NODES
A1=A
CODE ATOM IF CLASS < DIRECTIVES; ! GET NEXT ATOM
FINISH
NODE=NODE-1; N=NODE
IF EXTEND#0 START
K = LOC(N)&255
IF K # 0 START
J=REF(N)
TYPE = LOC(N)>>8
N=CO(N); ! WELL ?
-> ENTRY
FINISH
FINISH
-> SKIP
EOP: REORDER
N=-N; SUB(N)=K
SKIP: ! ON DOWN CHAIN
G=REF(N)&511; -> EOP IF G=0
TYPE=LOC(N)>>8
-> L1
DIR(89): ! %COLON
-> ERROR UNLESS ATOM1=3; ! LOOK FOR COLON
DONE: N=A; REORDER; SS=K
RETURN IF DUP=0
F TYPE=7
ERROR:
QUOTE=0 AND READSYM WHILE NL#SYM#';'
IF F TYPE=0 START
IF ATOM1=IDENT AND LIM=GLOBAL START
F TYPE=3
ELSE IF ATOM1 = 0
FTYPE = 1
ELSE IF SCONST <= ATOM1 <= RCONST
FTYPE = 2
FTYPE = 5 IF TYPE = 15
FINISH
FINISH
FAULT(F TYPE)
QUOTE=0; SYMTYPE=0; DEC TYPE=0
PREFIX=0; SPREFIX=0; CONST INT = 0
RETURN
DIR(86): ! %INT
-> ALT IF TYPE > 3 AND TYPE#8; ! NOT INTEGER
DCONT:
G = J&511
-> EOP IF G=0; ! END OF PHRASE
-> L1
DIR(87): ! %REAL
-> ALT IF TYPE < 6 OR TYPE=8 OR TYPE = 15; ! NOT REAL
-> DCONT
DIR(88): ! %STR
-> ALT IF TYPE#4; ! NOT STRING
-> DCONT
DIR(90): ! %FN
IF BLOCK TYPE&15 # 8 START; ! NOT A FUNCTION
->DALT IF DIAG >= 0 OR BLOCKTYPE&15 # 9; ! OR A FUNNY MAP
FINISH
TYPE=BLOCK TYPE>>4&7
IF TYPE <= 3 THEN TYPE=8 ELSE START
TYPE=9 IF TYPE >= 6
FINISH
-> DCONT
DIR(91): ! %M
-> DALT IF BLOCK TYPE&15#9; ! NOT A MAP
TYPE=BLOCK TYPE>>4&7
-> DCONT
DIR(94): ! %SUB
-> DCONT IF SUB LOCK#0
-> ALT UNLESS ATOM1=U LINE
-> ERROR IF SYMTYPE # -2
L=FORMAT
CODE ATOM
ATOM2=0
F TYPE=8 AND -> ERROR IF L <= 0
LIM=DICT(L); ! ONTO THE END
LOOKUP(L); ! LOOK FOR SUBNAME
F TYPE=3 AND -> ERROR IF ATOM2=0
! NOT FOUND
SUB LOCK=1
-> DCONT
DIR(95): ! %APP
-> ALT UNLESS ATOM1=LB
-> DCONT
DIR(97): ! %SETPLUS
PAPP = APP
L = PHRASE(152+APARM&7)
DICT(APARM>>3)=L IF APARM&X'FFF8'#0
WHILE A CHAIN#0 CYCLE
T=A CHAIN; A CHAIN=DICT(T); DICT(T)=L
REPEAT
! SET APP FOR ARRAY
-> DCONT
DIR(98): ! %PLUS
F TYPE=4 AND -> ERROR IF APARM&7=6
APARM=APARM+1
-> DCONT
DIR(99): ! %AMBIG
AMBIG=J&511
-> ALT
DIR(100): ! %DUMMY
EXTEND = 1 IF A1 # A
A1 = A1-1; K = 0
->ENTRY
DIR(101): ! %LUP
DICT(T LIMIT-2)=APARM
DICT(T LIMIT-1)=FORMAT
->DCONT UNLESS NODE = A1
TLIMIT = TLIMIT-2; FAULT(23) IF T LIMIT <= T MAX
-> DCONT
DIR(102): ! %LDOWN
->DCONT IF DOWN LOCK # 0
DOWN LOCK = 1
APARM=DICT(T LIMIT )
FORMAT=DICT(T LIMIT+1)
T LIMIT = T LIMIT+2 IF NODE = A1
-> D CONT
DALT: F TYPE=5; ! CONTEXT
-> ALT
END; ! OF ANALYSE
FORMAT=0; APARM=0; RELOCATE=0
LITPOS=400
SS=0; DEC TYPE=0; DUP=0; CONST INT = 0
PREFIX=0; SPREFIX=0
A CHAIN=0; F TYPE=0; MARK = ' '
IF CONT=0 START
MARGIN = MARGIN+POS
IF SYM TYPE=0 START
POS=0; READ SYM
FINISH
ATOM1=0
IF SYMTYPE=0 OR SYM='!' START
SKIP: READSYM WHILE SYMTYPE#0
RETURN
FINISH
CODE ATOM; -> SKIP IF ATOM1=COMMENT
STATS=STATS+1
OP('O',LINE NUM) IF PERMIN = 0; ! DUMP LINE NUMBER
IF ATOM1 = MCODE AND SUBATOM = 1 START
CODE ATOM
IF ATOM2 = IDENT START
LIM = GLOBAL; LOOKUP(T BASE)
FINISH
FAULT(0) IF ATOM2 # ICONST
CGEN(EVAL(SUBATOM)); PUT('P')
RETURN
FINISH
TYPE=0
IF ATOM1=IDENT AND (SYM=':' OR ATOM2=SWITCH) START
DEC TYPE=3
SS TYPE=0; ANALYSE(PHRASE(SS0));! LABEL
ELSE
IF DEC TYPE#0 OR OUT#0 START
TYPE=OUT
SS TYPE=1; ANALYSE(PHRASE(SS1));! DECLARATION
ELSE
SS TYPE=3; ANALYSE(PHRASE(SS3));! STATEMENT
FINISH
FINISH
RETURN
FINISH
CODE ATOM
IF CONT > 0 START; ! APP
SS TYPE=2; ANALYSE(PHRASE(SS2)); ! FORMAL PARAMETER
J=GAPP
FAULT(6) IF 0#|FPP|#J
FPP=J*SPEC
ELSE; ! RECORDFORMAT
FP=TMAX; ! REMEMBER START OF NAMES
SS TYPE=4; ANALYSE(PHRASE(SS4))
IF SS#0 AND TMAX > FP START
J=T LIMIT+TBASE-TMAX-1
FAULT(21) IF J <= TMAX
FPP=T LIMIT-1; ! FILL IN FORMAT REFERENCE
DICT(FPP)=J; ! END OF FORMAT
RELOCATE=J-FP
CYCLE K=J,1,FPP-1
DICT(K)=DICT(FP)
FP=FP+1
REPEAT
T LIMIT=J
FINISH
FINISH
END; ! ANALYSE SS
ROUTINE COMPILE SS
CONSTBYTEINTEGERARRAY RCOMP(33:40)=34,33,35,36,38,37,39,40
CONSTBYTEINTEGERARRAY COMP(33:40)='>','<','=','#',')','(',116,107
! 116 = LOWER CASE 'T', 107 = LOWER CASE 'K'
CONSTBYTEINTEGERARRAY CON OP(82 : 84)='''', 'N', 'D'
CONSTBYTEINTEGERARRAY OPCODE(1:10)='*','/','&','!',
'%','[',']','.','¬',120
! 120 = LOWER CASE 'X'
SWITCH C(1 : 130), D(50 : 57)
BYTEINTEGERNAME MM
INTEGERNAME M
INTEGER L, DIM, K
OWNINTEGER OWN DEF=0
OWNINTEGER BP SIZE=0
INTEGER CALL PENDING, PRED PENDING, PRED OP
INTEGER GLOBAL NOT, LOCAL NOT
INTEGER CLAST, CMOD, OPS, BIT, CLEVEL, DOUBLE
INTEGER PLAB, LOOP LAB, ULAB, CONDS, ELSE
INTEGER LIT1, LIT2, STARTT
INTEGER NEXT, CLASS, DCLASS, LINK
ROUTINE AOP(INTEGER C, A)
PUT(C)
IF A < 0 START
A = -A; PUT('-')
ELSE
A = A//2
FINISH
ADDR(A)
END
ROUTINE EXTRA(INTEGER N)
PUT(','); ADDR(N)
END
ROUTINE DEF(INTEGER N)
INTEGER K
N=N+RELOCATE
AOP('$',N); PRINT NAME(-N)
K=DICT(N-1)
EXTRA(K&127); ! TYPE!FORM
EXTRA(K>>8&255); ! MAX STRING LENGTH
EXTRA(DICT(N)>>13&7); ! OTYPE
! RECORD
AOP(',',DICT(N-2)) IF K&X'70'=X'50' AND K&127#84
END
ROUTINE CALL
INTEGER P
CALL PENDING = 1
AOP('@',X)
P = X
P = P-1 IF DICT(X)&512 # 0
IF |DICT(P-2)| = NULL START
PUT('E'); CALL PENDING = 0
ELSE
PRED PENDING = PRED PENDING<<1
FINISH
END
ROUTINE SET SIZE
BP SIZE=LIT1-LIT2+1
IF BPSIZE <= 0 START
ATOM POS=0; FAULT(4)
BP SIZE=1
FINISH
PUT('B'+32); ADDR(BP SIZE)
END
ROUTINE POP LAB(INTEGER MODE)
INTEGER L
IF LABEL > OLD LABEL START
L = LAB INF(LABEL>>2)
IF (L!!MODE)&1 # 0 START
LABEL = LABEL-4; P LAB = LABEL
EILAB = PLAB+1 IF L&4 # 0
P LAB = P LAB+1 IF L&3 = 3
PLAB = 0 IF L&8 = 0; ! NO EXIT CONDITION
RETURN
FINISH
FINISH
IF MODE = 0 THEN MODE = 13 ELSE MODE = 10
FAULT(MODE); ACCESS = 1
END
ROUTINE C END
INTEGER L, T,LIM, FLAG
IF X=88 START; ! ENDOFPERM
STATS=0; LINE NUM=0
LIST=LIST&1; DEC TYPE=0
SELECTINPUT(PROG); ! ONTO SOURCE PROGRAM
PERMIN = 0; ! SHOW NOT IN PERM
RETURN
FINISH
ATOM POS = 0; FLAG = SYM
IF LEVEL = 1 AND X # EOP AND FILE = 2 START
DEC TYPE = EOP; FAULT(5)
FINISH
LIM = T BASE
IF X=EOP OR X=EOF START; ! EOP
X = X-EOF; ! EOF -> 0, EOP -> L1
FAULT(5) UNLESS X = LEVEL
PUT(';')
WHILE LEVEL > 1 CYCLE
FAULT(9)
LEVEL=LEVEL-1
REPEAT
LIM = GLOBAL; ! GIVE UNUSED FOR GLOBALS
ELSE
FAULT(5) IF LEVEL <= 1 AND FILE = 2
PUT(';')
FINISH
WHILE LABEL > OLD LABEL CYCLE
L=LABINF(LABEL>>2)
IF L&7=2 THEN L=11 ELSE L=14
LABEL=LABEL-4
FAULT(L)
REPEAT
FAULT(17) IF ACCESS # 0 AND 8 <= BLOCKTYPE&15 <= 10
X=T MAX-1
WHILE X > LIM CYCLE
T=DICT(X)
IF DICT(X-1)&128=0=LIST AND T&X'400' = 0 START
IF CONTROL&X'1000' = 0 START
IF FLAG # NL START
MARGIN = MARGIN+POS
NEWLINE
FLAG = 0
FINISH
PRINTSTRING("? ")
PRINT NAME(X)
PRINTSTRING(" UNUSED
")
FINISH
FINISH
FAULT(12) IF T&X'400'#0
X=X-T&255-3
REPEAT
printsymbol(11)
SPACES(MARGIN+8) IF FLAG = 0
END
FAULT(24) IF LABEL < 4 OR LABEL > MAX LAB<<2
IF ACCESS = 0 AND SSTYPE = 3 AND 33 # LOC(-1)&255 # 34 START
FAULT(18) IF CONTROL&X'1000' = 0; ACCESS = 1
FINISH
CONDS=0; DIM=0; PRED PENDING = 0; PRED OP = 0
STARTT=0; ! DEFAULT TO CYCLE
PLAB=0; ULAB=0; LOOP LAB=0; ELSE = 0; EILAB = 0
LIT1=0; LIT2=0
NEXT=SS; LINK=0
LIT=0
DCLASS = 0
TOP: CYCLE
X=SUB(NEXT)
EXIT UNLESS X < 0 AND NEXT <= P
IF CO(NEXT)#0 START
SUB(NEXT)=LINK; LINK=NEXT
FINISH
NEXT=X
REPEAT
CLASS=LOC(NEXT)&255
IF DIAG&2 # 0 START
PRINTSTRING("C ="); WRITE(CLASS, 3)
PRINTSTRING(" X ="); WRITE(X, 3)
PRINTSTRING(" NEXT ="); WRITE(NEXT, 3)
NEWLINE
FINISH
NEXT=CO(NEXT)
-> C(X) IF CLASS < PRE1
-> CONT IF CLASS=APPEP
-> C(CLASS) UNLESS CLASS=IDENT
-> D(DCLASS)
ACONT: ACCESS = 0
C(112): ! %AND (UI)
CONT: CYCLE
->TOP IF NEXT#0
->RETURN IF LINK=0
NEXT=CO(LINK); LINK=SUB(LINK)
REPEAT
C(9): ! '¬'
IF CLASS = 45 START; ! LOGICAL NOT
LIT1=¬LIT1 AND LIT = LIT+1 IF LIT=CODE
ELSE
X = 10
FINISH
C(1): ! '*'
C(2): ! '/'
C(3): ! '&'
C(4): ! '!'
C(5): ! '!!'
C(6): ! '<<'
C(7): ! '>>'
C(8): ! '.'
PUT(OPCODE(X)); -> CONT
C(46):PUT('Q'); ->CONT;! REAL DIVIDE
C(10): PUT('M'); -> ACONT; ! %RESULT==
C(11): PUT('+') UNLESS CLASS=44; ! UNARY PLUS
-> CONT
C(12): IF CLASS#43 THEN PUT('-') ELSE START
LIT1=-LIT1 AND LIT = LIT+1 IF LIT=CODE
PUT('U')
FINISH
-> CONT
C(13): PUT('X'); ->CONT; ! ¬¬
C(14): PUT('Y'+32); DIAG = LIT1; -> CONT; ! DIAG
C(15): PUT('Z'+32); CONTROL = LIT1; -> CONT; ! CONTROL
C(16): PUT('V'); -> ACONT; ! %RESULT=
C(17): IF BLOCKTYPE # 7 START
FAULT(5) UNLESS DIAG < 0 AND BLOCKTYPE&15 = 8
FINISH
PUT('R'); -> ACONT; ! RETURN
C(18): PUT('T'); -> PREDT; ! TRUE
C(19): PUT('K'); ! FALSE
PREDT: FAULT(5) UNLESS BLOCKTYPE = 10
->ACONT
C(20): PUT(101); -> ACONT; ! %SIGNAL
C(44):LIT2 = 0; ! %ON %EVENT
FAULT(15) IF INHIBIT&1 # 0
INHIBIT = INHIBIT!1
CYCLE
EXIT IF NEXT = 0
X = SUB(NEXT)
EXIT IF (X < 0 AND NEXT <= P) OR LOC(NEXT)&255 # ICONST
NEXT = CO(NEXT)
LIT1 = EVAL(X)
FAULT(16) AND LIT1 = 0 UNLESS 0 <= LIT1 <= 15
LIT2 = LIT2!(1<<LIT1)
REPEAT
FAULT(16) IF LIT2 = 0
STARTT = 1+8
OP(111, LIT2); OP(',', LABEL)
->CONT
C(21): PUT('S'+32); -> ACONT; ! %STOP
C(22): LIST=LIST&2; -> CONT; ! %LIST
C(23): LIST=LIST!1; -> CONT; ! %ENDOFLIST
C(24): LREALS=16; -> CONT; ! %REALSLONG
C(25): LREALS=0; -> CONT; ! %REALSNORMAL
C(109):PUT('S'); -> CONT; ! 'EQ'
C(45): PUT('Z'); -> CONT; ! EQEQ
C(26): ! EXIT
C(27): ! CONTINUE
L=LABEL
WHILE L > OLD LABEL CYCLE
IF LABINF(L>>2)&7=2 START; ! CYCLE FOUND
IF X = 26 START
MM == LABINF(L>>2)
MM = MM!8
L = L-2; X = 'F'
ELSE
X = 113
FINISH
OP(X,L-2)
-> ACONT
FINISH
L=L-4
REPEAT
FAULT(10); ->CONT
C(31): ULAB=LABEL+3; OP(117,ULAB); ! UNTIL
C(30): LOOP LAB=LABEL+2; DEF LAB(LOOP LAB);! WHILE
C(28): ! IF
C(29): ! UNLESS
EILAB = PLAB IF ELSE # 0
INHIBIT = INHIBIT!1
CONDS=1; DOUBLE=0
STARTT=(X-26)>>1+8
GLOBAL NOT=0; C LAST=1
CMOD=0; CLEVEL=1; OPS=1
LOCAL NOT=X&1; P LAB=LABEL
CNEST(0)=P LAB; CNEST(1)=P LAB
-> CONT
C(32): LOCAL NOT=LOCAL NOT!!1; -> CONT; ! %NOT
C(79):
CALL; ! P
PRED OP = 4
->PAC IF CALL PENDING = 0
PRED PENDING = PRED PENDING!2
->CONT
C(108): PUT('C'); ! ACOMP
PAC: X=35; ! '='
CONDS = CONDS-1
-> COP
C(33): ! <
C(34): ! >
C(35): ! =
C(36): ! #
C(37): ! <=
C(38): ! >=
CONDS=CONDS-1
IF NEXT#0 START; ! DOUBLE SIDED
PUT(126); ! SHOW DOUBLE SIDED
DOUBLE=1; BIT=1; ! PSEUDO %AND
-> ANDOP
FINISH
IF DOUBLE # 0 START
DOUBLE = 0; X = RCOMP(X)
FINISH
PUT('?')
COP: LOCAL NOT=(LOCAL NOT!!GLOBAL NOT)&1
X=X!!7 IF LOCAL NOT#0
IF CLAST#0 START
X=X!!7 IF OPS&1#0
OP(COMP(X+PRED OP),CNEST(CLEVEL))
ELSE
WHILE CMOD&1#0 CYCLE
CMOD=CMOD>>1; OPS=OPS>>1
CLEVEL=CLEVEL-1
GLOBAL NOT=GLOBAL NOT>>1
REPEAT
CMOD=CMOD>>1; OPS=OPS>>1; CLEVEL=CLEVEL-1
GLOBAL NOT=GLOBAL NOT>>1
X=X!!7 IF OPS&1#0
OP(COMP(X+PRED OP),CNEST(CLEVEL))
DEF LAB(LABEL) UNLESS LABEL=CNEST(CLEVEL)
LABEL=CNEST(CLEVEL)
FINISH
CLAST=0; LOCAL NOT=0; PRED OP = 0
DEF LAB(ULAB) IF CONDS <= 0 AND ULAB#0
PUT('"') IF DOUBLE # 0
-> CONT
C(39): ! AND
C(40): ! OR
BIT=X&1; ! 1=AND, 0=OR
ANDOP: CONDS=CONDS+1
LOCAL NOT=(LOCAL NOT!!GLOBAL NOT)&1
BIT=BIT!!LOCAL NOT
IF BIT=OPS&1 START
IF CLAST#0 START
CMOD=CMOD<<1
CNEST(CLEVEL+1)=CNEST(CLEVEL)
CLEVEL=CLEVEL+1
OPS=OPS<<1!BIT
GLOBAL NOT=GLOBAL NOT<<1!LOCAL NOT
FINISH
ELSE
CMOD=CMOD<<1
IF CLAST#0 START
LABEL=LABEL+4
CLEVEL=CLEVEL+1; CNEST(CLEVEL)=LABEL
ELSE
CMOD=CMOD!1
IF OPS>>1&1 = BIT START
L = CNEST(CLEVEL-1)
ELSE
LABEL=LABEL+4; L=LABEL
FINISH
CLEVEL=CLEVEL+1; CNEST(CLEVEL)=L
FINISH
OPS=OPS<<1!BIT
GLOBAL NOT=GLOBAL NOT<<1!LOCAL NOT
FINISH
CLAST=1; LOCAL NOT=0
-> CONT IF DOUBLE=0
-> COP; ! REJOIN CONDITIONS
C(119): ! STARTT
STARTT = 2 AND DEF LAB(LABEL+2) IF STARTT = 0
LABEL = LABEL+4
FAULT(23) IF LABEL>>2 > MAX LAB
LABINF(LABEL>>2) = STARTT+ELSE
LOOP LAB = 0; P LAB = 0; ! LABEL NO LONGER PENDING
ELSE = 0; EILAB = 0
->CONT
C(41): OP('B',LABEL-2); ! REPEAT
ACCESS = 0
C(42): POP LAB(X&1); ->CONT; ! FINISH
C(43): ! ELSE
POP LAB(0) IF P LAB = 0; ! (FINISH) ELSE ...
FAULT(5) AND -> RETURN IF PLAB&1#0
OP('F',PLAB+1) UNLESS ACCESS = 0
DEF LAB(PLAB)
PLAB=PLAB+1
STARTT=3+8; ! SHOW ELSE
ELSE = 4
-> CONT
C(54): OWN DEF=0; OUT=0; ! OWNVTYPE
C(51): ! ATYPE
C(52): ! OWN ATYPE
C(53): ! VTYPE
C(56): ! TYPE
FAULT(15) IF INHIBIT&1 # 0 AND SPEC > 0
C(50): ! RTYPE
C(57): ! SWITCH
DCLASS=CLASS; -> CONT
C(60): ! VSET
C(61): ! NSET
C(67): ! V
C(68): ! N
C(74): ! RECV
C(75): ! RECN
C(122): ! RTP
C(123): ! PP
C(124): ! FNP
C(125): ! MP
C(77): ! RECAN
C(63): ! ANSET
C(70): ! AN
C(62): ! ASET
C(69): ! A
C(76): ! RECA
AOP('@', X); ->CONT
C(65): ! RFN
C(66): ! AFN
-> CONT
C(71): ! M
C(72): ! F
C(73): ! RT
C(78): ! RECORDMAP
C(64): ! MSET
CALL; -> CONT
C(83): LIT2=LIT1; LIT1=EVAL(X); ! 'ICONST'
CGEN(LIT1) AND ->CONT IF X < 0
C(82): ! SCONST
C(84): ! 'RCONST'
L=BUFFER(X)
IF L <= 0 AND CLASS=ICONST START; ! SYMBOL
OP('N',3); L=BUFFER(X-1)
PUT(','); PUT('Z')
X=L//10
PUT(X+'A')
PUT(L-X*10+'A')
ELSE
L=|L|
OP(CONOP(CLASS),L)
IF L > 0 START
integer x2
PUT(',')
x2 = X
CYCLE X=x2-1,-1,x2-L
PUT(BUFFER(X))
REPEAT
FINISH
FINISH
LIT=CODE
-> CONT
C(105):PUT('.'); -> CONT; ! '.'
C(106):PUT('V'+32); -> CONT
C(126):PUT('F'+32); ! COM
STARTT=2+8; ! PSEUDO %CYCLE
P LAB=LABEL; LOOP LAB=P LAB+2
DEF LAB(LOOP LAB)
-> CONT
C(113): ! BSEP
IF SPREFIX=0 THEN DIM=DIM+1 ELSE SET SIZE
-> CONT
C(116): AOP('L',X)
ACCESS = 1
INHIBIT = INHIBIT!1; -> CONT
C(80): INHIBIT = INHIBIT!1; ! SWITCH
AOP('W',X); ->ACONT
C(114):INHIBIT = INHIBIT!1; ! SLAB
ACCESS = 1
AOP('_',X)
L=DICT(X-2); ! POINTER TO TABLE
K=DICT(L); ! LOWER BOUND
FAULT(16) AND ->CONT UNLESS K <= LIT1 <= DICT(L-1)
K=LIT1-K
L=L-K>>4; ! ENTRY POINT
K=1<<(K&15); ! REQUISITE BIT
M == DICT(L-2)
FAULT(7) IF M&K#0
M = M!K
-> CONT
C(81): INHIBIT = INHIBIT!1; ! 'BL'
C(115): AOP('J',X); -> ACONT; ! 'FL'
C(128):LIT1 = BPSIZE IF LIT1 = 0
BPSIZE=BP SIZE-LIT1+1; ! ORB
-> OF IF LIT1 <= 0
-> CONT
C(129):PUT('P'+32); ->CONT; ! PSEP
C(130):PUT('P'+32); PUT('E')
PRED PENDING = PRED PENDING>>1
PRED PENDING = PRED PENDING-1 AND ->PAC IF PRED PENDING&1 # 0
->CONT
C(107): PUT('I'+32); ->CONT; ! ASSEP
C(118): IF DCLASS#54 START; ! OSEP
BP SIZE=BP SIZE-1
IF BP SIZE <= 0 START
OF: ATOM POS=0; FAULT(16)
OUT=0
-> RETURN
FINISH
FINISH
OSEP: PUT('A')
EXTRA(OWN DEF) IF OWN DEF > 1
OWN DEF=0; LIT1 = 0
-> CONT
C(117): BP SIZE=BP SIZE-1 IF OUT#0; ! OWNT
OUT=0
-> OSEP IF BP SIZE=0
BP SIZE=0
-> OF IF BUFFER(BPT)='A' OR LIT = CODE
PUT('I'); ! INDICATE CLEAR
-> CONT
C(110): ! LRB
C(111): ! RRB
-> CONT
C(127):PUT('A'+32); -> CONT
D(54): OWN DEF=OWN DEF+1; ! OWNVTYPE
DICT(X-2) = LIT1 IF CONST INT # 0
-> DDD
D(57): ! SWITCH
IF LIT=CODE THEN START; ! SWITCH DEF
PUT('W'+32)
DICT(X-2)=T LIMIT-1
DICT(TLIMIT-1)=LIT2; ! LOWER BOUND
DICT(TLIMIT-2)=LIT1; ! UPPER BOUND
IF LIT1 < LIT2 START; ! BOUNDS INSIDE-OUT
ATOM POS=0; FAULT(4)
LIT1=LIT2
FINISH
K=LIT1-LIT2+1
K=(K+15)>>4; ! ENTRIES NEEDED
TLIMIT=TLIMIT-K-3
FAULT(23) IF T LIMIT <= TMAX
DICT(L)=0 FOR L = TLIMIT,1,TLIMIT+K
FINISH
D(50): ! RTYPE
OP('F',0) IF DCLASS=50 AND DEC TYPE#84 AND SPEC >= 0 C
AND LEVEL # 0
! JUMP ROUND ROUTINE
D(56): ! TYPE
D(53): ! VTYPE
DDD: DEF(X)
-> CONT
D(51): ! ARRAY DEC
IF DIM#0 START; ! SET UP DOPE VECTOR
OP('D'+32, DIM); DIM = 0
FINISH
DEF(X); PUT('H'+32)
PUT('C'+32) IF DICT(X-1)&15#13; ! NO SPACE FOR FORMATS
-> CONT
D(52): DEF(X); OUT=TYPE; ! OWNARRAY
BPSIZE = 1 IF TYPE = 15; ! EXTRINSICS
->CONT
C(49): ! BEGEND
IF X=15 THEN PUT('H') AND XX=NULL STRING ELSE C END
RETURN:
!
! DEAL WITH LABELS
!
OP('B',LOOP LAB) IF LOOP LAB#0
DEF LAB(EILAB) IF EILAB # 0 AND EILAB # PLAB
DEF LAB(P LAB) IF P LAB#0
END; ! OF COMPILE SS
IF BLOCK TYPE=0 START; ! RECORD FORMAT
ANALYSE SS(-1)
XX=X-2
OP('G', 2)
COMPILE SS IF SS#0
OP('G',2); ! FORMAT END
-> L9
FINISH
IF BLOCKTYPE&15#15 START; ! NOT BEGIN
ANALYSE SS(1); ! FORMAL PARAMETERS
IF SPEC < 0 THEN K = 0 ELSE K = 1
OP('G', K)
COMPILE SS IF SS # 0
OP('G', K)
-> L9 IF K = 0
FINISH
ACCESS = 1
CYCLE
ANALYSE SS(0)
XX=X-2
COMPILE SS IF SS#0
COMPILE BLOCK(0,0,DICT(XX)) IF DEC TYPE=84
EXIT IF DECTYPE=85 OR DEC TYPE=EOP C
OR DEC TYPE=EOF
IF 7 <= DECTYPE&15 <= 10 OR DECTYPE=15 START
XX=XX-1 IF DECTYPE&X'70'=X'50'; ! RECORDMAPS
IF LEVEL = 0 AND DECTYPE = 15 START
IF FILE = 0 THEN FILE = 2 ELSE FAULT(5)
FINISH
IF SPEC > 0 AND SPREFIX > 3 AND SPREFIX # 7 START
IF LEVEL # 0 THEN FAULT(15) ELSE FILE = 1
FINISH
COMPILE BLOCK(LEVEL+1,DECTYPE,DICT(XX))
POS=0 AND EXIT C
IF DEC TYPE=EOP OR DEC TYPE=EOF; ! PREMATURE END
FINISH
REPEAT
! POINT TO JUMP ROUND ROUTINE
DEF LAB(0) UNLESS BLOCK TYPE=15 OR LEVEL = 0
L9: SPEC=1; TMAX=T BASE; T BASE=OLD T BASE
LABEL = OLD LABEL
T LIMIT=OLD T LIMIT IF BLOCK TYPE#0
INHIBIT = INHIBIT>>1
END; ! COMPILE BLOCK
ROUTINE SUMMARISE(INTEGER STREAM)
SELECT OUTPUT(STREAM)
IF FAULTY = 0 START
WRITE(STATS,5); PRINT STRING(" STATEMENTS COMPILED
")
ELSE
PRINT STRING("PROGRAM CONTAINS"); WRITE(FAULTY,1)
PRINT STRING(" FAULT"); PRINT SYMBOL('S') IF FAULTY # 1
NEWLINE
FINISH
CLOSE OUTPUT; ! TO ENSURE BUFFER FLUSHING
END
open input(PRIM, "interdata/prims.imp")
open input(PROG, "interdata/test.imp")
open output(REPORT, "interdata/test.rpt")
open output(OBJ, "interdata/test.icd")
open output(LISTING, "interdata/test.lis")
!!!! COMREG(0) = -1; !IN CASE IT BOMBS OUT
SELECTOUTPUT(LISTING); SELECT INPUT(PRIM)
NEWLINE; SPACES(5)
PRINT STRING("EDINBURGH C.S. IMP COMPILER VERSION ")
PRINT STRING(VERSION)
NEWLINES(2)
control = 0; ! **** optimise only: for supervisor maintenance
{CONTROL = COMREG(14)}; CGEN(CONTROL); PUT('Z'+32)
LIST = 2
CODE=0
LREALS=0; ! REALSNORMAL
FAULTY=0
OUT = 0
SYMTYPE=0; PAPP == PHRASE(APPEP); APP = PAPP
STATS=0; LINE NUM=0
BUFFER(NULL STRING)=0
T LIMIT=DICT END-1; G LIMIT=GBASE; LABEL=4
T MAX=GLOBAL; T BASE=GLOBAL
X=0; ATOM1=0; LAST=0; INHIBIT = 0
COMPILE BLOCK(0,15,DICT(TLIMIT)); ! COMPILE A BEGIN TO START
PUT(';')
PUT(4); ! TO TERMINATE
SEND; ! CLEAR THE BUFFER
SUMMARISE(LISTING)
!!!! COMREG(0) = -FAULTY
!!!! COMREG(0) = STATS %IF COMREG(0) = 0
signal 15,1 if faulty # 0
ENDOFPROGRAM