         Edinburgh IMP77 Compiler - Version 8.4

    1  !!! %option  stack=30
    2  !!!  19-Feb-82         !!!! 15/5/78
    3  {Modified run under new subsystem so that it can support its own supervisor}
    4  
    5  !!!!!!!!!!!%CONTROL 1;   ! ... TEST ONLY SWITCHES
    6  %CONSTSTRING(5) VERSION = "4.12"
    7  
    8  %CONSTINTEGER GBASE= 426
    9  %CONSTINTEGER  GMAX = 512;   !???
   10  
   11     {Changed from %CONST to %OWN to get 8.1 pass1 to accept source}
   12  %ownSHORTINTEGERARRAY PHRASE(132:255) = 326, 137, 219,   0,
   13+  386, 164, 242, 246, 216, 210, 229,  98,
   14+  378, 183, 310, 292, 268, 259, 349, 221,
   15+  367, 364, 410, 413, 416, 419, 422, 391,
   16+  405, 199, 236, 158, 382, 357,   0, 278,
   17+  285, 307, 302, 318, 321, 346, 341, 370,
   18+  425, 426,   0,   0,   0,   0,   0,   0,
   19+    0,   0,   0,   0,   0,   0,   0,   0,
   20+    0,   0,   0,   0,   0,   0,   0,   0,
   21+    0,   0,   0,   0,   0,   0,   0,   0,
   22+    0,   0,   0,   0,   0,   0,   0,   0,
   23+    0,   0,   0,   0,   0,   0,   0,   0,
   24+    0,   0,   0,   0,   0,   0,   0,   0,
   25+    0,   0,   0,   0,   0,   0,   0,   0,
   26+    0,   0,   0,   0,   0,   0,   0,   0,
   27+    0,   0,   1,   7,  40,  49,  96,   0
   28  
   29  %CONSTBYTEINTEGERARRAY ATOMIC(105:130) =
   30+   14,   9,   4,  20,   6, 110, 111,  30,
   31+    3,  80,  59,  59,  13,   4,  13,  59,
   32+   43,  73,  79,  72,  71,   4,   2,   2,
   33+    4,   2
   34  
   35  %OWNSHORTINTEGERARRAY GRAM(0:GMAX) =
   36+        0,  -32765,       4,       5,     511,    8198,       4,  -32748,
   37+   -32747,  -32741,  -32740,  -32739,  -32738,  -32737,      15,  -32736,
   38+   -32750,     511,  -32257,      15,      27,      22,  -32744,     511,
   39+     8217,  -32747,     511,     511,     511,      27,      33,      37,
   40+       36,    8226,  -32750,     511,      16,    8230,  -32737,     511,
   41+   -32726,     511,      43,      44,  -32725,  -32721,      27,  -32725,
   42+       44,  -32708,  -32706,  -32698,  -32689,  -32688,  -32687,  -32741,
   43+   -32675,  -32686,  -32741,      66,  -32706,     511,  -32698,  -32695,
   44+   -32257,      27,  -24482,  -24482,  -32673,     511,      71,  -32694,
   45+   -32695,     511,  -32695,  -32257,      77,  -32681,     511,      89,
   46+   -32257,    4187,  -32685,      84,  -32685,  -32695,     511,  -32695,
   47+       27,  -32703,      73,  -32695,     511,    8219,    8219,   12315,
   48+       97,      27,  -32657,  -32647,  -32655,  -32654,  -32647,  -32660,
   49+   -32653,  -32651,  -32646,     122,  -32645,  -32649,     120,  -32644,
   50+      121,  -32643,     126,  -32645,     119,  -32641,     128,  -24576,
   51+     8192,     129,     130,       0,    8192,    8192,    8192,    8192,
   52+      131,     132,     133,     134,     114,     115,     135,  -32649,
   53+      123,  -32768,  -32622,  -32621,  -32620,  -32624,  -32619,     150,
   54+   -32623,    8344,    8192,     126,     125,     154,  -32613,       0,
   55+   -32612,       0,     157,       0,   20480,     150,  -32607,  -32606,
   56+      163,    4096,    4608,    2048,  -32594,  -32768,  -32768,  -32594,
   57+   -32594,  -32593,  -32593,  -32591,  -32591,     177,     178,  -32589,
   58+        0,     180,     181,       0,     182,       0,     175,  -32594,
   59+   -32768,  -32768,  -32594,  -32594,  -32594,  -32574,  -32574,  -32573,
   60+   -32573,     195,     196,     197,       0,     198,     194,  -32564,
   61+   -32564,  -32562,  -32562,     206,  -32561,       0,     208,       0,
   62+      209,     204,  -32555,  -32768,       0,     214,   12503,       0,
   63+     8409,  -32552,       0,  -24576,    8192,  -32542,     223,  -32541,
   64+   -32540,     174,       0,     215,       0,  -32532,  -32536,     241,
   65+   -32529,  -24576,  -32533,    8192,  -32533,  -32533,    8192,  -24576,
   66+     8192,       0,     243,  -32526,  -32768,     243,  -32520,     249,
   67+      250,     254,  -32516,       0,  -32518,     250,    8447,     256,
   68+   -32510,       0,       0,  -32507,     262,    4608,    2311,     264,
   69+    18697,  -32501,       0,   10240,  -32498,     271,     272,     273,
   70+      274,     125,   16659,  -32491,       0,    8192,  -32768,  -32486,
   71+   -32485,       0,     215,    8476,       0,  -32768,  -32768,  -32478,
   72+   -32477,       0,     215,     284,  -32468,  -32474,    8487,  -32474,
   73+   -32467,  -32468,  -32468,       0,    8489,    8488,    8495,  -32466,
   74+   -32462,       0,    8496,    8500,  -32461,       0,  -32452,    8504,
   75+   -32457,  -32451,  -32452,       0,    8506,    8505,    8511,  -32450,
   76+        0,    8514,  -32447,  -32443,       0,    8515,  -32434,  -32440,
   77+     8521,  -32440,  -32430,  -32429,  -32429,       0,    8527,  -32428,
   78+   -32428,       0,    8522,    8523,    8527,    8534,  -32427,  -32423,
   79+        0,    8535,    8539,  -32422,       0,     350,  -24223,  -24222,
   80+        0,     355,     351,  -24223,       0,    8550,     359,    8552,
   81+      361,    8554,     363,    8192,     365,    4462,       0,     368,
   82+   -32401,       0,     371,    4468,     373,   12662,  -32392,     377,
   83+      371,       0,     379,    8572,  -32390,       0,     383,    8576,
   84+      385,    8407,  -32380,       0,  -32378,    8448,     388,  -32768,
   85+   -32768,  -32370,  -32370,  -32369,  -32369,     399,     401,  -32366,
   86+        0,       0,     403,     404,     398,     406,    4503,  -32359,
   87+      377,     406,     411,    4508,     365,     414,    4511,     411,
   88+      417,    4514,     414,     420,    4517,     417,     423,    4520,
   89+      420,       0,       0,       0,       0,       0,       0,       0,
   90+        0,       0,       0,       0,       0,       0,       0,       0,
   91+        0,       0,       0,       0,       0,       0,       0,       0,
   92+        0,       0,       0,       0,       0,       0,       0,       0,
   93+        0,       0,       0,       0,       0,       0,       0,       0,
   94+        0,       0,       0,       0,       0,       0,       0,       0,
   95+        0,       0,       0,       0,       0,       0,       0,       0,
   96+        0,       0,       0,       0,       0,       0,       0,       0,
   97+        0,       0,       0,       0,       0,       0,       0,       0,
   98+        0,       0,       0,       0,       0,       0,       0,       0,
   99+        0,       0,       0,       0,       0,       0,       0,       0,
  100+        0
  101  
  102  %OWNBYTEINTEGERARRAY GCLASS(0:GMAX) =
  103+      255,     114,     116,       1,      89,     162,       2,      53,
  104+       54,      49,      50,      51,      52,      57,     142,       1,
  105+      118,     117,      13,     142,     152,     152,       6,     117,
  106+      142,     118,     117,      13,      59,     144,      59,     152,
  107+       83,     164,       6,     117,     128,     164,       4,      13,
  108+        1,      13,      56,      59,      56,       4,       2,      56,
  109+       59,      34,      35,      28,      29,      10,      11,      33,
  110+       42,      19,      48,     133,      35,      13,      28,      12,
  111+      119,     133,      28,      29,      11,      13,     150,       5,
  112+       12,     119,      12,     119,     133,      35,      13,     150,
  113+      119,     165,      15,      83,       4,      12,     119,      12,
  114+      133,       5,      10,      10,     119,      83,     150,     165,
  115+        1,     138,      63,      62,      61,      60,      64,      75,
  116+       74,      77,      78,      76,      94,     109,      20,      20,
  117+       95,      20,     109,      94,     109,      20,      95,      83,
  118+      161,     101,     101,     143,     159,     137,     163,     166,
  119+      101,     153,     153,     153,     102,     102,     102,     109,
  120+       94,      23,       8,      22,      21,      24,      73,     143,
  121+       15,      83,     141,      90,      91,     101,     112,       0,
  122+        4,       0,     153,     133,     147,     102,      86,      87,
  123+       88,     147,     146,     140,      70,      67,      68,      69,
  124+       71,      74,      75,      76,      77,      78,     101,      94,
  125+        0,     101,     153,     137,     153,     102,     102,      70,
  126+       67,      68,      69,      72,      71,      74,      75,      76,
  127+       77,      78,      94,     101,     145,     153,     102,      74,
  128+       75,      76,      77,      78,      94,       0,     101,     161,
  129+      153,     102,      80,      81,     115,       1,     147,       2,
  130+      134,     105,       0,      82,     145,      99,     100,       1,
  131+       32,      79,     149,     150,     151,      86,      87,      88,
  132+       43,      84,      45,      83,      43,      45,      83,      84,
  133+       83,      82,     139,       4,       2,     139,      53,      51,
  134+       59,     152,       4,       0,      59,     139,     164,      97,
  135+        4,       0,     136,      99,     100,     148,     140,      46,
  136+      140,      46,       0,     140,      99,     100,     132,     137,
  137+       46,     108,     132,      46,       0,     132,      83,       1,
  138+        9,     145,     147,     167,     106,      84,      83,       1,
  139+        9,     145,     132,     168,      43,      45,     167,      36,
  140+       38,      39,      40,       0,     170,     169,     167,      36,
  141+       38,       0,     169,     167,      36,       0,      43,     168,
  142+       37,      41,      40,       0,     172,     171,     168,      37,
  143+        0,     168,      37,      41,       0,     171,      43,      45,
  144+      168,      36,      38,      39,      40,       0,     174,      39,
  145+       40,       0,     173,     174,     172,     168,      36,      38,
  146+        0,     173,     168,      36,       0,     151,      30,      31,
  147+        0,     151,     151,      30,       0,     137,       6,     147,
  148+        4,     147,     126,     147,       1,     147,     127,      59,
  149+        4,       0,       1,     147,     113,     147,       4,       2,
  150+       98,      97,     152,     175,       4,       0,       1,     162,
  151+      113,     162,      59,     139,       4,     164,      59,      70,
  152+       69,      74,      75,      76,      77,      78,      94,      95,
  153+        0,     159,     101,     153,     102,       1,     147,       4,
  154+      127,      98,       1,     147,     107,       1,     147,     107,
  155+        1,     147,     107,       1,     147,     107,       1,     147,
  156+      107,     124,     125,     147,     107,     147,     107,     147,
  157+      107,     147,     127,       0,       0,       0,       0,       0,
  158+        0,       0,       0,       0,       0,       0,       0,       0,
  159+        0,       0,       0,       0,       0,       0,       0,       0,
  160+        0,       0,       0,       0,       0,       0,       0,       0,
  161+        0,       0,       0,       0,       0,       0,       0,       0,
  162+        0,       0,       0,       0,       0,       0,       0,       0,
  163+        0,       0,       0,       0,       0,       0,       0,       0,
  164+        0,       0,       0,       0,       0,       0,       0,       0,
  165+        0,       0,       0,       0,       0,       0,       0,       0,
  166+        0,       0,       0,       0,       0,       0,       0,       0,
  167+        0
  168  
  169  %CONSTSHORTINTEGERARRAY KDICT(32: 538) =
  170+        0,     511,     131,     527,     131,     131,     531,     131,
  171+      535,     539,     543,     551,     555,     559,     575,     579,
  172+      129,     129,     129,     129,     129,     129,     129,     129,
  173+      129,     129,     591,     594,     599,     619,     635,     131,
  174+      131,     652,     724,     752,     840,     876,    1020,     128,
  175+      128,    1084,     128,     128,    1296,    1320,    1344,    1384,
  176+     1408,     128,    1460,    1824,    2056,    2080,     128,    2112,
  177+      128,     128,     128,     131,    2127,     131,     131,    2151,
  178+      131,     131,     131,     131,     131,     131,     131,     131,
  179+      131,     131,     131,     131,     131,     131,     131,     131,
  180+      131,     131,     131,     131,     131,     131,     131,     131,
  181+      131,     131,     131,     131,    2155,     131,     131,  -32351,
  182+   -16119,   16679,   16743,   18734,   16614,   16385,   16386,  -16282,
  183+    16489,   17128,   16388,  -32322,  -15576,   17195,   16392,   21710,
  184+   -32465,   19369,   16550,   16387,   16397,  -32196,  -32451,   18542,
  185+    18798,   16804,  -32323,  -14138,   18670,   19284,  -32195,  -32450,
  186+    18606,   16868,   18862,  -30642,   10578,   11457,  -31922,  -32429,
  187+    16823,    8912,      67,   16951,    9921,      69,  -32429,   16887,
  188+     8912,      67,   17079,      68,   18910,  -32187,   10841,      69,
  189+    16896,    9415,      78,   17393,  -30070,  -32177,    8665,    8908,
  190+    16394,  -31027,      78,  -31533,      84,  -32183,   10194,      76,
  191+    17386,   10958,      69,   18135,      84,   16512,    8909,   10830,
  192+    16391,   16384,  -32055,   10073,    9921,    8649,   16704,    9153,
  193+    10190,    8915,   17322,  -28340,  -31026,  -31530,      88,  -32055,
  194+     8916,   10066,    9793,   16768,      84,   18071,   10053,      84,
  195+    16399,      68,  -32433,   21873,      70,  -31034,  -31540,      80,
  196+   -32059,   10194,   10567,    9921,   22001,    9938,   22065,   10697,
  197+       84,   17904,    9801,      69,   21937,    8915,   19171,  -31039,
  198+   -31543,  -32306,   10575,   16395,  -32429,   17143,    8912,      67,
  199+    17207,    9422,    9299,   19106,   10700,      69,   17623,  -26042,
  200+    10830,    9157,   10565,  -28607,  -29626,  -30643,  -31794,  -32301,
  201+   -15243,   17528,    8912,      67,   23416,    9921,      69,  -32301,
  202+   -15179,   17592,    8912,      67,   23480,   10305,  -32301,  -14734,
  203+    18040,    8912,      67,   24306,      78,  -32301,  -14798,   17976,
  204+     8912,      67,   24370,   10578,   11457,  -31922,  -32429,   18163,
  205+     8912,      67,   23539,    9921,      69,  -32301,  -14539,   18232,
  206+     8912,      67,   23608,   18204,  -32183,   10063,      71,   17024,
  207+    10835,   17840,   10305,  -32429,   16631,    8912,      67,   16695,
  208+   -32319,   10831,   18464,    8909,  -32301,  -16201,   16568,    8912,
  209+       67,   17015,  -32050,  -32302,   10071,   16448,   18975,   19219,
  210+   -31291,    8914,    9412,    8387,    8916,  -32301,  -15694,   17080,
  211+     8912,      67,   24050,    9938,   16832,  -31419,   10959,    9428,
  212+     8910,  -32301,  -15886,   16888,    8912,      67,   24114,  -29759,
  213+   -30909,  -31408,  -32173,   10964,   10066,   17495,    9813,    7892,
  214+   -32451,   17430,   17045,    8389,      84,   19041,   10575,      68,
  215+   -32088,   10182,    9938,   10817,   21810,   21521,      76,  -27455,
  216+   -28474,  -29491,  -30642,  -32301,  -10123,   22648,  -31540,  -32178,
  217+     8912,      67,   23672,   10575,    8397,      76,   18032,   10063,
  218+       71,   17968,    9921,      69,  -32301,  -10059,   22712,    8912,
  219+       67,   23736,   10305,  -32301,   -9614,   23160,    8912,      67,
  220+    24178,      78,  -32301,   -9678,   23096,    8912,      67,   24242,
  221+    10578,   11457,  -31922,  -32429,   23283,    8912,      67,   23795,
  222+     9921,      69,  -32301,   -9419,   23352,    8912,      67,   23864,
  223+   -25656,  -26167,  -26672,  -31532,  -32041,   10713,    8916,      77,
  224+    16640,   10825,    9283,   16825,  -28223,  -28593,    9426,    9166,
  225+   -29144,  -30015,  -31034,  -32051,    8398,    8909,  -12107,   20664,
  226+    10305,  -32301,  -11662,   21112,    8912,      67,   24498,      78,
  227+   -32301,  -11726,   21048,    8912,      67,   23922,   10578,   11457,
  228+     8398,    8909,  -11467,   21304,   20496,      80,   17751,   10834,
  229+    16396,    8645,   -8206,   24567,   10055,    9793,   17688,   10575,
  230+       84,   16960,  -32184,   10962,      69,   17559,   10053,   16389,
  231+       78,  -32180,    9428,      76,   18397,   10693,      83,   18268,
  232+     9416,    8908,   18333,  -32067,  -32292,  -15771,   17005,   17252,
  233+    18734,   16402,   16649
  234  
  235  !*******************************************
  236  !*                                         *
  237  !*        TRANSPORTABLE IMP COMPILER       *
  238  !*                                         *
  239  !*      COPYRIGHT   PETER S. ROBERTSON     *
  240  !*      DEPARTMENT OF COMPUTER SCIENCE     *
  241  !*         UNIVERSITY OF EDINBURGH         *
  242  !*           ALL RIGHTS RESERVED           *
  243  !*                                         *
  244  !*******************************************
  245  !
  246  ! THROUGHOUT THE SOURCE TEXT OF THIS PROGRAM, THE LOWER CASE
  247  ! ALPHABET IS REPRESENTED BY LETTER+32 E.G.  'A'+32
  248  
  249  %CONSTINTEGER SS0=250, SS1=251, SS2=252, SS3=253, SS4=254
  250  %CONSTINTEGER NULL=512;    !???
  251  %CONSTINTEGER TRANSP = 18
  252  %CONSTINTEGER PHRASES = 132
  253  %CONSTINTEGER EQUIVS = 105
  254  %CONSTINTEGER DIRECTIVES = 86
  255  %CONSTINTEGER ANAPP=160
  256  %CONSTINTEGER GLOBAL=0
  257  %CONSTINTEGER ICONST=83, RCONST=84, SCONST=82
  258  %CONSTINTEGER LB=1, RB=2
  259  %CONSTINTEGER PRE1=49, PRE2=57
  260  %CONSTINTEGER OWN1=53, OWN2=51
  261  %CONSTINTEGER SET1=60, SET2=64
  262  %CONSTINTEGER CHECK1=66, CHECK2=72
  263  %CONSTINTEGER DEF1=60, DEF2=79
  264  %CONSTINTEGER IDENT=59, SWITCH=80, COMMENT=7
  265  %CONSTINTEGER TERMIN=13
  266  %CONSTINTEGER APPEP=153
  267  %CONSTINTEGER PAGE SIZE = 64
  268  %CONSTINTEGER STX = 2
  269  %CONSTINTEGER PAGE = 12
  270  !*********************************************
  271  !* OTYPE * MOD * SPECD * FORMAT * APP * LINK *
  272  !*********************************************
  273  !    3      2      1       1       1      8
  274  !
  275  ! OTYPE : 1 OWN
  276  !         2 CONST
  277  !         3 EXTRINSIC
  278  !         4 SYSTEM
  279  !         5 DYNAMIC
  280  !         6 EXTERNAL
  281  !         7 PERM
  282  !
  283  !*******************************
  284  !* LENGTH * USED * TYPE * FORM *
  285  !*******************************
  286  !     8       1      3      4
  287  !
  288  %BEGIN
  289  ! ------I/O STREAM ASSIGNMENTS CHANGED TEMPORARILY------
  290  %CONSTINTEGER PRIM = 2, PROG = 1;           ! INPUT STREAMS
  291  %CONSTINTEGER REPORT=3,OBJ=2, LISTING=1;    ! OUTPUT STREAMS
  292  %CONSTINTEGER EOP=87;                       ! ENDOFPROGRAM SUBATOM
  293  %CONSTINTEGER EOF=86;                       ! ENDOFFILE SUBATOM
  294  %CONSTINTEGER TEXT LIMIT=255;               ! MAX STRING LENGTH
  295  %CONSTBYTEINTEGERARRAY CMAP(0 : 15)= 0, 67, 68, 81, 65, 83, 80, 73,
  296+                                     72, 71, 79, 69, 7 0, 66, 0, 0
  297  %CONSTINTEGER STRING = 16, RECORD=17;       ! STRING/RECORD SUBATOMS
  298  %CONSTINTEGER SPECIAL=55;                   ! SPECIAL DECLARATOR
  299  %CONSTINTEGER RFN=65;                       ! RECORDFORMAT NAME CLASS
  300  %CONSTINTEGER ULINE=18;                     ! CLASS FOR '_'
  301  %CONSTINTEGER NULL STRING=401
  302  %OWNINTEGER PERMIN = 1;                     ! PERM/PROG SWITCH
  303  %OWNINTEGER DIAG = 0, CONTROL = 0
  304  %OWNINTEGER BPT=0;                          ! CODE BUFFER POINTER
  305  %OWNSHORTINTEGERARRAY BUFFER(1 : 401)
  306  %CONSTINTEGER MCODE = 38
  307  
  308     !  %DIAGNOSE FLAGS (2\\N)
  309     !
  310     !  0  -  GRAMMAR TRACE
  311     !  1  -  RECORD USE
  312     !  2  -  APP DEFN.
  313     !  3  -  RECORD DEFN.
  314     !
  315     %ROUTINESPEC FAULT(%INTEGER N)
  316  !*********************************************
  317  !* ALMOST THE WHOLE COMPILER ASSUMES A 16 BIT WORD. *
  318  !*********************************************
  319  %OWNINTEGER MARK = ' '
  320  %OWNINTEGER FILE = 0;                       ! BEGIN OR EXTERNAL FILE ?
  321  %CONSTINTEGER DICT END = 2750
  322  %INTEGERARRAY DICT(0:DICT END)
  323  %CONSTINTEGER MAX LAB = 80
  324  %BYTEINTEGERARRAY LABINF(1 : MAX LAB)
  325  %INTEGER LIST, LREALS;                      ! OPTION FLAGS
  326  %INTEGER STATS;                             ! NUMBER OF STATEMENTS
  327  %ownINTEGER CODE = 0;                              ! OBJECT FILE SIZE
  328  %INTEGER LINES;                             ! LINES ON LISTING PAGE
  329  %INTEGER LINENUM;                           ! CURRENT LINE NUMBER
  330  %INTEGER LIT;                               ! LAST LITERAL POS
  331  %INTEGER LIT POS;                           ! LITERAL TEXT POINTER
  332  %INTEGER LIMIT;                             ! DIGIT SEARCH LIMIT
  333  %INTEGER DIGIT;                             ! CURRECT DIGIT
  334  %INTEGER OLD SYM;                           ! FIRST SYM OF NAME
  335  %INTEGER LABEL;                             ! CURRENT LABEL
  336  %INTEGER X;                                 ! CURRENT TAG APP/FORMAT
  337  %ownINTEGER SYM = 0;                               ! CURRENT INPUT SYMBOL
  338  %INTEGER ATOM1;                             ! CURRENT ATOM
  339  %INTEGER ATOM2;                             ! VARIANT OF ATOM1
  340  %INTEGER SUBATOM;                           ! EXTRA INFO
  341  %INTEGER LAST;                              ! LAST ATOM TYPE
  342  %INTEGER SS TYPE;                           ! 0 LABEL, 1 DECLARATION,
  343                                              ! 2 FORMAL PARAMS, 3 STATEMENT
  344  %INTEGER SYMTYPE;                           ! -2:LETTER, -1: DIGIT
  345                                              ! 0:TERMINATOR, 1: OTHER
  346  %INTEGER TYPE;                              ! VARIABLE TYPE WANTED
  347  %INTEGER VAR TYPE;                          ! VARIABLE TYPE FOUND
  348  %ownINTEGER POS = 0;                               ! CURRENT INPUT POSITION
  349  %INTEGER ATOM POS;                          ! CURRENT ATOM START POSN.
  350  %INTEGER DUP;                               ! DUPLICATE FLAG
  351  %INTEGER OUT;                               ! CURRENT OUTPUT STREAM
  352  %INTEGER PREFIX, SPREFIX;                   ! OWN, BYTE, EXTERNAL ETC.
  353  %INTEGER CONST INT
  354  %INTEGER O TYPE
  355  %INTEGER DEC TYPE;                          ! CURRENT DECLARATOR
  356  %OWNINTEGERARRAY CNEST(0 :10);              ! STACK FOR CONDITIONS
  357  %OWNBYTEINTEGERARRAY LINE(1 : 73);          ! INPUT LINE BUFFER
  358  %CONSTINTEGER RECLEN = -300;     ! -(MAX LENGTH OF ANALYSIS RECORD)
  359  %INTEGERARRAY REF, CO, SUB, LOC(RECLEN : -1)
  360  %INTEGER SS;                                ! SOURCE STATEMENT ENTRY
  361  %INTEGER A;                                 ! ATOM POINTER
  362  %INTEGER P;                                 ! PHRASE POINTER
  363  %INTEGER FAULTY;                            ! FAULT INDICATOR
  364  %INTEGER F TYPE;                            ! TYPE OF FAULT
  365  %INTEGER G LIMIT;                           ! END OF GRAM POINTER
  366  %INTEGER T LIMIT;                           ! MAX EXTENT OF DICTIONARY
  367  %INTEGER TMAX;                              ! CURRENT MAX TAG (FREE)
  368  %INTEGER T BASE;                            ! FIRST NAME AT CURRENT LEVEL
  369  %INTEGER DP;                                ! END OF CURRENT NAME
  370  %INTEGER RELOCATE;                          ! RELOCATION FOR FORMATS
  371  %INTEGER APP
  372  %SHORTINTEGERNAME PAPP;                     ! ==PHRASE(APPEP)
  373  %INTEGER EILAB;                             ! %ELSEIF LABEL
  374  %ownINTEGER MARGIN = 0
  375  %INTEGER INHIBIT;                       ! FLAG FOR DECLARATIONS MISPLA
  376  
  377  %ROUTINE SEND
  378     %INTEGER J
  379     %RETURN %IF BPT <= 0
  380     FAULT(22) %IF BPT >= LITPOS
  381     %IF FAULTY = 0 %START
  382        SELECTOUTPUT(OBJ)
  383        PRINTSYMBOL(BUFFER(J)) %FOR J = 1,1,BPT
  384        SELECTOUTPUT(LISTING)
  385     %FINISH
  386     BPT=0
  387  %END
  388  %ROUTINE PUT(%INTEGER N)
  389     CODE = CODE+1
  390     SEND %IF BPT > 71
  391     BPT=BPT+1; BUFFER(BPT)=N
  392  %END
  393  %ROUTINE ADDR(%INTEGER N)
  394     %INTEGER V
  395     V=N//10
  396     ADDR(V) %UNLESS V=0
  397     PUT(N-V*10+'0')
  398  %END
  399  %ROUTINE OP(%INTEGER C, A)
  400     PUT(C); ADDR(A)
  401  %END
  402  %ROUTINE PRINT NAME(%INTEGER N)
  403     %INTEGER D, FLAG
  404  ! ----- 'UNPACK' USES AT LEAST A 30-BIT WORD ----
  405     %ROUTINE UNPACK(%INTEGER V)
  406        %INTEGER J, N, C
  407        %CYCLE  J = 24,-6,0
  408           C = (V>>J)&63
  409           %IF C # 0 %START
  410              C = C+32;   ! ADD IN 32 REMOVED WHEN PACKING
  411              %IF FLAG # 0 %START
  412                 %IF FLAG < 0 %THEN PUT(C) %ELSE PRINT SYMBOL(C)
  413                 FLAG = FLAG+1
  414              %FINISH
  415           %FINISH
  416        %REPEAT
  417     %END
