EXTERNALROUTINE CHECKINNER(INTEGER FSTART,FSIZE, INTEGERNAME PARM)
!%EXTERNALLONGREALFNSPEC CPUTIME
LONGREAL TIME1,TIME2
!
!DECLARATION CODES
CONSTINTEGER STRINGBIT=X'80', REALBITS=X'30', INTBIT=X'40'
CONSTINTEGER NUMBITS=X'70'
CONSTINTEGER APPMASK=X'FF00'
CONSTINTEGER EXP=1, FN=2
CONSTINTEGER RECFORMAT=4, ROUTINE=6
CONSTINTEGER REF=8, VAR=9, MAP=10
CONSTINTEGER LAB=12, JUMPLAB=13
CONSTINTEGER SWITCH=X'10C'
CONSTINTEGER IMP1MODES=B'01000011111111000000000000000000'
CONSTINTEGER IMPMODES =B'01000011111100000000000000000000'
CONSTINTEGER DESTMODES=B'00000000111100000000000000000000'
CONSTINTEGER ADRMODES =B'01000000111100000000000000000000'
CONSTINTEGER EXPMODES =B'11110000111100000000000000000000'
CONSTINTEGER FMATMODES=B'00001000000000000000000000000000'
!SYMBOL INIT CODES
! USED EXPLICITLY
! SPACE=0, DIGIT:ISO, LETTER:ISO, QUOTE=127
! PC=128, PCLET OR PUNCT: 128 + KEYDICT INDEX
! KEYDICT INDEX >= PUNCTMIN FOR PUNCT
! KEYDICT INDEX >= SKIP1MIN FOR ! * SEMICOLON NL
CONSTINTEGER NLCODE=127; !MASKED FROM 255 ACTUAL
!ATOM CODES
CONSTINTEGER IDENT=1, CONST=2, LB=11, COMMA=10, RB=12
CONSTINTEGER TERMINATOR=13, JUMP=15
CONSTINTEGER OP3=6, START=53, CYCLE=54
! VERTICAL BAR
CONSTINTEGER MARKER=124
OWNINTEGER STATS=0, ATOMS=-54, IDENTIFIERS=-54, NUMBERS=0, LOOPS=0
OWNINTEGER LOOKS=1, TIMES=1
INTEGER I,J
INTEGER LINEBASE; !BASE FOR SOURCE LINE (POINTER)
INTEGER FPOS; !CURRENT POSITION IN SOURCE (POINTER)
INTEGER FPOS1; !START OF CURRENT ATOM (POINTER)
INTEGER PRINTPOS; !'LINE-ALREADY-PRINTED' INDIC
INTEGER LINE; !CURRENT LINE NUMBER
INTEGER NEXTLINE
INTEGER FMAX; !LAST BYTE IN SOURCE (POINTER)
INTEGER FAULTNUM; !FAULTY NUMBER
INTEGER FAULTPOS; !FAULTY ATOM POSITION (POINTER)
INTEGER SYMCODE; !SYMBOL CODE FOR CURRENT SYMBOL
INTEGER SKIPMIN; !=SKIP1MIN OR NLCODE
!%INTEGER GG; !=GRAM(G)
INTEGER CLASS; !GRAMMAR CLASS
INTEGER G; !INDEX TO GRAM
INTEGER ATOM; !ATOM CODE FOR CURRENT ATOM
INTEGER ATOMTYPE; !TYPE FOR CURREMT ATOM
INTEGER ATOMVAL; !'VALUE' FOR CURRENT ATOM
INTEGER DECLTYPE; !DECLARATION TYPE
INTEGER MODES; !BIT VECTOR FOR PERMISSIBLE IDENT MODES
INTEGER DIMCOUNT; !DIMENSION COUNT
INTEGER CONSTCOUNT; !CONSTANT COUNT (DOWN)
INTEGER STRINGSIZE
INTEGER PRECISION
INTEGER LASTTYPE,LASTVAL
INTEGER TYPE,VAL
INTEGER NP; !NEST POINTER (INDEX TO NTYPE,NVAL)
INTEGERARRAY NTYPE,NVAL(1:50); !NEST
INTEGER LINKMAX; !GRAMMAR STACK MAX (INDEX TO LINK)
INTEGERARRAY LINK(1:20); !GRAMMAR CONTROL STACK
RECORDFORMAT BLOCKINF(INTEGER STACK,LOCAL,BTYPE)
INTEGER LEVEL; !CURRENT BLOCK LEVEL (MAIN=1)
RECORD(BLOCKINF) C; !INFO FOR CURRENT BLOCK
RECORD(BLOCKINF)ARRAY HOLD(1:12); !INFO FOR GLOBAL BLOCKS
INTEGERARRAY INDEX(0:255); !HASH INDEX TO IDENT DICT
INTEGERNAME HEAD; !HEAD OF IDENT SEARCH LIST
INTEGER DPOS; !DICT SEARCH POSITION (POINTER)
INTEGER DLIM; !DICT LIMIT (POINTER)
INTEGER NEWDLIM
INTEGER DBOUND; !DICT UPPER LIMIT (POINTER);
INTEGER IDENTS; !POS OF FIRST IDENT IN DECL LIST (POINTER)
INTEGER RECIDENTS; !POS OF FIRST IDENT IN RECORD LIST (POINTER)
INTEGER PIDENTPOS; !POS OF PROCEDURE IDENT (POINTER)
INTEGER FIDENTPOS; !POS OF FORMAT IDENT (POINTER)
INTEGER EXTIND; !SET BY %EXTERNAL
INTEGER CONDIND; !SET FOR START,CYCLE
INTEGER PARMAX; !CURRENT MAX IN PARTYPE
INTEGER ADGRAM0, LINK1; !PRE-COMPUTED GRAMMAR VALUES
INTEGER APPCONT
OWNINTEGERARRAY PARTYPE(0:255) = 0,
X'00000069', X'01000069', X'02000069', X'03000069',
X'04000069', X'05000069', X'00000029', X'01000029',
X'00000089', X'00000088', X'000000F8', X'02000029',
X'07000029', X'01000088', X'02000088', 0(236),
X'FD000069', X'FE0001F8', X'00000000', X'FF000069'
INTEGERARRAY DICT(1:4000)
!* GRAMMAR AND KEYWORD DICTIONARY GENERATED BY TAKEON PROGRAM
CONSTINTEGER PUNCTMIN = 43, SKIP1MIN = 86
CONSTBYTEINTEGERARRAY SYMINIT( 0: 255) = C
129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 255, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129,
0, 217, 127, 171, 129, 128, 173, 127,
175, 178, 214, 180, 182, 184, 187, 189,
48, 49, 50, 51, 52, 53, 54, 55,
56, 57, 192, 221, 194, 200, 203, 129,
129, 65, 66, 67, 68, 69, 70, 71,
72, 73, 74, 75, 76, 77, 78, 79,
80, 81, 82, 83, 84, 85, 86, 87,
88, 89, 90, 129, 207, 129, 210, 212,
129, 65, 66, 67, 68, 69, 70, 71,
72, 73, 74, 75, 76, 77, 78, 79,
80, 81, 82, 83, 84, 85, 86, 87,
88, 89, 90, 129, 207, 129, 210, 212,
129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 255, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129,
0, 217, 127, 171, 129, 128, 173, 127,
175, 178, 214, 180, 182, 184, 187, 189,
48, 49, 50, 51, 52, 53, 54, 55,
56, 57, 192, 221, 194, 200, 203, 129,
129, 130, 132, 134, 138, 139, 142, 129,
129, 146, 129, 129, 148, 150, 152, 154,
157, 158, 159, 161, 167, 169, 129, 170,
129, 129, 129, 129, 207, 129, 210, 212,
129, 130, 132, 134, 138, 139, 142, 129,
129, 146, 129, 129, 148, 150, 152, 154,
157, 158, 159, 161, 167, 169, 129, 170,
129, 129, 129, 129, 207, 129, 210, 212
CONSTSHORTINTEGERARRAY KEYDICT( 0: 487) = C
0, 5,-26642, 6194,-26523, 6329,-26385,-26247, 0, 0,
6585,-26132,-26066, 6776,-25887,-25815,-25746, 7151,-25562, 7342,
-25367, 7471,-25247, 7599,-25119, 7727,-24978,-24782, 8119, 8178,
8245,-24475, 8687,-24024,-23959,-23888,-23820,-23625, 9209,-23512,
9330, 9390, 9512, 512, 240, 320, 64,-23231, 704, 0,
786, 0, 384, 113, 640, 0,-23074, 384, 114, 384,
128,-22961, 320, 48, 1600, 1,-22835,-22692,-22563,-22434,
512, 240,-22307, 576, 240,-22179,-22050, 512, 240,-21923,
448, 68, 448, 68, 192, 0,-21814, 320, 112,-21695,
-21559, 384, 67, 832, 1, 11364, 11506, 11559, 11636,-21075,
11758, 11875, 11950, 12019, 12068,-20503, 12340, 12469, 12526, 2496,
11, 12594, 1664, 3, 12788, 12851, 12910, 12976, 13102, 13165,
13236,-19419, 3264, 1, 2816, 0, 13422, 13545, 13601,-19103,
-19037,-18969,-18896,-18829, 14004, 14069, 14127, 14183, 14245,-18463,
-18385, 14450, 14505, 14579, 14629, 14709,-18004, 14836, 14889, 3008,
0, 960, 0, 320, 64, 576, 0, 256, 64, 512,
240, 256, 64, 896, 0, 512, 240, 256, 64, 512,
240, 256, 112, 384, 68, 3072, 0, 2752, 0, 14945,
15017, 15077, 15149,-17549, 15284, 15340, 15393, 15461,-17169, 3712,
0, 15668,-16987, 15858, 15916, 15977,-16723, 3136, 0, 16101,
16180, 16295, 2496, 3, 16425, 16485, 2880, 0, 16630, 2048,
0, 16686, 16740, 16812, 17007, 17065, 17125, 17205, 17269, 17332,
17394, 17454, 17507, 17650, 17712, 17833, 17908, 17972, 18030, 18163,
18213, 18281, 18348, 18425, 18606, 18729, 18789, 18868, 18994, 19045,
19181, 3328, 1, 19238, 1024, 2, 19442, 19497, 19572, 19699,
19745, 19815, 1280, 0,-12887, 19954, 20020, 2240, 1, 20069,
20148, 20210,-12493, 1984, 25, 20402, 20467, 20513, 20588, 20658,
20713, 20788, 20897, 2624, 1, 20980, 1024, 0, 21102, 21155,
21221, 3200, 0, 21300, 21363, 21420, 21541,-11090, 2112, 256,
3648, 0, 21742, 21806, 2048, 8, 21871, 3456, 2, 21929,
-10778,-10708, 22128, 22190, 22254, 1472, 0, 22312, 22452, 22565,
22638, 22693, 22767, 22830, 22900, 22949, -9748, 23086, 23140, 23284,
23348, 23476, 23598, 23726, -8983, 23858, 23916, 3392, 1, 24039,
24168, 24301, 24421, 24499, 1728, 0, 1728, 0, 24609, 24692,
24756, 24876, 24995, 25129, 25193, 25266, 25313, 25395, 3520, 1,
2368, 0, 25458, 25588, 25633, 25714, 25908, 26021, 26081, 26159,
26223, 2304, 9, 26277, 3584, 0, 1088, 0, 1024, 1,
26341, 26478, 26543, 1152, 0, 2176, 137, 1920, 268, 2688,
0, 26596, 1664, 3, 26669, 26725, 0, 2, 1344, 0,
2688, 0, 26796, 26867, 26927, 26988, 27113, 1984, 105, 27173,
27244, -5389, 1152, 0, 3264, 1, 27448, 27500, 27630, 27698,
27762, 2560, 6, 27892, 27957, 28016, 28069, 28199, 28261, 28404,
28519, 2432, 0, 28579, 28711, 1984, 41, 28788, 28852, 1984,
57, 28967, 29101, 1856, 121, 29157, 29236, 29298, 2240, -255,
29349, 3776, 0, 1280, 0, 29426, 2048, 0, 29477, 29551,
1216, 0, 1408, 32, 29601, 29671, 29737, 29807, 29874, 29985,
30066, 30192, 30316, 30437, 30510, 30567, 1984, 73, 30637, 1984,
121, 1024, 0, 1408, 0, 30770, 30885, 31026, 3776, 1,
1984, 89, 1280, 0, 31073, 31149, 1280, 0
CONSTSHORTINTEGERARRAY PHRASE( 109: 126) = C
257, 249, 368, 430, 264, 269, 286, 298, 335, 345,
0, 452, 237, 374, 381, 0, 420, 437
CONSTINTEGER INITBASE = 472
{%CONST}OWNSHORTINTEGERARRAY GRAM( 0: 531) = C
66, 4084, 4511, 4898, 5028, 6440, 64, 7071, 7330, 5028,
64, 11553, 1955, 11685, 11945, 12273, 12321, 2467, 6439, 5617,
12429, 2996, 64, 5786, 5557, 5620, 2157, 12575, 12834, 6440,
64, 12954, 12955, 6961, 64, 13089, 6439, 5489, 4589, 13345,
1955, 12273, 7433, 12429, 64, 6005, 7602, 5557, 64, 7925,
13569, 13737, 64, 12429, 5630, 13089, 5489, 7149, 8257, 5557,
14068, 3250, 5558, 64, 8442, 8538, 4746, 12429, 64, 9042,
9200, 8963, 14217, 14350, 14479, 14617, 9927, 12429, 14763, 66,
14970, 15098, 15489, 64, 15729, 16129, 64, 8062, 16378, 5576,
12274, 16769, 64, 16897, 64, 5614, 5618, 69, 6439, 64,
12653, 5621, 17281, 64, 17409, 64, 17612, 13569, 64, 3124,
64, 18154, 18287, 9976, 9956, 116, 5599, 15199, 10378, 18319,
64, 18636, 15859, 10762, 12429, 64, 18897, 16479, 11274, 5557,
64, 19021, 17105, 17155, 12239, 19276, 19788, 17736, 19851, 19981,
64, 20218, 9964, 20225, 64, 20363, 64, 17616, 20619, 64,
19443, 22409, 12429, 64, 12275, 22905, 89, 9963, 23126, 23554,
64, 20806, 21279, 22306, 21796, 64, 23809, 24609, 24867, 64,
25089, 25889, 24867, 64, 21357, 22593, 26125, 26362, 26881, 64,
23242, 10378, 12429, 64, 5516, 64, 24014, 24330, 5516, 64,
23809, 20806, 27649, 64, 23809, 64, 25294, 28682, 25582, 20618,
5516, 64, 28929, 64, 22724, 26458, 22538, 29067, 29197, 64,
27084, 27402, 17804, 22905, 26881, 22905, 27854, 24586, 28147, 28426,
5516, 64, 27649, 20806, 25089, 64, 29390, 29562, 91, 25459,
29663, 29836, 64, 30046, 22538, 29197, 64, 30534, 31135, 31522,
31652, 40, 31691, 35, 39, 66, 31213, 35, 64, 32139,
64, 32385, 64, 32597, 32780, 64, 88, 33163, 66, 33402,
33503, 33676, 64, 98, 34049, 64, 34252, 33802, 66, 34597,
34801, 34955, 64, 35194, 35296, 35481, 64, 35677, 35834, 35936,
34954, 36236, 64, 36444, 34570, 66, 36875, 64, 37114, 37215,
37401, 64, 37608, 37754, 37855, 38028, 64, 99, 39937, 40847,
41104, 39569, 39058, 41363, 64, 41602, 12429, 14763, 66, 41737,
41870, 64, 40147, 40304, 40067, 14217, 14350, 14479, 9927, 41985,
64, 12429, 66, 42114, 64, 41184, 42346, 42479, 42582, 9953,
42746, 41196, 42864, 41195, 41162, 43126, 43520, 43691, 43820, 66,
67, 44022, 43382, 43691, 66, 44939, 44538, 45448, 45577, 45711,
67, 45173, 45824, 12, 64, 46202, 45544, 120, 46604, 64,
46313, 46728, 46857, 66, 44539, 47098, 46824, 105, 47361, 64,
47569, 47728, 47491, 66, 49281, 48770, 50182, 50311, 50443, 50607,
64, 50308, 50693, 51078, 66, 49492, 49648, 49411, 50308, 50693,
51078, 66, 51302, 51453, 51578, 51834, 50941, 51972, 49001, 52200,
52733, 48873, 48780, 64, 48816, 64, 52861, 52349, 52868, 52997,
49129, 52327, 50921, 53501, 53245, 53508, 52457, 52329, 53757, 53225,
54401, 2, 54539, 54703, 64, 47572, 45306, 54906, 48, 64,
55307, 66, 55546, 55615, 55306, 12, 64, 56175, 56288, 56457,
64, 56641, 56826, 56928, 57098, 64, 57338, 57440, 57610, 64,
57850, 96, 58057, 58251, 58479, 58618, 58721, 58977, 59142, 64,
59276, 64, 59621, 59782, 64, 58251, 64, 60005, 60143, 60257,
59142, 66, 0, 8833, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 40847, 41104, 39569,
39058, 41363, 5524, 10261, 5526, 10391, 0, 0, 5786, 6299,
0, 10525, 10782, 2079, 928, 0, 3362, 0, 1444, 0,
294, 0, 6440, 10921, 3498, 0, 0, 0, 0, 0,
0, 11185, 0, 11315, 0, 0, 6838, 2615, 5560, 11449,
5562, 59
!!END OF GENERATED SECTION
{%CONST}OWNBYTEINTEGERARRAY PERM(1:518) = C
'A','D','D','R',':',X'0B',X'62',
'A','R','C','C','O','S',':',X'07',X'22',
'A','R','C','S','I','N',':',X'07',X'22',
'A','R','R','A','Y',':',X'FC',X'F8',
'A','R','C','T','A','N',':',X'0D',X'22',
'B','Y','T','E','I','N','T','E','G','E','R',':',X'01',X'4A',
'C','H','A','R','N','O',':',X'0E',X'4A',
'C','L','O','S','E','S','T','R','E','A','M',':',X'01',X'06',
'C','O','S',':',X'07',X'22',
'E','X','P',':',X'07',X'22',
'F','R','A','C','P','T',':',X'07',X'22',
'F','R','O','M','S','T','R','I','N','G',':',X'0F',X'82',
'I','M','O','D',':',X'01',X'62',
'I','N','T',':',X'07',X'62',
'I','N','T','P','T',':',X'07',X'62',
'I','N','T','E','G','E','R',':',X'01',X'6A',
'L','E','N','G','T','H',':',X'0A',X'4A',
'L','O','G',':',X'07',X'22',
'L','O','N','G','R','E','A','L',':',X'01',X'1A',
'M','O','D',':',X'07',X'22',
'N','E','W','L','I','N','E',':',X'00',X'06',
'N','E','W','L','I','N','E','S',':',X'01',X'06',
'N','E','W','P','A','G','E',':',X'00',X'06',
'N','E','X','T','I','T','E','M',':',X'00',X'82',
'N','E','X','T','C','H',':',X'00',X'62',
'N','E','X','T','S','Y','M','B','O','L',':',X'00',X'62',
'N','L',':',X'00',X'62',
'P','I',':',X'00',X'22',
'P','R','I','N','T',':',X'0C',X'06',
'P','R','I','N','T','C','H',':',X'01',X'06',
'P','R','I','N','T','F','L',':',X'08',X'06',
'P','R','I','N','T','S','T','R','I','N','G',':',X'09',X'06',
'P','R','I','N','T','S','Y','M','B','O','L',':',X'01',X'06',
'R','A','D','I','U','S',':',X'0D',X'22',
'R','E','A','D',':',X'0B',X'06',
'R','E','A','D','C','H',':',X'0B',X'06',
'R','E','A','D','I','T','E','M',':',X'0A',X'06',
'R','E','A','D','S','T','R','I','N','G',':',X'0A',X'06',
'R','E','A','D','S','Y','M','B','O','L',':',X'0B',X'06',
'R','E','A','L',':',X'01',X'1A',
'R','E','C','O','R','D',':',X'01',X'0A',
'S','E','L','E','C','T','I','N','P','U','T',':',X'01',X'06',
'S','E','L','E','C','T','O','U','T','P','U','T',':',X'01',X'06',
'S','E','T','M','A','R','G','I','N','S',':',X'03',X'06',
'S','H','O','R','T','I','N','T','E','G','E','R',':',X'01',X'5A',
'S','I','N',':',X'07',X'22',
'S','K','I','P','S','Y','M','B','O','L',':',X'00',X'06',
'S','P','A','C','E',':',X'00',X'06',
'S','P','A','C','E','S',':',X'01',X'06',
'S','Q','R','T',':',X'07',X'22',
'S','T','R','I','N','G',':',X'01',X'8A',
'T','A','N',':',X'07',X'22',
'T','O','S','T','R','I','N','G',':',X'01',X'82',
'W','R','I','T','E',':',X'02',X'06'
ROUTINESPEC PRINT SS
ROUTINESPEC REPORT(INTEGER N)
ROUTINESPEC CODE ATOM
ROUTINESPEC POP CONTEXT
ROUTINESPEC DEFINE(INTEGER DISP, VAL)
ROUTINE FAULT(INTEGER N)
FAULTNUM = N AND FAULTPOS = FPOS1 IF FAULTNUM < 0
END
! GRAM LAYOUT: LINK<9> CLASS<7>
SWITCH A(0:127)
SWITCH X(0:4)
TIME1 = CPUTIME
CYCLE I = 0,1,255
INDEX(I) = 0
REPEAT
C = 0
IDENTS = 0
PRINTPOS = 0; PRECISION = 0; LEVEL = 0
NEXTLINE = 1; FAULTNUM = -1; PARMAX = 15
ADGRAM0 = ADDR(GRAM(0)); LINK1 = GRAM(1)>>6&1022+ADGRAM0
APPCONT = GRAM(GRAM(PHRASE(112))>>7&511)>>6&1022+ADGRAM0
DLIM = ADDR(DICT(1)); DBOUND = ADDR(DICT(4000))
FPOS = ADDR(PERM(1))-1; FMAX = ADDR(PERM(518))
CYCLE I = 1,1,54
SYMCODE = 0
CODE ATOM; MONITOR AND STOP IF ATOM # IDENT
INTEGER(DLIM) = BYTEINTEGER(FPOS+1)<<8+BYTEINTEGER(FPOS+2)
FPOS = FPOS+2
INTEGER(DLIM+4) = 0
INTEGER(DLIM+8) = HEAD; HEAD = DLIM
DLIM = NEWDLIM
REPEAT
C_LOCAL = DLIM
FPOS = FSTART-1; FMAX = FPOS+FSIZE
SYMCODE = 0
L1: ->ENDED IF FPOS >= FMAX
LINEBASE = FPOS; LINE = NEXTLINE
L3: ATOM = JUMP; !FOR NUMERIC LABEL DETECTION
SKIPMIN = SKIP1MIN; !TO IGNORE NULL STATEMENTS AND COMMENTS
CODE ATOM
SKIPMIN = NLCODE
STATS = STATS+1
EXTIND = 0; DECLTYPE = 0
CONSTCOUNT = 0; DIMCOUNT = 0
NP = 51
LINKMAX = 1; LINK(1) = LINK1; !FOR GRATUITOUS PHRASE EXIT
I = GRAM(INITBASE+ATOM)
->ERR IF I = 0
G = I>>6&1022+ADGRAM0
->A(ATOM)
A(1): !IDENT
A(6): !OP3
A(9): !EQ
A(13): !NL
A(25): !COLON
I = SHORTINTEGER(G); G = I>>6&1022+ADGRAM0
->A(I&127)
A(10): A(11): A(12): A(15): A(18): A(19): A(20):
A(21): A(23): A(27): A(37):
A(43): A(44): A(45):
A(47): A(48): A(50): A(57): A(65):
CODE:
CODE ATOM
ON:
REP:CYCLE
! LOOPS = LOOPS+1
CLASS = SHORTINTEGER(G)&127
EXIT IF CLASS >= 60 OR CLASS = ATOM
G = G+2
REPEAT
G = SHORTINTEGER(G)>>6&1022+ADGRAM0
->A(CLASS)
A(109): A(110): A(111): A(113): A(114):
A(115): A(116): A(117): A(118): A(119):
A(120): A(121): A(122): A(123): A(124):
A(125): A(126):
ENTER:
LINKMAX = LINKMAX+1; ->ERR IF LINKMAX > 20
LINK(LINKMAX) = G
G = PHRASE(CLASS)<<1+ADGRAM0
->REP
A(66):
EXIT:
G = LINK(LINKMAX); LINKMAX = LINKMAX-1
->REP
A(67): !ALT (ALTERNATIVE PHRASE RECOGNISED)
I = SHORTINTEGER(LINK(LINKMAX)); LINKMAX = LINKMAX-1
->ERR IF I&127 # 0; !NO ALTERNATIVE
G = I>>6&1022+ADGRAM0
->ON
A(68): !BREAK (TERMINATOR WITHIN CONST LIST)
REPORT(FAULTNUM) IF FAULTNUM >= 0
IF ATOMTYPE = 0 START; !NL
LINEBASE = FPOS; LINE = NEXTLINE
FINISH
->CODE
UNKNOWN:
WHILE DPOS < 0 CYCLE
->IGNORE IF STRING(-DPOS+4) = STRING(DLIM+12)
DPOS = INTEGER(-DPOS)
REPEAT
FAULT(2)
CYCLE
DBOUND = DBOUND-4; NEWDLIM = NEWDLIM-4
EXIT IF NEWDLIM = DLIM+8
INTEGER(DBOUND) = INTEGER(NEWDLIM)
REPEAT
HEAD == INTEGER(HEAD+8) WHILE HEAD > 0
INTEGER(DBOUND) = HEAD; HEAD = -DBOUND
->IGNORE
MODERR:
FAULT(3)
->IGNORE
A(0): A(64):
ERR:FAULTNUM = 0; FAULTNUM = ATOMTYPE IF ATOM = 0
->DISASTER IF FAULTNUM = 99
FAULTPOS = FPOS1
IGNORE:
I=ATOM AND CODE ATOM WHILE ATOM # TERMINATOR
C_STACK = C_STACK<<2+3 IF I = START
C_STACK = C_STACK<<2+2 IF I = CYCLE
REPORT(FAULTNUM) IF FAULTNUM >= 0
WHILE I = COMMA AND ATOMTYPE = 0 CYCLE
I=ATOM AND CODE ATOM UNTIL ATOM = TERMINATOR
REPEAT
A(69): !FIN
FIN:REPORT(FAULTNUM) IF FAULTNUM >= 0
IF C_BTYPE&1 # 0 START; !PSEUDO BLOCK ENTRY FOR SPEC
DLIM = C_LOCAL
C = HOLD(LEVEL); LEVEL = LEVEL-1
FINISH
->L3 IF ATOMTYPE # 0; !COLON OR SEMI-COLON
->L1; !NEWLINE
DISASTER:
PRINT STRING("** SPACE EXHAUSTED AT LINE"); WRITE(NEXTLINE,1)
NEWLINE
RETURN
A(74):
NAPP:
-> ON IF TYPE&APPMASK = 0
->ERR
ER20:
FAULT(20)
->NAPP
ER22:
FAULT(22)
->NAPP
A(22): !PREC
PRECISION = ATOMTYPE
->CODE
A(38): !EXTERNAL
A(42): !SYSTEM,DYNAMIC
EXTIND = 1
->CODE
A(70): !RESET
DECLTYPE = 0
->ON
A(36): !RECORD
RECIDENTS = DLIM
A(29): !REG
A(30): !SWITCH
A(31): !NTYPE
A(32): !OWN
A(33): !ARRAY
A(34): !STRING
A(35): !NAME
A(39): !FM
A(40): !ROUTINE
A(41): !SPEC
DECLTYPE = DECLTYPE!!ATOMTYPE
DECLTYPE = DECLTYPE!PRECISION IF DECLTYPE&X'F0' = X'10'
IDENTS = DLIM
MODES = ¬0; !FOR SPEC LOOKS
->CODE
A(75): !NOTYPE
DECLTYPE = X'F9'; ! '?' VAR
->ON
A(78): !IDENT: DC (DECLARE RECORD COMPONENT)
HEAD == INTEGER(FIDENTPOS+4); DPOS = HEAD; !ALTER SEARCH LIST
A(76): !IDENT: D (DECLARE)
D1: ->ADD IF C_BTYPE&1 # 0; !WITHIN SPEC PARAMS
D2: CYCLE
->NEW IF DPOS < C_LOCAL
EXIT IF STRING(DPOS+12) = STRING(DLIM+12)
DPOS = INTEGER(DPOS+8)
REPEAT
->D5 IF INTEGER(DPOS)&X'FF'-1 = DECLTYPE C
AND DECLTYPE&6 # 0 AND DECLTYPE&1 = 0
FAULT(5); !DUPLICATE
NEW:INTEGER(DLIM+8) = HEAD; HEAD = DLIM
ADD:INTEGER(DLIM) = DECLTYPE; INTEGER(DLIM+4) = 0
DLIM = NEWDLIM
->CODE
!PROCEDURE BODY AFTER SPEC, LABEL AFTER JUMP
D5: INTEGER(DPOS) = DECLTYPE IF DECLTYPE = LAB
IDENTS = DPOS
->CODE
A(77): !IDENT: DF (DECLARE RECORD FORMAT)
DECLTYPE = RECFORMAT; FIDENTPOS = DLIM
->D1
A(2): !CONST
TYPE = ATOMTYPE; VAL = ATOMVAL
->CODE
A(3): !SUB (ABSORBS FOLLOWING IDENT)
-> ERR IF TYPE&X'FFF4' # 0 AND TYPE # RECFORMAT; !NOT RECORD
CODE ATOM; ->ERR IF ATOM # IDENT
->IGNORE IF VAL = 0
DPOS = VAL; HEAD == VAL
A(81): !IDENT: LOOK
LOOK:
LOOKS = LOOKS+1
CYCLE
TIMES = TIMES+1
->UNKNOWN IF DPOS <= 0
EXIT IF STRING(DPOS+12) = STRING(DLIM+12)
DPOS = INTEGER(DPOS+8)
REPEAT
TYPE = INTEGER(DPOS); VAL = INTEGER(DPOS+4)
->CODE IF MODES<<(TYPE&15) < 0
->MODERR
A(82): !IDENT: IMP1LOOK
MODES = IMP1MODES
->LOOK IF BYTEINTEGER(FPOS) # ':'
DECLTYPE = LAB
->D2
A(83): !IDENT: IMPLOOK
MODES = IMPMODES
->LOOK
A(84): !IDENT: EXPLOOK
MODES = EXPMODES
->LOOK
A(85): !IDENT: FLOOK
MODES = FMATMODES
->LOOK
A(86): !IDENT: JLOOK
WHILE DPOS >= C_LOCAL CYCLE
->JL1 IF STRING(DPOS+12) = STRING(DLIM+12)
DPOS = INTEGER(DPOS+8)
REPEAT
INTEGER(DLIM+8) = HEAD; HEAD = DLIM
INTEGER(DLIM) = JUMPLAB; INTEGER(DLIM+4) = 0
DPOS = DLIM; DLIM = NEWDLIM
JL1:TYPE = INTEGER(DPOS)
->CODE IF TYPE&14 = LAB
->MODERR
A(79): !RECSPEC
->MODERR IF TYPE&X'F4' # 0 OR VAL # 0 OR DPOS < C_LOCAL
RECIDENTS = -DPOS
->ON
A(88): !FSET
IDENTS = RECIDENTS
IF IDENTS >= 0 THEN DEFINE(4,INTEGER(DPOS+4)) C
ELSE INTEGER(-IDENTS+4) = INTEGER(DPOS+4)
->ON
A(80): !PROCSPEC
->MODERR IF TYPE&X'FF03' # FN OR DPOS < C_LOCAL
IDENTS = DPOS
->ON
A(72): !BEG
PIDENTPOS = IDENTS
LEVEL = LEVEL+1; ->DISASTER IF LEVEL > 12
HOLD(LEVEL) = C
C_BTYPE = DECLTYPE
C_STACK = 0
C_LOCAL = DLIM
->ON
A(89): !NL: PARSET
IDENTS = C_LOCAL; NP = 51
WHILE IDENTS # DLIM CYCLE
NP = NP-1; NTYPE(NP) = INTEGER(IDENTS)
IDENTS = BYTEINTEGER(IDENTS+12)&(¬3)+IDENTS+16
REPEAT
I = 0
WHILE NP # 51 CYCLE
J = I<<24+NTYPE(NP); NP = NP+1
I = I+1 UNTIL I > PARMAX OR PARTYPE(I) = J
IF I > PARMAX START
->DISASTER IF I = 252
PARMAX = I
PARTYPE(I) = J
FINISH
REPEAT
IF C_BTYPE&1 = 0 AND INTEGER(PIDENTPOS)&1 # 0 START
FAULT(18) IF BYTEINTEGER(PIDENTPOS+2) # I
INTEGER(PIDENTPOS) = C_BTYPE
FINISH
BYTEINTEGER(PIDENTPOS+2) = I
INTEGER(PIDENTPOS) = INTEGER(PIDENTPOS)&(¬EXTIND)
->FIN
A(90): !INIT
CONSTCOUNT = CONSTCOUNT-1
->ER20 IF TYPE&15 # 0
->ER22 IF TYPE&DECLTYPE = 0
!RANGE CHECK
DEFINE(4,VAL) IF DECLTYPE&15 = 0
->ON
A(91): !NL: INITFIN
FAULT(21) IF CONSTCOUNT # 0 AND CONSTCOUNT < 1000000
->FIN
A(92): !DIMSET
DEFINE(0,DIMCOUNT)
DIMCOUNT = 0
->ON
A(93): !COLON: COUNT
IF DIMCOUNT = 6 THEN FAULT(23) ELSE DIMCOUNT = DIMCOUNT+1
->CODE
A(94): !REP
CONSTCOUNT = CONSTCOUNT-VAL+1
->ON
A(95): !LITINT
->ER20 IF TYPE&15 # 0
A(96): !INT
->ER22 IF TYPE&INTBIT = 0
->NAPP
A(97): !STR
->ER22 IF TYPE&STRINGBIT = 0
->NAPP
A(98): !SIZESET
STRINGSIZE = VAL
->ON IF 0 < VAL <= 255
FAULT(19); STRINGSIZE = 255
->ON
A(99): !CBSET
LASTVAL = NVAL(NP); NP = NP+1
->CBERR UNLESS -32768 <= LASTVAL <= 32767
CONSTCOUNT = VAL-LASTVAL+1
->CBERR UNLESS 0 < CONSTCOUNT <= 32767
IF DECLTYPE = SWITCH START
{%UNTIL IDENTS = DLIM} CYCLE
J = DBOUND
DBOUND = J-(CONSTCOUNT+63)>>5<<2
->DISASTER IF DBOUND <= DLIM
INTEGER(IDENTS+4) = DBOUND
INTEGER(DBOUND) = LASTVAL<<16+CONSTCOUNT
CYCLE
J = J-4
EXIT IF J = DBOUND
INTEGER(J) = 0
REPEAT
IDENTS = BYTEINTEGER(IDENTS+12)&(¬3)+IDENTS+16
REPEAT UNTIL IDENTS = DLIM
FINISH
CB1:IDENTS = DLIM
->ON
CBERR:
FAULT(23); CONSTCOUNT = 2000000
->CB1
A(100): !COLON: LAB
->FIN IF DECLTYPE # 0; !SIMPLE LABEL
->ERR IF TYPE # JUMPLAB; !IE SWITCH + APP
FAULT(20) AND ->FIN IF LASTTYPE&15 # 0
->FIN IF VAL = 0
J = LASTVAL-SHORTINTEGER(VAL)
FAULT(19) AND ->FIN UNLESS 0 <= J < SHORTINTEGER(VAL+2)
I = VAL+J>>5<<2; J = X'80000000'>>(J&31)
FAULT(16) IF INTEGER(I+4)&J # 0
INTEGER(I+4) = INTEGER(I+4)!J
->FIN
A(101): !OP3: DOT
->ERR IF ATOMTYPE # STRINGBIT; !IE OP3 # '.'
A(60): !FOR
MODES = DESTMODES
->CODE
A(73): !RESOL
->ER22 IF TYPE&STRINGBIT = 0
MODES = DESTMODES
->ON
A(102): !OP3: SIGN
->ERR IF ATOMTYPE&3 = 0; !IE OP3 # '+', '-', '!'
TYPE = ATOMTYPE; VAL = 0
->OP1
A(7): !UOP
TYPE = ATOMTYPE; VAL = -1
->OP1
A(8): !COP
A(4): !OP1
A(5): !OP2
A(104):!OP3 OR EQ: OP
->ERR IF TYPE&APPMASK # 0
IF TYPE&X'FF4F' = INTBIT THEN TYPE=TYPE!15 ELSE TYPE=TYPE&(¬15)
TYPE = TYPE!REALBITS IF TYPE&NUMBITS # 0
OP1:NP = NP-1; NTYPE(NP) = TYPE&ATOMTYPE; NVAL(NP) = VAL
->CODE
A(105): !EVAL
->ERR IF TYPE&APPMASK # 0
TYPE = TYPE!REALBITS IF TYPE&NUMBITS # 0
I = NTYPE(NP); NP = NP+1
J = I&TYPE&X'F0'
->ER22 IF J = 0
->X(I&15) IF TYPE&X'FF4F' = INTBIT
X(0):
TYPE = J+EXP
->ON
X(1): VAL = NVAL(NP-1)+VAL
X1: TYPE = NUMBITS
->ON
X(2): VAL = NVAL(NP-1)-VAL
->X1
X(3): VAL = NVAL(NP-1)!VAL
->X1
X(4): VAL = NVAL(NP-1)!!VAL
->X1
A(103): !BAR (FIDDLE FOR MOD-SIGN)
->ON UNLESS NTYPE(NP) = X'43'
->ERR UNLESS ATOM = OP3 AND ATOMTYPE = X'43'
NP = NP+1; CODE ATOM
->EXIT
A(106): !EQ: ASSOP
->ERR IF TYPE&X'FF0C' # 8
SAVE:
NP = NP-1; NTYPE(NP) = TYPE; NVAL(NP) = VAL
->CODE
A(14): !EQEQ
MODES = ADRMODES
->SAVE IF TYPE&15 = REF
->ERR
A(107): !ASS
I = NTYPE(NP); NP = NP+1
AS1:IF I&TYPE&X'C0' = 0 START
I = I&X'F0'
IF I = 0 START; !RECORD
->ER22 UNLESS TYPE&X'F0' = 0 OR C
(TYPE&X'FF4F'=INTBIT AND VAL=0)
FINISH ELSE START
->ER22 UNLESS I <= X'30' AND TYPE&NUMBITS # 0
FINISH
FINISH
->NAPP
A(108): !REFASS
I = NTYPE(NP); NP = NP+1
RA1:FAULT(22) IF (I!!TYPE)&X'F0' # 0 C
AND I&X'F0' # X'F0' AND TYPE&X'F0' # X'F0'
->NAPP IF I&APPMASK = 0; !SCALAR
FAULT(22) IF TYPE&APPMASK = 0 OR TYPE&14 = MAP
->ON
A(17): !RESULT
FAULT(25) IF C_BTYPE&7 # FN
TYPE = C_BTYPE&X'F8'; TYPE = TYPE+VAR IF TYPE&8 = 0
VAL = 0
->CODE
A(71): !RCALL
->ON IF TYPE&X'FFFC' = 4
->ERR
A(112): !APP
->ON IF ATOM # LB
LINKMAX = LINKMAX+1; ->ERR IF LINKMAX > 20
LINK(LINKMAX) = G
NP = NP-1; NVAL(NP) = VAL
AP: ->ERR IF TYPE&APPMASK = 0
NTYPE(NP) = TYPE
G = APPCONT
CODE ATOM
J = PARTYPE(TYPE>>8)&15
CLASS = 122; !EXP
->ENTER IF J = VAR
CLASS = 111; MODES = ADRMODES
->ENTER IF J = REF
MODES = X'C0000000'>>J
->ENTER
A(63): !AP
J = NTYPE(NP); I = PARTYPE(J>>8)
LASTTYPE = TYPE; LASTVAL = VAL
TYPE = I>>16+J&X'FF'
->AP IF ATOM = COMMA
->ERR IF ATOM # RB
VAL = NVAL(NP); NP = NP+1
IF TYPE&APPMASK # 0 START
TYPE = TYPE!!APPMASK
->ERR IF TYPE&X'FE00' # 0
FINISH
TYPE = TYPE&X'FFFC'!1
CODE ATOM
->EXIT
A(16): !SIMP: STOP(0), RETURN(1), EXIT(2)
FAULT(25) IF (ATOMTYPE = 1 AND C_BTYPE&15 # ROUTINE) C
OR (ATOMTYPE = 2 AND (C_STACK!!X'55555555')<<1&C_STACK = 0)
->CODE
A(54): !CYCLE
CONDIND = 2
A(53): !START
C_STACK = C_STACK<<2+CONDIND
->CODE
A(55): !FINISH(1)
A(56): !REPEAT(0)
CONDIND = C_STACK&3
IF CONDIND = 0 OR (CONDIND!!ATOMTYPE)&1 # 0 C
THEN FAULT(12+ATOMTYPE) C
ELSE C_STACK = C_STACK>>2
->CODE
A(52): !ELSE(1)
FAULT(25) IF CONDIND = 1
A(26): !CWORD(3)
A(51): !ON(1)
CONDIND = ATOMTYPE
->CODE
A(58): !END
IF LEVEL = 0 OR (LEVEL=1 AND C_BTYPE=0) THEN FAULT(11) C
ELSE POP CONTEXT
->CODE
A(59): !ENDPROG
FPOS1 = FPOS
REPORT(8) IF LEVEL > ATOMTYPE
REPORT(11) IF LEVEL < ATOMTYPE
POP CONTEXT WHILE LEVEL > 0
TIME2 = CPUTIME
->ENDOK
ENDED:
TIME2 = CPUTIME
PRINT STRING("** END OF FILE AT LINE"); WRITE(NEXTLINE,1)
NEWLINE
ENDOK:
IF PARM&4 # 0 START
WRITE(LINE,4); PRINTSYMBOL('L')
WRITE(STATS,4); PRINT SYMBOL('S')
STATS = 1 IF STATS = 0
PRINT(ATOMS/STATS,2,1); PRINT SYMBOL('A')
PRINT(NUMBERS/STATS,2,1); PRINT SYMBOL('N')
PRINT(IDENTIFIERS/STATS,2,1); PRINT SYMBOL('I')
PRINT(LOOPS/STATS,2,1); PRINT SYMBOL('C')
PRINT(TIMES/LOOKS,2,1); PRINT SYMBOL('H')
PRINT((TIME2-TIME1)*1000/STATS,3,3); PRINT SYMBOL('M')
NEWLINE
FINISH
IF PARM&8 # 0 START
CYCLE I = 0,1,255
J = INDEX(I)
IF J > 0 START
WRITE(I,3); PRINT SYMBOL(':')
WHILE J > 0 CYCLE
SPACE; PRINT STRING(STRING(J+12))
J = INTEGER(J+8)
REPEAT
NEWLINE
FINISH
REPEAT
FINISH
RETURN
!
ROUTINE PRINT SS
{%SHORTROUTINE}
INTEGER K
ROUTINE WRITE(INTEGER V,P)
IF V >= 10 START
WRITE(V//10,P-1); V = V-10*(V//10)
FINISH ELSE SPACES(P-1)
PRINT SYMBOL(V+'0')
END
WRITE(LINE,4); SPACE
PRINTPOS = LINEBASE
{%UNTIL PRINTPOS = FPOS1} CYCLE
PRINTPOS = PRINTPOS+1
PRINT SYMBOL(MARKER) IF PRINTPOS = FAULTPOS
K = BYTEINTEGER(PRINTPOS)
IF K = NL OR 32 <= K <= 126 THEN PRINT SYMBOL(K) C
ELSE PRINT SYMBOL('[') AND WRITE(K,0) AND PRINT SYMBOL(']')
REPEAT UNTIL PRINTPOS = FPOS1
NEWLINE IF K # NL
END
ROUTINE REPORT(INTEGER N)
{%SHORTROUTINE}
SWITCH S(0:25)
FAULTPOS = 0 IF N > 7
PRINT SS IF PRINTPOS # FPOS1
PRINT SYMBOL('*')
->S(N)
S(0): PRINT STRING("FORM?"); ->F
S(1): PRINT STRING("ATOM?"); ->F
S(2): PRINT STRING("NAME?"); ->F
S(3): PRINT STRING("MODE?"); ->F
S(4): PRINT STRING("SIZE?"); ->F
S(11):PRINT STRING("%BEGIN"); ->M
S(12):PRINT STRING("%CYCLE"); ->M
S(13):PRINT STRING("%START"); ->M
S(8): PRINT STRING("%END"); ->M
S(9): PRINT STRING("%REPEAT"); ->M
S(10):PRINT STRING("%FINISH"); ->M
S(15): PRINT SYMBOL('''')
PRINT STRING(STRING(DPOS+12))
PRINT SYMBOL('''')
M: PRINT STRING(" MISSING"); ->F
S(23):PRINT STRING("BOUNDS?"); ->F
S(25):PRINT STRING("CONTEXT?"); ->F
S(5):
S(16):PRINT STRING("DUPLICATE"); ->F
S(17):PRINT STRING("ORDER?"); ->F
S(18):PRINT STRING("MATCH?"); ->F
S(19):PRINT STRING("RANGE?"); ->F
S(20):PRINT STRING("LITERAL?"); ->F
S(21): IF CONSTCOUNT < 0 START
WRITE(-CONSTCOUNT,1); PRINT STRING(" EXTRA")
FINISH ELSE START
WRITE(CONSTCOUNT,1); PRINT STRING(" MISSING")
FINISH
PRINT STRING(" VALUE(S)"); ->F
S(22):PRINT STRING("TYPE?"); ->F
F: NEWLINE
FAULTNUM = -1; PARM = PARM!X'80000000'
END
ROUTINE CODE ATOM
{%SHORTROUTINE}
{%REGISTER} INTEGER FP{(5)}; !FILE POS
{%REGISTER} INTEGER SC{(6)}; !SYMCODE OR SYM
INTEGER I,J,K,L
INTEGER HASH
ATOMS = ATOMS+1
FP = FPOS; SC = SYMCODE
->C2 IF SC # 0
C1: {%UNTIL SC # ' '} CYCLE
FP = FP+1; SC = BYTEINTEGER(FP)
REPEAT UNTIL SC # ' '
SC = SYMINIT(SC)
C2: FPOS1 = FP
->NAMENUM IF SC < 127
SC = SC-128
->KEYWORD IF SC > 0
->QUOTEMARK IF SC # 0
!PERCENT
FP = FP+1; SC = SYMINIT(BYTEINTEGER(FP)!128)
->C2 IF SC # 0
->C1
!LOCATE ATOM IN FIXED DICT
!KEYDICT := MORE<5> : LINK<9> : SYM-32<6>
! OR CLASS<7> : 0<6>
! THEN SUBCLASS<16>
KEYWORD:
->NLQ IF SC >= SKIPMIN; !NL OR EQUIVALENT
I = SC; L = 0; L = 128 IF SC < PUNCTMIN
CYCLE
CYCLE
FP = FP+1; K = BYTEINTEGER(FP)
SC = SYMINIT(K!L)
EXIT IF SC&127 # 0
L = SC
REPEAT
K = K-32 IF SC&128 # 0
CYCLE
J = KEYDICT(I)
EXIT IF J >= 0 OR J&63 = K
I = I+1
REPEAT
EXIT IF J&63 # K
I = J>>6&511
REPEAT
->ERR IF J&63 # 0
ATOMTYPE = KEYDICT(I+1)&X'FFFF'
ATOM = J>>6
->KEY5 IF ATOM = 0
FIN:FPOS = FP; SYMCODE = SC
RETURN
KEY5:
IF ATOMTYPE # 0 START; !%COMMENT
->FIN IF SKIPMIN # SKIP1MIN
->SKP
FINISH
->ERR UNLESS BYTEINTEGER(FP) = NL
NEXTLINE = NEXTLINE+1
->TERM IF FP >= FMAX
->C1
NLQ:
->TERM IF SKIPMIN # SKIP1MIN; !NOT LEADING ATOM
SKP:
FP = FP-1
{%UNTIL SC = NL %OR SC = ';'} CYCLE
FP = FP+1; SC = BYTEINTEGER(FP)
REPEAT UNTIL SC = NL OR SC = ';'
IF SC = NL START
->TERM IF FP >= FMAX
LINEBASE = FP; NEXTLINE = NEXTLINE+1; LINE = NEXTLINE
FINISH
->C1
TERM:
ATOM = TERMINATOR; ATOMTYPE = 0
NEXTLINE = NEXTLINE+1; SC = 0
SC = 255 IF FP >= FMAX
->FIN
DISASTER:
ATOMTYPE = 99
->ER1
STRINGERR:
ATOMTYPE = 4; NEXTLINE = L
ER1:FP = FPOS1; SC = 0
->ER2
ERR:ATOMTYPE = 1
ER2:ATOM = 0
->FIN
NAMENUM:
->NUMBER IF SC <= '9' AND ATOM # JUMP
IF BYTEINTEGER(FP+1) = '''' START
->HEX IF SC = 'X'
->OCT IF SC = 'K'
->BIN IF SC = 'B'
->MULTI IF SC = 'M'
FINISH
J = DLIM; ->DISASTER IF J+84 >= DBOUND
HASH = 0
{%UNTIL SC > 'Z'} CYCLE
IF SC # 0 START
J = J+1; BYTEINTEGER(J+12) = SC
HASH = HASH<<1!!SC
FINISH
FP = FP+1; SC = SYMINIT(BYTEINTEGER(FP))
REPEAT UNTIL SC > 'Z'
BYTEINTEGER(DLIM+12) = J-DLIM
NEWDLIM = J&(¬3)+16
HEAD == INDEX(HASH&255); DPOS = HEAD;
ATOM = IDENT;
IDENTIFIERS = IDENTIFIERS+1
->FIN
NUMBER:
ATOMTYPE = NUMBITS
ATOMVAL = SC-'0'
CYCLE
FP = FP+1; SC = SYMINIT(BYTEINTEGER(FP))
EXIT IF SC > '9'
ATOMVAL = (ATOMVAL<<2+ATOMVAL)<<1+SC-'0' C
IF SC # 0 AND ATOMVAL < 1000000
REPEAT
IF BYTEINTEGER(FP) = '.' START
{%UNTIL SC > '9'} CYCLE
FP = FP+1; SC = SYMINIT(BYTEINTEGER(FP))
REPEAT UNTIL SC > '9'
ATOMTYPE = REALBITS
FINISH
IF BYTEINTEGER(FP) = '@' START
{%UNTIL SC # ' '} CYCLE
FP = FP+1; SC = BYTEINTEGER(FP)
REPEAT UNTIL SC # ' '
IF SC = '-' START
{%UNTIL SC # ' '} CYCLE
FP = FP+1; SC = BYTEINTEGER(FP)
REPEAT UNTIL SC # ' '
FINISH
SC = SYMINIT(SC)
->ERR UNLESS SC <= '9'
{%UNTIL SC > '9'} CYCLE
FP = FP+1; SC = SYMINIT(BYTEINTEGER(FP))
REPEAT UNTIL SC > '9'
ATOMTYPE = REALBITS
FINISH
NN: ATOM = CONST
NUMBERS = NUMBERS+1
->FIN
MULTI:
FP = FP+1
ATOMTYPE = NUMBITS
->Q1
QUOTEMARK:
ATOMTYPE = STRINGBIT
Q1: K = BYTEINTEGER(FP); J = -1; L = NEXTLINE
ATOMVAL = 0
CYCLE
FP = FP+1; SC = BYTEINTEGER(FP)
IF SC = NL START
NEXTLINE = NEXTLINE+1
->TERM IF FP >= FMAX
FINISH
IF SC = K START
EXIT IF SC # BYTEINTEGER(FP+1)
FP = FP+1
FINISH
ATOMVAL = ATOMVAL<<8+SC
J = J+1; ->STRINGERR IF J = 255
REPEAT
IF ATOMTYPE = STRINGBIT START; !IE NOT MULTI
ATOMVAL = J<<8+ATOMVAL&255
ATOMTYPE = STRINGBIT+NUMBITS IF J = 0
FINISH
SC = 0
->NN
HEX:J = 4; ->RAD
OCT:J = 3; ->RAD
BIN:J = 1
RAD:FP = FP+1
ATOMTYPE = NUMBITS; ATOMVAL = 0
CYCLE
FP = FP+1; SC = BYTEINTEGER(FP)
EXIT IF SC = ''''
K = SC-'0'
K = K+('0'-'A'+10) IF K >= 'A'-'0'
->ERR IF K>>J # 0
ATOMVAL = ATOMVAL<<J+K
REPEAT
SC = 0
->NN
END; !CODE ATOM
ROUTINE POP CONTEXT
{%SHORTROUTINE}
INTEGER I
DPOS = C_LOCAL; FPOS1 = FPOS
WHILE DPOS # DLIM CYCLE
I = INTEGER(DPOS)
IF I # RECFORMAT START
REPORT(15) IF I&1 # 0 AND I&6 # 0
FINISH ELSE START
DPOS = INTEGER(DPOS+4) IF INTEGER(DPOS+4) # 0
FINISH
DPOS = BYTEINTEGER(DPOS+12)&(¬3)+DPOS+16
REPEAT
REPORT(C_STACK&1+9) AND C_STACK=C_STACK>>2 WHILE C_STACK # 0
DLIM = C_LOCAL
C = HOLD(LEVEL); LEVEL = LEVEL-1
CYCLE I = ADDR(INDEX(0)),4,ADDR(INDEX(255))
INTEGER(I) = INTEGER(INTEGER(I)+8) WHILE INTEGER(I) >= DLIM
REPEAT
END
ROUTINE DEFINE(INTEGER DISP,VAL)
{%SHORTROUTINE}
WHILE IDENTS # DLIM CYCLE
IF DISP # 0 THEN INTEGER(IDENTS+4) = VAL C
ELSE BYTEINTEGER(IDENTS+2) = VAL
IDENTS = BYTEINTEGER(IDENTS+12)&(¬3)+IDENTS+16
REPEAT
END
END; !CHECKINNER
EXTERNALROUTINE CHECK(STRING(63) PARAM)
RECORDFORMAT FINF(INTEGER CONAD,FILESIZE, BYTEINTEGER RUP, C
EEP,MODE,CONS,ARCH, STRING(6) TRAN, C
SHORTINTEGER FILETYPE,NUMIPERMS, C
INTEGER DATASTART,DATAEND, PLISTPTR)
{%EXTERNAL}ROUTINE{SPEC} DEFINE(STRING(63) S)
end
{%SYSTEM}ROUTINE{SPEC} CONNECT(STRING(15) S, INTEGER A,M,P, C
RECORD(FINF)NAME R, INTEGERNAME F)
end
{%EXTERNAL}STRING(255)FN{SPEC} SSFMESSAGE
result="error" ; ! I thought I had added this one to the perms..?
end
RECORD(FINF) R
INTEGER I,J,FLAG
STRING(63) OPTIONS,OUT
OUT = "" UNLESS PARAM -> PARAM.("/").OUT
OPTIONS = "" UNLESS PARAM -> PARAM.(",").OPTIONS
CONNECT(PARAM,0,0,0,R,FLAG)
PRINTSTRING(SSFMESSAGE) AND RETURN IF FLAG # 0
IF OUT # "" START
DEFINE("ST19,".OUT)
SELECT OUTPUT(19)
FINISH
I = 0
WHILE I < LENGTH(OPTIONS) CYCLE
I = I+1; J = CHARNO(OPTIONS,I)
FLAG = FLAG!8 IF J = 'D'
FLAG = FLAG!4 IF J = 'S'
REPEAT
CHECKINNER(R_CONAD+R_DATASTART,R_DATAEND-R_DATASTART,FLAG)
PRINT STRING(" OK") AND NEWLINE IF FLAG >= 0
END; !CHECK
begin
end
ENDOFFILE