! IMP77 compiler first pass
!###########################################################
! This program is a Copyright work. #
! #
! Over the last 40+ years a long and distinguished list of #
! institutions, individuals and other entities have made #
! contributions to portions of this program and may have a #
! reasonable claim over rights to certain parts of the #
! program. #
! #
! This version is therefore provided for education and #
! demonstration purposes only #
!###########################################################
begin
conststring(4) version = "8.4"
!configuration parameters
{ minus one represents all bits set for an %integer }
{ %integer could be 16,32,64 bits wide depending on the }
{ processor being targeted }
{ i.e 8086 (16 bits), 80386 (32 bits), i86_64 (64 bits) }
constinteger minus one = -1;
! Wee change needed to cross-compile the compiler when going from 16 bit to 32 bit world
! %constinteger minus one = 16_7fff;
{ now to set up various constants }
constinteger max int = ((minus one)>>1)//10
constinteger max dig = (minus one)>>1-maxint*10
constinteger byte size = 8; !bits per byte
constinteger max tag = 800; !max no. of tags
constinteger max dict = 6000; !max extent of dictionary
constinteger name bits = 11; !size of name table as a power of two
constinteger max names = 1<<namebits-1; !table limit (a mask, eg 255)
owninteger spare names = max names
constinteger lit max = 50; !max no. of constants/stat.
constinteger rec size = 520; !size of analysis record
constinteger dim limit = 6; !maximum array dimension
!symbols
constinteger ff = 12; !form feed
constinteger marker = '^'; !marker for faults
constinteger squote = '"'; !string quote
constinteger cquote = ''''; !character quote
!streams
constinteger report = 0, source = 1
constinteger object = 1, listing = 2
!types
constinteger integer = 1
constinteger real = 2
constinteger stringv = 3
constinteger record = 4
!forms
constinteger iform = integer<<4+1
constinteger var = 91
constinteger const = 93
constinteger swit = 105
constinteger comment = 22
constinteger termin = 20
constinteger lab = 3
constinteger jump = 54
constinteger recfm = 4
constinteger proc = 7; !class for proc
!phrase entries
constinteger escdec = 252
constinteger escproc = 253
constinteger escarray = 254
constinteger escrec = 255
!%recordformat arfm(%shortinteger class,sub,link,ptype,papp,pformat,x,pos);!imp77:
recordformat arfm(integer class,sub,link,ptype,papp,pformat,x,pos)
recordformat tagfm(integer app, format, integer flags, index, text, link)
!flags
! *===.===.===.===.===.====.====.====.===.======.======*
! ! u ! c ! c ! p ! s ! a ! o ! pr ! s ! type ! form !
! ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 1 ! 3 ! 4 !
! *===^===^===^===^===^====^====^====^===^======^======*
! u c c p s a o p s t f
! s l o a u n w r p y o
! e o n r b a n o e p r
! d s s a n m t c e m
! e t m a e
! d s m
! e
!
!
constinteger used bit = 2_1000000000000000
constinteger closed = 2_0100000000000000
constinteger const bit = 2_0010000000000000
constinteger parameters = 2_0001000000000000
constinteger subname = 2_0000100000000000
constinteger aname = 2_0000010000000000
constinteger own bit = 2_0000001000000000
constinteger prot = 2_0000000100000000
constinteger spec = 2_0000000010000000
constinteger trans bit = 16_4000
constinteger error = 16_8000
record(arfm)array ar(1:rec size)
owninteger class = 0; !class of atom wanted
owninteger x = 0; !usually last tag
owninteger atom1 = 0; !atom class (major)
owninteger atom2 = 0; !atom class (minor)
owninteger subatom = 0; !extra info about atom
owninteger type = 0
owninteger app = 0
owninteger format = 0; !atom info
integer hash value
owninteger faulty = 0; !fault indicator
owninteger fault rate = 0; !fault rate count
owninteger lines = 0; !current line number
owninteger text line = 0; !starting line for string const
owninteger margin = 0; !statement start margin
owninteger error margin = 0
owninteger error sym = 0
owninteger column = 0
owninteger stats = 0; !statements compiled
owninteger mon pos = 0; !flag for diagnose
owninteger sym = nl; !current input symbol
owninteger symtype = 0; !type of current symbol
owninteger quote = 0; !>0 strings, <0 chars
owninteger end mark = 0; !%end flag
owninteger cont = ' '
owninteger csym = ' '; !listing continuation marker
owninteger decl = 0; !current declarator flags
owninteger dim = 0; !arrayname dimension
owninteger spec given = 0
owninteger escape class = 0; !when and where to escape
owninteger protection = 0
owninteger atom flags = 0
owninteger otype = 0; !current 'own' type
owninteger reals ln = 1; ! =4 for %REALSLONG
owninteger last1 = 0; !previous atom class
owninteger gen type = 0
owninteger ptype = 0; !current phrase type
owninteger papp = 0; !current phrase parameters
owninteger pformat = 0; !current phrase format
owninteger force = 0; !force next ptype
owninteger g = 0
owninteger gg = 0
owninteger map gg = 0; !grammar entries
owninteger fdef = 0; !current format definition
owninteger this = -1; !current recordformat tag
owninteger nmin = 0; !analysis record atom pointer
owninteger nmax = 0; !analysis record phrase pointer
owninteger rbase = 0; !record format definition base
owninteger dmax = 1
owninteger tmin = max tag; !upper bound on tags
owninteger ss = 0; !source statement entry
string(63) include file
owninteger include list = 0
owninteger include level= 0
owninteger include = 0; !=0 unused, #0 being used
owninteger perm = 1; !1 = compiling perm, 0 = program
owninteger progmode = 0; !-1 = file, 1 = begin/eop
owninteger sstype = 0; !-1:exec stat
! 0: declaration
! 1: block in
! 2: block out
owninteger spec mode = 0; !>=0: definition
! -1: proc spec
! -2: recordformat
owninteger ocount = -1; !own constants wanted
owninteger limit = 0; !lookup limit
owninteger copy = 0; !duplicate name flag
owninteger order = 0; !out of sequence flag
owninteger for warn = 0; !non-local flag
owninteger dubious = 0; !flag for dubious statements
owninteger dp = 1
owninteger pos1 = 0
owninteger pos2 = 0; !error position
owninteger pos = 0; !input line index
owninteger dimension = 0; !current array dimension
owninteger local = 0; !search limit for locals
owninteger fm base = 0; !entry for format decls
owninteger search base = 0; !entry for record_names
owninteger format list = 0; !size of current format list
integer recid
ownbyteintegerarray char(0:133) = { input line }
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10
integerarray lit pool(0:lit max)
owninteger lit = 0; !current literal (integer)
owninteger lp = 0; !literals pointer
owninteger block x = 0; !block tag
owninteger list = 1; !<= to enable
owninteger control = 0
owninteger diag = 0; !diagnose flags
integerarray hash(0:max names)
record(tagfm)array tag(0:max tag)
integerarray dict(1:max dict)
byteintegerarray buff(1:512)
owninteger bp = 0
{ grammar related constants }
constinteger max grammar = 1720
owninteger gmin = max grammar ; ! upper bound on grammar
constinteger manifest = 120, figurative = 130
constinteger actions = 180, phrasal = 200
constbyteintegerarray amap(0:15) = 89, 91, 92, 104, 94, 93, 105, 100, 101, 102, 103, 106, 107, 108, 109, 89
! ? v n l fm const swit rp fp mp pp a an na nan ?
constbyteintegerarray atoms(0:15) = 89, 1, 1, 10, 9, 1, 10, 7,
7, 7, 7, 4, 1, 4, 1, 89
!*** start of generated tables ***
include "i77.tables.imp"
! %endoflist
conststring(8)array text(0:255) =
"Z","VDEC","OWNVDEC","EXTVSPEC","ADEC","OWNADEC","EXTASPEC","PROC",
"PROCSPEC","FORMDEC","SWDEC","LDEC","FORMSPEC","","","",
"","","OPTION","COMMA","T","COLON","COMMENT","LB",
"ALIAS","RB","SUB","ARRAYD","STYPE","ARRAY","NAME","PROCD",
"FNMAP","SWITCH","OWN","EXTERNAL","STRING","RECORD","FORMAT","SPEC",
"MCODE","LABEL","OP1","OP2","OP3","SIGN","UOP","MOD",
"DOT","COMP","ACOMP","EQ","EQEQ","JAM","JUMP","RESOP",
"AND","OR","NOT","WHILE","UNTIL","FOR","CWORD","EXIT",
"ON","SIGNAL","THEN","START","ELSE","FINISH","FELSE","CYCLE",
"REPEAT","PROGRAM","BEGIN","END","ENDPROG","ENDPERM","FRESULT","MRESULT",
"BACK","MONITOR","STOP","LIST","REALSLN","CONTROL","INCLUDE","MASS",
"RTYPE","ADDOP","IDENT","V","N","CONST","FM","",
"R","F","M","P","RP","FP","MP","PP",
"L","S","A","AN","NA","NAN","","",
"","","","","","","","",
"%MSTART","%CLEAR","%PRED","","%DUBIOUS","%DUP","%PIN","%POUT",
"%EDUP","","PIDENT","CIDENT","OIDENT","FNAME","SWID","DOTL",
"DOTR","ASEP","CSEP","OSEP","PSEP","ARB","BPLRB","ORB",
"PRB","CRB","RCRB","RECRB","RECLB","LAB","MLAB","SLAB",
"XNAME","OWNT","DBSEP","PCONST","CMOD","CSIGN","CUOP","COP1",
"COP2","COP3","INDEF","XELSE","CRESOP","NLAB","RUNTIL","ACONST",
"ORRB","FMANY","OSTRING","FMLB","FMRB","FMOR","RANGERB","FSID",
"","","","","","%DUMMY","%DECL","%TYPE",
"%ZERO","%APPLY","%PROT","%SETPROT","%PTYPE","%GAPP","%LOCAL","%GUARD",
"%MCODE","%CDUMMY","%SETTYPE","%OPER","%PARAM","%BLOCK","%OTHER","%COMPILE",
"APP","BASEAPP","APP2","APP3","APP4","APP5","APP6","ADEFN",
"NPARM","SWDEF","SWIDS","CIEXP","RCONST","SCONST","ARRAYP","XIMP",
"IMP","COND","SCOND","EXP1","EXP2","SEXP","IEXP","IEXP1",
"IEXP2","ISEXP","SEQ","FDEF","EXP","NARRAYP","STRUCT","RESEXP",
"BPL","CONSTB","FITEM","MOREA","CLIST","FPP","FPP0","FPP1",
"FPP2","INITVAR","RECEXP","EIMP","IDENTS","RANGE","RCONSTB","VARP",
"INITDEC","","","","ESCDEC","ESCPROC","ESCARRAY","ESCREC"
constinteger gmax1=719
owninteger gmax=719
constinteger imp phrase =25
! FLAG<1> 0<1> SS<2> 0<3> T<1> LINK<8>
constshortintegerarray initial(0:119) =
24, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 23, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
20, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, -32551, 0,
0, 0, 0, 13, 0, 14, 4, -32557,
16, -32550, 0, 0, 5, 6, 3, 12,
15, 8, 7, 9, 10, 11, -32558, -32554,
-32559, -32552, -32553, 18, 22, 17, 21, 19,
0, 0, 0, -32562, -32560, 0, 0, 0,
-32561, 0, 0, 0, 0, 0, 0, 0,
1, 2, 0, -32556, 0, -32555, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0
constbyteintegerarray atomic(130:179) =
90, 90, 90, 90, 90, 48, 48, 19,
19, 19, 19, 25, 25, 25, 25, 25,
25, 25, 23, 104, 104, 105, 30, 20,
21, 93, 47, 45, 46, 42, 43, 44,
40, 68, 55, 104, 60, 93, 25, 40,
93, 23, 25, 57, 25, 90, 176, 177,
178, 179
ownshortintegerarray phrase(200:255) =
0, 564, 565, 567, 569, 571, 573, 562,
614, 203, 200, 602, 478, 480, 624, 298,
206, 308, 318, 433, 426, 437, 444, 458,
453, 461, 467, 482, 402, 627, 629, 603,
521, 511, 486, 502, 575, 527, 528, 543,
550, 578, 397, 287, 197, 636, 516, 621,
167, 0, 0, 0, 640, 693, 701, 709
! MORE<1> 0<1> ORDER<2> TYPE<4> CLASS<8>
ownshortintegerarray gram(0:max grammar) =
0, -28523, -28521, -28602, -32706, -28509, -28603, -24502,
-24503, -20405, -20404, -28595, -32697, -32709, -16323, -28600,
-32704, -28587, -28589, -32681, -16344, -28586, -28588, -12270,
-32586, 216, -12287, -16380, -8185, -8184, -12285, -12286,
-12283, -12282, -12279, -12276, -16373, 20490, -32706, -32701,
216, -16364, -28610, -28613, -28612, 16445, 217, -16364,
62, -32701, 16450, -16364, 5346, -16364, 166, -16344,
4332, 130, -16360, -16361, 126, 217, -32701, 216,
-16364, 16450, -32700, 16404, -32701, -32706, 216, 16405,
16407, -16222, 8414, 130, 217, -32697, 16450, 1250,
4307, 4318, 192, 93, 170, 90, 207, -16365,
16404, 90, -16360, -16365, 16404, 241, -16365, 16404,
132, 132, -16360, 4329, -16365, 16404, 133, 175,
90, -16365, 16404, 209, -16365, 16404, 4313, 217,
16451, 4263, 16384, 16384, 120, 216, -32700, 16404,
-32706, 16404, 243, 16409, 454, -32685, 16404, 454,
248, -16365, 16404, 4263, 194, -16360, 4329, -32717,
16404, 4263, 16407, 454, 237, 127, 215, 454,
4263, 16384, -16364, 1502, -32629, -16361, 153, -32606,
222, 143, -32629, 153, 454, 126, 16409, 454,
16384, 234, -16365, -32595, 147, -32678, 234, 193,
-32677, -32676, -32661, 109, -32717, 53, 52, 52,
52, 194, 194, 194, -28581, 4188, 194, -28566,
4203, 194, -28564, 4205, 4580, 16429, 183, 183,
186, 186, -28583, 0, 9437, 90, -16365, 0,
134, -16365, 0, 210, 4329, 199, -32677, -32672,
-32676, -32688, -32690, -32705, -32661, -32659, -32689, -32686,
-32687, -16330, 65, -32716, 186, -28583, -32717, -32715,
-32713, 52, -32664, 4201, 186, -32717, -32715, 55,
-16328, 0, 197, 197, 52, 52, 197, -28581,
-28580, 186, -28581, 4188, 4318, 194, -28581, 4188,
9437, 194, 194, 454, 16407, 216, 194, -28566,
-28565, 186, -28566, 4203, 194, -28564, -28563, 186,
-28564, 4205, 183, 183, 186, 183, -16365, 0,
183, 4580, 16429, 5095, 9444, 5348, 186, -28583,
-16328, 0, 16409, -16365, 0, 9437, 5348, 217,
-32701, 16450, -32701, 216, -32700, 0, -32701, -32706,
216, 243, 217, -16318, 0, -32552, 0, -32700,
0, -32706, 0, 215, -32550, 228, -28616, -28615,
0, 4096, 218, 218, -28616, 0, -32677, -32676,
-16361, -32710, -32669, -32662, -32661, -32660, -32659, 740,
-32039, 740, -32719, 4096, 194, -32719, -32718, -32604,
-32726, -32725, -32724, -32720, 4096, 710, 6116, -32719,
0, 710, 6116, -28581, 4188, 218, 122, 50,
16409, -32726, -32725, -32724, -32719, 4096, 710, 454,
195, 195, 195, 454, -28581, 4188, 194, -28566,
-28565, -28564, 4205, 195, 195, 195, 710, 4836,
5095, 4829, -32726, -32725, -32724, -32719, 4096, 4827,
4828, 454, -32720, -32719, 4096, 4829, 4827, 4828,
194, -32719, 0, 710, 4836, -16291, -32677, 92,
184, 121, -28581, -28580, -32722, -32723, 4317, -32726,
-32725, -32724, 0, 183, -32726, -32725, -32724, -32720,
0, 4316, 195, 195, 195, 454, -28581, 4188,
4315, 183, 4317, -32726, -32725, 0, 195, 195,
4315, 4317, -32726, 0, 195, -32677, -32676, -16361,
16431, 228, 228, 47, -32610, -32611, 5345, -32609,
-32608, -32607, 0, 4320, 4319, 5345, -32609, -32608,
0, 4319, 5345, -32609, 0, -32613, -16361, 16431,
222, 222, 156, -32677, 92, 183, 186, 1222,
16435, 228, 16403, 4324, 138, 8420, -32723, 4189,
93, 454, 148, -32674, 16546, 16409, -32597, 182,
-16383, 16388, 234, -16365, -32595, 172, -32678, 234,
90, 244, 246, -16365, 0, 235, -32678, 234,
-16365, 246, -16365, 0, -32678, 234, 90, 16407,
222, 16405, 222, 145, 16407, 222, 16405, 222,
146, 16407, 1252, 154, 5348, -16365, 142, 126,
182, -16383, 16391, 90, -16365, 127, -32678, 238,
90, 125, 239, -16365, 8319, 8430, 128, 126,
-16361, 127, 190, 240, 189, 16409, 182, -16383,
16391, 90, -16365, 0, -32678, 240, 90, 16623,
-16365, 0, 244, 232, 1252, 1252, 137, 1252,
137, 1252, 137, 1252, 137, 1252, 137, 222,
-16365, 0, 131, 194, -16360, -16333, -16332, 124,
181, -16292, -16277, 16493, -31802, 5342, -28581, 4188,
4263, 181, 186, 454, 16475, 183, -28583, 199,
5598, 9438, 222, -32677, -32676, 16407, 186, 228,
135, 16409, -32632, 0, -32677, 92, -32677, -32676,
-32662, -32661, -32660, -32659, 165, -32677, 92, 188,
-32662, 107, 188, -32660, 109, -32732, 37, -16344,
4318, 148, -32674, 16424, 222, 16405, 222, 174,
-28644, -32734, -32680, -28641, -32733, -32730, -32735, -32727,
-32738, 4326, -32738, -32739, -32741, -32736, 199, -28644,
-32680, -28641, 4326, -32739, -32741, 199, -32738, -32739,
-32741, -32736, -32729, 199, -32616, 199, -32739, -32741,
-32729, 199, -32616, -32729, 199, -28644, -32680, 4326,
-32738, -32739, -32741, 199, 245, 4318, 245, 16409,
152, 4318, 16409, 152, 245, -32672, -32671, -32670,
99, 16407, 200, 144, 185, -32677, 92, 16407,
-32582, 200, 200, 187, 141, -32677, 92, 16410,
191, -32677, -32676, -32662, -32661, -32660, 109, 198,
0(max grammar-gmax1)
ownshortintegerarray glink(0:max grammar) =
-1, 71, 72, 38, 46, 47, 67, 67,
75, 67, 0, 67, 51, 76, 79, 53,
55, 80, 67, 81, 82, 83, 67, 84,
26, 41, 85, 86, 57, 57, 89, 93,
96, 97, 102, 103, 104, 107, 46, 67,
67, 0, 110, 110, 111, 52, 49, 0,
61, 67, 62, 0, 67, 0, 111, 112,
112, 58, 113, 114, 115, 64, 67, 66,
116, 117, 68, 0, 67, 122, 67, 0,
73, 123, 123, 67, 77, 67, 40, 77,
67, 67, 0, 124, 127, 128, 87, 86,
0, 90, 131, 89, 0, 94, 93, 0,
132, 98, 137, 100, 97, 0, 138, 67,
105, 104, 0, 108, 107, 0, 67, 67,
67, 139, 140, 141, 0, 118, 120, 116,
142, 116, 67, 71, 125, 67, 0, 67,
129, 85, 0, 143, 133, 144, 135, 145,
0, 156, 157, 59, 158, 67, 119, 91,
159, 146, 145, 148, 146, 151, 0, 153,
153, 154, 146, 0, 99, 160, 67, 134,
161, 162, 165, 161, 141, 162, 162, 168,
172, 174, 175, 176, 177, 178, 179, 182,
185, 188, 189, 180, 190, 190, 183, 191,
191, 186, 191, 191, 0, 188, 192, 193,
194, 0, 196, 0, 0, 198, 197, 0,
201, 200, 0, 204, 205, 0, 228, 232,
219, 234, 235, 0, 236, 237, 238, 0,
232, 226, 244, 245, 221, 248, 249, 250,
251, 245, 0, 252, 229, 249, 250, 251,
253, 0, 0, 188, 254, 260, 239, 269,
269, 242, 191, 191, 270, 246, 272, 272,
229, 273, 274, 275, 276, 0, 255, 266,
266, 258, 267, 267, 261, 266, 266, 264,
267, 267, 232, 268, 232, 0, 277, 0,
278, 232, 273, 232, 282, 283, 279, 285,
253, 0, 0, 286, 0, 232, 0, 288,
0, 290, 0, 292, 294, 0, 0, 297,
0, 0, 299, 301, 0, 303, 0, 305,
0, 307, 0, 0, 310, 313, 314, 315,
0, 0, 316, 311, 314, 0, 332, 332,
328, 349, 350, 351, 351, 351, 351, 330,
282, 352, 358, 0, 333, 341, 347, 359,
360, 361, 362, 363, 0, 342, 343, 345,
0, 346, 0, 269, 269, 0, 0, 366,
353, 371, 372, 373, 374, 0, 375, 376,
377, 383, 384, 364, 385, 385, 367, 269,
269, 269, 269, 389, 390, 391, 392, 393,
0, 378, 360, 361, 362, 341, 0, 379,
380, 386, 363, 341, 0, 353, 354, 355,
375, 395, 0, 396, 0, 400, 269, 269,
401, 0, 411, 411, 406, 417, 407, 418,
419, 420, 0, 412, 418, 419, 420, 421,
0, 409, 406, 424, 417, 422, 425, 425,
408, 415, 427, 430, 431, 0, 426, 432,
428, 434, 436, 0, 433, 269, 269, 441,
442, 282, 443, 0, 446, 451, 447, 446,
452, 451, 0, 449, 448, 454, 453, 457,
0, 455, 459, 458, 0, 269, 464, 465,
282, 466, 0, 469, 469, 470, 471, 472,
473, 474, 475, 476, 477, 0, 479, 269,
481, 0, 483, 485, 485, 205, 490, 488,
496, 497, 491, 494, 490, 0, 491, 491,
0, 498, 499, 501, 0, 0, 504, 506,
510, 499, 508, 0, 506, 506, 504, 512,
513, 514, 515, 0, 517, 518, 519, 520,
0, 522, 523, 524, 525, 522, 0, 528,
529, 531, 536, 532, 534, 0, 532, 0,
537, 538, 539, 541, 542, 542, 0, 544,
546, 0, 547, 548, 549, 533, 551, 553,
558, 554, 556, 0, 554, 0, 559, 560,
557, 0, 563, 205, 0, 566, 564, 568,
565, 570, 567, 572, 569, 574, 571, 576,
575, 0, 579, 580, 592, 593, 584, 205,
585, 588, 588, 588, 590, 205, 594, 594,
595, 596, 597, 581, 600, 598, 601, 0,
205, 205, 205, 606, 606, 607, 608, 609,
605, 610, 612, 0, 193, 193, 193, 193,
193, 193, 193, 193, 0, 623, 623, 192,
626, 626, 0, 626, 626, 631, 633, 282,
282, 634, 282, 282, 637, 638, 639, 0,
650, 677, 684, 666, 655, 205, 205, 205,
205, 650, 659, 668, 685, 666, 0, 662,
686, 666, 662, 668, 685, 0, 670, 674,
689, 666, 205, 0, 205, 0, 674, 689,
205, 0, 666, 205, 0, 680, 692, 680,
659, 668, 685, 0, 650, 687, 662, 688,
205, 690, 691, 666, 680, 697, 697, 697,
697, 698, 699, 700, 0, 703, 703, 704,
706, 707, 708, 708, 700, 711, 711, 712,
713, 719, 719, 719, 719, 719, 719, 0,
0(max grammar-gmax1)
constshortinteger max kdict = 618
constshortintegerarray kdict(32:max kdict) =
0, 511, 131, 531, 131, 551, 559, 131,
567, 575, 583, 603, 623, 631, 663, 671,
129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 691, 698, 707, 751, 795, 131,
131, 824, 900, 960, 1076, 1120, 1280, 128,
128, 1392, 128, 128, 1460, 1600, 1636, 1704,
1792, 128, 1872, 2088, 2284, 2316, 128, 2356,
128, 128, 128, 2375, 2383, 2415, 2423, 2443,
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, 2451, 131, 2459, -32351,
16428, 25, 16428, 29, -32349, 16433, 1, 16434,
1, -16127, 0, 16427, 21, 16407, 0, 16409,
0, -32323, -10840, 40, 16471, 0, -32341, -10580,
32, 16473, 117, 16384, 19, -31955, -32322, -10580,
36, -9290, 0, 16473, 113, 16432, 13, -32337,
16427, 46, 16427, 17, 16405, 0, 16404, 0,
-31556, -31939, -32322, -9551, 2, 16433, 1, 16433,
5, 16426, 5, -31606, -32323, -9807, 0, -32374,
-9678, 0, 16436, 0, 16435, 0, -31939, -32322,
16433, 4, 16426, 9, 16433, 3, -30772, -31666,
10578, 11457, -32344, 16413, 2, 16411, 2, 68,
-32374, 16440, 0, 16440, 0, 8393, 83, 16408,
0, -31291, 10841, 69, -32311, 16412, 18, 10830,
9157, 10565, 16412, 18, 9415, 78, 16458, 0,
-32049, 8665, 8908, 16455, 0, -30131, 78, -31277,
84, -32055, 10194, 76, 16469, 0, 10958, 69,
16447, 32, 84, -32319, 16418, 2, 10830, 16418,
2, 8909, 10830, 16406, 0, -31927, 10073, 9921,
8649, 16419, 5, 9153, 10190, 8915, 16469, 1,
-27956, -31282, 88, -31927, 8916, 10066, 9793, 16419,
3, 84, 16447, 4, 68, -32305, 16459, 2,
70, -30650, -31284, 80, -31931, 10194, 10567, 9921,
16460, 1, 9938, 16461, 0, 10697, 84, 16467,
3, 9801, 69, 16460, 0, 8915, 16452, 0,
-29631, -30903, -31282, -31793, 10069, 10819, 10185, 78,
16416, 9, 82, 16445, 0, 16416, 9, 9422,
9299, -32315, 16453, 0, 10700, 69, 16454, 0,
10700, 69, 16464, 1210, -30778, 78, -31549, 8916,
8903, 82, -32344, 16412, 17, 16472, 17, 10956,
8900, 16470, 0, 16446, 44, -28735, -29239, 10063,
71, -30263, -31668, -32302, 16412, 20, 8389, 76,
16412, 36, 10063, 71, -32311, 16412, 21, 10830,
9157, 10565, 16412, 21, 10830, 9157, 10565, 16412,
20, 10835, 16467, 1, 8898, 76, 16425, 6,
-31935, 10063, 10825, 10575, 16465, 109, 80, 16416,
10, -32191, 10831, 16442, 0, 8909, -32314, 16414,
1, -31794, 10069, 10819, 10185, 78, 16416, 10,
16416, 10, -30770, -31408, -32174, 10071, 16418, 1,
-32374, 16441, 2, 16441, 2, 9428, 10063, 16402,
0, -32315, 16448, 0, 8918, 10830, 16448, 0,
-30523, 82, -31419, -31927, 9167, 8402, 77, 16457,
0, 77, 16419, 6, 9412, 8387, 8916, 16415,
123, 9938, 16419, 7, -31931, 10959, 9428, 8910,
16415, 104, -28351, -30397, -31024, -32045, 10964, 10066,
16464, 1319, 9813, 7892, -32323, 16462, 1384, 16463,
1241, 8389, 84, 16456, 0, 10575, 68, -32314,
16421, 64, 10575, 8397, 84, -32301, 16422, 9,
8912, 67, 16422, 12, 76, -32301, 16412, 33,
-31924, 10190, 9938, 9793, 16468, 1, 10063, 71,
16468, 4, -27704, -28983, -29488, -31276, -31913, 10713,
8916, 77, 16419, 4, 10825, 9283, 16417, 12,
-31423, -31921, 9426, 9166, 40, 16420, 48, 80,
16466, 115, 10834, 16451, 0, 8645, 16423, 0,
10055, 9793, -32315, 16449, 0, 8918, 10830, 16449,
0, 10575, 84, -32311, 16412, 19, 10830, 9157,
10565, 16412, 19, -32056, 10962, 69, 16464, 1354,
10053, 16450, 0, 78, -32052, 9428, 76, 16444,
182, 10693, 83, 16446, 46, 9416, 8908, 16443,
180, 16407, 0, -31939, -32292, -10454, 51, 16426,
13, 16433, 1, 16409, 0, -32290, -10454, 51,
16426, 13, 16410, 0, 16431, 14, -32323, 16430,
51, 16433, 1
! %list
!%endoffile
!*** end of generated tables ***
routine flush buffer( integer limit )
integer j
if bp >= limit start
if faulty = 0 start
selectoutput(object)
for j = 1, 1, bp cycle
printsymbol(buff(j))
repeat
selectoutput(listing)
finish
bp = 0
finish
end
routine add char( byteinteger ch )
bp = bp + 1
buff(bp) = ch
end
routine op(integer code, param)
buff(bp+1) = code
buff(bp+2) = param>>8
buff(bp+3) = param
bp = bp+3
end
routine set const(integer m)
buff(bp+1) = 'N'
buff(bp+5) = m; m = m>>8
buff(bp+4) = m; m = m>>8
buff(bp+3) = m; m = m>>8
buff(bp+2) = m
bp = bp+5
end
routine octal(integer n)
integer m
m = n>>3
octal(m) if m # 0
add char( n&7+'0' )
end
routine hexadecimal(integer n)
integer m
m = n>>4
hexadecimal(m) if m # 0
if n&15 > 9 then add char( n&15+'A' ) else add char( n&15+'0' )
end
routine print ident(integer p, mode)
routine putit(integer ch)
if mode = 0 then start
printsymbol(ch)
else
add char( ch )
finish
end
integer k, l
p = tag(p)_text
if p = 0 start
putit('?')
return
finish
p = p+1; ! advance to name string
k = dict(p)
l = k & 255; ! length
while l > 0 cycle
putit(k>>8)
l = l-1
p = p+1
k = dict(p)
exit if l = 0
putit(k&255)
l = l-1
repeat
end
routine abandon(integer n)
switch reason(0:9)
integer stream
stream = listing
cycle
newline if sym # nl
printsymbol('*'); write(lines,4); space
->reason(n)
reason(0): printstring("compiler error!"); ->more
reason(1): printstring("switch vector too large"); ->more
reason(2): printstring("too many names"); ->more
reason(3): printstring("program too complex"); ->more
reason(4): printstring("feature not implemented"); ->more
reason(5): printstring("input ended: ")
if quote # 0 start
if quote < 0 then printsymbol(cquote) else printsymbol(squote)
else
printstring("%endof")
if progmode >= 0 then printstring("program") else printstring("file")
finish
printstring(" missing?"); ->more
reason(6): printstring("too many faults!"); ->more
reason(7): printstring("string constant too long"); ->more
reason(8): printstring("dictionary full"); ->more
reason(9): printstring("Included file ".include file." does not exist")
more: newline
printstring("*** compilation abandoned ***"); newline
exit if stream = report
close output
stream = report
select output(report)
repeat
!%signal 15,15 %if diag&4096 # 0
stop
end
routine compile block(integer level, block tag, dmin, tmax, id)
integerfnspec gapp
routinespec delete names(integer quiet)
routinespec analyse
routinespec compile
integer open; open = closed; !zero if can return from proc
integer dbase; dbase = dmax; !dictionary base
integer tbase; tbase = tmax; !tag base
integer tstart; tstart = tmax
integer label; label = 4; !first internal label
integer access; access = 1; !non-zero if accessible
integer inhibit; inhibit = 0; !non-zero inhibits declaratons
integername bflags; bflags == tag(block tag)_flags
integer block type; block type = bflags>>4&7
integer block form; block form = bflags&15
integer block fm; block fm = tag(block tag)_format
integer block otype; block otype = otype
integername block app; block app == tag(block tag)_app
integer l, new app
routine fault(integer n)
! -5 : -1 - warnings
! 1 : 22 - errors
switch fm(-5:22)
integer st
routine print ss
integer s, p
return if pos = 0
space
p = 1
cycle
printsymbol(marker) if p = pos1
exit if p = pos
s = char(p); p = p+1
exit if s = nl or (s='%' and p = pos)
if s < ' ' start; !beware of tabs
if s = ff then s = nl else s = ' '
finish
printsymbol(s)
repeat
pos = 0 if list <= 0
end
pos1 = pos2 if pos2 > pos1
newline if sym # nl
st = report
st = listing if n = -3; !don't report unused on the console
cycle
select output(st)
if n < 0 then printsymbol('?') and pos1 = 0 else printsymbol('*')
if st # report start
if list <= 0 and pos1 # 0 start
spaces(pos1+margin); printstring(" ! ")
finish
finish else start
printstring(include file) if include # 0
write(lines, 4); printsymbol(csym); space
finish
->fm(n) if -5 <= n and n <= 22
printstring("fault"); write(n, 2); ->ps
fm(-5): printstring("Dubious statement"); dubious = 0; ->psd
fm(-4): printstring("Non-local")
pos1 = for warn; for warn = 0; ->ps
fm(-3): print ident(x, 0); printstring(" unused"); ->nps
fm(-2): printstring("""}"""); ->miss
fm(-1): printstring("access"); ->psd
fm(0): printstring("form"); ->ps
fm(1): printstring("atom"); ->ps
fm(2): printstring("not declared"); ->ps
fm(3): printstring("too complex"); ->ps
fm(4): printstring("duplicate "); Print Ident(x, 0); ->ps
fm(5): printstring("type"); ->ps
fm(6): printstring("match"); ->psd
fm(7): printstring("context"); ->psd
fm(8): printstring("%cycle"); ->miss
fm(9): printstring("%start"); ->miss
fm(10): printstring("size"); write(lit, 1) if pos1 = 0; ->ps
fm(11): printstring("bounds")
write(ocount, 1) unless ocount < 0; ->ps
fm(12): printstring("index"); ->ps
fm(13): printstring("order"); ->psd
fm(14): printstring("not a location"); ->ps
fm(15): printstring("%begin"); ->miss
fm(16): printstring("%end"); ->miss
fm(17): printstring("%repeat"); ->miss
fm(18): printstring("%finish"); ->miss
fm(19): printstring("result"); ->miss
fm(20): printsymbol('"'); print ident(x, 0); printsymbol('"'); ->miss
fm(21): printstring("context "); print ident(this, 0); ->ps
fm(22): printstring("format"); ->ps
miss: printstring(" missing"); ->nps
psd: pos1 = 0
ps: print ss
nps: newline
exit if st = listing
st = listing
repeat
if n >= 0 start
!%signal 15,15 %if diag&4096 # 0
if n # 13 start; !order is fairly safe
ocount = -1
gg = 0
copy = 0; quote = 0
search base = 0; escape class = 0
gg = 0
finish
faulty = faulty+1
!check that there haven't been too many faults
fault rate = fault rate+3; abandon(6) if fault rate > 30
fault rate = 3 if fault rate <= 0
finish
tbase = tstart
if list <= 0 and sym # nl start
error margin = column
error sym = sym; sym = nl
finish
end
dmin = dmin-1; dict(dmin) = -1; !end marker for starts & cycles
abandon(2) if dmax = dmin
if list > 0 and level > 0 start
write(lines, 5); spaces(level*3-1)
if block tag = 0 start
printstring("Begin")
finish else start
printstring("Procedure "); print ident(block tag, 0)
finish
newline
finish
!deal with procedure definition (parameters)
if block tag # 0 start; !proc
analyse; compile if ss # 0
if block otype # 0 start; !external-ish
if bflags&spec = 0 start; !definition
if progmode <= 0 and level = 1 then progmode = -1 else fault(7)
finish
finish
new app = gapp; !generate app grammar
if spec given # 0 start; !definition after spec
fault(6) if new app # block app; !different from spec
finish
block app = new app; !use the latest
if level < 0 start; !not procedure definition
delete names(0)
return
finish
finish else start
open = 0; !can return from a block?
finish
cycle
analyse
if ss # 0 start
compile
fault(-5) if dubious # 0
flush buffer( 128 ) ;! flush if bp >= 128
if sstype > 0 start; !block in or out
exit if sstype = 2; !out
compile block(spec mode, block x, dmin, tmax, id)
exit if ss < 0; !endofprogram
finish
finish
repeat
if list > 0 and level > 0 start
write(lines, 5); spaces(level*3-1)
printstring("End")
newline
finish
delete names(0)
return
! generate app grammar (backwards)
integerfn gapp
constinteger comma = 140; !psep
routinespec set cell(integer g, tt)
routinespec class(record(tagfm)name v)
record(tagfm)name v
integer p, link, tp, c, ap, t
result = 0 if tmax = local; !no app needed
p = gmax1; link = 0; t = tmax
cycle
v == tag(t); t = t-1
class(v); ! deduce class from tag
if c < 0 start; ! insert %PARAM
c = -c
set cell(196, tp)
tp = -1
finish
set cell(c, tp)
exit if t = local; ! end of parameters
set cell(comma, -1); ! add the separating comma
repeat
abandon(3) if gmax > gmin
result = link
routine set cell(integer g, tt)
! add the cell to the grammar, combining common tails
while p # gmax cycle
p = p+1
if glink(p) = link and gram(p) = g start
if tt < 0 or (gram(p+1) = tt and glink(p+1)=ap) start
link = p; ! already there
return
finish
finish
repeat
!add a new cell
gmax = gmax+1
gram(gmax) = g
glink(gmax) = link
link = gmax
if tt >= 0 start; ! set type cell
gmax = gmax+1
gram(gmax) = tt
glink(gmax) = ap
finish
p = gmax
end
routine class(record(tagfm)name v)
constinteger err = 89
constinteger rtp = 100
constinteger fnp = 101
constinteger mapp = 102
constinteger predp = 103
constintegerarray class map(0:15) = err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214,
{ err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214, }
err, 229, err
! err, 229, err
integer tags, type, form
ap = 0
tags = v_flags
type = tags>>4&7; form = tags&15
tp = v_format<<3!type
c = class map(form)
c = 208 and tp = 0 if type = 0 and form = 2; !%name
ap = v_app if tags¶meters # 0
end
end
routine delete names(integer quiet)
integer flags
record(tagfm)name tx
while tmax > tbase cycle
x = tmax; tmax = tmax-1
tx == tag(x)
flags = tx_flags
fault(20) if flags&spec # 0 and flags&own bit = 0
!{spec with no definition & not external}
if flags&used bit = 0 and level >= 0 and list <= 0 start
fault(-3) if quiet = 0; !unused
finish
dict(tx_text) = tx_link
repeat
end
routine analyse
constinteger order bits = 16_3000, order bit = 16_1000
constinteger escape = 16_1000
integer strp, mark, flags, prot err, k, s, c
owninteger key = 0
integer node
integername z
record(arfm)name arp
switch act(actions:phrasal), paction(0:15)
routine trace analysis
!diagnostic trace routine (diagnose&1 # 0)
integer a
routine show(integer a)
if 0 < a and a < 130 start
space
printstring(text(a))
finish else write(a, 3)
end
owninteger la1=0, la2=0, lsa=0, lt=0
newline if mon pos # pos and sym # nl
mon pos = pos
write(g, 3)
space
printstring(text(class))
printsymbol('"') if gg&trans bit # 0
a = gg>>8&15
if a # 0 start
printsymbol('{')
write(a, 0)
printsymbol('}')
finish
if atom1 # la1 or atom2 # la2 or lsa # subatom or lt # type start
printstring(" [")
la1 = atom1
show(la1)
la2 = atom2
show(la2)
lsa = subatom
write(lsa, 3)
lt = type
write(lt, 5)
printsymbol(']')
finish
newline
end
routine get sym
readsymbol(sym)
abandon(5) if sym < 0
pos = pos+1 if pos # 133
char(pos) = sym
printsymbol(sym) if list <= 0
column = column+1
end
routine read sym
owninteger Last = 0
constbyteintegerarray mapped(0:127) = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 10, 0, 3, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0,'!','"','#', '$', 1,'&', 39, '(',')','*','+', ',','-','.','/',
'0','1','2','3', '4','5','6','7', '8','9',':',';', '<','=','>','?',
'@','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O',
'P','Q','R','S', 'T','U','V','W', 'X','Y','Z','[', '¬',']','^','_',
'`','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O',
'P','Q','R','S', 'T','U','V','W', 'X','Y','Z', 2 , '|','}','~', 0
!! 0 = space
!! 1 = %
!! 2 = {
!! 3 = ff
!! other values represent themselves
if sym = nl start
s1: lines = lines+1
printsymbol(end mark) if end mark # 0
s11: pos = 0; pos1 = 0; pos2 = 0; margin = 0; column = 0
Last = 0
end mark = 0
if list <= 0 start
if include # 0 start
printstring(" &"); write(lines, -4)
finish else write(lines, 5)
csym = cont; printsymbol(csym)
space
if error margin # 0 start
lines = lines-1
spaces(error margin)
error margin = 0
if error sym # 0 start
printsymbol(error sym)
pos = 1; char(1) = error sym
sym = error sym; error sym = 0
->s5
finish
finish
finish
s2: symtype = 1
finish
s3: readsymbol(sym)
abandon(5) if sym < 0
pos = pos+1 if pos # 133
char(pos) = sym
printsymbol(sym) if list <= 0
column = column+1
s5: if sym # nl start
Last = Sym
return if quote # 0; !dont alter strings
sym = mapped(sym&127)
if sym <= 3 start; !special symbol
->s2 if sym = 0; !space (or dubious control)
symtype = 2 and ->s3 if sym = 1; !%
cont = '+' and ->s11 if sym = 3; !ff
!must be {
cycle
get sym
->s3 if sym = '}'
->s4 if sym = nl
repeat
finish
key = kdict(sym)
if key&3 = 0 and symtype = 2 start; !keyword
if sym = 'C' and nextsymbol = nl start; !%c...
getsym; cont = '+'; ->s1
finish
else
symtype = key&3-2
finish
return
finish
s4: symtype = quote
->S1 if last = 0 and Quote = 0
Cont = '+'
end
integerfn format selected
format list = tag(format)_app; !number of names
if format list < 0 start; !forward ref
atom1 = error+22
result = 0
finish
if sym = '_' start
escape class = esc rec
search base = tag(format)_format
finish
result = 1
end
routine code atom(integer target)
integer dbase, da
integer base, n, mul, pend quote
integer j,k,l, pt
routine lookup(integer d)
integer new name, vid, k1, k2, form
record(tagfm)name t
integer new
! twee little function because SKIMP86 can't do string compare properly
! returns 1 if the two names are the same, else zero
integerfn dict match(integer ptr1, ptr2)
integer len;
! start with a cheap check of the length and first character
if dict(ptr1) # dict(ptr2) then result = 0
len = dict(ptr1) & 255
ptr1 = ptr1 + 1
ptr2 = ptr2 + 1
len = len - 1
while len >= 2 cycle
if dict(ptr1) # dict(ptr2) then result = 0
ptr1 = ptr1 + 1
ptr2 = ptr2 + 1
len = len - 2
repeat
! if the string was odd length, we might need one last byte checked
if len = 1 start
if dict(ptr1)&255 # dict(ptr2)&255 then result = 0
finish
result = 1
end
!first locate the text of the name
new = dmax+1; ! points to text of string in dictionary
k1 = hash value & max names; ! rather crude hash!
cycle
newname = hash(k1)
exit if newname = 0; !not in
->in if dict match(newname+1, new) = 1
k1 = (k1+1)&max names
repeat
! not found
spare names = spare names-1
abandon(2) if spare names <= 0
hash(k1) = dmax; !put it in
dict(dmax) = -1
newname = dmax; dmax = dp; ->not in
in: search base = rbase if this >= 0 and d # 0; !record elem defn
if search base # 0 start; !record subname
new = -1
x = search base
cycle
->not in if x < format list
exit if tag(x)_text = new name
x = x-1
repeat
finish else start; !hash in for normal names
x = dict(newname)
->not in if x <= limit; !wrong level
finish
subatom = x; !name found, extract info
t == tag(x)
atom flags = t_flags
format = t_format; app = t_app
protection = atom flags&prot
type = atom flags>>4&7; atom1 = amap(atom flags&15)
if diag&8 # 0 start
printstring("lookup:")
write(atom1, 3)
write(type, 1)
write(app, 3)
write(format, 5)
write(atom flags, 3)
newline
finish
if d = 0 start; !old name wanted
t_flags = t_flags!used bit
search base = 0
if atom flags&subname # 0 and format # 0 start; !a record
return if format selected = 0
finish
if atom flags¶meters # 0 start; !proc or array
if app = 0 start; !no parameters needed
atom2 = atom1
atom1 = atom1-4
if 97 <= atom1 and atom1 <= 98 start
map gg = atom1; atom1 = var
finish
finish else start
if sym = '(' start
search base = 0; !ignore format for now
if atom1 >= 106 start; !arrays
app = phrase(app+200)
escape class = esc array
atom1 = (atom1-106)>>1+91; !a,an->v na,nan->n
finish else start; !procedures
escape class = esc proc
atom1 = atom1-4
finish
phrase(200) = app
finish
finish
pos2 = pos; return
finish
!deal with constintegers etc
if atom flags&const bit # 0 and atom1 = var start
map gg = const; atom2 = const
subatom = -subatom if type = integer
finish
return
finish
!new name wanted
->not in if tbase # tstart; !don't fault proc parm-parm
if d = lab+spec+used bit start
t_flags = t_flags!used bit
return
finish
if atom flags&spec # 0 start; !a spec has been given
if d = lab start; !define label
t_flags = t_Flags-Spec
return
finish
if 7 <= decl&15 and decl&15 <= 10 and decl&spec = 0 start
!procedure definition after spec
if (decl!!atom flags)&2_1111111 = 0 start; !correct type?
t_flags = t_flags-spec
spec given = 1
return
finish
!note that an external procedure must be speced as a
!non-external procedure.
finish
if decl&15 = recfm start; !recordformat
t_flags = record<<4+recfm
t_format = fdef
return
finish
finish
return if last1 = jump and atom1 = swit
copy = x if copy = 0
notin: app = 0; vid = 0
atom1 = error+2
return if d = 0; !old name wanted
type = d>>4&7; form = d&15; atom1 = amap(form)
if this < 0 start; !normal scope
new = newname
tmax = tmax+1; x = tmax
finish else start; !recordformat scope
new = -1
recid = recid-1; vid = recid
tmin = tmin-1; x = tmin
format list = tmin
finish
if 11 <= form and form <= 14 start; !arrays
dim = 1 if dim = 0; !set dim for owns
app = dim
finish
d = d!used bit if (otype > 2 and d&spec = 0) or perm # 0 or Level = Include Level
!external definitions need not be used in the file in which
!they are defined, so inhibit a useless unused warning.
t == tag(x)
if form = lab start
id = id+1; vid = id
finish
t_index = vid
t_text = new name
t_flags = d
t_app = app
t_format = fdef; format = fdef
subatom = x
if new >= 0 start; !insert into hash table
t_link = dict(new); dict(new) = x
if gmin = max grammar start; !proc param params
tmin = tmin-1; subatom = tmin
tag(tmin) = t
finish
finish
abandon(3) if tmax >= tmin
end
top: pos1 = pos
subatom = 0; pend quote = 0; atom flags = 0
!app and format must be left for assigning to papp & pformat
->name if symtype = -2; ! letter
->number if symtype < 0; ! digit
if symtype = 0 start
atom1 = termin; atom2 = 0
return
finish
if symtype # 2 start; ! catch keywords here
->text if quote # 0; ! completion of text
->strings if sym = squote; ! start of string
->symbols if sym = cquote; ! start of symbol
->number if sym = '.' and '0' <= nextsymbol and nextsymbol <= '9'
finish
! locate atom in fixed dict
k = key>>2; read sym
cycle
j = kdict(k)
exit if j&16_4000 # 0
if j&127 # sym or symtype < 0 start
->err unless j < 0
k = k+1
finish else start
l = j>>7&127; read sym
if j > 0 start
if l # 0 start
->err if l # sym or symtype < 0
read sym
finish
l = 1
finish
k = k+l
finish
repeat
atom1 = j&127
if atom1 = 0 start; ! comma
atom1 = 19; subatom = 19; atom2 = 0
if sym = nl start
return if ocount >= 0
! special action needs to be taken with <comma nl> as
! const array lists can be enormous
read sym
finish
return
finish
atom2 = j>>7&127
subatom = kdict(k+1)&16_3fff
!!!!!cont = ' '
return
! report an error. adjust the error marker (pos1) to point
! to the faulty character in an atom, but care needs to be taken
! to prevent misleading reports in cases like ...?????
err: atom1 = error+1; atom2 = 0
pos1 = pos if pos-pos1 > 2
return
! take care with strings and symbol constants.
! make sure the constant is valid here before sucking it in
! (and potentially loosing many lines)
symbols: atom1 = var; atom2 = const; type = integer
map gg = const; protection = prot
subatom = lp; abandon(3) if lp >= lit max
quote = ¬pend quote
return
! an integer constant is acceptable so get it in and
! get the next atom
chars: n = 0; cont = cquote
cycle
read sym
if sym = cquote start
exit if nextsymbol # cquote
read sym
finish
if n&(¬((-1)>>byte size)) # 0 start; ! overflow
pos1 = pos; atom1 = error+10; return
finish
->err if quote = 0
n = n<<byte size+sym
quote = quote+1
repeat
quote = 0; cont = ' '
readsym if sym # nl
lit pool(lp) = n; lp = lp+1
->top
!sniff the grammar before getting the string
strings: atom1 = var; atom2 = const; type = stringv
subatom = strp!16_4000
map gg = const; protection = prot
quote = subatom
text line = lines; ! in case of errors
return
! a string constant is ok here, so pull it in and get
! the next atom
! ABD - temp variable to help pack bytes into words
integer flipflop
text: ->chars if quote < 0; ! character consts
l = strp; ! point to beginning
k = 0; ! length so far
flipflop = 0; ! space for the length is up the spout
cycle
cont = squote; quote = 1
cycle
read sym
if sym = squote start; ! terminator?
exit if nextsymbol # squote; ! yes ->
read sym; ! skip quote
finish
if flipflop >= 0 start
glink(strp) = sym<<8 + flipflop
strp = strp+1
flipflop = -1
else
flipflop = sym
finish
k = k+1
lines = text line and abandon(7) if k > 255; ! too many chars
repeat
if flipflop >=0 start; ! tail-end charlie
glink(strp) = flipflop
strp = strp+1
finish
glink(l) = glink(l)!k; ! plug in length
quote = 0; cont = ' '; read sym
code atom(target)
return unless atom1 = 48 and sym = squote; ! fold "???"."+++"
repeat
routine get(integer limit)
integer s, shift
shift = 0
if base # 10 start
if base = 16 start
shift = 4
finish else start
if base = 8 start
shift = 3
finish else start
if base = 2 start
shift = 1
finish
finish
finish
finish
n = 0
cycle
if symtype = -1 start; ! digit
s = sym-'0'
finish else start
if symtype < 0 start; ! letter
s = sym-'A'+10
finish else start
return
finish
finish
return if s >= limit
pt = pt+1; glink(pt) = sym
if base = 10 start; ! check overflow
if n >= max int and (s > max dig or n > max int) start
!too big for an integer,
!so call it a real
base = 0; type = real; n = 0
finish
finish
if shift = 0 start
n = n*base+s
finish else start
n = n<<shift+s
finish
read sym
repeat
end
number: base = 10
bxk: atom1 = var; atom2 = const; type = integer; subatom = lp
map gg = const; protection = prot
abandon(3) if lp >= lit max
pt = strp; mul = 0
cycle
get(base)
exit unless sym = '_' and base # 0 and pend quote = 0; ! change of base
pt = pt+1; glink(pt) = '_'
read sym
base = n
repeat
if pend quote # 0 start
->err if sym # cquote
readsym
finish
if sym = '.' start; ! a real constant
pt = pt+1; glink(pt) = '.'
read sym
type = real; n = base; base = 0; get(n)
finish
if sym = '@' start; ! an exponent
pt = pt+1; glink(pt) = '@'; k = pt
readsym
type = integer; base = 10
if sym = '-' start
read sym; get(10); n = -n
finish else start
get(10)
finish
pt = k+1; glink(pt) = lp; litpool(lp) = n; lp = lp+1
atom1 = error+10 if base = 0
type = real; ! exponents force the type
finish
if type = real start
glink(strp) = pt-strp; ! store the length (difference)
subatom = (strp)!16_2000; strp = pt+1
finish else start
litpool(lp) = n
lp = lp+1
finish
return
name: atom1 = 0 and return if 27 <= target and target <= 41
hash value = 0
! ABD changed to remove dependency on direct addressing
dp = dmax+1
dbase = dp
n = 0
dict(dp) = 0
cycle
hash value = hash value+(hash value+sym); ! is this good enough?
dict(dp) = dict(dp) ! (sym << 8);
n = n+1
dp = dp+1
read sym
exit if symtype >= 0
dict(dp) = sym;
n = n+1
read sym
exit if symtype >= 0
repeat
if sym = cquote start
pend quote = 100
->symbols if hash value = 'M'
read sym
if hash value = 'X' then base = 16 and ->bxk
if hash value = 'K' or hash value = 'O' then base = 8 and ->bxk
if hash value = 'B' then base = 2 and ->bxk
->err
finish
dict(dbase) = dict(dbase)!n
if n&1 = 0 then dp = dp+1
abandon(8) if dp >= dmin
atom2 = 90; ! ident
if last1 = 0 and sym = ':' start; ! label
limit = local; lookup(lab); return
finish
if last1 = jump start; ! ->label
limit = local; lookup(lab+spec+used bit); return
finish
if decl # 0 and target = 90 start; ! identifier
search base = fm base
limit = local; lookup(decl)
search base = 0
finish else start
limit = 0; lookup(0)
finish
end
integerfn parsed machine code
! *opcode_??????????
atom1 = error and result=0 unless symtype = -2; ! starts with letter
flush buffer( 128 ); ! flush if bp >= 128
add char( 'w' )
cycle
add char( sym ); read sym
repeat until Sym = '_' or Symtype = 0; ! pull in letters and digits
add char( '_' )
if symtype # 0 start; ! not terminator
read sym
while symtype # 0 cycle
if symtype < 0 start; ! complex
code atom(0); result=0 if atom1&error # 0
if atom2 = const and type = integer start
if subatom < 0 then set const(tag(-subatom)_format) else set const(litpool(subatom))
finish else if 91 <= atom1 and atom1 <= 109 start
if atom1 = 104 and Tag(Subatom)_Flags&Closed = 0 start
This = Subatom; Atom1 = Error+21
result = 0
finish
op(' ', tag(subatom)_index)
finish else start
atom1 = error; result=0
finish
finish else start
sym = sym!128 if symtype = 2 {underline with %}
add char( sym ); read sym
finish
repeat
finish
add char( ';' )
result=1
end
cont = ' ' if gg = 0
last1 = 0; mapgg = 0
s = 0; ss = 0; sstype = -1; fdef = 0
fm base = 0
app = 0
! deal with alignment following an error in one statement
! of several on a line
margin = column; ! start of statement
pos = 0
strp = gmax+1; lp = 0
tbase = tstart; ! ??????????????
local = tbase
if gg = 0 or ocount >= 0 start; ! data or not continuation(z)
again: while sym type = 0 cycle; ! skip redundant terminators
c = cont
cont = ' '; cont = '+' if ocount >= 0
read sym
cont = c
repeat
->skip if sym = '!'; ! comment
this = -1
code atom(0)
if atom1 = comment start
skip: quote = 1
c = cont
read sym and cont = c while sym # nl; ! skip to end of line
quote = 0; symtype = 0
->again
finish
finish
decl = 0; mark = 0
gentype = 0; force = 0
dim = 0; prot err = 0
node = 0; nmax = 0; nmin = rec size+1
order = 1; gmin = max grammar+1
sstype = 0 and ->more if gg # 0; ! continuation
ptype = 0; spec given = 0
stats = stats+1; op('O', lines) if perm = 0
->fail1 if atom1&error # 0; ! first atom faulty
if escape class # 0 start; ! enter the hard way after
g = imp phrase; sstype = -1; ->a3
finish
g = initial(atom1); ! pick up entry point
if g = 0 start; ! invalid first atom
g = initial(0); sstype = 0; ->a3; ! declarator?
finish
if g < 0 start; ! phrase imp
g = g&255
nmax = 1
ar(1)_class = 0; ar(1)_link = 0; ar(1)_sub = imp phrase
finish
gg = gram(g); class = gg&255; sstype = gg>>12&3-1
->a1
act(194): ptype = type; papp = app; pformat = format; ->more
act(196): k =g+1; ->a610
act(188): k = ar(nmax)_sub+1
a610: papp = glink(k)
k = gram(k)
->more if k = 0; ! %name
ptype = k&7; pformat = k>>3
act(183): k = type; gentype = k if gentype = 0 or k = real
if pformat < 0 start; ! general type
app = papp; format = pformat
k = real if ptype = real and type = integer
k = force and force = 0 if force # 0
finish
->fail2 unless papp = app and (ptype = k or ptype = 0)
->more if pformat=format or pformat = 0 or format = 0
->fail2
act(197): arp == ar(nmin)
k = arp_sub
->fail3 unless block form = k&15
arp_sub = k>>4
type = block type
ptype = block type; pformat = block fm; papp = app
pformat = -1 if ptype # record
->more
act(195): ->Fail2 if Type # 0 and Type # Integer and Type # Real
arp == ar(nmin)
k = arp_sub
arp_sub = k>>2
k = k&3
! 1 = check integer
! 2 = check real
! 3 = check real + int
->more if k = 0; ! 0 = no action
if k = 1 start
force = integer
->more if type = integer or type = 0
->fail2
finish
->fail2 unless ptype = real or ptype = 0; ! {or added?}
force = integer if k = 3
->more
act(198): ! %OTHER
k = gg>>8&15
if k = 0 start; ! restore atom
atom1 = last1
->more
finish
if k = 1 start; ! test string
->fail2 unless type = stringv
->more
finish
if k = 2 start; ! {fault record comparisons}
->fail2 if type = record
->more
finish
if k = 3 start; ! check OWN variable coming
code atom(0)
->A7 if atom flags&own bit = 0
->more
finish
for warn = pos1 if x <= local; ! %for TEST
->more
paction(1): if type = record then g = phrase(242) else pformat = -1; ->a3
paction(2): ptype = real; pformat = -1; ->a3
paction(3): ptype = stringv; pformat = -1; ->a3
paction(4): ptype = integer; pformat = -1; ->a3
paction(5): ->a3 if ptype = integer
g = phrase(212) and pformat=-1 if ptype = real
g = phrase(213) if ptype = stringv
->a3
paction(6): ptype = gram(ar(nmax)_sub+1)&7; pformat = -1; ->a3
paction(7): ptype=real if ptype = integer; pformat = -1; ->a3
a1: last1 = class; atom1 = 0; s = subatom
a2: if gg&trans bit = 0 start; ! insert into analysis record
z == node
cycle; ! insert cell in order
k = z
exit if gg&order bits = 0 or k = 0
gg = gg-order bit; z == ar(k)_link
repeat
gg = map gg if map gg # 0 and gg&255 = var
nmin = nmin-1; ->fail0 if nmin = nmax
z = nmin
arp == ar(nmin)
arp_sub = s; arp_class = (gg&255)!mark
arp_link = k
finish
mark = 0; map gg = 0
more: g = glink(g); ! chain down the grammar
paction(0):
a3: gg = gram(g); class = gg&255
trace analysis if diag&1 # 0
->a5 if class = 0; ! end of phrase
if class < actions start; ! not a phrase or an action
class = atomic(class) if class >= figurative
->a2 if class >= manifest
code atom(class) if atom1 = 0
if escape class # 0 start; ! escape to new grammar
class = escape class; escape class = 0
g = g+escape
! note that following an escape the next item is
! forced to be transparent!
esc: gg = 0
arp == ar(nmax+1)
arp_papp = papp; arp_x = x; ->a4
finish
->a1 if class = atom1 or class = atom2
a7: ->fail1 if gg >= 0; ! no alternative
g = g+1
->a3
finish
if class >= phrasal start; ! a phrase
a4: nmax = nmax+1; ->fail0 if nmax = nmin
arp == ar(nmax)
arp_ptype = ptype
arp_pos = pos1
arp_pformat = pformat
arp_link = gentype
arp_class = node
arp_sub = g
node = 0
g = phrase(class)
ptype = force and force = 0 if force # 0
gentype = 0
->paction(gg>>8&15)
finish
->act(class); ! only actions left
a5: ;! reverse links
s = 0
while node # 0 cycle
z == ar(node)_link
k = z; z = s; s = node; node = k
repeat
ss = s
a6: if nmax # 0 start
k = gentype; ! type of phrase
arp == ar(nmax); nmax = nmax-1
node = arp_class
gentype = arp_link
ptype = arp_ptype
pformat = arp_pformat
g = arp_sub
if g&escape # 0 start
g = g-escape
papp = arp_papp
mark = 255
subatom = s
->a3
finish
gentype = k if gentype = 0 or k = real
type = gen type
k = gg; ! exit-point code
cycle
gg = gram(g)
->a2 if k = 0
->fail1 if gg >= 0; ! no alternative phrase
k = k-order bit
g = g+1; ! sideways step
repeat
finish
Fault(4) if copy # 0
fault(13) if order = 0
fault(-4) if for warn # 0
pos1 = 0
fault rate = fault rate-1
return
act(193): gg = 0 and ->a5 unless sym = '=' or sym = '<'; ! cdummy
act(181): atom1 = amap(decl&15); ! dummy
->more
act(182): class = escdec; g = glink(g)!escape; ! an example of ! as an operator
decl = 0; otype = 0; ->esc; ! decl
act(199): ; ! compile
s = 0
while node # 0 cycle
z == ar(node)_link
k = z; z = s; s = node; node = k
repeat
ss = s
code atom(28) if quote # 0; ! expend
compile; ->more if atom1&error = 0
->fail1
act(184): ->fail4 unless type = integer
if subatom < 0 then lit = tag(-subatom)_format else lit = lit pool(subatom)
->fail4 if lit # 0
->more
act(185): ; ! apply parameters
s = 0
while node # 0 cycle
z == ar(node)_link
k = z; z = s; s = node; node = k
repeat
ss = s
atom1 = ar(s)_class; atom2 = 0
atom1 = var if atom1 = 97 or atom1 = 98
arp == ar(nmax)
x = arp_x
pos1 = arp_pos
pos2 = 0
app = 0
format = tag(x)_format
flags = tag(x)_flags
type = flags>>4&7
protection = flags&prot
protection = 0 if flags&aname # 0
if flags&subname # 0 and format # 0 start
->fail1 if format selected = 0
finish
->a6
act(187): protection = prot; ->more; ! %SETPROT
act(186): ->More if protection&prot = 0
prot err = nmin
->A7
act(191): k = protection; ! %GUARD
code atom(0)
protection = k if atom flags&aname = 0
->more
act(192): ->fail1 if parsed machine code=0
->more
act(189): k = gapp; ! %GAPP
delete names(1)
tmax = tbase; tbase = gram (gmin); ! restore tmax
local= tbase
gmin = gmin+1
x = ar(ar(nmax)_class)_sub
tag(x)_app = k; ! update app
->more
act(190): gmin = gmin-1; ! %LOCAL
abandon(2) if gmin <= gmax
gram (gmin) = tbase; tbase = tmax
local = tbase
->more
! errors
fail4: k = error+10; ->failed; ! *size
fail3: k = error+7; ->failed; ! *context
fail2: k = error+5; pos2 = 0; ->failed; ! *type
fail0: k = error+3; ->failed; ! *too complex
fail1: k = atom1; pos2 = 0
failed: if diag&32 # 0 start
printstring("Atom1 ="); write(atom1, 3)
printstring(" Atom2 ="); write(atom2, 3)
printstring(" subatom ="); write(subatom, 3); newline
printstring("Type ="); write(type, 1)
printstring(" Ptype ="); write(ptype, 1); newline
printstring("App ="); write(app, 1)
printstring(" Papp ="); write(papp, 1); newline
printstring("Format ="); write(format, 1)
printstring(" Pformat ="); write(pformat, 1); newline
!%signal 13,15
finish
quote = 0 and readsym while sym # nl and sym # ';'
if k&error # 0 start
fault(k&255)
finish else start
if prot err = nmin then fault(14) else fault(0)
finish
gg = 0; ss = 0; symtype = 0
end; ! of analyse
routine compile
constinteger then = 4, else = 8, loop = 16
switch c(0:actions), litop(1:12)
constbyteintegerarray operator(1:14) = '[', ']', 'X', '/', '&', '!', '%', '+', '-', '*', 'Q', 'x', '.', 'v'
constbyteintegerarray cc(0 : 7) = '#','=',')','<','(','>', 'k','t'
constbyteintegerarray anyform(0:15) = 1,0,1,1,1,1,1,1,0,1,1,0,1,1,1,1
constintegerarray decmap(0:15) = 1, 2,
16_100B, 16_100D, 16_140C, 16_140E,
3, 4,
16_1007, 16_1008, 16_1009, 16_100A,
6, 0, 0, 0
ownbyteintegerarray cnest(0:15)
integer lmode, clab, dupid
integer resln
owninteger last def = 0
owninteger lb, ub
integer cp, ord
integer next, link, j, k, n, done
integer class
integer lit2, defs, decs, cident
integer pending; ownintegerarray pstack(1:40)
ownstring(8) name = ""
owninteger count = 0
routine def lab(integer l)
op(':', l)
access = 1
end
routine get next
record(arfm)name p
gn: if next = 0 start; ! end of phrase
class = 0 and return if link = 0; ! end of statement
p == ar(link)
next = p_link
link = p_sub
finish
cycle
p == ar(next)
x = p_sub
class = p_class
exit if class < actions; ! an atom
if x = 0 start; ! null phrase
next = p_link; ->gn
finish
if p_link # 0 start; ! follow a phrase
p_sub = link; link = next
finish
next = x
repeat
next = p_link
if diag&2 # 0 start
spaces(8-length(name)) unless length(name) = 0
name = text(class)
write(x, 2)
space
printstring(name)
space
count = count-1
if count <= 0 start
count = 5
name = ""
newline
finish
finish
end
routine set subs(integer n)
!update the app field in n array descriptors
integer p
p = tmax
while n > 0 cycle
!%signal 15,15 %if p < tbase
tag(p)_app = dimension
p = p-1; n = n-1
repeat
end
routine set bp
!define a constant bound pair from the last stacked constants
pending = pending-2
lb = pstack(pending+1); ub = pstack(pending+2)
if ub-lb+1 < 0 start
pos1 = 0; next = link; fault(11)
ub = lb
finish
set const(lb); set const(ub)
add char( 'b' ) unless class = 146
end
routine compile end(integer type)
! type = 0:eof, 1:eop, 2:end
if access # 0 start
open = 0
fault(19) if block form > proc; ! can reach end
finish
while dict(dmin) >= 0 cycle; ! finishes & repeats
fault(17+dict(dmin)&1)
dmin = dmin+1
repeat
!{delete names(0)}
add char( ';' )
add char( ';' ) if type = 1; ! endofprogram
bflags = bflags!open; ! show if it returns
def lab(0) if block tag # 0 and level # 1; ! for jump around
if type # 2 start; ! eop, eof
fault(16) if level # type; ! end missing
finish else start
if level = 0 start
fault(15); ! spurious end
finish
finish
end mark = 11; !******Mouses specific******
end
routine def(integer p)
!dump a descriptor
integer t, f, type
record(tagfm)name v
flush buffer( 1 ); ! flush if bp > 0
defs = defs+1
v == tag(p)
t = 0
unless v_index < 0 start; ! no index for subnames
id = id+1 and v_index = id if v_index = 0
last def = v_index
t = last def
finish
op('$', t)
print ident(p, 1); ! output the name
t = v_flags
type = t
type = type&(¬(7<<4)) if type&(7<<4) >= 6<<4; !routine & pred
op(',', type&2_1111111); ! type & form
f = v_format
f = tag(f)_index if t&16_70 = record<<4
f = v_index if f < 0
op(',', f); ! format
f = otype+t>>4&2_1111000
f = f!8 if class = 125; ! add spec from %DUP
dim = v_app; ! dimension
dim = 0 unless 0 < dim and dim <= dim limit
op(',', f+dim<<8); ! otype & spec & prot
defs = 0 if t¶meters = 0
f = t&15
if v_flags&spec # 0 start
v_flags = v_flags&(¬spec) unless 3 <= f and f <= 10
ocount = -1; ! external specs have no constants
finish
dimension = 0
if otype = 2 and (f=2 or f=12 or f=14) start
v_flags = v_flags-1; ! convert to simple
finish
end
routine def s lab(integer n)
! define a switch label, x defines the switch tag
integer p, l, b, w, bit
p = tag(x)_format; ! pointer to table
l = dict(p); ! lower bound
if l <= n and n <= dict(p+1) start
b = n-l
w = b>>4+p
bit = 1<<(b&15)
if dict(w+2)&bit # 0 start; ! already set
fault(4) if pending # 0
return
finish
dict(w+2) = dict(w+2)!bit if pending # 0
set const(n)
op('_', tag(x)_index)
finish else start
fault(12)
finish
access = 1
end
routine call
record(tagfm)name T
t == tag(x)
op('@', t_index)
access = 0 if t_flags&closed # 0; ! never comes back
add char( 'E' ) if t_app = 0; ! no parameters
end
routine pop def
set const(pstack(pending)); pending = pending-1
end
routine pop lit
if pending = 0 then lit = 0 else start
lit = pstack(pending); pending = pending-1
finish
end
!conditions & jumps
routine push(integer x)
if cnest(cp)&2 # x start
cnest(cp) = cnest(cp)!1; x = x+4
finish
clab = clab+1 if cnest(cp)&1 # 0
cnest(cp+1) = x; cp = cp+1
end
routine pop label(integer mode)
lmode = dict(dmin)
if lmode < 0 or lmode&1 # mode start
fault(mode+8)
finish else start
dmin = dmin+1; label = label-3
finish
end
if sstype < 0 start; ! executable statement
if level = 0 start; ! outermost level
fault(13); ! *order
finish else start
if access = 0 start
access = 1; fault(-1); ! only a warning
finish
finish
finish
if diag&2 # 0 start
newline if sym # nl
printstring("ss =")
write(ss, 1)
newline
count = 5
name = ""
finish
next = ss
pending = 0; lmode = 0
link = 0; decs = 0
defs = 0; resln = 0; done = 0
ord = level
ord = 1 if this >= 0; ! recordformat declarations
c(0):
top: if next # link start
get next; ->c(class)
finish
!all done, tidy up declarations and jumps
newline if diag&2 # 0 and count # 5
if lmode&(loop!then!else) # 0 start; ! pending labels and jumps
op('B', label-1) if lmode&loop # 0; ! repeat
def lab(label) if lmode&then # 0; ! entry from then
def lab(label-1) if lmode&else # 0; ! entry from else
finish
return if decs = 0
atom1 = error and return if atom1 # 0; ! %integerroutine
order = ord
decl = decl&(¬15)+decmap(decl&15); ! construct declarator flags
atom1 = atoms(decl&15); ! generate class
if otype # 0 start; ! own, const etc.
atom1 = atom1+1 if atom1 # proc
if otype = 2 start; ! const
n = decl&15
if n&1 # 0 start
decl = decl!prot
decl = decl!const bit if decl&2_1111111 = iform
finish
else
decl = decl!own bit
finish
finish
sstype = 1 if sstype = 0 and atom1 = proc
atom1 = atom1+1 if decl&spec # 0; ! onto spec variant
ocount = 0 and cont = '+' if atom1 = 5; ! own array
if anyform(decl&15) = 0 start; ! check meaningful
if decl>>4&7 = record start
this = fdef if tag(fdef)_flags&spec # 0
atom1 = error+21 if fdef = this; ! *context for format
finish
atom1 = error+10 if fdef = 0; ! *size
finish
return
atop: access = 0; ->top
! declarators
c(88): ; ! rtype
c(28): decl = x&(¬7); ! stype
fdef = x&7; ! precision
fdef = reals ln if x&2_1110001 = real<<4+1; ! convert to long
decs = 1; ->top
c(34): ; ! own
c(35): otype = x; ord = 1; ->top; ! external
c(152): decl = decl+x<<1; ->top; ! xname
c(31): ; ! proc
c(32): spec mode = level+1; ! fn/map
decl = decl!prot if x = 9; ! function
c(29): ord = 1; ! array
dim = 0
c(30): decl = decl+x; ! name
decs = 1
->top
c(27): lit = 0; ! arrayd
if pending # 0 start
pop lit
unless 0<lit and lit<=dim limit start
atom1 = error + 11; return
finish
finish
dim = lit
decl = decl + x; decs = 1
-> top
c(37): x = x!subname; ! record
c(36): lit = 0; ! string
if pending # 0 start
pop lit
unless 0 < lit and lit <= 255 start; ! max length wrong
atom1 = error+10; return
finish
finish
fdef = lit; ! format or length
c(33): decl = x; ! switch
decs = 1
->top
c(39): decl = decl!spec; ! spec
ocount = -1; ! no initialisation
spec mode = -1
->top
c(38): decl = 64+4; ! recordformat (spec)
order = 1
atom1 = x
decl = decl!spec if atom1 = 12; ! formatspec
fdef = tmax+1; ! format tag
return
c(175): id = id+1; tag(x)_index = id; return; ! FSID
c(41): decs = 1; decl = x!spec!closed; ->top; ! label
c(133): recid = 0; rbase = tmin-1; ! fname
this = x
fm base = fdef; format list = tmin
def(this); ->top
c(148): fdef = 0 and ->top if next = 0; ! reclb
get next; ! skip name
fdef = x
->top
c(127): add char( '}' ); ->top; ! %POUT
c(126): add char( '{' ); ->top; ! %PIN
c(174): set bp; ! rangerb
c(171): ; ! fmlb
c(172): ; ! fmrb
c(173): add char( '~' )
add char( class-171+'A' ); ->top; ! fmor
c(168): rbase = -rbase; ! orrb
sstype = 0; spec mode = 0
c(147): search base = 0; ! recrb
tag(this)_app = tmin
tag(this)_format = rbase
->top
c(45): add char( 'U' ) if x = 36; ->top; ! sign
c(46): add char( '¬' ); ->top; ! uop
c(47):; ! mod
c(48):; ! dot
c(42):; ! op1
c(43):; ! op2
c(44): add char( operator(x) ); ->top; ! op3
c(56): ; ! and
c(57): push(x); ->top; ! or
c(58): cnest(cp) = cnest(cp)!!2; ->top; ! not
c(138): x = 128+32+16+4; ! csep: treat like %while
c(59): ; ! while
c(60): if class = 138 then op('f', label-1) else def lab(label-1); ! until
c(166): ; ! runtil
c(62): lmode = (lmode&(else!loop)) !(x>>3); ! cword
clab = label; cp = 1; cnest(1) = x&7
->top
c(72): pop label(0); ! repeat
def lab(label+1) if lmode&32 # 0; ->atop
c(69): pop label(1); ->top; ! finish
c(163): ; ! xelse
c(70): pop label(1); ! finish else ...
fault(7) if lmode&3 = 3; ! dangling else
c(68): lmode = (lmode&else)!3; ! ...else...
if access # 0 start
op('F', label-1); lmode = else!3
finish
def lab(label)
->top if next # 0
c(120): ; ! MSTART
c(67): ; ! start
c(71): ; ! cycle
stcy: def lab(label-1) and lmode = loop if lmode = 0; ! cycle
dmin = dmin-1; abandon(3) if dmin <= dmax
dict(dmin) = lmode
label = label+3
return
c(64): fault(13) if dict(dmin) >= 0 or inhibit # 0; ! on event
inhibit = 1
n = 0
n = 16_FFFF if pending = 0; ! * = all events
while pending > 0 cycle
pop lit; fault(10) if lit&(¬15) # 0; ! too big
j = 1<<lit
dubious = 1 if n&j # 0
n = n!j; ! construct bit mask
repeat
op('o', n); op(',', label)
lmode = then!1; ->stcy
c(104): op('J', tag(x)_index); ! l
inhibit = 1; ->atop
c(149): stats = stats-1; ! lab
access = 1; inhibit = 1
op('L', tag(x)_index); ->top
c(63): j = dmin; l = label-3; ! exit, continue
cycle
fault(7) and ->top if dict(j) < 0
exit if dict(j)&1 = 0
j = j+1; l = l-3
repeat
l = l+1 if x = 32; ! continue
op('F', l)
dict(j) = dict(j)!x; ! show given
->atop
c(50): add char( 'C' ); ->cop; ! acomp
c(49):
if next # 0 start; ! comparator
add char( '"' )
push(0); ! double sided
finish else start
add char( '?' )
finish
cop: x = x!!1 if cnest(cp)&2 # 0; ! invert the condition
j = cp; l = clab
while cnest(j)&4 = 0 cycle
j = j-1; l = l-cnest(j)&1
repeat
op(cc(x), l)
def lab(clab+1) if cnest(cp)&1 # 0
cp = cp-1
clab = clab-cnest(cp)&1
->top
c(78): ; ! fresult
c(79): ; ! mresult
c(80): open = 0; ! return, true, false
c(82): access = 0; ! stop
c(89): ; ! addop
c(81): add char( x ); ->top; ! monitor
c(65): pop lit; op('e', lit); ->atop; ! signal
c(51): add char( 'S' ); ->top; ! eq
c(53): add char( 'j' ); ->top; ! jam transfer
c(52): add char( 'Z' ); ->top; ! eqeq
c(74): if level = 0 start; ! begin
if progmode <= 0 then progmode = 1 else fault(7)
!{Permit BEGIN after external defs}
finish
spec mode = level+1
block x = 0
add char( 'H' )
return
c(77): perm = 0; lines = 0; stats = 0; ! endofperm
close input
select input(source)
list = list-1
tbase = tmax; tstart = tmax
return
c(76): if include # 0 and x = 0 start; ! end of ...
lines = include; sstype = 0; ! include
close input
list = include list
include level = 0
include = 0; select input(source); return
finish
ss = -1; ! prog/file
c(75): compile end(x); return; ! %end
c(85): if x=0 then control=lit else start; ! control
diag = lit&16_3FFF if lit>>14&3 = 1
finish
op('z'-x, lit)
->top
c(83): list = list+x-2; ->top; ! %LIST/%endoflist
c(84): reals ln = x; ->top; ! %REALS long/normal
c(86): if include # 0 start; ! include "file"
fault(7); return
finish
get next; ! sconst
x = x-16_4000
j = glink(x)
k = j&255
!ABD - another little copy loop because SKIMP can't do the string map
include file = ""
cycle
k = k-1; exit if k < 0
include file = include file.tostring(j>>8)
x = x+1
j = glink(x)
k = k-1; exit if k < 0
include file = include file.tostring(j&255)
repeat
! include file = string(x-16_4000+stbase)
! remove this event block for SKIMP or pre-event IMP versions
begin
on 9 start; Abandon(9); finish
open input(3, include file)
end
include = lines; lines = 0
include list = list; include level = level
select input(3)
->top
c(154): dimension = dimension+1; ! dbsep
fault(11) if dimension = dim limit+1
->top
c(145): set bp; ->top; ! crb
c(146): set bp; ! rcrb
c(142): ; ! bplrb
dimension = 1 if dimension = 0
op('d', dimension); op(',', defs)
if class # 146 start
set subs(defs)
fault(13) if dict(dmin) >= 0 or inhibit # 0 or level=0
finish
dimension = 0; defs = 0
->top
c(128): id = dupid; ->top; ! EDUP
c(130): block x = x
op('F', 0) if decl&spec = 0 and level # 0; ! jump round proc
c(125): dupid = id; ! %DUP
return if Level < 0; ! {spec about}
c(90): def(x); ->top; ! ident
c(131): ; ! cident
if tag(x)_flags&(2_1111111+const bit) = iform+const bit start
tag(x)_format = lit
finish else start
set const(lit) if pending # 0
def(x)
op('A', 1)
finish
cident = x
->top
c(124): dubious = 1 if tag(cident)_flags&prot # 0; ! %DUBIOUS
->top
c(97): ; ! f
c(98): ; ! m
c(99): ; ! p
c(96): call; ->top; ! r
c(165): ; ! nlab
c(100): ; ! rp
c(101): ; ! fp
c(102): ; ! mp
c(103): ; ! pp
c(91): ; ! v
c(92): ; ! n
c(106): ; ! a
c(107): ; ! an
c(108): ; ! na
c(109): ; ! nan
k = tag(x)_index
if k < 0 then op('n', -k) else op('@', k)
->top
c(121): set const(0); ->top; ! special for zero
c(167): add char( 'G' ); ->pstr; ! aconst (alias)
c(const): ; ! const
if x < 0 start; ! constinteger
set const(tag(-x)_format); ->top
finish
if x&16_4000 # 0 start; ! strings
add char( '''' )
pstr: x = x-16_4000
j = glink(x)
k = j&255
add char( k )
cycle
k = k-1; ->top if k < 0
add char( j>>8 );
x = x+1
j = glink(x)
k = k-1; ->top if k < 0
add char( j&255 )
repeat
finish
if x&16_2000 # 0 start; ! real - ABD also string-like, but NOT packed
x = x-16_2000
k = glink(x)
op('D', k); add char( ',' )
cycle
->top if k = 0
k = k-1
x = x+1; j = glink(x)
if j = '@' start
op('@', litpool(glink(x+1))); ->top
finish
add char( j )
repeat
finish
set const(lit pool(x))
->top
c(137): add char( 'i' ); ->top; ! asep
c(141): add char( 'a' ); ->top; ! arb
!own arrays
c(132): ocount = ub-lb+1
def(x); ! oident
dimension = 1; set subs(1)
if next = 0 start; ! no initialisation
op('A', ocount) if ocount > 0
ocount = -1
finish else start; ! initialisation given
get next
finish
->top
c(162): lit = ocount; ->ins; ! indef
c(143): pop lit; ! orb
ins: fault(10) and lit = 0 if lit < 0
get next
->inst
c(139): ; ! osep (x=19)
c(153): lit = 1
inst: pop def if pending # 0; ! ownt (x=0)
op('A', lit)
ocount = ocount-lit
if ocount >= 0 start
->top if x # 0; ! more coming
ocount = -1 and return if ocount = 0; ! all done
finish
fault(11); return
c(swit): op('W', tag(x)_index); inhibit = 1; ->atop
c(134): def(x); ! swid
n = ub-lb+1
n = (n+15)>>4; ! slots needed (includes zero)
j = dmax; dmax = dmax+n+2
abandon(1) if dmax >= dmin
tag(x)_format = j
dict(j) = lb; dict(j+1) = ub
cycle
n = n-1
->top if n < 0
j = j+1; dict(j+1) = 0
repeat
c(151): stats = stats-1; ! slab
fault(7) and return if x < tbase
if pending # 0 start; ! explicit label
def s lab(pstack(1))
finish else start
fault(4) and return if tag(x)_app # 0
tag(x)_app = 1
n = tag(x)_format
for j = dict(n), 1, dict(n+1) cycle
def s lab(j)
flush buffer( 128 ); ! flush if bp >= 128
repeat
finish
inhibit = 1
return
c(140): add char( 'p' ); ->top; ! psep
c(144): ; ! prb
add char( 'p' );
add char( 'E' ); ->top
!constant expressions
c(155): ; ! pconst
if x < 0 then lit = tag(-x)_format else lit = lit pool(x)
pending = pending+1; pstack(pending) = lit; ->top
c(156): lit = pstack(pending); lit = -lit if lit < 0
pstack(pending) = lit; ->top; !cmod
c(157): lit = -pstack(pending); pstack(pending) = lit; ->top; ! csign
c(158): lit = ¬pstack(pending); pstack(pending) = lit; ->top; ! cuop
c(159): ; ! cop1
c(160): ; ! cop2
c(161): pending = pending-1; ! cop3
lit2 = pstack(pending+1); lit = pstack(pending)
->litop(x>>2)
litop(1): lit = lit<<lit2; ->setl
litop(2): lit = lit>>lit2; ->setl
litop(3): n = 1; ! lit = lit¬¬lit2
fault(10) if lit2 < 0
while lit2 > 0 cycle
lit2 = lit2-1
n = n*lit
repeat
lit = n; ->setl
litop(4): if lit2 = 0 then fault(10) else lit = lit//lit2
->setl
litop(5): lit = lit&lit2; ->setl
litop(6): lit = lit!lit2; ->setl
litop(7): lit = lit!!lit2; ->setl
litop(8): lit = lit+lit2; ->setl
litop(9): lit = lit-lit2; ->setl
litop(10): lit = lit*lit2; ->setl
litop(11): lit = lit+lit2; ->setl
litop(12): n = 1; ! lit = lit¬¬lit2
fault(10) if lit2 < 0
while lit2 > 0 cycle
lit2 = lit2-1
n = n*lit
repeat
lit = n; ->setl
setl: pstack(pending) = lit; ->top
c(170): ;
!Fault(4) %if IMPCOM_Option # ""
!IMPCOM_Option = String(x-x'4000'+Stbase); ! Option string
->Top
!string resolution
c(135): resln = 2; ->top; ! dotl
c(136): resln = resln+1; ->top; ! dotr
c(55): op('r', resln); resln = 0; ->top; ! resop
c(164): op('r', resln+4); resln = 0; ! cresop
c(122): x = 6; ->cop; ! %PRED
c(87): set const(pstack(1)); ! mass
bp=bp+1 and buff(bp)='P'; ->top
end
end; ! of compile block
on 9 start
abandon(5)
finish
selectinput(2); selectoutput(listing)
tag(max tag) = 0; ! %begin defn
tag(0) = 0; tag(0)_flags = 7; ! %begin tag!
Hash(x) = 0 for x = 0, 1, max names
printstring(" Edinburgh IMP77 Compiler - Version ")
! printstring(" Preston IMP2020 Compiler - Version ")
printstring(version); newlines(2)
op('l', 0)
compile block(0, 0, max dict, 0, 0)
add char( nl ); ! {for bouncing off}
flush buffer( 0 ); ! flush if bp >= 0
x = listing
newline
cycle
if faulty = 0 start
write(stats, 5)
printstring(" Statements compiled")
else
printstring(" Program contains ")
write(faulty, 1)
printstring(" fault")
printsymbol('s') unless faulty = 1
finish
newline
exit if x = report
x = report
selectoutput(report)
repeat
if faulty # 0 then stop; ! try to flag to shell that we failed
endofprogram