         Edinburgh IMP77 Compiler - Version 8.4

    1  %EXTERNALROUTINE CHECKINNER(%INTEGER FSTART,FSIZE, %INTEGERNAME PARM)
    2  !%EXTERNALLONGREALFNSPEC CPUTIME
    3  %LONGREAL TIME1,TIME2
    4  !
    5  !DECLARATION CODES
    6  %CONSTINTEGER STRINGBIT=X'80', REALBITS=X'30', INTBIT=X'40'
    7  %CONSTINTEGER NUMBITS=X'70'
    8  %CONSTINTEGER APPMASK=X'FF00'
    9  %CONSTINTEGER EXP=1, FN=2
   10  %CONSTINTEGER RECFORMAT=4, ROUTINE=6
   11  %CONSTINTEGER REF=8, VAR=9, MAP=10
   12  %CONSTINTEGER LAB=12, JUMPLAB=13
   13  %CONSTINTEGER SWITCH=X'10C'
   14  %CONSTINTEGER IMP1MODES=B'01000011111111000000000000000000'
   15  %CONSTINTEGER IMPMODES =B'01000011111100000000000000000000'
   16  %CONSTINTEGER DESTMODES=B'00000000111100000000000000000000'
   17  %CONSTINTEGER ADRMODES =B'01000000111100000000000000000000'
   18  %CONSTINTEGER EXPMODES =B'11110000111100000000000000000000'
   19  %CONSTINTEGER FMATMODES=B'00001000000000000000000000000000'
   20  !SYMBOL INIT CODES
   21  ! USED EXPLICITLY
   22  ! SPACE=0, DIGIT:ISO, LETTER:ISO, QUOTE=127
   23  ! PC=128, PCLET OR PUNCT: 128 + KEYDICT INDEX
   24  ! KEYDICT INDEX >= PUNCTMIN FOR PUNCT
   25  ! KEYDICT INDEX >= SKIP1MIN FOR  !  *  SEMICOLON  NL
   26  %CONSTINTEGER NLCODE=127;  !MASKED FROM 255 ACTUAL
   27  !ATOM CODES
   28  %CONSTINTEGER IDENT=1, CONST=2, LB=11, COMMA=10, RB=12
   29  %CONSTINTEGER TERMINATOR=13, JUMP=15
   30  %CONSTINTEGER OP3=6, START=53, CYCLE=54
   31  ! VERTICAL BAR
   32  %CONSTINTEGER MARKER=124
   33  
   34  %OWNINTEGER STATS=0, ATOMS=-54, IDENTIFIERS=-54, NUMBERS=0, LOOPS=0
   35  %OWNINTEGER LOOKS=1, TIMES=1
   36  %INTEGER I,J
   37  %INTEGER LINEBASE;     !BASE FOR SOURCE LINE (POINTER)
   38  %INTEGER FPOS;         !CURRENT POSITION IN SOURCE (POINTER)
   39  %INTEGER FPOS1;        !START OF CURRENT ATOM (POINTER)
   40  %INTEGER PRINTPOS;     !'LINE-ALREADY-PRINTED' INDIC
   41  %INTEGER LINE;         !CURRENT LINE NUMBER
   42  %INTEGER NEXTLINE
   43  %INTEGER FMAX;  !LAST BYTE IN SOURCE (POINTER)
   44  %INTEGER FAULTNUM;     !FAULTY NUMBER
   45  %INTEGER FAULTPOS;     !FAULTY ATOM POSITION (POINTER)
   46  %INTEGER SYMCODE;  !SYMBOL CODE FOR CURRENT SYMBOL
   47  %INTEGER SKIPMIN;  !=SKIP1MIN OR NLCODE
   48  !%INTEGER GG;           !=GRAM(G)
   49  %INTEGER CLASS;        !GRAMMAR CLASS
   50  %INTEGER G;            !INDEX TO GRAM
   51  %INTEGER ATOM;         !ATOM CODE FOR CURRENT ATOM
   52  %INTEGER ATOMTYPE;     !TYPE FOR CURREMT ATOM
   53  %INTEGER ATOMVAL;      !'VALUE' FOR CURRENT ATOM
   54  %INTEGER DECLTYPE;     !DECLARATION TYPE
   55  %INTEGER MODES;  !BIT VECTOR FOR PERMISSIBLE IDENT MODES
   56  %INTEGER DIMCOUNT;     !DIMENSION COUNT
   57  %INTEGER CONSTCOUNT;   !CONSTANT COUNT (DOWN)
   58  %INTEGER STRINGSIZE
   59  %INTEGER PRECISION
   60  %INTEGER LASTTYPE,LASTVAL
   61  %INTEGER TYPE,VAL
   62  %INTEGER NP;           !NEST POINTER (INDEX TO NTYPE,NVAL)
   63  %INTEGERARRAY NTYPE,NVAL(1:50);  !NEST
   64  %INTEGER LINKMAX;      !GRAMMAR STACK MAX (INDEX TO LINK)
   65  %INTEGERARRAY LINK(1:20);  !GRAMMAR CONTROL STACK
   66  %RECORDFORMAT BLOCKINF(%INTEGER STACK,LOCAL,BTYPE)
   67  %INTEGER LEVEL;        !CURRENT BLOCK LEVEL (MAIN=1)
   68  %RECORD(BLOCKINF) C;   !INFO FOR CURRENT BLOCK
   69  %RECORD(BLOCKINF)%ARRAY HOLD(1:12);  !INFO FOR GLOBAL BLOCKS
   70  %INTEGERARRAY INDEX(0:255);  !HASH INDEX TO IDENT DICT
   71  %INTEGERNAME HEAD;     !HEAD OF IDENT SEARCH LIST
   72  %INTEGER DPOS;         !DICT SEARCH POSITION (POINTER)
   73  %INTEGER DLIM;         !DICT LIMIT (POINTER)
   74  %INTEGER NEWDLIM
   75  %INTEGER DBOUND;       !DICT UPPER LIMIT (POINTER);
   76  %INTEGER IDENTS;       !POS OF FIRST IDENT IN DECL LIST (POINTER)
   77  %INTEGER RECIDENTS;    !POS OF FIRST IDENT IN RECORD LIST (POINTER)
   78  %INTEGER PIDENTPOS;    !POS OF PROCEDURE IDENT (POINTER)
   79  %INTEGER FIDENTPOS;    !POS OF FORMAT IDENT (POINTER)
   80  %INTEGER EXTIND;  !SET BY %EXTERNAL
   81  %INTEGER CONDIND;  !SET FOR START,CYCLE
   82  %INTEGER PARMAX;  !CURRENT MAX IN PARTYPE
   83  %INTEGER ADGRAM0, LINK1;  !PRE-COMPUTED GRAMMAR VALUES
   84  %INTEGER APPCONT
   85  
   86  %OWNINTEGERARRAY PARTYPE(0:255) =  0,
   87+     X'00000069', X'01000069', X'02000069', X'03000069',
   88+     X'04000069', X'05000069', X'00000029', X'01000029',
   89+     X'00000089', X'00000088', X'000000F8', X'02000029',
   90+     X'07000029', X'01000088', X'02000088', 0(236),
   91+     X'FD000069', X'FE0001F8', X'00000000', X'FF000069'
   92  
   93  %INTEGERARRAY DICT(1:4000)
   94  
   95  !* GRAMMAR AND KEYWORD DICTIONARY GENERATED BY TAKEON PROGRAM
   96  
   97  %CONSTINTEGER PUNCTMIN = 43, SKIP1MIN = 86
   98  
   99  %CONSTBYTEINTEGERARRAY SYMINIT( 0: 255) =  %C
  100+  129, 129, 129, 129, 129, 129, 129, 129,
  101+  129, 129, 255, 129, 129, 129, 129, 129,
  102+  129, 129, 129, 129, 129, 129, 129, 129,
  103+  129, 129, 129, 129, 129, 129, 129, 129,
  104+    0, 217, 127, 171, 129, 128, 173, 127,
  105+  175, 178, 214, 180, 182, 184, 187, 189,
  106+   48,  49,  50,  51,  52,  53,  54,  55,
  107+   56,  57, 192, 221, 194, 200, 203, 129,
  108+  129,  65,  66,  67,  68,  69,  70,  71,
  109+   72,  73,  74,  75,  76,  77,  78,  79,
  110+   80,  81,  82,  83,  84,  85,  86,  87,
  111+   88,  89,  90, 129, 207, 129, 210, 212,
  112+  129,  65,  66,  67,  68,  69,  70,  71,
  113+   72,  73,  74,  75,  76,  77,  78,  79,
  114+   80,  81,  82,  83,  84,  85,  86,  87,
  115+   88,  89,  90, 129, 207, 129, 210, 212,
  116+  129, 129, 129, 129, 129, 129, 129, 129,
  117+  129, 129, 255, 129, 129, 129, 129, 129,
  118+  129, 129, 129, 129, 129, 129, 129, 129,
  119+  129, 129, 129, 129, 129, 129, 129, 129,
  120+    0, 217, 127, 171, 129, 128, 173, 127,
  121+  175, 178, 214, 180, 182, 184, 187, 189,
  122+   48,  49,  50,  51,  52,  53,  54,  55,
  123+   56,  57, 192, 221, 194, 200, 203, 129,
  124+  129, 130, 132, 134, 138, 139, 142, 129,
  125+  129, 146, 129, 129, 148, 150, 152, 154,
  126+  157, 158, 159, 161, 167, 169, 129, 170,
  127+  129, 129, 129, 129, 207, 129, 210, 212,
  128+  129, 130, 132, 134, 138, 139, 142, 129,
  129+  129, 146, 129, 129, 148, 150, 152, 154,
  130+  157, 158, 159, 161, 167, 169, 129, 170,
  131+  129, 129, 129, 129, 207, 129, 210, 212
  132    
  133  %CONSTSHORTINTEGERARRAY KEYDICT( 0: 487) =  %C
  134+      0,     5,-26642,  6194,-26523,  6329,-26385,-26247,     0,     0,
  135+   6585,-26132,-26066,  6776,-25887,-25815,-25746,  7151,-25562,  7342,
  136+ -25367,  7471,-25247,  7599,-25119,  7727,-24978,-24782,  8119,  8178,
  137+   8245,-24475,  8687,-24024,-23959,-23888,-23820,-23625,  9209,-23512,
  138+   9330,  9390,  9512,   512,   240,   320,    64,-23231,   704,     0,
  139+    786,     0,   384,   113,   640,     0,-23074,   384,   114,   384,
  140+    128,-22961,   320,    48,  1600,     1,-22835,-22692,-22563,-22434,
  141+    512,   240,-22307,   576,   240,-22179,-22050,   512,   240,-21923,
  142+    448,    68,   448,    68,   192,     0,-21814,   320,   112,-21695,
  143+ -21559,   384,    67,   832,     1, 11364, 11506, 11559, 11636,-21075,
  144+  11758, 11875, 11950, 12019, 12068,-20503, 12340, 12469, 12526,  2496,
  145+     11, 12594,  1664,     3, 12788, 12851, 12910, 12976, 13102, 13165,
  146+  13236,-19419,  3264,     1,  2816,     0, 13422, 13545, 13601,-19103,
  147+ -19037,-18969,-18896,-18829, 14004, 14069, 14127, 14183, 14245,-18463,
  148+ -18385, 14450, 14505, 14579, 14629, 14709,-18004, 14836, 14889,  3008,
  149+      0,   960,     0,   320,    64,   576,     0,   256,    64,   512,
  150+    240,   256,    64,   896,     0,   512,   240,   256,    64,   512,
  151+    240,   256,   112,   384,    68,  3072,     0,  2752,     0, 14945,
  152+  15017, 15077, 15149,-17549, 15284, 15340, 15393, 15461,-17169,  3712,
  153+      0, 15668,-16987, 15858, 15916, 15977,-16723,  3136,     0, 16101,
  154+  16180, 16295,  2496,     3, 16425, 16485,  2880,     0, 16630,  2048,
  155+      0, 16686, 16740, 16812, 17007, 17065, 17125, 17205, 17269, 17332,
  156+  17394, 17454, 17507, 17650, 17712, 17833, 17908, 17972, 18030, 18163,
  157+  18213, 18281, 18348, 18425, 18606, 18729, 18789, 18868, 18994, 19045,
  158+  19181,  3328,     1, 19238,  1024,     2, 19442, 19497, 19572, 19699,
  159+  19745, 19815,  1280,     0,-12887, 19954, 20020,  2240,     1, 20069,
  160+  20148, 20210,-12493,  1984,    25, 20402, 20467, 20513, 20588, 20658,
  161+  20713, 20788, 20897,  2624,     1, 20980,  1024,     0, 21102, 21155,
  162+  21221,  3200,     0, 21300, 21363, 21420, 21541,-11090,  2112,   256,
  163+   3648,     0, 21742, 21806,  2048,     8, 21871,  3456,     2, 21929,
  164+ -10778,-10708, 22128, 22190, 22254,  1472,     0, 22312, 22452, 22565,
  165+  22638, 22693, 22767, 22830, 22900, 22949, -9748, 23086, 23140, 23284,
  166+  23348, 23476, 23598, 23726, -8983, 23858, 23916,  3392,     1, 24039,
  167+  24168, 24301, 24421, 24499,  1728,     0,  1728,     0, 24609, 24692,
  168+  24756, 24876, 24995, 25129, 25193, 25266, 25313, 25395,  3520,     1,
  169+   2368,     0, 25458, 25588, 25633, 25714, 25908, 26021, 26081, 26159,
  170+  26223,  2304,     9, 26277,  3584,     0,  1088,     0,  1024,     1,
  171+  26341, 26478, 26543,  1152,     0,  2176,   137,  1920,   268,  2688,
  172+      0, 26596,  1664,     3, 26669, 26725,     0,     2,  1344,     0,
  173+   2688,     0, 26796, 26867, 26927, 26988, 27113,  1984,   105, 27173,
  174+  27244, -5389,  1152,     0,  3264,     1, 27448, 27500, 27630, 27698,
  175+  27762,  2560,     6, 27892, 27957, 28016, 28069, 28199, 28261, 28404,
  176+  28519,  2432,     0, 28579, 28711,  1984,    41, 28788, 28852,  1984,
  177+     57, 28967, 29101,  1856,   121, 29157, 29236, 29298,  2240,  -255,
  178+  29349,  3776,     0,  1280,     0, 29426,  2048,     0, 29477, 29551,
  179+   1216,     0,  1408,    32, 29601, 29671, 29737, 29807, 29874, 29985,
  180+  30066, 30192, 30316, 30437, 30510, 30567,  1984,    73, 30637,  1984,
  181+    121,  1024,     0,  1408,     0, 30770, 30885, 31026,  3776,     1,
  182+   1984,    89,  1280,     0, 31073, 31149,  1280,     0
  183  
  184  %CONSTSHORTINTEGERARRAY PHRASE( 109: 126) =  %C
  185+   257,  249,  368,  430,  264,  269,  286,  298,  335,  345,
  186+     0,  452,  237,  374,  381,    0,  420,  437
  187  
  188  %CONSTINTEGER INITBASE = 472
  189  
  190  {%CONST}%OWNSHORTINTEGERARRAY GRAM( 0: 531) =  %C
  191+     66,  4084,  4511,  4898,  5028,  6440,    64,  7071,  7330,  5028,
  192+     64, 11553,  1955, 11685, 11945, 12273, 12321,  2467,  6439,  5617,
  193+  12429,  2996,    64,  5786,  5557,  5620,  2157, 12575, 12834,  6440,
  194+     64, 12954, 12955,  6961,    64, 13089,  6439,  5489,  4589, 13345,
  195+   1955, 12273,  7433, 12429,    64,  6005,  7602,  5557,    64,  7925,
  196+  13569, 13737,    64, 12429,  5630, 13089,  5489,  7149,  8257,  5557,
  197+  14068,  3250,  5558,    64,  8442,  8538,  4746, 12429,    64,  9042,
  198+   9200,  8963, 14217, 14350, 14479, 14617,  9927, 12429, 14763,    66,
  199+  14970, 15098, 15489,    64, 15729, 16129,    64,  8062, 16378,  5576,
  200+  12274, 16769,    64, 16897,    64,  5614,  5618,    69,  6439,    64,
  201+  12653,  5621, 17281,    64, 17409,    64, 17612, 13569,    64,  3124,
  202+     64, 18154, 18287,  9976,  9956,   116,  5599, 15199, 10378, 18319,
  203+     64, 18636, 15859, 10762, 12429,    64, 18897, 16479, 11274,  5557,
  204+     64, 19021, 17105, 17155, 12239, 19276, 19788, 17736, 19851, 19981,
  205+     64, 20218,  9964, 20225,    64, 20363,    64, 17616, 20619,    64,
  206+  19443, 22409, 12429,    64, 12275, 22905,    89,  9963, 23126, 23554,
  207+     64, 20806, 21279, 22306, 21796,    64, 23809, 24609, 24867,    64,
  208+  25089, 25889, 24867,    64, 21357, 22593, 26125, 26362, 26881,    64,
  209+  23242, 10378, 12429,    64,  5516,    64, 24014, 24330,  5516,    64,
  210+  23809, 20806, 27649,    64, 23809,    64, 25294, 28682, 25582, 20618,
  211+   5516,    64, 28929,    64, 22724, 26458, 22538, 29067, 29197,    64,
  212+  27084, 27402, 17804, 22905, 26881, 22905, 27854, 24586, 28147, 28426,
  213+   5516,    64, 27649, 20806, 25089,    64, 29390, 29562,    91, 25459,
  214+  29663, 29836,    64, 30046, 22538, 29197,    64, 30534, 31135, 31522,
  215+  31652,    40, 31691,    35,    39,    66, 31213,    35,    64, 32139,
  216+     64, 32385,    64, 32597, 32780,    64,    88, 33163,    66, 33402,
  217+  33503, 33676,    64,    98, 34049,    64, 34252, 33802,    66, 34597,
  218+  34801, 34955,    64, 35194, 35296, 35481,    64, 35677, 35834, 35936,
  219+  34954, 36236,    64, 36444, 34570,    66, 36875,    64, 37114, 37215,
  220+  37401,    64, 37608, 37754, 37855, 38028,    64,    99, 39937, 40847,
  221+  41104, 39569, 39058, 41363,    64, 41602, 12429, 14763,    66, 41737,
  222+  41870,    64, 40147, 40304, 40067, 14217, 14350, 14479,  9927, 41985,
  223+     64, 12429,    66, 42114,    64, 41184, 42346, 42479, 42582,  9953,
  224+  42746, 41196, 42864, 41195, 41162, 43126, 43520, 43691, 43820,    66,
  225+     67, 44022, 43382, 43691,    66, 44939, 44538, 45448, 45577, 45711,
  226+     67, 45173, 45824,    12,    64, 46202, 45544,   120, 46604,    64,
  227+  46313, 46728, 46857,    66, 44539, 47098, 46824,   105, 47361,    64,
  228+  47569, 47728, 47491,    66, 49281, 48770, 50182, 50311, 50443, 50607,
  229+     64, 50308, 50693, 51078,    66, 49492, 49648, 49411, 50308, 50693,
  230+  51078,    66, 51302, 51453, 51578, 51834, 50941, 51972, 49001, 52200,
  231+  52733, 48873, 48780,    64, 48816,    64, 52861, 52349, 52868, 52997,
  232+  49129, 52327, 50921, 53501, 53245, 53508, 52457, 52329, 53757, 53225,
  233+  54401,     2, 54539, 54703,    64, 47572, 45306, 54906,    48,    64,
  234+  55307,    66, 55546, 55615, 55306,    12,    64, 56175, 56288, 56457,
  235+     64, 56641, 56826, 56928, 57098,    64, 57338, 57440, 57610,    64,
  236+  57850,    96, 58057, 58251, 58479, 58618, 58721, 58977, 59142,    64,
  237+  59276,    64, 59621, 59782,    64, 58251,    64, 60005, 60143, 60257,
  238+  59142,    66,     0,  8833,     0,     0,     0,     0,     0,     0,
  239+      0,     0,     0,     0,     0,     0,     0, 40847, 41104, 39569,
  240+  39058, 41363,  5524, 10261,  5526, 10391,     0,     0,  5786,  6299,
  241+      0, 10525, 10782,  2079,   928,     0,  3362,     0,  1444,     0,
  242+    294,     0,  6440, 10921,  3498,     0,     0,     0,     0,     0,
  243+      0, 11185,     0, 11315,     0,     0,  6838,  2615,  5560, 11449,
  244+   5562,    59
  245  
  246  !!END OF GENERATED SECTION
  247  
  248  {%CONST}%OWNBYTEINTEGERARRAY PERM(1:518) =  %C
  249+ 'A','D','D','R',':',X'0B',X'62',
  250+ 'A','R','C','C','O','S',':',X'07',X'22',
  251+ 'A','R','C','S','I','N',':',X'07',X'22',
  252+ 'A','R','R','A','Y',':',X'FC',X'F8',
  253+ 'A','R','C','T','A','N',':',X'0D',X'22',
  254+ 'B','Y','T','E','I','N','T','E','G','E','R',':',X'01',X'4A',
  255+ 'C','H','A','R','N','O',':',X'0E',X'4A',
  256+ 'C','L','O','S','E','S','T','R','E','A','M',':',X'01',X'06',
  257+ 'C','O','S',':',X'07',X'22',
  258+ 'E','X','P',':',X'07',X'22',
  259+ 'F','R','A','C','P','T',':',X'07',X'22',
  260+ 'F','R','O','M','S','T','R','I','N','G',':',X'0F',X'82',
  261+ 'I','M','O','D',':',X'01',X'62',
  262+ 'I','N','T',':',X'07',X'62',
  263+ 'I','N','T','P','T',':',X'07',X'62',
  264+ 'I','N','T','E','G','E','R',':',X'01',X'6A',
  265+ 'L','E','N','G','T','H',':',X'0A',X'4A',
  266+ 'L','O','G',':',X'07',X'22',
  267+ 'L','O','N','G','R','E','A','L',':',X'01',X'1A',
  268+ 'M','O','D',':',X'07',X'22',
  269+ 'N','E','W','L','I','N','E',':',X'00',X'06',
  270+ 'N','E','W','L','I','N','E','S',':',X'01',X'06',
  271+ 'N','E','W','P','A','G','E',':',X'00',X'06',
  272+ 'N','E','X','T','I','T','E','M',':',X'00',X'82',
  273+ 'N','E','X','T','C','H',':',X'00',X'62',
  274+ 'N','E','X','T','S','Y','M','B','O','L',':',X'00',X'62',
  275+ 'N','L',':',X'00',X'62',
  276+ 'P','I',':',X'00',X'22',
  277+ 'P','R','I','N','T',':',X'0C',X'06',
  278+ 'P','R','I','N','T','C','H',':',X'01',X'06',
  279+ 'P','R','I','N','T','F','L',':',X'08',X'06',
  280+ 'P','R','I','N','T','S','T','R','I','N','G',':',X'09',X'06',
  281+ 'P','R','I','N','T','S','Y','M','B','O','L',':',X'01',X'06',
  282+ 'R','A','D','I','U','S',':',X'0D',X'22',
  283+ 'R','E','A','D',':',X'0B',X'06',
  284+ 'R','E','A','D','C','H',':',X'0B',X'06',
  285+ 'R','E','A','D','I','T','E','M',':',X'0A',X'06',
  286+ 'R','E','A','D','S','T','R','I','N','G',':',X'0A',X'06',
  287+ 'R','E','A','D','S','Y','M','B','O','L',':',X'0B',X'06',
  288+ 'R','E','A','L',':',X'01',X'1A',
  289+ 'R','E','C','O','R','D',':',X'01',X'0A',
  290+ 'S','E','L','E','C','T','I','N','P','U','T',':',X'01',X'06',
  291+ 'S','E','L','E','C','T','O','U','T','P','U','T',':',X'01',X'06',
  292+ 'S','E','T','M','A','R','G','I','N','S',':',X'03',X'06',
  293+ 'S','H','O','R','T','I','N','T','E','G','E','R',':',X'01',X'5A',
  294+ 'S','I','N',':',X'07',X'22',
  295+ 'S','K','I','P','S','Y','M','B','O','L',':',X'00',X'06',
  296+ 'S','P','A','C','E',':',X'00',X'06',
  297+ 'S','P','A','C','E','S',':',X'01',X'06',
  298+ 'S','Q','R','T',':',X'07',X'22',
  299+ 'S','T','R','I','N','G',':',X'01',X'8A',
  300+ 'T','A','N',':',X'07',X'22',
  301+ 'T','O','S','T','R','I','N','G',':',X'01',X'82',
  302+ 'W','R','I','T','E',':',X'02',X'06'
  303  
  304  
  305  %ROUTINESPEC PRINT SS
  306  %ROUTINESPEC REPORT(%INTEGER N)
  307  %ROUTINESPEC CODE ATOM
  308  %ROUTINESPEC POP CONTEXT
  309  %ROUTINESPEC DEFINE(%INTEGER DISP, VAL)
  310  
  311  %ROUTINE FAULT(%INTEGER N)
  312      FAULTNUM = N %AND FAULTPOS = FPOS1 %IF FAULTNUM < 0
  313  %END
  314  
  315  ! GRAM LAYOUT: LINK<9> CLASS<7>
  316  %SWITCH A(0:127)
  317  %SWITCH X(0:4)
  318      TIME1 = CPUTIME
  319      %CYCLE I = 0,1,255
  320         INDEX(I) = 0
  321      %REPEAT
  322      C = 0
  323      IDENTS = 0
  324      PRINTPOS = 0;  PRECISION = 0;  LEVEL = 0
  325      NEXTLINE = 1;  FAULTNUM = -1;  PARMAX = 15
  326      ADGRAM0 = ADDR(GRAM(0));  LINK1 = GRAM(1)>>6&1022+ADGRAM0
  327      APPCONT = GRAM(GRAM(PHRASE(112))>>7&511)>>6&1022+ADGRAM0
  328      DLIM = ADDR(DICT(1));  DBOUND = ADDR(DICT(4000))
  329      FPOS = ADDR(PERM(1))-1;  FMAX = ADDR(PERM(518))
  330      %CYCLE I = 1,1,54
  331         SYMCODE = 0
  332         CODE ATOM;  %MONITOR %AND %STOP %IF ATOM # IDENT
  333         INTEGER(DLIM) = BYTEINTEGER(FPOS+1)<<8+BYTEINTEGER(FPOS+2)
  334         FPOS = FPOS+2
  335         INTEGER(DLIM+4) = 0
  336         INTEGER(DLIM+8) = HEAD;  HEAD = DLIM
  337         DLIM = NEWDLIM
  338      %REPEAT
  339      C_LOCAL = DLIM
  340      FPOS = FSTART-1;  FMAX = FPOS+FSIZE
  341      SYMCODE = 0
  342  L1: ->ENDED %IF FPOS >= FMAX
  343      LINEBASE = FPOS;  LINE = NEXTLINE
  344  L3: ATOM = JUMP;  !FOR NUMERIC LABEL DETECTION
  345      SKIPMIN = SKIP1MIN;  !TO IGNORE NULL STATEMENTS AND COMMENTS
  346      CODE ATOM
  347      SKIPMIN = NLCODE
  348      STATS = STATS+1
  349      EXTIND = 0;  DECLTYPE = 0
  350      CONSTCOUNT = 0;  DIMCOUNT = 0
  351      NP = 51
  352      LINKMAX = 1;  LINK(1) = LINK1;    !FOR GRATUITOUS PHRASE EXIT
  353      I = GRAM(INITBASE+ATOM)
  354      ->ERR %IF I = 0
  355      G = I>>6&1022+ADGRAM0
  356      ->A(ATOM)
  357  A(1): !IDENT
  358  A(6): !OP3
  359  A(9): !EQ
  360  A(13): !NL
  361  A(25): !COLON
  362      I = SHORTINTEGER(G); G = I>>6&1022+ADGRAM0
  363      ->A(I&127)
  364  A(10): A(11): A(12): A(15): A(18): A(19): A(20):
  365  A(21): A(23): A(27): A(37):
  366  A(43): A(44): A(45):
  367  A(47): A(48): A(50): A(57): A(65):
  368  CODE:
  369      CODE ATOM
  370  ON:
  371  REP:%CYCLE
  372  !     LOOPS = LOOPS+1
  373         CLASS = SHORTINTEGER(G)&127
  374         %EXIT %IF CLASS >= 60 %OR CLASS = ATOM
  375         G = G+2
  376      %REPEAT
  377      G = SHORTINTEGER(G)>>6&1022+ADGRAM0
  378      ->A(CLASS)
  379  A(109): A(110): A(111): A(113): A(114):
  380  A(115): A(116): A(117): A(118): A(119):
  381  A(120): A(121): A(122): A(123): A(124):
  382  A(125): A(126):
  383  ENTER:
  384      LINKMAX = LINKMAX+1;  ->ERR %IF LINKMAX > 20
  385      LINK(LINKMAX) = G
  386      G = PHRASE(CLASS)<<1+ADGRAM0
  387      ->REP
  388  A(66):
  389  EXIT:
  390      G = LINK(LINKMAX);  LINKMAX = LINKMAX-1
  391      ->REP
  392      
  393  A(67): !ALT (ALTERNATIVE PHRASE RECOGNISED)
  394      I = SHORTINTEGER(LINK(LINKMAX));  LINKMAX = LINKMAX-1
  395      ->ERR %IF I&127 # 0;  !NO ALTERNATIVE
  396      G = I>>6&1022+ADGRAM0
  397      ->ON
  398  A(68): !BREAK (TERMINATOR WITHIN CONST LIST)
  399      REPORT(FAULTNUM) %IF FAULTNUM >= 0
  400      %IF ATOMTYPE = 0 %START;  !NL
  401         LINEBASE = FPOS;  LINE = NEXTLINE
  402      %FINISH
  403      ->CODE
  404  
  405  UNKNOWN:
  406      %WHILE DPOS < 0 %CYCLE
  407         ->IGNORE %IF STRING(-DPOS+4) = STRING(DLIM+12)
  408         DPOS = INTEGER(-DPOS)
  409      %REPEAT
  410      FAULT(2)
  411      %CYCLE
  412         DBOUND = DBOUND-4;  NEWDLIM = NEWDLIM-4
  413         %EXIT %IF NEWDLIM = DLIM+8
  414         INTEGER(DBOUND) = INTEGER(NEWDLIM)
  415      %REPEAT
  416      HEAD == INTEGER(HEAD+8) %WHILE HEAD > 0
  417      INTEGER(DBOUND) = HEAD;  HEAD = -DBOUND
  418      ->IGNORE
  419  MODERR:
  420      FAULT(3)
  421      ->IGNORE
  422  A(0): A(64):
  423  ERR:FAULTNUM = 0;  FAULTNUM = ATOMTYPE %IF ATOM = 0
  424      ->DISASTER %IF FAULTNUM = 99
  425      FAULTPOS = FPOS1
  426  IGNORE:
  427      I=ATOM %AND CODE ATOM %WHILE ATOM # TERMINATOR
  428      C_STACK = C_STACK<<2+3 %IF I = START
  429      C_STACK = C_STACK<<2+2 %IF I = CYCLE
  430      REPORT(FAULTNUM) %IF FAULTNUM >= 0
  431      %WHILE I = COMMA %AND ATOMTYPE = 0 %CYCLE
  432         I=ATOM %AND CODE ATOM %UNTIL ATOM = TERMINATOR
  433      %REPEAT
  434  A(69): !FIN
  435  FIN:REPORT(FAULTNUM) %IF FAULTNUM >= 0
  436      %IF C_BTYPE&1 # 0 %START;  !PSEUDO BLOCK ENTRY FOR SPEC
  437         DLIM = C_LOCAL
  438         C = HOLD(LEVEL);  LEVEL = LEVEL-1
  439      %FINISH
  440      ->L3 %IF ATOMTYPE # 0;  !COLON OR SEMI-COLON
  441      ->L1;  !NEWLINE
  442  DISASTER:
  443      PRINT STRING("** SPACE EXHAUSTED AT LINE");  WRITE(NEXTLINE,1)
  444      NEWLINE
  445      %RETURN
  446  
  447  A(74):
  448  NAPP:
  449      -> ON %IF TYPE&APPMASK = 0
  450      ->ERR
  451  ER20:
  452      FAULT(20)
  453      ->NAPP
  454  ER22:
  455      FAULT(22)
  456      ->NAPP
  457  
  458  A(22): !PREC
  459      PRECISION = ATOMTYPE
  460      ->CODE
  461  A(38): !EXTERNAL
  462  A(42): !SYSTEM,DYNAMIC
  463      EXTIND = 1
  464      ->CODE
  465  A(70): !RESET
  466      DECLTYPE = 0
  467      ->ON
  468  A(36): !RECORD
  469      RECIDENTS = DLIM
  470  A(29): !REG
  471  A(30): !SWITCH
  472  A(31): !NTYPE
  473  A(32): !OWN
  474  A(33): !ARRAY
  475  A(34): !STRING
  476  A(35): !NAME
  477  A(39): !FM
  478  A(40): !ROUTINE
  479  A(41): !SPEC
  480      DECLTYPE = DECLTYPE!!ATOMTYPE
  481      DECLTYPE = DECLTYPE!PRECISION %IF DECLTYPE&X'F0' = X'10'
  482      IDENTS = DLIM
  483      MODES = \0;      !FOR SPEC LOOKS
  484      ->CODE
  485  A(75): !NOTYPE
  486      DECLTYPE = X'F9';         ! '?' VAR
  487      ->ON
  488  A(78): !IDENT: DC (DECLARE RECORD COMPONENT)
  489      HEAD == INTEGER(FIDENTPOS+4);  DPOS = HEAD;  !ALTER SEARCH LIST
  490  A(76): !IDENT: D (DECLARE)
  491  D1: ->ADD %IF C_BTYPE&1 # 0;  !WITHIN SPEC PARAMS
  492  D2: %CYCLE
  493         ->NEW %IF DPOS < C_LOCAL
  494         %EXIT %IF STRING(DPOS+12) = STRING(DLIM+12)
  495         DPOS = INTEGER(DPOS+8)
  496      %REPEAT
  497      ->D5 %IF INTEGER(DPOS)&X'FF'-1 = DECLTYPE %C
  498+       %AND DECLTYPE&6 # 0 %AND DECLTYPE&1 = 0
  499      FAULT(5);  !DUPLICATE
  500  NEW:INTEGER(DLIM+8) = HEAD;  HEAD = DLIM
  501  ADD:INTEGER(DLIM) = DECLTYPE;  INTEGER(DLIM+4) = 0
  502      DLIM = NEWDLIM
  503      ->CODE
  504     !PROCEDURE BODY AFTER SPEC, LABEL AFTER JUMP
  505  D5: INTEGER(DPOS) = DECLTYPE %IF DECLTYPE = LAB
  506      IDENTS = DPOS
  507      ->CODE
  508  A(77): !IDENT: DF (DECLARE RECORD FORMAT)
  509      DECLTYPE = RECFORMAT;  FIDENTPOS = DLIM
  510      ->D1
  511  A(2): !CONST
  512      TYPE = ATOMTYPE;  VAL = ATOMVAL
  513      ->CODE
  514  A(3): !SUB (ABSORBS FOLLOWING IDENT)
  515      -> ERR %IF TYPE&X'FFF4' # 0 %AND TYPE # RECFORMAT;  !NOT RECORD
  516      CODE ATOM;  ->ERR %IF ATOM # IDENT
  517      ->IGNORE %IF VAL = 0
  518      DPOS = VAL;  HEAD == VAL
  519  A(81): !IDENT: LOOK
  520  LOOK:
  521      LOOKS = LOOKS+1
  522      %CYCLE
  523         TIMES = TIMES+1
  524         ->UNKNOWN %IF DPOS <= 0
  525         %EXIT %IF STRING(DPOS+12) = STRING(DLIM+12)
  526         DPOS = INTEGER(DPOS+8)
  527      %REPEAT
  528      TYPE = INTEGER(DPOS);  VAL = INTEGER(DPOS+4)
  529      ->CODE %IF MODES<<(TYPE&15) < 0
  530      ->MODERR
  531  A(82): !IDENT: IMP1LOOK
  532      MODES = IMP1MODES
  533      ->LOOK %IF BYTEINTEGER(FPOS) # ':'
  534      DECLTYPE = LAB
  535      ->D2
  536  A(83): !IDENT: IMPLOOK
  537      MODES = IMPMODES
  538      ->LOOK
  539  A(84): !IDENT: EXPLOOK
  540      MODES = EXPMODES
  541      ->LOOK
  542  A(85): !IDENT: FLOOK
  543      MODES = FMATMODES
  544      ->LOOK
  545  A(86): !IDENT: JLOOK
  546      %WHILE DPOS >= C_LOCAL %CYCLE
  547         ->JL1 %IF STRING(DPOS+12) = STRING(DLIM+12)
  548         DPOS = INTEGER(DPOS+8)
  549      %REPEAT
  550      INTEGER(DLIM+8) = HEAD;  HEAD = DLIM
  551      INTEGER(DLIM) = JUMPLAB;  INTEGER(DLIM+4) = 0
  552      DPOS = DLIM;  DLIM = NEWDLIM
  553  JL1:TYPE = INTEGER(DPOS)
  554      ->CODE %IF TYPE&14 = LAB
  555      ->MODERR
  556  A(79): !RECSPEC
  557      ->MODERR %IF TYPE&X'F4' # 0 %OR VAL # 0 %OR DPOS < C_LOCAL
  558      RECIDENTS = -DPOS
  559      ->ON
  560  A(88): !FSET
  561      IDENTS = RECIDENTS
  562      %IF IDENTS >= 0 %THEN DEFINE(4,INTEGER(DPOS+4)) %C
  563+     %ELSE INTEGER(-IDENTS+4) = INTEGER(DPOS+4)
  564      ->ON
  565  A(80):  !PROCSPEC
  566      ->MODERR %IF TYPE&X'FF03' # FN %OR DPOS < C_LOCAL
  567      IDENTS = DPOS
  568      ->ON
  569  A(72): !BEG
  570      PIDENTPOS = IDENTS
  571      LEVEL = LEVEL+1;  ->DISASTER %IF LEVEL > 12
  572      HOLD(LEVEL) = C
  573      C_BTYPE = DECLTYPE
  574      C_STACK = 0
  575      C_LOCAL = DLIM
  576      ->ON
  577  A(89): !NL: PARSET
  578      IDENTS = C_LOCAL;  NP = 51
  579      %WHILE IDENTS # DLIM %CYCLE
  580         NP = NP-1;  NTYPE(NP) = INTEGER(IDENTS)
  581         IDENTS = BYTEINTEGER(IDENTS+12)&(\3)+IDENTS+16
  582      %REPEAT
  583      I = 0
  584      %WHILE NP # 51 %CYCLE
  585         J = I<<24+NTYPE(NP);  NP = NP+1
  586         I = I+1 %UNTIL I > PARMAX %OR PARTYPE(I) = J
  587         %IF I > PARMAX %START
  588            ->DISASTER %IF I = 252
  589            PARMAX = I
  590            PARTYPE(I) = J
  591         %FINISH
  592      %REPEAT
  593      %IF C_BTYPE&1 = 0 %AND INTEGER(PIDENTPOS)&1 # 0 %START
  594         FAULT(18) %IF BYTEINTEGER(PIDENTPOS+2) # I
  595         INTEGER(PIDENTPOS) = C_BTYPE
  596      %FINISH
  597      BYTEINTEGER(PIDENTPOS+2) = I
  598      INTEGER(PIDENTPOS) = INTEGER(PIDENTPOS)&(\EXTIND)
  599      ->FIN
  600  A(90): !INIT
  601      CONSTCOUNT = CONSTCOUNT-1
  602      ->ER20 %IF TYPE&15 # 0
  603      ->ER22 %IF TYPE&DECLTYPE = 0
  604      !RANGE CHECK
  605      DEFINE(4,VAL) %IF DECLTYPE&15 = 0
  606      ->ON
  607  A(91): !NL: INITFIN
  608      FAULT(21) %IF CONSTCOUNT # 0 %AND CONSTCOUNT < 1000000
  609      ->FIN
  610  A(92): !DIMSET
  611      DEFINE(0,DIMCOUNT)
  612      DIMCOUNT = 0
  613      ->ON
  614  A(93): !COLON: COUNT
  615      %IF DIMCOUNT = 6 %THEN FAULT(23) %ELSE DIMCOUNT = DIMCOUNT+1
  616      ->CODE
  617  A(94): !REP
  618      CONSTCOUNT = CONSTCOUNT-VAL+1
  619      ->ON
  620  A(95): !LITINT
  621      ->ER20 %IF TYPE&15 # 0
  622  A(96): !INT
  623      ->ER22 %IF TYPE&INTBIT = 0
  624      ->NAPP
  625  A(97): !STR
  626      ->ER22 %IF TYPE&STRINGBIT = 0
  627      ->NAPP
  628  A(98): !SIZESET
  629      STRINGSIZE = VAL
  630      ->ON %IF 0 < VAL <= 255
  631      FAULT(19);  STRINGSIZE = 255
  632      ->ON
  633  A(99): !CBSET
  634      LASTVAL = NVAL(NP);  NP = NP+1
  635      ->CBERR %UNLESS -32768 <= LASTVAL <= 32767
  636      CONSTCOUNT = VAL-LASTVAL+1
  637      ->CBERR %UNLESS 0 < CONSTCOUNT <= 32767
  638      %IF DECLTYPE = SWITCH %START
  639         {%UNTIL IDENTS = DLIM} %CYCLE
  640            J = DBOUND
  641            DBOUND = J-(CONSTCOUNT+63)>>5<<2
  642            ->DISASTER %IF DBOUND <= DLIM
  643            INTEGER(IDENTS+4) = DBOUND
  644            INTEGER(DBOUND) = LASTVAL<<16+CONSTCOUNT
  645            %CYCLE
  646               J = J-4
  647               %EXIT %IF J = DBOUND
  648               INTEGER(J) = 0
  649            %REPEAT
  650            IDENTS = BYTEINTEGER(IDENTS+12)&(\3)+IDENTS+16
  651         %REPEAT %UNTIL IDENTS = DLIM
  652      %FINISH
  653  CB1:IDENTS = DLIM
  654      ->ON
  655  CBERR:
  656      FAULT(23);  CONSTCOUNT = 2000000
  657      ->CB1
  658  A(100): !COLON: LAB
  659      ->FIN %IF DECLTYPE # 0;  !SIMPLE LABEL
  660      ->ERR %IF TYPE # JUMPLAB;  !IE SWITCH + APP
  661      FAULT(20) %AND ->FIN %IF LASTTYPE&15 # 0
  662      ->FIN %IF VAL = 0
  663      J = LASTVAL-SHORTINTEGER(VAL)
  664      FAULT(19) %AND ->FIN %UNLESS 0 <= J < SHORTINTEGER(VAL+2)
  665      I = VAL+J>>5<<2;  J = X'80000000'>>(J&31)
  666      FAULT(16) %IF INTEGER(I+4)&J # 0
  667      INTEGER(I+4) = INTEGER(I+4)!J
  668      ->FIN
  669  A(101): !OP3: DOT
  670      ->ERR %IF ATOMTYPE # STRINGBIT;  !IE OP3 # '.'
  671  A(60): !FOR
  672      MODES = DESTMODES
  673      ->CODE
  674  A(73): !RESOL
  675      ->ER22 %IF TYPE&STRINGBIT = 0
  676      MODES = DESTMODES
  677      ->ON
  678  A(102): !OP3: SIGN
  679      ->ERR %IF ATOMTYPE&3 = 0;  !IE OP3 # '+', '-', '!'
  680      TYPE = ATOMTYPE;  VAL = 0
  681      ->OP1
  682  A(7):  !UOP
  683      TYPE = ATOMTYPE;  VAL = -1
  684      ->OP1
  685  A(8):  !COP
  686  A(4): !OP1
  687  A(5): !OP2
  688  A(104):!OP3 OR EQ: OP
  689      ->ERR %IF TYPE&APPMASK # 0
  690      %IF TYPE&X'FF4F' = INTBIT %THEN TYPE=TYPE!15 %ELSE TYPE=TYPE&(\15)
  691      TYPE = TYPE!REALBITS %IF TYPE&NUMBITS # 0
  692  OP1:NP = NP-1;  NTYPE(NP) = TYPE&ATOMTYPE;  NVAL(NP) = VAL
  693      ->CODE
  694  A(105): !EVAL
  695      ->ERR %IF TYPE&APPMASK # 0
  696      TYPE = TYPE!REALBITS %IF TYPE&NUMBITS # 0
  697      I = NTYPE(NP);  NP = NP+1
  698      J = I&TYPE&X'F0'
  699      ->ER22 %IF J = 0
  700      ->X(I&15) %IF TYPE&X'FF4F' = INTBIT
  701  X(0):
  702      TYPE = J+EXP
  703      ->ON
  704  X(1): VAL = NVAL(NP-1)+VAL
  705  X1: TYPE = NUMBITS
  706      ->ON
  707  X(2): VAL = NVAL(NP-1)-VAL
  708      ->X1
  709  X(3): VAL = NVAL(NP-1)!VAL
  710      ->X1
  711  X(4): VAL = NVAL(NP-1)!!VAL
  712      ->X1
  713  A(103): !BAR (FIDDLE FOR MOD-SIGN)
  714      ->ON %UNLESS NTYPE(NP) = X'43'
  715      ->ERR %UNLESS ATOM = OP3 %AND ATOMTYPE = X'43'
  716      NP = NP+1;  CODE ATOM
  717      ->EXIT
  718  A(106): !EQ: ASSOP
  719      ->ERR %IF TYPE&X'FF0C' # 8
  720  SAVE:
  721      NP = NP-1;  NTYPE(NP) = TYPE;  NVAL(NP) = VAL
  722      ->CODE
  723  A(14): !EQEQ
  724      MODES = ADRMODES
  725      ->SAVE %IF TYPE&15 = REF
  726      ->ERR
  727  A(107): !ASS
  728      I = NTYPE(NP);  NP = NP+1
  729  AS1:%IF I&TYPE&X'C0' = 0 %START
  730         I = I&X'F0'
  731         %IF I = 0 %START;  !RECORD
  732            ->ER22 %UNLESS TYPE&X'F0' = 0 %OR %C
  733+             (TYPE&X'FF4F'=INTBIT %AND VAL=0)
  734         %FINISH %ELSE %START
  735            ->ER22 %UNLESS I <= X'30' %AND TYPE&NUMBITS # 0
  736         %FINISH
  737      %FINISH
  738      ->NAPP
  739  A(108): !REFASS
  740      I = NTYPE(NP);  NP = NP+1
  741  RA1:FAULT(22) %IF (I!!TYPE)&X'F0' # 0 %C
  742+       %AND I&X'F0' # X'F0' %AND TYPE&X'F0' # X'F0'
  743      ->NAPP %IF I&APPMASK = 0;  !SCALAR
  744      FAULT(22) %IF TYPE&APPMASK = 0 %OR TYPE&14 = MAP
  745      ->ON
  746  A(17): !RESULT
  747      FAULT(25) %IF C_BTYPE&7 # FN
  748      TYPE = C_BTYPE&X'F8';  TYPE = TYPE+VAR %IF TYPE&8 = 0
  749      VAL = 0
  750      ->CODE
  751  A(71): !RCALL
  752      ->ON %IF TYPE&X'FFFC' = 4
  753      ->ERR
  754  A(112): !APP
  755      ->ON %IF ATOM # LB
  756      LINKMAX = LINKMAX+1;  ->ERR %IF LINKMAX > 20
  757      LINK(LINKMAX) = G
  758      NP = NP-1;  NVAL(NP) = VAL
  759  AP: ->ERR %IF TYPE&APPMASK = 0
  760      NTYPE(NP) = TYPE
  761      G = APPCONT
  762      CODE ATOM
  763      J = PARTYPE(TYPE>>8)&15
  764      CLASS = 122;  !EXP
  765      ->ENTER %IF J = VAR
  766      CLASS = 111;  MODES = ADRMODES
  767      ->ENTER %IF J = REF
  768      MODES = X'C0000000'>>J
  769      ->ENTER
  770  A(63): !AP
  771      J = NTYPE(NP);  I = PARTYPE(J>>8)
  772      LASTTYPE = TYPE;  LASTVAL = VAL
  773      TYPE = I>>16+J&X'FF'
  774      ->AP %IF ATOM = COMMA
  775      ->ERR %IF ATOM # RB
  776      VAL = NVAL(NP);  NP = NP+1
  777      %IF TYPE&APPMASK # 0 %START
  778         TYPE = TYPE!!APPMASK
  779         ->ERR %IF TYPE&X'FE00' # 0
  780      %FINISH
  781      TYPE = TYPE&X'FFFC'!1
  782      CODE ATOM
  783      ->EXIT
  784  A(16): !SIMP: STOP(0), RETURN(1), EXIT(2)
  785      FAULT(25) %IF (ATOMTYPE = 1 %AND C_BTYPE&15 # ROUTINE) %C
  786+           %OR (ATOMTYPE = 2 %AND (C_STACK!!X'55555555')<<1&C_STACK = 0)
  787      ->CODE
  788  A(54): !CYCLE
  789      CONDIND = 2
  790  A(53): !START
  791      C_STACK = C_STACK<<2+CONDIND
  792      ->CODE
  793  A(55): !FINISH(1)
  794  A(56): !REPEAT(0)
  795      CONDIND = C_STACK&3
  796      %IF CONDIND = 0 %OR (CONDIND!!ATOMTYPE)&1 # 0 %C
  797+      %THEN FAULT(12+ATOMTYPE) %C
  798+     %ELSE C_STACK = C_STACK>>2
  799      ->CODE
  800  A(52): !ELSE(1)
  801      FAULT(25) %IF CONDIND = 1
  802  A(26): !CWORD(3)
  803  A(51): !ON(1)
  804      CONDIND = ATOMTYPE
  805      ->CODE
  806  A(58): !END
  807      %IF LEVEL = 0 %OR (LEVEL=1 %AND C_BTYPE=0) %THEN FAULT(11) %C
  808+     %ELSE POP CONTEXT
  809      ->CODE
  810  A(59): !ENDPROG
  811      FPOS1 = FPOS
  812      REPORT(8) %IF LEVEL > ATOMTYPE
  813      REPORT(11) %IF LEVEL < ATOMTYPE
  814      POP CONTEXT %WHILE LEVEL > 0
  815      TIME2 = CPUTIME
  816      ->ENDOK
  817  ENDED:
  818      TIME2 = CPUTIME
  819      PRINT STRING("** END OF FILE AT LINE");  WRITE(NEXTLINE,1)
  820      NEWLINE
  821  ENDOK:
  822      %IF PARM&4 # 0 %START
  823         WRITE(LINE,4);  PRINTSYMBOL('L')
  824         WRITE(STATS,4);  PRINT SYMBOL('S')
  825         STATS = 1 %IF STATS = 0
  826         PRINT(ATOMS/STATS,2,1);  PRINT SYMBOL('A')
  827         PRINT(NUMBERS/STATS,2,1);  PRINT SYMBOL('N')
  828         PRINT(IDENTIFIERS/STATS,2,1);  PRINT SYMBOL('I')
  829         PRINT(LOOPS/STATS,2,1);  PRINT SYMBOL('C')
  830         PRINT(TIMES/LOOKS,2,1);  PRINT SYMBOL('H')
  831         PRINT((TIME2-TIME1)*1000/STATS,3,3);  PRINT SYMBOL('M')
  832         NEWLINE
  833      %FINISH
  834      %IF PARM&8 # 0 %START
  835         %CYCLE I = 0,1,255
  836            J = INDEX(I)
  837            %IF J > 0 %START
  838               WRITE(I,3);  PRINT SYMBOL(':')
  839               %WHILE J > 0 %CYCLE
  840                  SPACE;  PRINT STRING(STRING(J+12))
  841                  J = INTEGER(J+8)
  842               %REPEAT
  843               NEWLINE
  844            %FINISH
  845         %REPEAT
  846      %FINISH
  847      %RETURN
  848  
  849  !
  850  
  851  %ROUTINE PRINT SS
  852  {%SHORTROUTINE}
  853  %INTEGER K
  854  %ROUTINE WRITE(%INTEGER V,P)
  855      %IF V >= 10 %START
  856         WRITE(V//10,P-1);  V = V-10*(V//10)
  857      %FINISH %ELSE SPACES(P-1)
  858      PRINT SYMBOL(V+'0')
  859  %END
  860      WRITE(LINE,4);  SPACE
  861      PRINTPOS = LINEBASE
  862      {%UNTIL PRINTPOS = FPOS1} %CYCLE
  863         PRINTPOS = PRINTPOS+1
  864         PRINT SYMBOL(MARKER) %IF PRINTPOS = FAULTPOS
  865         K = BYTEINTEGER(PRINTPOS)
  866         %IF K = NL %OR 32 <= K <= 126 %THEN PRINT SYMBOL(K) %C
  867+        %ELSE PRINT SYMBOL('[') %AND WRITE(K,0) %AND PRINT SYMBOL(']')
  868      %REPEAT %UNTIL PRINTPOS = FPOS1
  869      NEWLINE %IF K # NL
  870  %END
  871  
  872  %ROUTINE REPORT(%INTEGER N)
  873  {%SHORTROUTINE}
  874  %SWITCH S(0:25)
  875         FAULTPOS = 0 %IF N > 7
  876         PRINT SS %IF PRINTPOS # FPOS1
  877         PRINT SYMBOL('*')
  878         ->S(N)
  879  S(0): PRINT STRING("FORM?");  ->F
  880  S(1): PRINT STRING("ATOM?");  ->F
  881  S(2): PRINT STRING("NAME?");  ->F
  882  S(3): PRINT STRING("MODE?");  ->F
  883  S(4): PRINT STRING("SIZE?");  ->F
  884  S(11):PRINT STRING("%BEGIN");  ->M
  885  S(12):PRINT STRING("%CYCLE");  ->M
  886  S(13):PRINT STRING("%START");  ->M
  887  S(8): PRINT STRING("%END");  ->M
  888  S(9): PRINT STRING("%REPEAT");  ->M
  889  S(10):PRINT STRING("%FINISH");  ->M
  890  S(15): PRINT SYMBOL('''')
  891         PRINT STRING(STRING(DPOS+12))
  892         PRINT SYMBOL('''')
  893  M:    PRINT STRING(" MISSING");  ->F
  894  S(23):PRINT STRING("BOUNDS?");  ->F
  895  S(25):PRINT STRING("CONTEXT?");  ->F
  896  S(5):
  897  S(16):PRINT STRING("DUPLICATE");  ->F
  898  S(17):PRINT STRING("ORDER?");  ->F
  899  S(18):PRINT STRING("MATCH?");  ->F
  900  S(19):PRINT STRING("RANGE?");  ->F
  901  S(20):PRINT STRING("LITERAL?");  ->F
  902  S(21): %IF CONSTCOUNT < 0 %START
  903            WRITE(-CONSTCOUNT,1); PRINT STRING(" EXTRA")
  904         %FINISH %ELSE %START
  905            WRITE(CONSTCOUNT,1); PRINT STRING(" MISSING")
  906           %FINISH
  907        PRINT STRING(" VALUE(S)");  ->F
  908  S(22):PRINT STRING("TYPE?");  ->F
  909  F:     NEWLINE
  910      FAULTNUM = -1;  PARM = PARM!X'80000000'
  911  %END
  912  
  913  %ROUTINE CODE ATOM
  914  {%SHORTROUTINE}
  915  {%REGISTER} %INTEGER FP{(5)};  !FILE POS
  916  {%REGISTER} %INTEGER SC{(6)};  !SYMCODE OR SYM
  917  %INTEGER I,J,K,L
  918  %INTEGER HASH
  919  
  920      ATOMS = ATOMS+1
  921      FP = FPOS;  SC = SYMCODE
  922      ->C2 %IF SC # 0
  923  C1: {%UNTIL SC # ' '} %CYCLE
  924         FP = FP+1;  SC = BYTEINTEGER(FP)
  925      %REPEAT %UNTIL SC # ' '
  926      SC = SYMINIT(SC)
  927  C2: FPOS1 = FP
  928      ->NAMENUM %IF SC < 127
  929      SC = SC-128
  930      ->KEYWORD %IF SC > 0
  931      ->QUOTEMARK %IF SC # 0
  932     !PERCENT
  933      FP = FP+1;  SC = SYMINIT(BYTEINTEGER(FP)!128)
  934      ->C2 %IF SC # 0
  935      ->C1
  936  
  937  !LOCATE ATOM IN FIXED DICT
  938  !KEYDICT := MORE<5> : LINK<9> : SYM-32<6>
  939  !           OR CLASS<7> : 0<6>
  940  !           THEN  SUBCLASS<16>
  941  KEYWORD:
  942      ->NLQ %IF SC >= SKIPMIN;  !NL OR EQUIVALENT
  943      I = SC;  L = 0;  L = 128 %IF SC < PUNCTMIN
  944      %CYCLE
  945         %CYCLE
  946            FP = FP+1;  K = BYTEINTEGER(FP)
  947            SC = SYMINIT(K!L)
  948            %EXIT %IF SC&127 # 0
  949            L = SC
  950         %REPEAT
  951         K = K-32 %IF SC&128 # 0
  952         %CYCLE
  953            J = KEYDICT(I)
  954            %EXIT %IF J >= 0 %OR J&63 = K
  955            I = I+1
  956         %REPEAT
  957         %EXIT %IF J&63 # K
  958         I = J>>6&511
  959      %REPEAT
  960      ->ERR %IF J&63 # 0
  961      ATOMTYPE = KEYDICT(I+1)&X'FFFF'
  962      ATOM = J>>6
  963      ->KEY5 %IF ATOM = 0
  964  FIN:FPOS = FP;  SYMCODE = SC
  965      %RETURN
  966  KEY5:
  967      %IF ATOMTYPE # 0 %START;  !%COMMENT
  968         ->FIN %IF SKIPMIN # SKIP1MIN
  969         ->SKP
  970      %FINISH
  971      ->ERR %UNLESS BYTEINTEGER(FP) = NL
  972      NEXTLINE = NEXTLINE+1
  973      ->TERM %IF FP >= FMAX
  974      ->C1
  975  
  976  NLQ:
  977      ->TERM %IF SKIPMIN # SKIP1MIN;  !NOT LEADING ATOM
  978  SKP:
  979      FP = FP-1
  980      {%UNTIL SC = NL %OR SC = ';'} %CYCLE
  981         FP = FP+1;  SC = BYTEINTEGER(FP)
  982      %REPEAT %UNTIL SC = NL %OR SC = ';'
  983      %IF SC = NL %START
  984         ->TERM %IF FP >= FMAX
  985         LINEBASE = FP;  NEXTLINE = NEXTLINE+1;  LINE = NEXTLINE
  986      %FINISH
  987      ->C1
  988  
  989  TERM:
  990      ATOM = TERMINATOR;  ATOMTYPE = 0
  991      NEXTLINE = NEXTLINE+1;  SC = 0
  992      SC = 255 %IF FP >= FMAX
  993      ->FIN
  994  
  995  DISASTER:
  996      ATOMTYPE = 99
  997      ->ER1
  998  STRINGERR:
  999      ATOMTYPE = 4;  NEXTLINE = L
 1000  ER1:FP = FPOS1;  SC = 0
 1001      ->ER2
 1002  ERR:ATOMTYPE = 1
 1003  ER2:ATOM = 0
 1004      ->FIN
 1005  
 1006  NAMENUM:
 1007      ->NUMBER %IF SC <= '9' %AND ATOM # JUMP
 1008      %IF BYTEINTEGER(FP+1) = '''' %START
 1009         ->HEX %IF SC = 'X'
 1010         ->OCT %IF SC = 'K'
 1011         ->BIN %IF SC = 'B'
 1012         ->MULTI %IF SC = 'M'
 1013      %FINISH
 1014      J = DLIM;  ->DISASTER %IF J+84 >= DBOUND
 1015      HASH = 0
 1016      {%UNTIL SC > 'Z'} %CYCLE
 1017         %IF SC # 0 %START
 1018            J = J+1;  BYTEINTEGER(J+12) = SC
 1019            HASH = HASH<<1!!SC
 1020         %FINISH
 1021         FP = FP+1;  SC = SYMINIT(BYTEINTEGER(FP))
 1022      %REPEAT %UNTIL SC > 'Z'
 1023      BYTEINTEGER(DLIM+12) = J-DLIM
 1024      NEWDLIM = J&(\3)+16
 1025      HEAD == INDEX(HASH&255);  DPOS = HEAD;
 1026      ATOM = IDENT;
 1027      IDENTIFIERS = IDENTIFIERS+1
 1028      ->FIN
 1029  
 1030  NUMBER:
 1031      ATOMTYPE = NUMBITS
 1032      ATOMVAL = SC-'0'
 1033      %CYCLE
 1034         FP = FP+1;  SC = SYMINIT(BYTEINTEGER(FP))
 1035         %EXIT %IF SC > '9'
 1036         ATOMVAL = (ATOMVAL<<2+ATOMVAL)<<1+SC-'0' %C
 1037+          %IF SC # 0 %AND ATOMVAL < 1000000
 1038      %REPEAT
 1039      %IF BYTEINTEGER(FP) = '.' %START
 1040         {%UNTIL SC > '9'} %CYCLE
 1041            FP = FP+1;  SC = SYMINIT(BYTEINTEGER(FP))
 1042         %REPEAT %UNTIL SC > '9'
 1043         ATOMTYPE = REALBITS
 1044      %FINISH
 1045      %IF BYTEINTEGER(FP) = '@' %START
 1046         {%UNTIL SC # ' '} %CYCLE
 1047            FP = FP+1;  SC = BYTEINTEGER(FP)
 1048         %REPEAT %UNTIL SC # ' '
 1049         %IF SC = '-' %START
 1050            {%UNTIL SC # ' '} %CYCLE
 1051               FP = FP+1;  SC = BYTEINTEGER(FP)
 1052            %REPEAT %UNTIL SC # ' '
 1053         %FINISH
 1054         SC = SYMINIT(SC)
 1055         ->ERR %UNLESS SC <= '9'
 1056         {%UNTIL SC > '9'} %CYCLE
 1057            FP = FP+1;  SC = SYMINIT(BYTEINTEGER(FP))
 1058         %REPEAT %UNTIL SC > '9'
 1059         ATOMTYPE = REALBITS
 1060      %FINISH
 1061  NN: ATOM = CONST
 1062      NUMBERS = NUMBERS+1
 1063      ->FIN
 1064  
 1065  MULTI:
 1066      FP = FP+1
 1067      ATOMTYPE = NUMBITS
 1068      ->Q1
 1069  QUOTEMARK:
 1070      ATOMTYPE = STRINGBIT
 1071  Q1: K = BYTEINTEGER(FP);  J = -1;  L = NEXTLINE
 1072      ATOMVAL = 0
 1073      %CYCLE
 1074         FP = FP+1;  SC = BYTEINTEGER(FP)
 1075         %IF SC = NL %START
 1076            NEXTLINE = NEXTLINE+1
 1077            ->TERM %IF FP >= FMAX
 1078         %FINISH
 1079         %IF SC = K %START
 1080            %EXIT %IF SC # BYTEINTEGER(FP+1)
 1081            FP = FP+1
 1082         %FINISH
 1083         ATOMVAL = ATOMVAL<<8+SC
 1084         J = J+1;  ->STRINGERR %IF J = 255
 1085      %REPEAT
 1086      %IF ATOMTYPE = STRINGBIT %START;  !IE NOT MULTI
 1087         ATOMVAL = J<<8+ATOMVAL&255
 1088         ATOMTYPE = STRINGBIT+NUMBITS %IF J = 0
 1089      %FINISH
 1090      SC = 0
 1091      ->NN
 1092  
 1093  HEX:J = 4;  ->RAD
 1094  OCT:J = 3;  ->RAD
 1095  BIN:J = 1
 1096  RAD:FP = FP+1
 1097      ATOMTYPE = NUMBITS;  ATOMVAL = 0
 1098      %CYCLE
 1099         FP = FP+1;  SC = BYTEINTEGER(FP)
 1100         %EXIT %IF SC = ''''
 1101         K = SC-'0'
 1102         K = K+('0'-'A'+10) %IF K >= 'A'-'0'
 1103         ->ERR %IF K>>J # 0
 1104         ATOMVAL = ATOMVAL<<J+K
 1105      %REPEAT
 1106      SC = 0
 1107      ->NN
 1108  
 1109  %END; !CODE ATOM
 1110  
 1111  %ROUTINE POP CONTEXT
 1112  {%SHORTROUTINE}
 1113  %INTEGER I
 1114      DPOS = C_LOCAL;  FPOS1 = FPOS
 1115      %WHILE DPOS # DLIM %CYCLE
 1116         I = INTEGER(DPOS)
 1117         %IF I # RECFORMAT %START
 1118            REPORT(15) %IF I&1 # 0 %AND I&6 # 0
 1119         %FINISH %ELSE %START
 1120            DPOS = INTEGER(DPOS+4) %IF INTEGER(DPOS+4) # 0
 1121         %FINISH
 1122         DPOS = BYTEINTEGER(DPOS+12)&(\3)+DPOS+16
 1123      %REPEAT
 1124      REPORT(C_STACK&1+9) %AND C_STACK=C_STACK>>2 %WHILE C_STACK # 0
 1125      DLIM = C_LOCAL
 1126      C = HOLD(LEVEL);  LEVEL = LEVEL-1
 1127      %CYCLE I = ADDR(INDEX(0)),4,ADDR(INDEX(255))
 1128         INTEGER(I) = INTEGER(INTEGER(I)+8) %WHILE INTEGER(I) >= DLIM
 1129      %REPEAT
 1130  %END
 1131  
 1132  %ROUTINE DEFINE(%INTEGER DISP,VAL)
 1133  {%SHORTROUTINE}
 1134      %WHILE IDENTS # DLIM %CYCLE
 1135         %IF DISP # 0 %THEN INTEGER(IDENTS+4) = VAL %C
 1136+        %ELSE BYTEINTEGER(IDENTS+2) = VAL
 1137         IDENTS = BYTEINTEGER(IDENTS+12)&(\3)+IDENTS+16
 1138      %REPEAT
 1139  %END
 1140  
 1141  
 1142  %END;
?RA1 unused
?AS1 unused
 1143       ;  !CHECKINNER
 1143  
 1144  %EXTERNALROUTINE CHECK(%STRING(63) PARAM)
 1145  %RECORDFORMAT FINF(%INTEGER CONAD,FILESIZE, %BYTEINTEGER RUP, %C
 1146+               EEP,MODE,CONS,ARCH, %STRING(6) TRAN, %C
 1147+               %SHORTINTEGER FILETYPE,NUMIPERMS, %C
 1148+               %INTEGER DATASTART,DATAEND, PLISTPTR)
 1149  {%EXTERNAL}%ROUTINE{SPEC} DEFINE(%STRING(63) S)
 1150  %end
?S unused
 1151  {%SYSTEM}%ROUTINE{SPEC} CONNECT(%STRING(15) S, %INTEGER A,M,P, %C
 1152+                            %RECORD(FINF)%NAME R, %INTEGERNAME F)
 1153  %end
?F unused
?R unused
?P unused
?M unused
?A unused
?S unused
 1154  {%EXTERNAL}%STRING(255)%FN{SPEC} SSFMESSAGE
 1155  %result="error"  ;! I thought I had added this one to the perms..?
 1156  %end
 1157  
 1158  %RECORD(FINF) R
 1159  %INTEGER I,J,FLAG
 1160  %STRING(63) OPTIONS,OUT
 1161      OUT = "" %UNLESS PARAM -> PARAM.("/").OUT
 1162      OPTIONS = "" %UNLESS PARAM -> PARAM.(",").OPTIONS
 1163      CONNECT(PARAM,0,0,0,R,FLAG)
 1164      PRINTSTRING(SSFMESSAGE) %AND %RETURN %IF FLAG # 0
 1165      %IF OUT # "" %START
 1166         DEFINE("ST19,".OUT)
 1167         SELECT OUTPUT(19)
 1168      %FINISH
 1169      I = 0
 1170      %WHILE I < LENGTH(OPTIONS) %CYCLE
 1171         I = I+1;  J = CHARNO(OPTIONS,I)
 1172         FLAG = FLAG!8 %IF J = 'D'
 1173         FLAG = FLAG!4 %IF J = 'S'
 1174      %REPEAT
 1175      CHECKINNER(R_CONAD+R_DATASTART,R_DATAEND-R_DATASTART,FLAG)
 1176     PRINT STRING(" OK") %AND NEWLINE %IF FLAG >= 0
 1177  %END;  !CHECK
 1178  
 1179  %begin
 1180  %end
 1181  
 1182  %ENDOFFILE

  911 Statements compiled