?N unused
  418     %IF N < 0 %THEN N = -N %AND FLAG = -13 %ELSE FLAG = 1
  419     D=DICT(N)
  420     UNPACK(DICT(D-2)) %FOR D = N-D&255, 1, N-D>>11&3
  421  %END
  422  
  423  %ROUTINE FAULT(%INTEGER N)
  424        %INTEGER  ERROR POS, STREAM, SPACING, pos2
  425        %SWITCH FM(-1 : 24)
  426        STREAM = REPORT;  SELECTOUTPUT(REPORT)
  427        ATOM POS = DUP %IF DUP # 0
  428        ERROR POS = ATOM POS
  429        ERROR POS = 0 %IF ERROR POS = POS %AND N > 1
  430        FAULTY=FAULTY+1
  431        SPACING = MARGIN+ERROR POS+8 -2
  432        %CYCLE
  433           %IF POS > 0 %AND (LIST # 0 %OR STREAM = REPORT) %START
  434              WRITE(LINE NUM, 4) %AND SPACE %IF STREAM # REPORT
  435              pos2 = POS
  436              %CYCLE POS = 1,1,pos2
?Non-local
  437                 PRINTSYMBOL('|') %IF POS = ERROR POS %AND STREAM=REPORT
  438                 PRINTSYMBOL(LINE(POS))
  439              %REPEAT
  440              SYM=LINE(POS)
  441           %FINISH
  442           NEWLINE %IF SYM # NL
  443           PRINTSYMBOL('*')
  444           %IF STREAM = REPORT %START
  445              WRITE(LINE NUM, 4);  SPACE
  446           %ELSE
  447              SPACE
  448              %IF ERROR POS # 0 %START
  449                 SPACES(SPACING-1);  PRINTSTRING("! ")
  450              %FINISH
  451           %FINISH
  452           ->FM(N)
  453  FM(24):   PRINTSTRING("COMPILER ERROR!");  ->F
  454  FM(20):   PRINTSTRING("TEXT TOO LONG");  ->F
  455  FM(21):   PRINTSTRING("TOO MANY NAMES");  ->F
  456  FM(22):   PRINTSTRING("TOO MANY LONG NAMES");  ->F
  457  FM(23):   PRINTSTRING("PROGRAM TOO COMPLEX");  ->F
  458  FM(18):   PRINTSTRING("ACCESS")
  459           FAULTY = FAULTY-1 %IF STREAM = REPORT
  460           ->F
  461  FM(0):    PRINTSTRING("FORM");      ->F
  462  FM(1):    PRINTSTRING("ATOM");      ->F
  463  FM(2):    PRINTSTRING("TYPE");      ->F
  464  FM(3):    PRINTSTRING("NAME");      ->F
  465  FM(4):    PRINTSTRING("SIZE");      ->F
  466  FM(5):    PRINTSTRING("CONTEXT");   ->F
  467  FM(6):    PRINTSTRING("MATCH");     ->F
  468  FM(7):    PRINTSTRING("COPY");      ->F
  469  FM(8):    PRINTSTRING("SPEC");      ->F
  470  FM(9):    PRINTSTRING("%END");      ->MISS
  471  FM(10):   PRINTSTRING("%CYCLE");    ->MISS
  472  FM(11):   PRINTSTRING("%REPEAT");   ->MISS
  473  FM(12):   PRINTSYMBOL('"');  PRINT NAME(X); PRINTSYMBOL('"');  ->MISS
  474  FM(13):   PRINTSTRING("%START");    ->MISS
  475  FM(14):   PRINTSTRING("%FINISH");   ->MISS
  476  FM(15):   PRINTSTRING("ORDER");     ->F
  477  FM(16):   PRINTSTRING("BOUNDS");     ->F
  478  FM(17):   PRINTSTRING("RESULT")
  479  MISS:     PRINTSTRING(" MISSING")
  480  F:        NEWLINE
  481           %EXIT %IF STREAM = LISTING
  482           STREAM = LISTING;  SELECTOUTPUT(LISTING)
  483        %REPEAT
  484        MARGIN = MARGIN+POS %AND SPACES(MARGIN+8) %IF SYM # NL
  485        POS = 0;  OUT = 0
  486        %SIGNAL 0,10 %IF N >= 20
  487  %END
  488  
  489  ! ---- 'C GEN' DEPENDS ON A 32-BIT WORD ----
  490  %ROUTINE C GEN(%INTEGER N)
  491        %INTEGER J, M, L
  492        M = N;  N = |M|
  493        %IF N>>16 = 0 %THEN L = 4 %ELSE L = 8
  494        PUT('N');  PUT(L+1+'0');  PUT(',');  PUT('Y')
  495        PUT( (N>>J)&15+'A' ) %FOR J = (L-1)*4, -4, 0
  496        PUT('U') %IF M < 0
  497        LIT = CODE
  498  %END
  499  %INTEGERFN EVAL(%INTEGER P)
  500     %CONSTBYTEINTEGERARRAY BASIS('V' : 'Z')=3,1,8,4,0
  501     %INTEGER N, J, B, S, L, MOD
  502     N=0
  503     %RESULT = DICT(-P) %IF P < 0
  504     L=BUFFER(P);  %RESULT=0 %IF L=0 %OR L=1
  505     B=BUFFER(P-1);  %RESULT=B %IF L < 0
  506     B=BASIS(B)
  507     MOD='A'; MOD=0 %IF B=8
  508     %CYCLE J=P-2,-1,P-L
  509        S=BUFFER(J)-MOD
  510        %IF B=0 %THEN N=N*10 %ELSE N=N<<B
  511        N=N+S
  512     %REPEAT
  513     %RESULT=N
  514  %END
  515  
  516     %ROUTINE COMPILE BLOCK(%INTEGER LEVEL, BLOCK TYPE, %C
  517+       %INTEGERNAME FPP)
  518        %INTEGER J, K, XX, COUNT, ACCESS = 0
  519        %INTEGER FP;                         ! START OF FORMAT
  520        %INTEGER FORMAT;                     ! CURRENT FORMAT POINTER
  521        %INTEGER A CHAIN;                    ! ARRAY CHAIN
  522        %INTEGER OLD LABEL
  523        %INTEGER APARM, OLD T BASE, OLD T LIMIT
  524        %OWNINTEGER SPEC=1
  525        OLD T BASE=T BASE
  526        T BASE=T MAX
  527        OLD T LIMIT=T LIMIT;  OLD LABEL = LABEL
  528        INHIBIT = INHIBIT<<1
  529  
  530        %ROUTINE DEF LAB(%INTEGER L)
  531           INHIBIT = INHIBIT!1
  532           PUT(':');  ADDR(L)
  533           ACCESS = 1
  534        %END
  535        %ROUTINE ANALYSE SS(%INTEGER CONT)
  536        %INTEGER CLASS;                      ! CLASS OF ATOM WANTED
  537        %INTEGER LIM;                        ! LOOKUP LIMIT
  538        %OWNINTEGER TAG=0;                   ! CURRENT VAR TAG
  539        %OWNINTEGER DELIM = '"'
  540        %OWNINTEGER QUOTE=0;                 ! TEXT MODE FLAG
  541        %OWNINTEGER KEY=0;                   ! SYMBOL DICT KEY
  542  
  543        %ROUTINE DECLARE IDEN
  544           %INTEGER EXTRA, FF
  545           %INTEGERNAME FLAG
  546           %IF SUBATOM#0 %START;             ! ALREADY EXISTS
  547              FLAG == DICT(SUBATOM)
  548              TAG=DICT(SUBATOM-1)
  549              %IF FLAG&1024#0 %START;        ! SPEC GIVEN
  550                 %IF TAG&15=3 %START;        ! LABEL REF
  551                    FLAG=FLAG!!1024 %IF DECTYPE=3
  552                    %RETURN
  553                 %FINISH
  554                 %IF DECTYPE = TAG&(\128) %OR DECTYPE=1 %START;! SAME TYPE
  555                    %IF (7 <= TAG&15 <= 10 %AND SPEC > 0) %C
  556+                   %OR TAG&15 = 4 %OR DECTYPE=1 %START;   ! VALID REDEFINITION
  557                       FLAG = FLAG!!1024;    ! REMOVE SPEC BIT
  558                       DECTYPE = TAG&(\128)
  559                       %RETURN
  560                    %FINISH
  561                 %FINISH
  562              %FINISH
  563              DUP=ATOM POS %IF DUP=0
  564              %RETURN %IF DECTYPE=0;         ! LABEL
  565           %FINISH
  566           EXTRA=DP;                         ! APP + FORMAT
  567           TAG=DECTYPE
  568           FF=0
  569           %IF DECTYPE = 0 %START
  570              TAG = 3;  FF = 1024
  571           %ELSE
  572              FF = FF!SPREFIX<<13
  573           %FINISH
  574           %IF TAG&15 >= 7 %START;           ! APP NEEDED
  575              FF = FF!1024 %IF SSTYPE = 2 %AND TAG&15 <= 10
  576              CONST INT = 0
  577              %UNLESS 11#TAG&15#13 %START
  578                 %IF SPREFIX=1 %OR SPREFIX=2 %C
  579+                %THEN DICT(DP)=APP %ELSE %START
  580                    APARM=1; DICT(DP)=A CHAIN
  581                    A CHAIN=DP
  582                 %FINISH
  583              %FINISH %ELSE DICT(DP)=0
  584              DP=DP+1;  FF=FF!256;           ! SET APP BIT
  585              FF=FF!1024 %IF SPEC < 0 %AND SPREFIX < 3
  586           %FINISH
  587           %IF TAG&X'70'=X'50' %START;       ! RECORD
  588              DICT(DP)=FORMAT; DP=DP+1
  589              FF=FF!512;                     ! SET FORMAT BIT
  590           %FINISH
  591           %IF TAG&15=6 %START;              ! SWITCH
  592              DICT(DP)=0
  593              DP=DP+1
  594           %FINISH
  595           TAG = TAG!128 %IF SPREFIX > 3 %OR PERMIN# 0
  596           %IF CONST INT # 0 %START
  597              DICT(DP) = 0;  DP = DP+1
  598              TAG = TAG&X'FFF0'+5
  599           %FINISH
  600           EXTRA=DP-EXTRA;                   ! 1=APP, 2=APP+FORMAT, 0=NEITH
  601           DICT(DP) = TAG; TYPE=TAG>>4&7
  602           DP=DP+1
  603           DICT(DP) = FF!(DP-T MAX-2)!EXTRA<<11
  604           SUBATOM=DP; TMAX=DP+1
  605           X=DP
  606     %END
  607  
  608     %ROUTINE READ SYM
  609        %IF SYM<32 %START
  610           LINE NUM = LINE NUM+1
  611           ATOM POS = 0;  POS = 0;  MARGIN = 0
  612           %IF LIST = 0 %START
  613              WRITE(LINE NUM, 5)
  614              %IF QUOTE # 0 %THEN PRINT SYMBOL('"') %ELSE %START
  615                 PRINT SYMBOL(MARK);  MARK = ' '
  616              %FINISH
  617              SPACE
  618           %FINISH
  619           SYM TYPE=1
  620        %FINISH
  621        %CYCLE
  622           %CYCLE
  623              READSYMBOL(SYM)
  624              %IF SYM = PAGE %START
  625                 LINES = 0 %AND %CONTINUE %IF QUOTE = 0
  626                 LINES = PAGE SIZE
  627              %FINISH
  628              PRINTSYMBOL(SYM) %IF LIST = 0
  629              POS=POS+1 %AND LINE(POS)=SYM %UNLESS POS >= 73
  630              %RETURN %IF QUOTE#0
  631              %EXIT %IF SYM#' '
  632              SYM TYPE=1
  633           %REPEAT
  634           %EXIT %UNLESS SYM='%'
  635           SYM TYPE=2
  636        %REPEAT
  637        %IF SYM<32 %THEN SYMTYPE=0 %AND MARK='+' %ELSE %START
  638           SYM=SYM-32 %IF 'A'+32 <= SYM <= 'Z'+32; ! ...CONVERT LOWER CASE
  639           KEY=KDICT(SYM)
  640           SYM TYPE=KEY&3-2 %UNLESS KEY&3=0 %AND SYMTYPE=2
  641        %FINISH
  642     %END
  643  
  644     %ROUTINE LOOKUP(%INTEGER P)
  645        %INTEGER OLD, NEW, L, DISP, D, SIZE, FIRST
  646        COUNT=0;  SIZE = DP-TMAX+1;  FIRST = DICT(T MAX)
  647        %WHILE P > LIM %CYCLE
  648           COUNT = COUNT-1
  649           P=P-1
  650           D=DICT(P)
  651           DISP=D&255+2
  652           L=D>>11&3; OLD=P-DISP; X=P; P=OLD
  653           %IF SIZE+L-DISP=0 %AND DICT(OLD) = FIRST %START
  654              NEW=T MAX
  655              %CYCLE
  656                 NEW = NEW+1;  OLD = OLD+1
  657                 %IF NEW=DP %START;           ! FOUND IT
  658                    O TYPE = D>>13
  659                    TAG = DICT(X-1)
  660                    ATOM2=CMAP(TAG&15);       ! FORM -> CLASS
  661                    SUB ATOM=X; VAR TYPE=TAG>>4&7
  662                    ATOM2 = 66 %IF VARTYPE = 0 %AND ATOM2 = 68
  663                    ATOM1 = ATOM2 %AND SUBATOM = -OLD %IF ATOM2 = ICONST
  664                    %IF D&256#0 %START;       ! SET APP
  665                       PAPP=|DICT(OLD)|
  666                       %IF PAPP=0 %START
  667                          %IF 11 <= TAG&15 <= 12 %START
  668                             PAPP=PHRASE(ANAPP)
  669                             APARM=OLD<<3+1;  ! 1 DIMEN
  670                          %ELSE
  671                             F TYPE=8
  672                             %RETURN %IF SPEC < 0
  673                             ATOM1=0; ATOM2=0
  674                          %FINISH
  675                       %FINISH
  676                       OLD=OLD+1
  677                    %FINISH %ELSE PAPP=APP;   ! DEFAULT APP
  678                    FORMAT=0
  679                    %IF D&512#0 %START
  680                       %IF ATOM2=RFN %THEN FORMAT=SUBATOM %ELSE %START
  681                          FORMAT=DICT(DICT(OLD)-2)
  682                          ATOM2=ATOM2+7
  683                       %FINISH
  684                    %FINISH
  685                    DICT(X-1)=DICT(X-1)!128 %UNLESS SPEC < 0
  686                    SUBATOM=COUNT %IF LIM > T MAX
  687                    %RETURN
  688                 %FINISH
  689                 %EXIT %IF DICT(NEW) # DICT(OLD)
  690              %REPEAT
  691           %FINISH
  692        %REPEAT
  693     %END
  694  
  695     %ROUTINE CODE DIGIT
  696        %IF LIMIT=0 %START;                  ! MULTI CHAR
  697           DIGIT = SYM
  698           %IF DIGIT = '''' %START
  699              QUOTE = 0
  700              READSYM
  701              DIGIT = -1 %AND %RETURN %UNLESS SYM = ''''
  702              QUOTE = 1
  703           %FINISH
  704           READSYM
  705        %ELSE
  706           %IF '0' <= SYM <= '9' %OR 'A' <= SYM <= 'F' %START
  707              %IF SYM <= '9' %THEN DIGIT = SYM-'0' %C
  708+                            %ELSE DIGIT = SYM-'A'+10
  709                 %IF DIGIT <= LIMIT %START
  710                    DIGIT = DIGIT+'A'
  711                    READ SYM
  712                    %RETURN
  713                 %FINISH
  714           %FINISH
  715           DIGIT=0;  QUOTE=0
  716           %IF SYM='''' %START
  717              %IF LIMIT # 9 %START
  718                 DIGIT = -1;  READSYM
  719              %FINISH
  720           %FINISH
  721        %FINISH
  722     %END
  723  
  724     %ROUTINE CODE ATOM
  725        %INTEGER TP
  726        %ROUTINE TPUT(%INTEGER S)
  727           POS = 0 %IF S < 32
  728           FAULT(20) %IF TP = TEXT LIMIT
  729           TP = TP+1;  BUFFER(LITPOS-TP) = S
  730        %END
  731        %INTEGERNAME SS
  732        %INTEGER DTYPE, XTYPE, SRMOD, SLEN, PREFIX
  733        %INTEGER J, K, L, S, LP
  734        %CONSTBYTEINTEGERARRAY BASE SYM(1 : 4)= 'X', 'M', 'B', 'K'
  735        %CONSTSHORTINTEGERARRAY BASE INF(1:4)=
  736+                                         X'590F',X'5800',X'5701',X'5607'
  737        %CONSTSHORTINTEGER SPS=117;          ! START OF SPEC SUB
  738        %CONSTBYTEINTEGERARRAY SPEC SUB(SPS : 127)=%C
  739+                                     8,9,10,7,105,104,25,24,72,73,1
  740        %CONSTSHORTINTEGERARRAY P VALUE(0 : 10)=%C
  741+                                     0,
  742+                               X'1827'(2), X'1067', X'0127'(2),X'10A7',
  743+                               X'00A7',X'2418',X'4418',
  744+                               X'2218'
  745        %CONSTSHORTINTEGERARRAY SATOMS(1 : 12) =
  746+ !         SPEC,     NAME,     MAP,      MAPSPEC,    <NULL>,
  747+           X'0035',  X'3835',  X'3238',  X'0032',    X'3835',
  748+ !         ARRAY     ARRAYNAME ARRAYSPEC NAMESPEC    ARRAYNAMESPEC,
  749+           X'0033',  X'3835',  X'0033',  X'3835',    X'3835',
  750+ !         FN,       FNSPEC
  751+           X'3238',  X'0032'
  752  
  753        %CONSTBYTEINTEGERARRAY SCLASS(1 : 12) =
  754+ !         SPEC,     NAME,     MAP,      MAPSPEC,    <NULL>,
  755+           109,      2,        9,        118,        1,
  756+ !         ARRAY,    ARRAYNAME,ARRAYSPEC,NAMESPEC,   ARRAYNAMESPEC,
  757+           11,       12,       111,      110,        112,
  758+ !         FN,       FNSPEC
  759+           8,        117
  760        %CONSTINTEGER XSPS = 109
  761        %CONSTINTEGERARRAY XMOD(XSPS : 116) = 17,18,27,28,97,98,107,108
  762        LP=LIT POS
  763        ATOM POS=POS; LAST=ATOM1
  764        %IF QUOTE#0 %START;                  ! CONTINUATION OF STRING CONST
  765           TP=0
  766           TPUT(QUOTE>>8); TPUT(QUOTE&255)
  767           %CYCLE
  768              READSYM
  769              %IF SYM= DELIM %START
  770                 QUOTE=0
  771                 READSYM; %EXIT %IF SYM# DELIM
  772                 QUOTE=1
  773              %FINISH
  774              TPUT(SYM)
  775           %REPEAT
  776           BUFFER(LIT POS)=TP
  777           LITPOS=LITPOS-TP-1
  778        %FINISH
  779        SLEN=0; XTYPE=0; SRMOD=0; PREFIX=0
  780        %CYCLE
  781           ATOM1=0; ATOM2=0; SUB ATOM=0; TAG=0
  782           ATOM1=TERMIN %AND %RETURN %IF SYMTYPE=0
  783           %IF SYMTYPE=-1 %START;             ! DIGIT
  784              %UNLESS (LAST=0 %AND OUT=0) %OR LAST=8%START
  785                 LIMIT=9; DIGIT='Z'
  786  NEW BASE:      ATOM1=ICONST;  ATOM2 = ICONST
  787                 %CYCLE
  788                    LIT POS=LIT POS-1
  789                    BUFFER(LIT POS)=DIGIT
  790                    CODE DIGIT
  791                    %IF DIGIT <= 0 %START
  792                       %IF LIMIT = 9 %AND SYM = '.' %AND ATOM1 = ICONST %START
  793                          DIGIT = '.'
  794                          ATOM1 = RCONST;  ATOM2 = RCONST
  795                          LP = LP-1
  796                          READ SYM
  797                       %ELSE
  798                          ATOM1=0 %IF LIMIT#9 %AND DIGIT=0
  799                          BUFFER(LP)=LP-LITPOS
  800                          LIT POS=LIT POS-1
  801                          SUBATOM=LP
  802                          FAULT(23) %IF LITPOS <= 0
  803                          %RETURN
  804                       %FINISH
  805                    %FINISH
  806                 %REPEAT
  807              %FINISH
  808           %FINISH
  809           %IF SYM TYPE < 0 %START;           ! LETTER
  810              DP=T MAX
  811              OLD SYM=SYM
  812  ! ---- THE FOLLOWING PACKING ROUTINE IS WORD-LENGTH DEPENDENT BUT CAN
  813  !      BE MODIFIED WITH NO OTHER SIDE-EFFECTS PROVIDED COMPLEMENTARY
  814  !      ALTERATIONS ARE MADE TO  'UNPACK'  IN ROUTINE 'PRINT NAME' ----
  815              %CYCLE
  816                 SS == DICT(DP)
  817                 SS = SYM-32
  818                 READ SYM; %EXIT %IF SYM TYPE >= 0
  819                 OLD SYM=0
  820                 SS = (SS<<6) + (SYM-32)
  821                 READ SYM;  %EXIT %IF SYM TYPE >= 0
  822                 SS = (SS<<6) + (SYM-32)
  823                 READ SYM;  %EXIT %IF SYM TYPE >= 0
  824                 SS = (SS<<6) + (SYM-32)
  825                 READ SYM;  %EXIT %IF SYM TYPE >= 0
  826                 SS = (SS<<6) + (SYM-32)
  827                 READ SYM;  %EXIT %IF SYM TYPE >= 0
  828                 DP=DP+1
  829              %REPEAT
  830              %IF SYM='''' %AND OLD SYM # 0 %START
  831                 DELIM = ''''
  832                 %CYCLE J=1,1,4
  833                    %IF OLD SYM=BASE SYM(J) %START
  834                       QUOTE = 1
  835                       K=BASE INF(J)
  836                       DIGIT=K>>8; LIMIT=K&255
  837                       READSYM
  838                       -> NEW BASE
  839                    %FINISH
  840                 %REPEAT
  841              %FINISH
  842              DP=DP+1
  843              FAULT(21) %IF DP >= T LIMIT
  844              ATOM1=IDENT; ATOM2=IDENT
  845              LIM=T BASE; LOOKUP(T MAX)
  846              %RETURN
  847           %FINISH
  848           %IF SYM='''' %OR SYM = '"' %START
  849              DELIM = SYM
  850              QUOTE=1;                        ! INTO TEXT MODE
  851              ATOM1=SCONST;                   ! SYMBOL, OR
  852              ATOM2=ICONST;                   ! STRING
  853              READSYM;  SUB ATOM=SYM;         ! FIRST CHAR
  854              QUOTE=0 %IF SUBATOM=DELIM
  855              READSYM
  856              %IF SUBATOM=DELIM %START;       ! ' ' FOUND
  857                 %IF SYM#DELIM %START;        ! NULL SYMBOL OR STRING
  858                    SUB ATOM=NULL STRING; %RETURN
  859                 %FINISH
  860                                            ! ' ' ' FOUND
  861                 QUOTE=1
  862              READSYM;                      ! '' -> '
  863              %FINISH
  864              %IF SYM=DELIM %START;           ! FOUND DELIM %OR '?'
  865                 QUOTE=0
  866                 READ SYM;                    ! SKIP QUOTE
  867                 %IF SYM#DELIM %START
  868                    LITPOS=LITPOS-2
  869                    BUFFER(LITPOS+2)=-1
  870                    BUFFER(LITPOS+1)=SUBATOM
  871                    SUBATOM=LITPOS+2
  872                    %RETURN
  873                 %FINISH
  874              %FINISH
  875              QUOTE=SUBATOM<<8+SYM;           ! PRESERVE SYMBOLS
  876              ATOM2=SCONST;                   ! IT MUST BE A STRING
  877              SUBATOM=LITPOS
  878              %RETURN
  879           %FINISH
  880           DP=KEY>>2;                         ! INDEX INTO DICT
  881           READ SYM;                          ! GET NEXT SYMBOL
  882           %CYCLE
  883              S=KDICT(DP)
  884              %EXIT %IF S&X'4000'#0;          ! END OF LIST MARKER
  885              %IF S&127#SYM %OR SYMTYPE < 0 %START
  886                 ATOM POS=POS %AND %RETURN %IF S >= 0
  887                 DP=DP+1;                     ! ONTO ALTERNATIVE
  888              %ELSE
  889                 K = S>>7&127;  READ SYM
  890                 %IF S > 0 %START
  891                    %IF K # 0 %START
  892                       ATOM POS = POS %AND %RETURN %IF K#SYM %OR SYMTYPE<0
  893                       READ SYM
  894                    %FINISH
  895                    K = 1
  896                 %FINISH
  897                 DP = DP+K
  898              %FINISH
  899           %REPEAT
  900           ATOM1=S&63;                        ! PICK OFF CLASS
  901           SUB ATOM=S>>6&255
  902           %EXIT %IF ATOM1#0
  903           L=P VALUE(SUBATOM)
  904           %IF L#0 %START
  905              %RETURN %IF PREFIX&L&63 # 0 %OR (LAST # 0 %AND L&1 # 0)
  906              PREFIX=PREFIX!L>>6
  907              XTYPE=SUBATOM %IF SUBATOM <= 7
  908           %FINISH
  909           ATOM POS=POS
  910        %REPEAT;                             ! ROUND FOR ANOTHER
  911        ATOM2=KDICT(DP+1)&63 %IF S < 0;      ! VARIANT
  912        %IF ATOM1=STRING %OR ATOM1=RECORD %START
  913           DTYPE=ATOM1
  914           CODE ATOM
  915           %IF DTYPE=STRING %START
  916              ATOM1=0 %AND %RETURN %UNLESS ATOM1=ICONST
  917              SLEN=EVAL(SUBATOM);            ! STRING LENGTH
  918              %UNLESS 0 < SLEN <= TEXT LIMIT %START
  919                 ATOM1=0; F TYPE=4
  920                 %RETURN
  921              %FINISH
  922              SRMOD=X'40';                   ! TYPE FOR STRING
  923           %ELSE
  924              %IF ATOM2=IDENT %START
  925                 LIM=GLOBAL; LOOKUP(T BASE)
  926              %FINISH
  927              %UNLESS ATOM2 = RFN %START
  928                 F TYPE = 3
  929                 ATOM1 = 0;  ATOM2 = 0
  930                 %RETURN
  931              %FINISH
  932              SRMOD=X'50';                   ! TYPE FOR RECORD
  933           %FINISH
  934           CODE ATOM
  935           ATOM1=0 %AND %RETURN %IF ATOM1#RB
  936           %IF SYM TYPE=2 %START;            ! KEYWORD FOLLOWS
  937              CODE ATOM
  938              %IF ATOM1 # SPECIAL %AND ATOM2 # SPECIAL %START
  939                 ATOM1 = 0;  ATOM2 = 0;  %RETURN
  940              %FINISH
  941              SUBATOM = 1 %IF SUBATOM = 127;! SPEC
  942           %FINISH %ELSE SUBATOM=5;          ! NULL SPECIAL
  943           ATOM1=0 %AND %RETURN %C
  944+          %IF DTYPE=RECORD %AND SUBATOM >= 11
  945           K=SATOMS(SUBATOM)
  946           ATOM1=K&255; ATOM2=K>>8&255
  947           SUBATOM=SCLASS(SUBATOM)
  948        %ELSE
  949           %UNLESS PRE1 <= ATOM1 <= PRE2 %START
  950              ATOM1=0 %IF PREFIX#0
  951              %RETURN
  952           %FINISH
  953        %FINISH
  954        %IF SUBATOM >= SPS %START
  955           SPEC = -1;  SUBATOM = SPEC SUB(SUBATOM)
  956        %ELSE %IF SUBATOM >= XSPS
  957           %IF XTYPE # 6 %START
  958              ATOM1 = 0;  ATOM2 = 0;  %RETURN
  959           %FINISH
  960           XTYPE = 3;                         ! EXTRINSIC!!
  961           SUBATOM = XMOD(SUBATOM)
  962           SRMOD = SRMOD-X'10' %IF SRMOD # 0
  963        %FINISH
  964        %IF PREFIX&64#0 %START;              ! OWN DATA
  965           %UNLESS ATOM1 = OWN1 %OR ATOM1 = OWN2 %START;! NON-DATA
  966              %IF XTYPE <= 3 %START;          ! CONSTROUTINE ?
  967                 ATOM1 = 0;  %RETURN
  968              %FINISH
  969           %ELSE
  970              ATOM1=ATOM1+1;                 ! ONTO '%OWN' VARIANT
  971              OUT=(SUB ATOM+SRMOD)>>4
  972              %IF SUBATOM&1 = 0  %START;     ! CONSTNAME ?
  973                 OUT = 1;                    ! ADDRESSES ARE INTEGERS
  974              %ELSE
  975                 CONST INT = 1 %IF XTYPE = 2 %C
  976+                            %AND (SUBATOM+SRMOD)&X'70' <= X'30'
  977              %FINISH
  978              OUT = 15 %IF XTYPE = 3;        ! DON'T INITIALIZE EXTRINSICS
  979           %FINISH
  980        %FINISH
  981        SUBATOM=SUBATOM+LREALS %IF SUBATOM&X'70'=X'60'
  982        SUBATOM=SUBATOM+SLEN<<8+SRMOD+(PREFIX>>3&X'70')
  983        DEC TYPE=SUBATOM
  984        SPREFIX=XTYPE
  985        PREFIX=0
  986     %END
  987  !*************************************************************
  988  !* DEC TYPE: <EXT><EXTR><CONST><OWN><DYN><SYS><FLAG1><FLAG2> *
  989  !*************************************************************
  990     %INTEGERFN GAPP
  991        %CONSTINTEGER PSEP = 129, PCALL = 130
  992        %INTEGER L, P, TYPE, NEXT, C
  993        %INTEGERFN CLASS(%INTEGER T)
  994           %CONSTBYTEINTEGERARRAY EXPS(0 : 7)=0,147(3),140,0,146(2)
  995           %CONSTBYTEINTEGERARRAY PARM MAP(0 : 15)=0,0,137,0,0,0,0,122,
  996+                                              176,177,123,0,159,0,0,0
  997           %CONSTBYTEINTEGERARRAY TMOD(0:7) = 0,8(3),4,0,9,9
  998           TYPE = T>>4
  999           TYPE = TMOD(TYPE) %AND %RESULT = EXPS(T>>4) %IF T&15 = 1;! EXPRN
 1000           TYPE = 10 %IF TYPE = 0
 1001           %RESULT=PARM MAP(T&15);           ! CORRECT CLASS FOR NAMES
 1002        %END
 1003        %ROUTINE SET GCELL(%INTEGER C, GC, LEN)
 1004           C = C<<9;  C = C+L %UNLESS GC = PCALL
 1005           %WHILE L#GLIMIT %CYCLE
 1006              L=L+1
 1007              %RETURN %IF GRAM(L)=C %AND GCLASS(L) = GC %C
 1008+             %AND (TAG&X'70'#X'40' %OR GRAM(L-1)=LEN)
 1009           %REPEAT
 1010           %IF TAG&X'70'=X'40' %START
 1011              GLIMIT=GLIMIT+1;  GRAM(GLIMIT)=LEN;  ! SET STRING LE
 1012           %FINISH
 1013           GLIMIT=GLIMIT+1; GRAM(GLIMIT)=C;  GCLASS(GLIMIT) = GC
 1014           L=GLIMIT
 1015           %IF DIAG&4 # 0 %START
 1016              PRINTSTRING("SET");  WRITE(L, 3)
 1017              WRITE(C, 3);  WRITE(GC, 3);  WRITE(LEN, 3)
 1018              NEWLINE
 1019           %FINISH
 1020        %END
 1021  
 1022        %RESULT = NULL %IF TBASE=TMAX
 1023        L = GBASE;  P = TMAX
 1024        SET GCELL(0, PCALL, 0)
 1025        %CYCLE
 1026           P = P-1
 1027           NEXT = P-DICT(P)&255-2
 1028           TAG = DICT(P-1)
 1029           C = CLASS(TAG&127)
 1030           SET GCELL(TYPE, C, TAG>>8&255)
 1031           %EXIT %IF NEXT <= TBASE
 1032           P = NEXT
 1033           SET GCELL(0, PSEP, 0)
 1034        %REPEAT
 1035        SET GCELL(0, LB, 0)
 1036        FAULT(23) %IF GLIMIT >= GMAX
 1037        %RESULT=L
 1038     %END
 1039  
 1040     %ROUTINE HEX(%INTEGER N)
 1041        %INTEGER J,K
 1042        %CYCLE J = 1, 1, 4
 1043           K = N>>12;  N = N<<4
 1044           %IF K > 9 %THEN K = K-10+'A' %ELSE K = K+'0'
 1045           PRINTSYMBOL(K)
 1046        %REPEAT
 1047     %END
 1048     %ROUTINE ANALYSE(%INTEGER G)
 1049        %SWITCH DIR(86:102)
 1050        %INTEGER EXTEND, AMBIG, SUB LOCK, DOWN LOCK
 1051        %INTEGER J, K, L, N, A1, NODE, NEW TYPE, T
 1052  
 1053        %ROUTINE REORDER
 1054           %INTEGERNAME X, Y
 1055           %INTEGER R
 1056           K=0
 1057           %WHILE N < 0 %CYCLE
 1058              R=REF(N); J=CO(N)
 1059              %IF LOC(N)&X'FF' > TRANSP %START;! DROP TRANSPARENT
 1060                 X == K;  R=R&X'6000';         ! PICK OFF ORDER
 1061                 %WHILE X#0 %CYCLE
 1062                    Y == REF(X)
 1063                    %EXIT %IF Y&X'6000' <= R
 1064                    Y=Y-X'2000';               ! DECREMENT ORDERING CODE
 1065                    X == CO(X);                ! ON DOWN THE CHAIN
 1066                 %REPEAT
 1067                 CO(N)=X; X=N
 1068              %FINISH
 1069              N=J
 1070           %REPEAT
 1071           %IF DIAG&8 # 0 %START
 1072              PRINTSTRING("REORDER N =");  WRITE(N, 3);  NEWLINE
 1073           %FINISH
 1074        %END
 1075        %ROUTINE SHOW(%INTEGER Z)
 1076           WRITE(Z, 3)
 1077           PRINTSTRING(" [")
 1078           HEX(REF(Z))
 1079           SPACE;  HEX(CO(Z))
 1080           SPACE;  HEX(SUB(Z))
 1081           SPACE;  HEX(LOC(Z))
 1082           PRINTSYMBOL(']');  NEWLINE
 1083        %END
 1084        EXTEND=0;  SUB LOCK = 0;  DOWN LOCK = 0
 1085        A=0; A1=0; N=0; NODE=0
 1086        AMBIG=0
 1087        P = RECLEN
 1088  L1:     J=GRAM(G);  K = GCLASS(G);  ->EOP %IF K = 0
 1089        NEW TYPE = J>>9&15
 1090        NEW TYPE = TYPE %IF NEW TYPE = 0
 1091        %IF DIAG&1 # 0 %START
 1092           WRITE(G, 4);  WRITE(K, 3)
 1093           WRITE(ATOM1, 3);  WRITE(ATOM2, 3);  WRITE(SUBATOM, 3)
 1094           WRITE(TYPE, 2);  WRITE(FORMAT, 3)
 1095           NEWLINE
 1096        %FINISH
 1097        %IF K >= PHRASES %START;             ! PHRASE
 1098           P=P+1; F TYPE=4 %AND -> ERROR %IF P=A
 1099           REF(P)=J; CO(P)=N
 1100           LOC(P)=TYPE<<8+K
 1101           TYPE=NEW TYPE
 1102           SHOW(P) %IF DIAG&8 # 0
 1103           N=-P
 1104           G=PHRASE(K)
 1105           -> L1
 1106        %FINISH
 1107        CLASS=K
 1108        CLASS=ATOMIC(CLASS) %IF CLASS >= EQUIVS
 1109        ->DIR(CLASS) %IF CLASS >= DIRECTIVES
 1110        %IF ATOM2=IDENT %AND (DEF1 <= CLASS <= DEF2 %OR  CLASS = ICONST)%START
 1111           LIM=GLOBAL; LOOKUP(T BASE)
 1112        %FINISH
 1113        %IF SET1 <= CLASS <= SET2 %AND %C
 1114+                               (OTYPE#2 %OR ATOM2=68 %OR ATOM2=70) %START
 1115           CLASS = CLASS+7;  TYPE = TAG>>4&7
 1116        %FINISH
 1117        NEW TYPE=TYPE
 1118        %IF CLASS=ATOM1 %OR CLASS=ATOM2 %START
 1119           %IF CLASS = IDENT %START
 1120              DECLARE IDEN
 1121              TYPE = 15 %IF NEWTYPE = 15
 1122           %FINISH
 1123           %IF CHECK1 <= CLASS <= CHECK2 %START
 1124              %IF VAR TYPE#TYPE %START
 1125                 %UNLESS VARTYPE <= 3 %AND (TYPE=8 %OR TYPE=9) %START
 1126                    %UNLESS VARTYPE >= 6 %AND TYPE=9 %START
 1127                       %UNLESS TYPE = 10 %START
 1128                          F TYPE = 2;  ->ALT
 1129                       %FINISH
 1130                    %FINISH
 1131                 %FINISH
 1132              %FINISH
 1133              F TYPE=0
 1134           %FINISH
 1135  ENTRY:    A=A-1; F TYPE=4 %AND -> ERROR %IF A=P
 1136           REF(A)=J; CO(A)=N
 1137           LOC(A)=TYPE<<8+K
 1138           TYPE=NEW TYPE
 1139           SUB(A)=SUBATOM
 1140           SHOW(A) %IF DIAG&8 # 0
 1141           ->DONE %IF J&511 = 511;           ! END OF SS
 1142           -> NEXT %IF AMBIG=0;              ! NOT AMBIGUOUS
 1143           G=AMBIG; AMBIG=0; -> L1
 1144        %FINISH
 1145  ALT:   G=G+1;  -> L1 %IF J < 0;              ! TRY ALTERNATIVE
 1146  NEXT:  %IF NODE=A1 %START;                  ! LAST NODE FOR THIS ATOM
 1147           EXTEND=0; SUB LOCK=0;  DOWN LOCK = 0
 1148           -> ERROR %IF NODE=A;              ! NO NEW NODES
 1149           A1=A
 1150           CODE ATOM %IF CLASS < DIRECTIVES; ! GET NEXT ATOM
 1151        %FINISH
 1152        NODE=NODE-1; N=NODE
 1153        %IF EXTEND#0 %START
 1154           K = LOC(N)&255
 1155           %IF K # 0 %START
 1156              J=REF(N)
 1157              TYPE = LOC(N)>>8
 1158              N=CO(N);                       ! WELL ?
 1159              -> ENTRY
 1160           %FINISH
 1161        %FINISH
 1162        -> SKIP
 1163  EOP:   REORDER
 1164        N=-N; SUB(N)=K
 1165  SKIP:                                       ! ON DOWN CHAIN
 1166        G=REF(N)&511; -> EOP %IF G=0
 1167        TYPE=LOC(N)>>8
 1168        -> L1
 1169  DIR(89):                                    ! %COLON
 1170        -> ERROR %UNLESS ATOM1=3;            ! LOOK FOR COLON
 1171  DONE:  N=A; REORDER; SS=K
 1172        %RETURN %IF DUP=0
 1173        F TYPE=7
 1174  ERROR:
 1175        QUOTE=0 %AND READSYM %WHILE NL#SYM#';'
 1176        %IF F TYPE=0 %START
 1177           %IF ATOM1=IDENT %AND LIM=GLOBAL %START
 1178              F TYPE=3
 1179           %ELSE %IF ATOM1 = 0
 1180              FTYPE = 1
 1181           %ELSE %IF SCONST <= ATOM1 <= RCONST
 1182              FTYPE = 2
 1183              FTYPE = 5 %IF TYPE = 15
 1184           %FINISH
 1185        %FINISH
 1186        FAULT(F TYPE)
 1187        QUOTE=0; SYMTYPE=0; DEC TYPE=0
 1188        PREFIX=0; SPREFIX=0;  CONST INT = 0
 1189        %RETURN
 1190  DIR(86):                                    ! %INT
 1191        -> ALT %IF TYPE > 3 %AND TYPE#8;     ! NOT INTEGER
 1192  DCONT:
 1193        G = J&511
 1194        -> EOP %IF G=0;                      ! END OF PHRASE
 1195        -> L1
 1196  DIR(87):                                    ! %REAL
 1197        -> ALT %IF TYPE < 6 %OR TYPE=8 %OR TYPE = 15;! NOT REAL
 1198        -> DCONT
 1199  DIR(88):                                    ! %STR
 1200        -> ALT %IF TYPE#4;                   ! NOT STRING
 1201        -> DCONT
 1202  DIR(90):                                    ! %FN
 1203        %IF BLOCK TYPE&15 # 8 %START;        ! NOT A FUNCTION
 1204           ->DALT %IF DIAG >= 0 %OR BLOCKTYPE&15 # 9;  ! OR A FUNNY MAP
 1205        %FINISH
 1206        TYPE=BLOCK TYPE>>4&7
 1207        %IF TYPE <= 3 %THEN TYPE=8 %ELSE %START
 1208           TYPE=9 %IF TYPE >= 6
 1209        %FINISH
 1210        -> DCONT
 1211  DIR(91):                                    ! %M
 1212        -> DALT %IF BLOCK TYPE&15#9;         ! NOT A MAP
 1213        TYPE=BLOCK TYPE>>4&7
 1214        -> DCONT
 1215  DIR(94):                                    ! %SUB
 1216        -> DCONT %IF SUB LOCK#0
 1217        -> ALT %UNLESS ATOM1=U LINE
 1218        -> ERROR %IF SYMTYPE # -2
 1219        L=FORMAT
 1220        CODE ATOM
 1221        ATOM2=0
 1222        F TYPE=8 %AND -> ERROR %IF L <= 0
 1223        LIM=DICT(L);                         ! ONTO THE END
 1224        LOOKUP(L);                           ! LOOK FOR SUBNAME
 1225        F TYPE=3 %AND -> ERROR %IF ATOM2=0
 1226                                            ! NOT FOUND
 1227        SUB LOCK=1
 1228        -> DCONT
 1229  DIR(95):                                    ! %APP
 1230        -> ALT %UNLESS ATOM1=LB
 1231        -> DCONT
 1232  DIR(97):                                    ! %SETPLUS
 1233        PAPP = APP
 1234        L = PHRASE(152+APARM&7)
 1235        DICT(APARM>>3)=L %IF APARM&X'FFF8'#0
 1236        %WHILE A CHAIN#0 %CYCLE
 1237           T=A CHAIN; A CHAIN=DICT(T); DICT(T)=L
 1238        %REPEAT
 1239                                            ! SET APP FOR ARRAY
 1240        -> DCONT
 1241  DIR(98):                                    ! %PLUS
 1242        F TYPE=4 %AND -> ERROR %IF APARM&7=6
 1243        APARM=APARM+1
 1244        -> DCONT
 1245  DIR(99):                                    ! %AMBIG
 1246        AMBIG=J&511
 1247        -> ALT
 1248  DIR(100):                                   !  %DUMMY
 1249           EXTEND = 1 %IF A1 # A
 1250           A1 = A1-1;  K = 0
 1251           ->ENTRY
 1252  DIR(101):                                   ! %LUP
 1253        DICT(T LIMIT-2)=APARM
 1254        DICT(T LIMIT-1)=FORMAT
 1255        ->DCONT %UNLESS NODE = A1
 1256        TLIMIT = TLIMIT-2;  FAULT(23) %IF T LIMIT <= T MAX
 1257        -> DCONT
 1258  DIR(102):                                   ! %LDOWN
 1259        ->DCONT %IF DOWN LOCK # 0
 1260        DOWN LOCK = 1
 1261        APARM=DICT(T LIMIT  )
 1262        FORMAT=DICT(T LIMIT+1)
 1263        T LIMIT = T LIMIT+2 %IF NODE = A1
 1264        -> D CONT
 1265  DALT:  F TYPE=5;                            ! CONTEXT
 1266        -> ALT
 1267     %END;                                   ! OF ANALYSE
 1268        FORMAT=0; APARM=0; RELOCATE=0
 1269        LITPOS=400
 1270        SS=0; DEC TYPE=0; DUP=0;  CONST INT = 0
 1271        PREFIX=0; SPREFIX=0
 1272        A CHAIN=0; F TYPE=0; MARK = ' '
 1273        %IF CONT=0 %START
 1274           MARGIN = MARGIN+POS
 1275           %IF SYM TYPE=0 %START
 1276              POS=0; READ SYM
 1277           %FINISH
 1278           ATOM1=0
 1279           %IF SYMTYPE=0 %OR SYM='!' %START
 1280  SKIP:        READSYM %WHILE SYMTYPE#0
 1281              %RETURN
 1282           %FINISH
 1283           CODE ATOM; -> SKIP %IF ATOM1=COMMENT
 1284           STATS=STATS+1
 1285           OP('O',LINE NUM) %IF  PERMIN = 0; ! DUMP LINE NUMBER
 1286           %IF ATOM1 =  MCODE %AND SUBATOM = 1 %START
 1287              CODE ATOM
 1288              %IF ATOM2 = IDENT %START
 1289                 LIM = GLOBAL;  LOOKUP(T BASE)
 1290              %FINISH
 1291              FAULT(0) %IF ATOM2 # ICONST
 1292              CGEN(EVAL(SUBATOM));  PUT('P')
 1293              %RETURN
 1294           %FINISH
 1295           TYPE=0
 1296           %IF ATOM1=IDENT %AND (SYM=':' %OR ATOM2=SWITCH) %START
 1297              DEC TYPE=3
 1298              SS TYPE=0; ANALYSE(PHRASE(SS0));!  LABEL
 1299           %ELSE
 1300              %IF DEC TYPE#0 %OR OUT#0 %START
 1301                 TYPE=OUT
 1302                 SS TYPE=1;  ANALYSE(PHRASE(SS1));! DECLARATION
 1303              %ELSE
 1304                 SS TYPE=3;  ANALYSE(PHRASE(SS3));! STATEMENT
 1305              %FINISH
 1306           %FINISH
 1307           %RETURN
 1308        %FINISH
 1309        CODE ATOM
 1310        %IF CONT > 0 %START;                 ! APP
 1311           SS TYPE=2;  ANALYSE(PHRASE(SS2)); ! FORMAL PARAMETER
 1312           J=GAPP
 1313           FAULT(6) %IF 0#|FPP|#J
 1314           FPP=J*SPEC
 1315        %ELSE;                               ! RECORDFORMAT
 1316           FP=TMAX;                          ! REMEMBER START OF NAMES
 1317           SS TYPE=4; ANALYSE(PHRASE(SS4))
 1318           %IF SS#0 %AND TMAX > FP %START
 1319              J=T LIMIT+TBASE-TMAX-1
 1320              FAULT(21) %IF J <= TMAX
 1321              FPP=T LIMIT-1;                 ! FILL IN FORMAT REFERENCE
 1322              DICT(FPP)=J;                   ! END OF FORMAT
 1323              RELOCATE=J-FP
 1324              %CYCLE K=J,1,FPP-1
?Non-local
 1325                 DICT(K)=DICT(FP)
 1326                 FP=FP+1
 1327              %REPEAT
 1328              T LIMIT=J
 1329           %FINISH
 1330        %FINISH
 1331     %END;                                   ! ANALYSE SS
 1332     %ROUTINE COMPILE SS
 1333        %CONSTBYTEINTEGERARRAY RCOMP(33:40)=34,33,35,36,38,37,39,40
 1334        %CONSTBYTEINTEGERARRAY COMP(33:40)='>','<','=','#',')','(',116,107
 1335        !  116 = LOWER CASE 'T',  107 = LOWER CASE 'K'
 1336        %CONSTBYTEINTEGERARRAY CON OP(82 : 84)='''', 'N', 'D'
 1337        %CONSTBYTEINTEGERARRAY OPCODE(1:10)='*','/','&','!',
 1338+                                           '%','[',']','.','\',120
 1339        ! 120 = LOWER CASE 'X'
 1340        %SWITCH C(1 : 130), D(50 : 57)
 1341        %BYTEINTEGERNAME MM
 1342        %INTEGERNAME M
 1343        %INTEGER L, DIM, K
 1344        %OWNINTEGER OWN DEF=0
 1345        %OWNINTEGER BP SIZE=0
 1346        %INTEGER CALL PENDING, PRED PENDING, PRED OP
 1347        %INTEGER GLOBAL NOT, LOCAL NOT
 1348        %INTEGER CLAST, CMOD, OPS, BIT, CLEVEL, DOUBLE
 1349        %INTEGER PLAB, LOOP LAB, ULAB, CONDS, ELSE
 1350        %INTEGER  LIT1, LIT2, STARTT
 1351        %INTEGER NEXT, CLASS, DCLASS, LINK
 1352  
 1353        %ROUTINE AOP(%INTEGER C, A)
 1354           PUT(C)
 1355           %IF A < 0 %START
 1356              A = -A;  PUT('-')
 1357           %ELSE
 1358              A = A//2
 1359           %FINISH
 1360           ADDR(A)
 1361        %END
 1362  
 1363        %ROUTINE EXTRA(%INTEGER N)
 1364           PUT(','); ADDR(N)
 1365        %END
 1366  
 1367        %ROUTINE DEF(%INTEGER N)
 1368           %INTEGER K
 1369           N=N+RELOCATE
 1370           AOP('$',N);  PRINT NAME(-N)
 1371           K=DICT(N-1)
 1372           EXTRA(K&127);                     ! TYPE!FORM
 1373           EXTRA(K>>8&255);                  ! MAX STRING LENGTH
 1374           EXTRA(DICT(N)>>13&7);             ! OTYPE
 1375                                            ! RECORD
 1376           AOP(',',DICT(N-2)) %IF K&X'70'=X'50' %AND K&127#84
 1377        %END
 1378  
 1379        %ROUTINE CALL
 1380           %INTEGER P
 1381           CALL PENDING = 1
 1382           AOP('@',X)
 1383           P = X
 1384           P = P-1 %IF DICT(X)&512 # 0
 1385           %IF |DICT(P-2)| = NULL %START
 1386              PUT('E');  CALL PENDING = 0
 1387           %ELSE
 1388              PRED PENDING = PRED PENDING<<1
 1389           %FINISH
 1390        %END
 1391        %ROUTINE SET SIZE
 1392           BP SIZE=LIT1-LIT2+1
 1393           %IF BPSIZE <= 0 %START
 1394              ATOM POS=0; FAULT(4)
 1395              BP SIZE=1
 1396           %FINISH
 1397           PUT('B'+32);  ADDR(BP SIZE)
 1398        %END
 1399  
 1400        %ROUTINE POP LAB(%INTEGER MODE)
 1401           %INTEGER L
 1402           %IF LABEL > OLD LABEL %START
 1403              L = LAB INF(LABEL>>2)
 1404              %IF (L!!MODE)&1 # 0 %START
 1405                 LABEL = LABEL-4;  P LAB = LABEL
 1406                 EILAB = PLAB+1 %IF L&4 # 0
 1407                 P LAB = P LAB+1 %IF L&3 = 3
 1408                 PLAB = 0 %IF L&8 = 0;        ! NO EXIT CONDITION
 1409                 %RETURN
 1410              %FINISH
 1411           %FINISH
 1412           %IF MODE = 0 %THEN MODE = 13 %ELSE MODE = 10
 1413           FAULT(MODE);  ACCESS = 1
 1414        %END
 1415  
 1416        %ROUTINE C END
 1417           %INTEGER L, T,LIM, FLAG
 1418           %IF X=88 %START;                  ! ENDOFPERM
 1419              STATS=0; LINE NUM=0
 1420              LIST=LIST&1; DEC TYPE=0
 1421              SELECTINPUT(PROG);             ! ONTO SOURCE PROGRAM
 1422              PERMIN = 0;                    ! SHOW NOT IN PERM
 1423              %RETURN
 1424           %FINISH
 1425           ATOM POS = 0;  FLAG = SYM
 1426           %IF LEVEL = 1 %AND X # EOP %AND FILE = 2 %START
 1427              DEC TYPE = EOP;  FAULT(5)
 1428           %FINISH
 1429           LIM = T BASE
 1430           %IF X=EOP %OR X=EOF %START;       ! EOP
 1431              X = X-EOF;    ! EOF -> 0,  EOP -> L1
 1432              FAULT(5) %UNLESS X = LEVEL
 1433              PUT(';')
 1434              %WHILE LEVEL > 1 %CYCLE
 1435                 FAULT(9)
 1436                 LEVEL=LEVEL-1
 1437              %REPEAT
 1438              LIM = GLOBAL;                  ! GIVE UNUSED FOR GLOBALS
 1439           %ELSE
 1440              FAULT(5) %IF LEVEL <= 1 %AND FILE = 2
 1441              PUT(';')
 1442           %FINISH
 1443           %WHILE LABEL > OLD LABEL %CYCLE
 1444              L=LABINF(LABEL>>2)
 1445              %IF L&7=2 %THEN L=11 %ELSE L=14
 1446              LABEL=LABEL-4
 1447              FAULT(L)
 1448           %REPEAT
 1449           FAULT(17) %IF ACCESS # 0 %AND 8 <= BLOCKTYPE&15 <= 10
 1450           X=T MAX-1
 1451           %WHILE X > LIM %CYCLE
 1452              T=DICT(X)
 1453              %IF DICT(X-1)&128=0=LIST %AND T&X'400' = 0  %START
 1454                 %IF CONTROL&X'1000' = 0 %START
 1455                    %IF FLAG # NL %START
 1456                       MARGIN = MARGIN+POS
 1457                       NEWLINE
 1458                       FLAG = 0
 1459                    %FINISH
 1460                    PRINTSTRING("? ")
 1461                    PRINT NAME(X)
 1462                    PRINTSTRING(" UNUSED
 1463+ ")
 1464                 %FINISH
 1465              %FINISH
 1466              FAULT(12) %IF T&X'400'#0
 1467              X=X-T&255-3
 1468           %REPEAT
 1469           printsymbol(11)
 1470           SPACES(MARGIN+8) %IF FLAG = 0
 1471        %END
 1472        FAULT(24) %IF LABEL < 4 %OR LABEL > MAX LAB<<2
 1473        %IF ACCESS = 0 %AND SSTYPE = 3 %AND 33 # LOC(-1)&255 # 34 %START
 1474           FAULT(18) %IF CONTROL&X'1000' = 0;  ACCESS = 1
 1475        %FINISH
 1476        CONDS=0; DIM=0;  PRED PENDING = 0;  PRED OP = 0
 1477        STARTT=0;                            ! DEFAULT TO CYCLE
 1478        PLAB=0; ULAB=0; LOOP LAB=0;  ELSE = 0;  EILAB = 0
 1479        LIT1=0; LIT2=0
 1480        NEXT=SS; LINK=0
 1481        LIT=0
 1482        DCLASS = 0
 1483  TOP:   %CYCLE
 1484           X=SUB(NEXT)
 1485           %EXIT %UNLESS X < 0 %AND NEXT <= P
 1486           %IF CO(NEXT)#0 %START
 1487              SUB(NEXT)=LINK; LINK=NEXT
 1488           %FINISH
 1489           NEXT=X
 1490        %REPEAT
 1491        CLASS=LOC(NEXT)&255
 1492        %IF DIAG&2 # 0 %START
 1493           PRINTSTRING("C =");  WRITE(CLASS, 3)
 1494           PRINTSTRING("  X =");  WRITE(X, 3)
 1495           PRINTSTRING("  NEXT =");  WRITE(NEXT, 3)
 1496           NEWLINE
 1497        %FINISH
 1498        NEXT=CO(NEXT)
 1499        -> C(X) %IF CLASS < PRE1
 1500        -> CONT %IF CLASS=APPEP
 1501        -> C(CLASS) %UNLESS CLASS=IDENT
 1502        -> D(DCLASS)
 1503  ACONT: ACCESS = 0
 1504  C(112):                                     ! %AND (UI)
 1505  CONT:  %CYCLE
 1506           ->TOP %IF NEXT#0
 1507           ->RETURN %IF LINK=0
 1508           NEXT=CO(LINK); LINK=SUB(LINK)
 1509        %REPEAT
 1510  C(9):                                       ! '\'
 1511        %IF CLASS = 45 %START;! LOGICAL NOT
 1512           LIT1=\LIT1 %AND LIT = LIT+1 %IF LIT=CODE
 1513        %ELSE
 1514           X = 10
 1515        %FINISH
 1516  C(1):                                       ! '*'
 1517  C(2):                                       ! '/'
 1518  C(3):                                       ! '&'
 1519  C(4):                                       ! '!'
 1520  C(5):                                       ! '!!'
 1521  C(6):                                       ! '<<'
 1522  C(7):                                       ! '>>'
 1523  C(8):                                       ! '.'
 1524        PUT(OPCODE(X)); -> CONT
 1525  C(46):PUT('Q');  ->CONT;!    REAL DIVIDE
 1526  C(10): PUT('M');  -> ACONT;                  ! %RESULT==
 1527  C(11): PUT('+') %UNLESS CLASS=44;           ! UNARY PLUS
 1528        -> CONT
 1529  C(12): %IF CLASS#43 %THEN PUT('-') %ELSE %START
 1530           LIT1=-LIT1 %AND LIT = LIT+1 %IF LIT=CODE
 1531           PUT('U')
 1532        %FINISH
 1533        -> CONT
 1534  C(13): PUT('X');  ->CONT;                   ! \\
 1535  C(14): PUT('Y'+32);  DIAG = LIT1;  -> CONT;    ! DIAG
 1536  C(15): PUT('Z'+32);  CONTROL = LIT1;  -> CONT; ! CONTROL
 1537  C(16): PUT('V');  -> ACONT;                 ! %RESULT=
 1538  C(17): %IF BLOCKTYPE # 7 %START
 1539            FAULT(5) %UNLESS DIAG < 0 %AND BLOCKTYPE&15 = 8
 1540         %FINISH
 1541         PUT('R');  -> ACONT;                 ! RETURN
 1542  C(18): PUT('T');  -> PREDT;                 ! TRUE
 1543  C(19): PUT('K');                            ! FALSE
 1544  PREDT: FAULT(5) %UNLESS BLOCKTYPE = 10
 1545         ->ACONT
 1546  C(20): PUT(101);  -> ACONT;                 ! %SIGNAL
 1547  C(44):LIT2 = 0;                             ! %ON %EVENT
 1548        FAULT(15) %IF INHIBIT&1 # 0
 1549        INHIBIT = INHIBIT!1
 1550        %CYCLE
 1551           %EXIT %IF NEXT = 0
 1552           X = SUB(NEXT)
 1553           %EXIT %IF (X < 0 %AND NEXT <= P) %OR LOC(NEXT)&255 # ICONST
 1554           NEXT = CO(NEXT)
 1555           LIT1 = EVAL(X)
 1556           FAULT(16) %AND LIT1 = 0 %UNLESS 0 <= LIT1 <= 15
 1557           LIT2 = LIT2!(1<<LIT1)
 1558        %REPEAT
 1559        FAULT(16) %IF LIT2 = 0
 1560        STARTT = 1+8
 1561        OP(111, LIT2);  OP(',', LABEL)
 1562        ->CONT
 1563  C(21): PUT('S'+32);  -> ACONT;                 ! %STOP
 1564  C(22): LIST=LIST&2;  -> CONT;               ! %LIST
 1565  C(23): LIST=LIST!1;  -> CONT;               ! %ENDOFLIST
 1566  C(24): LREALS=16;  -> CONT;                 ! %REALSLONG
 1567  C(25): LREALS=0;  -> CONT;                  ! %REALSNORMAL
 1568  C(109):PUT('S');  -> CONT;                  ! 'EQ'
 1569  C(45): PUT('Z');  -> CONT;                  ! EQEQ
 1570  C(26):                                      ! EXIT
 1571  C(27):                                      ! CONTINUE
 1572        L=LABEL
 1573        %WHILE L > OLD LABEL %CYCLE
 1574           %IF LABINF(L>>2)&7=2 %START;! CYCLE FOUND
 1575              %IF X = 26 %START
 1576                 MM == LABINF(L>>2)
 1577                 MM = MM!8
 1578                 L = L-2;  X = 'F'
 1579              %ELSE
 1580                 X = 113
 1581              %FINISH
 1582              OP(X,L-2)
 1583              -> ACONT
 1584           %FINISH
 1585           L=L-4
 1586        %REPEAT
 1587        FAULT(10);  ->CONT
 1588  C(31): ULAB=LABEL+3;  OP(117,ULAB);         ! UNTIL
 1589  C(30): LOOP LAB=LABEL+2;  DEF LAB(LOOP LAB);! WHILE
 1590  C(28):                                      ! IF
 1591  C(29):                                      ! UNLESS
 1592        EILAB = PLAB %IF ELSE # 0
 1593        INHIBIT = INHIBIT!1
 1594        CONDS=1; DOUBLE=0
 1595        STARTT=(X-26)>>1+8
 1596        GLOBAL NOT=0; C LAST=1
 1597        CMOD=0; CLEVEL=1; OPS=1
 1598        LOCAL NOT=X&1; P LAB=LABEL
 1599        CNEST(0)=P LAB; CNEST(1)=P LAB
 1600        -> CONT
 1601  C(32): LOCAL NOT=LOCAL NOT!!1;  -> CONT;    ! %NOT
 1602  C(79):
 1603        CALL;                                ! P
 1604        PRED OP = 4
 1605        ->PAC %IF CALL PENDING = 0
 1606        PRED PENDING = PRED PENDING!2
 1607        ->CONT
 1608  C(108): PUT('C');                           ! ACOMP
 1609  PAC:   X=35;                                ! '='
 1610        CONDS = CONDS-1
 1611        -> COP
 1612  C(33):                                      ! <
 1613  C(34):                                      ! >
 1614  C(35):                                      ! =
 1615  C(36):                                      ! #
 1616  C(37):                                      ! <=
 1617  C(38):                                      ! >=
 1618        CONDS=CONDS-1
 1619        %IF NEXT#0    %START;                ! DOUBLE SIDED
 1620           PUT(126);                         ! SHOW DOUBLE SIDED
 1621           DOUBLE=1;  BIT=1;                 ! PSEUDO %AND
 1622           -> ANDOP
 1623        %FINISH
 1624        %IF DOUBLE # 0 %START
 1625           DOUBLE = 0;  X = RCOMP(X)
 1626        %FINISH
 1627        PUT('?')
 1628  COP:  LOCAL NOT=(LOCAL NOT!!GLOBAL NOT)&1
 1629        X=X!!7 %IF LOCAL NOT#0
 1630        %IF CLAST#0 %START
 1631           X=X!!7 %IF OPS&1#0
 1632           OP(COMP(X+PRED OP),CNEST(CLEVEL))
 1633        %ELSE
 1634           %WHILE CMOD&1#0 %CYCLE
 1635              CMOD=CMOD>>1; OPS=OPS>>1
 1636              CLEVEL=CLEVEL-1
 1637              GLOBAL NOT=GLOBAL NOT>>1
 1638           %REPEAT
 1639           CMOD=CMOD>>1; OPS=OPS>>1; CLEVEL=CLEVEL-1
 1640           GLOBAL NOT=GLOBAL NOT>>1
 1641           X=X!!7 %IF OPS&1#0
 1642           OP(COMP(X+PRED OP),CNEST(CLEVEL))
 1643           DEF LAB(LABEL) %UNLESS LABEL=CNEST(CLEVEL)
 1644           LABEL=CNEST(CLEVEL)
 1645        %FINISH
 1646        CLAST=0; LOCAL NOT=0;  PRED OP = 0
 1647        DEF LAB(ULAB) %IF CONDS <= 0 %AND ULAB#0
 1648        PUT('"') %IF DOUBLE # 0
 1649        -> CONT
 1650  C(39):                                      ! AND
 1651  C(40):                                      ! OR
 1652        BIT=X&1;                             ! 1=AND, 0=OR
 1653  ANDOP: CONDS=CONDS+1
 1654        LOCAL NOT=(LOCAL NOT!!GLOBAL NOT)&1
 1655        BIT=BIT!!LOCAL NOT
 1656        %IF BIT=OPS&1 %START
 1657           %IF CLAST#0 %START
 1658              CMOD=CMOD<<1
 1659              CNEST(CLEVEL+1)=CNEST(CLEVEL)
 1660              CLEVEL=CLEVEL+1
 1661              OPS=OPS<<1!BIT
 1662              GLOBAL NOT=GLOBAL NOT<<1!LOCAL NOT
 1663           %FINISH
 1664        %ELSE
 1665           CMOD=CMOD<<1
 1666           %IF CLAST#0 %START
 1667              LABEL=LABEL+4
 1668              CLEVEL=CLEVEL+1; CNEST(CLEVEL)=LABEL
 1669           %ELSE
 1670              CMOD=CMOD!1
 1671              %IF OPS>>1&1 = BIT %START
 1672                 L = CNEST(CLEVEL-1)
 1673              %ELSE
 1674                 LABEL=LABEL+4; L=LABEL
 1675              %FINISH
 1676              CLEVEL=CLEVEL+1; CNEST(CLEVEL)=L
 1677           %FINISH
 1678           OPS=OPS<<1!BIT
 1679           GLOBAL NOT=GLOBAL NOT<<1!LOCAL NOT
 1680        %FINISH
 1681        CLAST=1; LOCAL NOT=0
 1682        -> CONT %IF DOUBLE=0
 1683        -> COP;                              ! REJOIN CONDITIONS
 1684  C(119):                                     ! STARTT
 1685        STARTT = 2 %AND DEF LAB(LABEL+2) %IF STARTT = 0
 1686        LABEL = LABEL+4
 1687        FAULT(23) %IF LABEL>>2 > MAX LAB
 1688        LABINF(LABEL>>2) = STARTT+ELSE
 1689        LOOP LAB = 0;  P LAB = 0;            ! LABEL NO LONGER PENDING
 1690        ELSE = 0;  EILAB = 0
 1691        ->CONT
 1692  C(41): OP('B',LABEL-2);                     ! REPEAT
 1693        ACCESS = 0
 1694  C(42): POP LAB(X&1);  ->CONT;               ! FINISH
 1695  C(43):                                      ! ELSE
 1696        POP LAB(0) %IF P LAB = 0;            ! (FINISH) ELSE ...
 1697        FAULT(5) %AND -> RETURN %IF PLAB&1#0
 1698        OP('F',PLAB+1) %UNLESS ACCESS = 0
 1699        DEF LAB(PLAB)
 1700        PLAB=PLAB+1
 1701        STARTT=3+8;                          ! SHOW ELSE
 1702        ELSE = 4
 1703        -> CONT
 1704  C(54): OWN DEF=0;  OUT=0;                   ! OWNVTYPE
 1705  C(51):                                      ! ATYPE
 1706  C(52):                                      ! OWN ATYPE
 1707  C(53):                                      ! VTYPE
 1708  C(56):                                      ! TYPE
 1709        FAULT(15) %IF INHIBIT&1 # 0 %AND SPEC > 0
 1710  C(50):                                      ! RTYPE
 1711  C(57):                                      ! SWITCH
 1712        DCLASS=CLASS; -> CONT
 1713  C(60):                                      ! VSET
 1714  C(61):                                      ! NSET
 1715  C(67):                                      ! V
 1716  C(68):                                      ! N
 1717  C(74):                                      ! RECV
 1718  C(75):                                      ! RECN
 1719  C(122):                                     ! RTP
 1720  C(123):                                     ! PP
 1721  C(124):                                     ! FNP
 1722  C(125):                                     ! MP
 1723  C(77):                                      ! RECAN
 1724  C(63):                                      ! ANSET
 1725  C(70):                                      ! AN
 1726  C(62):                                      ! ASET
 1727  C(69):                                      ! A
 1728  C(76):                                      ! RECA
 1729        AOP('@', X);  ->CONT
 1730  C(65):                                      ! RFN
 1731  C(66):                                      ! AFN
 1732        -> CONT
 1733  C(71):                                      ! M
 1734  C(72):                                      ! F
 1735  C(73):                                      ! RT
 1736  C(78):                                      ! RECORDMAP
 1737  C(64):                                      ! MSET
 1738        CALL;  -> CONT
 1739  C(83): LIT2=LIT1;  LIT1=EVAL(X);            ! 'ICONST'
 1740        CGEN(LIT1) %AND ->CONT %IF X < 0
 1741  C(82):                                      ! SCONST
 1742  C(84):                                      ! 'RCONST'
 1743        L=BUFFER(X)
 1744        %IF L <= 0 %AND CLASS=ICONST %START; ! SYMBOL
 1745           OP('N',3); L=BUFFER(X-1)
 1746           PUT(','); PUT('Z')
 1747           X=L//10
 1748           PUT(X+'A')
 1749           PUT(L-X*10+'A')
 1750        %ELSE
 1751           L=|L|
 1752           OP(CONOP(CLASS),L)
 1753           %IF L > 0 %START
 1754              %integer x2
 1755              PUT(',')
 1756              x2 = X
 1757              %CYCLE X=x2-1,-1,x2-L
?Non-local
 1758                 PUT(BUFFER(X))
 1759              %REPEAT
 1760           %FINISH
 1761        %FINISH
 1762        LIT=CODE
 1763        -> CONT
 1764  C(105):PUT('.');  -> CONT;                  ! '.'
 1765  C(106):PUT('V'+32); -> CONT
 1766  C(126):PUT('F'+32);                            ! COM
 1767        STARTT=2+8;                          ! PSEUDO %CYCLE
 1768        P LAB=LABEL; LOOP LAB=P LAB+2
 1769        DEF LAB(LOOP LAB)
 1770        -> CONT
 1771  C(113):                                     ! BSEP
 1772        %IF SPREFIX=0 %THEN DIM=DIM+1 %ELSE SET SIZE
 1773        -> CONT
 1774  C(116): AOP('L',X)
 1775        ACCESS = 1
 1776        INHIBIT = INHIBIT!1; -> CONT
 1777  C(80): INHIBIT = INHIBIT!1;         ! SWITCH
 1778        AOP('W',X);  ->ACONT
 1779  C(114):INHIBIT = INHIBIT!1;        ! SLAB
 1780        ACCESS = 1
 1781        AOP('_',X)
 1782        L=DICT(X-2);                         ! POINTER TO TABLE
 1783        K=DICT(L);                           ! LOWER BOUND
 1784        FAULT(16) %AND ->CONT  %UNLESS K <= LIT1 <= DICT(L-1)
 1785        K=LIT1-K
 1786        L=L-K>>4;                            ! ENTRY POINT
 1787        K=1<<(K&15);                         ! REQUISITE BIT
 1788        M == DICT(L-2)
 1789        FAULT(7) %IF M&K#0
 1790        M = M!K
 1791        -> CONT
 1792  C(81): INHIBIT = INHIBIT!1;         ! 'BL'
 1793  C(115): AOP('J',X);  -> ACONT;               ! 'FL'
 1794  C(128):LIT1 = BPSIZE %IF LIT1 = 0
 1795        BPSIZE=BP SIZE-LIT1+1;               ! ORB
 1796        -> OF %IF LIT1 <= 0
 1797        -> CONT
 1798  C(129):PUT('P'+32);  ->CONT;                   ! PSEP
 1799  C(130):PUT('P'+32);  PUT('E')
 1800        PRED PENDING = PRED PENDING>>1
 1801        PRED PENDING = PRED PENDING-1 %AND ->PAC %IF PRED PENDING&1 # 0
 1802        ->CONT
 1803  C(107): PUT('I'+32);  ->CONT;                  ! ASSEP
 1804  C(118): %IF DCLASS#54 %START;               ! OSEP
 1805           BP SIZE=BP SIZE-1
 1806           %IF BP SIZE <= 0 %START
 1807  OF:          ATOM POS=0; FAULT(16)
 1808              OUT=0
 1809              -> RETURN
 1810           %FINISH
 1811        %FINISH
 1812  OSEP:  PUT('A')
 1813        EXTRA(OWN DEF) %IF OWN DEF > 1
 1814        OWN DEF=0;  LIT1 = 0
 1815        -> CONT
 1816  C(117): BP SIZE=BP SIZE-1 %IF OUT#0;        ! OWNT
 1817        OUT=0
 1818        -> OSEP %IF BP SIZE=0
 1819        BP SIZE=0
 1820        -> OF %IF BUFFER(BPT)='A' %OR LIT = CODE
 1821        PUT('I');                            ! INDICATE CLEAR
 1822        -> CONT
 1823  C(110):                                     ! LRB
 1824  C(111):                                     ! RRB
 1825        -> CONT
 1826  C(127):PUT('A'+32);  -> CONT
 1827  D(54): OWN DEF=OWN DEF+1;                   ! OWNVTYPE
 1828        DICT(X-2) = LIT1 %IF CONST INT # 0
 1829        -> DDD
 1830  D(57):                                      ! SWITCH
 1831        %IF LIT=CODE %THEN %START;           ! SWITCH DEF
 1832           PUT('W'+32)
 1833           DICT(X-2)=T LIMIT-1
 1834           DICT(TLIMIT-1)=LIT2;              ! LOWER BOUND
 1835           DICT(TLIMIT-2)=LIT1;              ! UPPER BOUND
 1836           %IF LIT1 < LIT2 %START;           ! BOUNDS INSIDE-OUT
 1837              ATOM POS=0; FAULT(4)
 1838              LIT1=LIT2
 1839           %FINISH
 1840           K=LIT1-LIT2+1
 1841           K=(K+15)>>4;                      ! ENTRIES NEEDED
 1842           TLIMIT=TLIMIT-K-3
 1843           FAULT(23) %IF T LIMIT <= TMAX
 1844           DICT(L)=0 %FOR L = TLIMIT,1,TLIMIT+K
 1845        %FINISH
 1846  D(50):                                      ! RTYPE
 1847        OP('F',0) %IF DCLASS=50 %AND DEC TYPE#84 %AND SPEC >= 0 %C
 1848+                               %AND LEVEL # 0
 1849                                            ! JUMP ROUND ROUTINE
 1850  D(56):                                      ! TYPE
 1851  D(53):                                      ! VTYPE
 1852  DDD:   DEF(X)
 1853        -> CONT
 1854  D(51):                                      ! ARRAY DEC
 1855        %IF DIM#0 %START;                    ! SET UP DOPE VECTOR
 1856           OP('D'+32, DIM);  DIM = 0
 1857        %FINISH
 1858        DEF(X);  PUT('H'+32)
 1859        PUT('C'+32) %IF DICT(X-1)&15#13;        ! NO SPACE FOR FORMATS
 1860        -> CONT
 1861  D(52): DEF(X);  OUT=TYPE;                   ! OWNARRAY
 1862        BPSIZE = 1 %IF TYPE = 15;            ! EXTRINSICS
 1863        ->CONT
 1864  C(49):                                      ! BEGEND
 1865        %IF X=15 %THEN PUT('H') %AND XX=NULL STRING %ELSE C END
 1866  RETURN:
 1867                                            !
 1868                                            ! DEAL WITH LABELS
 1869                                            !
 1870        OP('B',LOOP LAB) %IF LOOP LAB#0
 1871        DEF LAB(EILAB) %IF EILAB # 0 %AND EILAB # PLAB
 1872        DEF LAB(P LAB) %IF P LAB#0
 1873     %END;                                   ! OF COMPILE SS
 1874     %IF BLOCK TYPE=0 %START;                ! RECORD FORMAT
 1875        ANALYSE SS(-1)
 1876        XX=X-2
 1877        OP('G', 2)
 1878        COMPILE SS %IF SS#0
 1879        OP('G',2);                           ! FORMAT END
 1880        -> L9
 1881     %FINISH
 1882     %IF BLOCKTYPE&15#15 %START;             ! NOT BEGIN
 1883        ANALYSE SS(1);                       ! FORMAL PARAMETERS
 1884        %IF SPEC < 0 %THEN K = 0 %ELSE K = 1
 1885        OP('G', K)
 1886        COMPILE SS %IF SS # 0
 1887        OP('G', K)
 1888        -> L9 %IF K = 0
 1889     %FINISH
 1890     ACCESS = 1
 1891     %CYCLE
 1892        ANALYSE SS(0)
 1893        XX=X-2
 1894        COMPILE SS %IF SS#0
 1895        COMPILE BLOCK(0,0,DICT(XX)) %IF DEC TYPE=84
 1896        %EXIT %IF DECTYPE=85 %OR DEC TYPE=EOP %C
 1897+       %OR DEC TYPE=EOF
 1898        %IF 7 <= DECTYPE&15 <= 10 %OR DECTYPE=15 %START
 1899           XX=XX-1 %IF DECTYPE&X'70'=X'50';  ! RECORDMAPS
 1900           %IF LEVEL = 0 %AND DECTYPE = 15 %START
 1901              %IF FILE = 0 %THEN FILE = 2 %ELSE FAULT(5)
 1902           %FINISH
 1903           %IF SPEC > 0 %AND SPREFIX > 3 %AND SPREFIX # 7 %START
 1904              %IF LEVEL # 0 %THEN FAULT(15) %ELSE FILE = 1
 1905           %FINISH
 1906           COMPILE BLOCK(LEVEL+1,DECTYPE,DICT(XX))
 1907           POS=0 %AND %EXIT %C
 1908+          %IF DEC TYPE=EOP %OR DEC TYPE=EOF;! PREMATURE END
 1909           %FINISH
 1910     %REPEAT
 1911  ! POINT TO JUMP ROUND ROUTINE
 1912     DEF LAB(0) %UNLESS BLOCK TYPE=15 %OR LEVEL = 0
 1913  L9:  SPEC=1; TMAX=T BASE; T BASE=OLD T BASE
 1914     LABEL = OLD LABEL
 1915     T LIMIT=OLD T LIMIT %IF BLOCK TYPE#0
 1916     INHIBIT = INHIBIT>>1
 1917  %END;                                       ! COMPILE BLOCK
 1918  
 1919  %ROUTINE  SUMMARISE(%INTEGER STREAM)
 1920     SELECT OUTPUT(STREAM)
 1921     %IF FAULTY = 0 %START
 1922        WRITE(STATS,5);  PRINT STRING(" STATEMENTS COMPILED
 1923+ ")
 1924     %ELSE
 1925        PRINT STRING("PROGRAM CONTAINS");  WRITE(FAULTY,1)
 1926        PRINT STRING(" FAULT");  PRINT SYMBOL('S') %IF FAULTY # 1
 1927        NEWLINE
 1928     %FINISH
 1929     CLOSE OUTPUT;        !  TO ENSURE BUFFER FLUSHING
 1930  %END
 1931  
 1932     open input(PRIM, "interdata/prims.imp")
 1933     open input(PROG, "interdata/test.imp")
 1934     open output(REPORT, "interdata/test.rpt")
 1935     open output(OBJ, "interdata/test.icd")
 1936     open output(LISTING, "interdata/test.lis")
 1937     
 1938  !!!!   COMREG(0) = -1;      !IN CASE IT BOMBS OUT
 1939     SELECTOUTPUT(LISTING);  SELECT INPUT(PRIM)
 1940  
 1941     NEWLINE;  SPACES(5)
 1942     PRINT STRING("EDINBURGH C.S. IMP COMPILER  VERSION ")
 1943     PRINT STRING(VERSION)
 1944     NEWLINES(2)
 1945  
 1946     control = 0;      ! **** optimise only:  for supervisor maintenance
 1947     {CONTROL = COMREG(14)};  CGEN(CONTROL);  PUT('Z'+32)
 1948     LIST = 2
 1949     CODE=0
 1950     LREALS=0;                                ! REALSNORMAL
 1951     FAULTY=0
 1952     OUT = 0
 1953     SYMTYPE=0; PAPP == PHRASE(APPEP);  APP = PAPP
 1954     STATS=0; LINE NUM=0
 1955     BUFFER(NULL STRING)=0
 1956     T LIMIT=DICT END-1; G LIMIT=GBASE; LABEL=4
 1957     T MAX=GLOBAL; T BASE=GLOBAL
 1958     X=0; ATOM1=0; LAST=0;  INHIBIT = 0
 1959     COMPILE BLOCK(0,15,DICT(TLIMIT));        ! COMPILE A BEGIN TO START
 1960     PUT(';')
 1961     PUT(4);                                  ! TO TERMINATE
 1962     SEND;                                    ! CLEAR THE BUFFER
 1963     SUMMARISE(LISTING)
 1964  !!!!   COMREG(0) = -FAULTY
 1965  !!!!   COMREG(0) = STATS %IF COMREG(0) = 0
 1966     %signal 15,1 %if faulty # 0
 1967  %ENDOFPROGRAM

 1808 Statements compiled
