         Edinburgh IMP77 Compiler - Version 8.4

    1  !***********************************************************************
    2  !*              SOAP80 - IMP80 formatter                               *
    3  !*                                               Last altered 15/06/83 *
    4  !*                                                                     *
    5  !*              Created by E.N.Gregory, UKC.                           *
    6  !*              All syntax directed sections rewritten by P.D.S., ERCC *
    7  !*                using IMP80 syntax version 02.                       *
    8  !*              User interface and parameters revised by J.M.M., ERCC. *
    9  !*                                                                     *
   10  !***********************************************************************
   11  
   12  
   13  !***********************************************************************
   14  !*                                                                     *
   15  !*                           Record formats.                           *
   16  !*                                                                     *
   17  !***********************************************************************
   18  
   19  %record %format fhdr(%integer dataend, datastart, filesize, filetype)
   20  %record %format chdr(%integer conad, filetype, datastart, dataend)
   21  %const %integer maxopt= 16,numopt = 3
   22  %record %format pformat(%byte %integer %array tab(0:20),
   23+   (%byte %integer line, icontin, poscom, movecom, uckey, sepkey, expkey,
   24+   lcasnam, spacnam, spacass, spacop, lclist, iblock, istat, seplab,
   25+   spcomma %or %byte %integer %array optarr(1:maxopt)) %or %c
   26+  %byte %integer %array a(1:21+maxopt))
   27  
   28  
   29  !***********************************************************************
   30  !*                                                                     *
   31  !*                           System routines.                          *
   32  !*                                                                     *
   33  !***********************************************************************
   34  
   35  !%external %string (255) %fn %spec itos(%integer i)
   36  
   37  %external %routine connect(%string (31) %name name, %integer mode, hole, prot, %record (chdr) %name rec, %integer %name eflag)
   38  %end
?EFLAG unused
?REC unused
?PROT unused
?HOLE unused
?MODE unused
?NAME unused
   39  
   40  %external %routine {%spec} trim(%string (31) file, %integer %name eflag)
   41  %end
?EFLAG unused
?FILE unused
   42  
   43  
   44  %external %routine setfname(%string (31) file)
   45  %end
?FILE unused
   46  
   47  %external %string (255) %fn nexttemp
   48    %result = ""
   49  %end
   50  
   51  %external %routine sendfile(%string (31) file, device, header, %integer copies, form, %integer %name eflag)
   52  %end
?EFLAG unused
?FORM unused
?COPIES unused
?HEADER unused
?DEVICE unused
?FILE unused
   53  
   54  %external %integer %fn devcode(%string (31) name)
   55    %result = 0
   56  %end
?NAME unused
   57  
   58  %external %routine disconnect(%string (31) %name filename, %integer %name eflag)
   59  %end
?EFLAG unused
?FILENAME unused
   60  
   61  %external %string (255) %fn failuremessage(%integer type)
   62    %result = itos(type,0).snl
   63  %end
   64  
   65  %external %routine changefilesize(%string (31) %name filename, %integer filesize, %integer %name eflag)
   66  %end
?EFLAG unused
?FILESIZE unused
?FILENAME unused
   67  
   68  %external %routine newgen(%string (31) %name filename, %string(*)%name newfilename, %integer %name eflag)
   69  %end
?EFLAG unused
?NEWFILENAME unused
?FILENAME unused
   70  
   71  %external %routine outfile(%string (31) %name filename, %integer size, hole, prot, %integer %name conad, eflag)
   72  %end
?EFLAG unused
?CONAD unused
?PROT unused
?HOLE unused
?SIZE unused
?FILENAME unused
   73  
   74  %external %routine read profile(%string (11) key,  %record (pformat) %name info, %integer %name version, uflag)
   75  %end
?UFLAG unused
?VERSION unused
?INFO unused
?KEY unused
   76  
   77  %external %routine write profile(%string (11) %name key, %record (pformat) %name info, %integer %name version, uflag)
   78  %end
?UFLAG unused
?VERSION unused
?INFO unused
?KEY unused
   79  
   80  %begin
   81     %string (255) s; ! argv[1]
   82  !%external %routine soap80(%string (255) s)
   83     %integer ptr, dataend, inptr, z, in, obp, eflag, writeaddress, wa0,
   84+      filesize, conad, errors, line, erptr, startline, stream, filesizeptr,
   85+      ssalt, strdelimiter, str, semicolon, colon, maxptr, maxitem, level,
   86+      stop, increm, inlabel, charsin, ersave, inconst, bheading, inline
   87     %string (255) outf
   88     %string (31) workfile, infile
   89     %string (2) percentc
   90     %record (pformat) p
   91     %record (chdr) rec, rr
   92     %record (fhdr) %name outrec
   93     %const %integer ccsize= 16384
   94     %short %integer %array outbuf(0:ccsize+200)
   95     %byte %integer %array sc(0:ccsize)
   96  
   97     %own{%const - imp77 won't allow the use of LENGTH() on a const string!} %string (7) %array optname(1:maxopt)=   "LINE","ICONTIN","POSCOM",
   98+     "MOVECOM","UCKEY","SEPKEY","EXPKEY","LCASNAM","SPACNAM","SPACASS","SPACOP",
   99+     "LCLIST","IBLOCK","ISTAT","SEPLAB","SPCOMMA"
  100  
  101     !!%const %string (255) %array optmess(0:1, 1:maxopt)=
  102     %const %string (255) %array optmess(2:33)=
  103+     "Line length zero (!!!)",
  104+     "Maximum line length",
  105+     "Continued lines not indented",
  106+     "Indentation of continued lines",
  107+     "Right hand comments not positioned",
  108+     "Right hand comment position",
  109+     "Whole line comments indented normally",
  110+     "Whole line comments moved to POSCOM",
  111+     "Keywords output in lower case",
  112+     "Keywords output in upper case",
  113+     "Keywords not split",
  114+     "Keywords split",
  115+     "%FN, %CONST, %ELSE not expanded",
  116+     "%FN, %CONST, (sometimes) %ELSE expanded",    
  117+     "Case of names controlled by UCKEY",
  118+     "Case of names left alone",
  119+     "Spaces removed from names",
  120+     "Spaces preserved within names",
  121+     "No spaces round assignment operators",
  122+     "Spaces added round assignment operators",
  123+     "No spaces round operators",
  124+     "Spaces added round operators",
  125+     "Constant lists formatted",
  126+     "Constant lists left alone",
  127+     "Block not indented w.r.t. block heading",
  128+     "Block indented w.r.t. block heading",
  129+     "Statements aligned with declarations",
  130+     "Statements indented w.r.t. declarations",
  131+     "Labels not on lines by themselves",
  132+     "Labels on lines by themselves",
  133+     "No space character after commas",
  134+     "Space character after commas"
  135  
  136     %const %string (62) %array fault(1:4) = "Statement is too long and could not be compiled.",
  137+       "End of file reached before end of program terminator found.",
  138+       "%END found, but could not match it to a start of routine.",
  139+       "Disaster *** Indentation too near line length limit."
  140  
  141     %const %integer charfile= 3; !  Code for a character file.
  142     %const %integer underline= 128
  143     %const %integer instring= 256,incurly = 512,bpoint = 1024,bpoint2 = 2048
  144     %const %integer terminal= 1,file = 2,samefile = 3,device = 4
  145     %const %integer true= 255,false = 0; ! Synthetic boolean values.
  146     %const %integer nl= 10,dquotes = 34,squotes = 39
  147     %const %integer rs= 30; ! RECORD SEPARATOR IS USED AS A DELETED(BY %c) NL
  148     %const %integer rem= B'00000001'
  149     %const %integer constart= B'00000010'
  150     %const %integer quotes= B'00000100'
  151     %const %integer endst= B'00001000'
  152     %const %integer number= B'00010000'
  153     %const %integer letter= B'00100000'
  154     %const %byte %integer constfirst= B'01000000'
  155     %const %integer constcont= B'10000000'
  156     !
  157     %const %byte %integer %array onecase(0:127)=
  158+    0,1,2,3,4,5,6,7,8,9,10,11,12,
  159+    13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,
  160+    35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,
  161+    57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
  162+    79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,65,66,67,68,
  163+    69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,
  164+    123,124,125,126,127
  165     %const %byte %integer %array chartype(0:255)=     B'00000001',
  166+  B'00000000',
  167+           B'00000000',B'00000000',B'00000000',B'00000000',B'00000000',
  168+           B'00000000',B'00000000',B'00000000',B'00001000',B'00000000'(22),
  169+           B'00000001'{!},B'00000100',B'01000000',B'00000000',B'00000001'{%},
  170+           B'00000000',B'00000100',B'00000000',B'00000000',B'00000000',
  171+           B'00000000',B'00000000',B'00000000',B'11000000',B'00000000',
  172+           B'11010000'(10),
  173+           B'00000000',B'00001000',B'01000000',B'01000000',B'01000000',
  174+           B'00000000',B'00000000',
  175+           B'00100000',B'00100010',B'00100010',B'00100010',B'00100000',
  176+           B'00100000',B'00100000',B'00100000',
  177+           B'00100000',B'00100000',B'00100010',B'00100000',
  178+           B'00100010',B'00100000',B'00100000',B'00100000',B'00100000',
  179+           B'00100010',B'00100000',B'00100000',B'00100000',B'00100000'(2),
  180+           B'00100010',B'00100000',B'00100000',B'00000000',B'00000000',
  181+           B'00000000',B'00000000',B'00000000',B'00000000',
  182+           B'00100000',B'00100010'{b},B'00100010',B'00100010',B'00100000'(6),
  183+           B'00100010'{k},B'00100000',B'00100010'{m},B'00100000'(4),
  184+           B'00100010'{r},B'00100000'(5),B'00100010'{x},B'00100000'(2),
  185+           B'00000000',B'00000001'{|},B'00000000',B'00000000',B'00000000',
  186+           B'0'(67),
  187+           B'00000001'{%C},
  188+           B'0'(60)
  189     %const %byte %integer %array keycom(0:7)= '%','C','O','M','M','E','N','T'
  190     %const %integer %array fstable(1:3)=     4096,16384,65536
  191     !
  192     ! Special delimiters noted by SOAP80.
  193     !
  194     %const %integer offile= 133,ofprogram = 123,equals = 38,comma = 10,
  195+  if = 12,
  196+     unless = 15,while = 22,until = 28,else = 227,then = 222,and = 158,or = 162,
  197+     const = 204, constant = 195, fn = 96, function = 103
  198  
  199     ! {%const} %string (2) snl = to string(nl)
  200  
  201     !
  202     !
  203     !
  204     %routine %spec fail(%integer type, action)
  205     %routine %spec opt(%string (255) parm, %record (pformat) %name p)
  206     !
  207     ! Produced by oldps from impalgs_imp80ps04 on 19/01/83
  208     %const %byte %integer %array clett(0:434)=   1,
  209+ {1}  43,   1,  45,   1,  40,   1,  41,   1,  42,   1,  44,   2, 201, 198,
  210+ {15}   6, 213, 206, 204, 197, 211, 211,   5, 215, 200, 201, 204, 197,   5,
  211+ {29} 213, 206, 212, 201, 204,   3, 198, 207, 210,   1,  61,   5, 193, 204,
  212+ {43} 201, 193, 211,   7, 201, 206, 212, 197, 199, 197, 210,   4, 210, 197,
  213+ {57} 193, 204,   4, 204, 207, 206, 199,   4, 194, 217, 212, 197,   6, 211,
  214+ {71} 212, 210, 201, 206, 199,   4, 200, 193, 204, 198,   6, 210, 197, 195,
  215+ {85} 207, 210, 196,   7, 210, 207, 213, 212, 201, 206, 197,   2, 198, 206,
  216+ {99}   3, 205, 193, 208,   8, 198, 213, 206, 195, 212, 201, 207, 206,   4,
  217+ {113} 206, 193, 205, 197,   5, 193, 210, 210, 193, 217,   9, 207, 198, 208,
  218+ {127} 210, 207, 199, 210, 193, 205,   6, 207, 198, 198, 201, 204, 197,   6,
  219+ {141} 207, 198, 204, 201, 211, 212,   6, 198, 207, 210, 205, 193, 212,   3,
  220+ {155} 206, 207, 212,   3, 193, 206, 196,   2, 207, 210,   1,  58,   4, 211,
  221+ {169} 208, 197, 195,   3, 207, 215, 206,   8, 197, 216, 212, 197, 210, 206,
  222+ {183} 193, 204,   9, 197, 216, 212, 210, 201, 206, 211, 201, 195,   8, 195,
  223+ {197} 207, 206, 211, 212, 193, 206, 212,   5, 195, 207, 206, 211, 212,   5,
  224+ {211} 197, 214, 197, 206, 212,   5, 211, 212, 193, 210, 212,   4, 212, 200,
  225+ {225} 197, 206,   4, 197, 204, 211, 197,   1,  95,   6, 211, 217, 211, 212,
  226+ {239} 197, 205,   7, 196, 217, 206, 193, 205, 201, 195,   4,  80,  85,  84,
  227+ {253}  95,   5,  67,  78,  79,  80,  95,   2, 204,  61,   1,  60,   1,  62,
  228+ {267}   4,  40, 196, 210,  43,   2, 196, 210,   1, 194,   3, 212, 207, 211,
  229+ {281}   3, 204, 206, 194,   3, 216, 206, 194,   2, 208, 195,   3, 195, 212,
  230+ {295} 194,   2,  45,  62,   6, 210, 197, 212, 213, 210, 206,   6, 210, 197,
  231+ {309} 211, 213, 204, 212,   7, 205, 207, 206, 201, 212, 207, 210,   4, 211,
  232+ {323} 212, 207, 208,   6, 211, 201, 199, 206, 193, 204,   4, 197, 216, 201,
  233+ {337} 212,   8, 195, 207, 206, 212, 201, 206, 213, 197,   6, 198, 201, 206,
  234+ {351} 201, 211, 200,   5, 195, 217, 195, 204, 197,   6, 210, 197, 208, 197,
  235+ {365} 193, 212,   3, 197, 206, 196,   7, 201, 206, 195, 204, 213, 196, 197,
  236+ {379}   5, 194, 197, 199, 201, 206,   2, 207, 206,   6, 211, 215, 201, 212,
  237+ {393} 195, 200,   4, 204, 201, 211, 212,  14, 212, 210, 213, 211, 212, 197,
  238+ {407} 196, 208, 210, 207, 199, 210, 193, 205,   6, 205, 193, 201, 206, 197,
  239+ {421} 208,   7, 195, 207, 206, 212, 210, 207, 204,   4,  40,  42,  41,  58
  240  
  241  
  242     %const %integer %array symbol(1300:2167)=  1307,
  243+   1303,     0,  1305,     2,  1307,  1000,  1319,  1312,  1001,  1366,
  244+   1786,  1315,  1003,  1020,  1319,     4,  1345,     6,  1329,  1323,
  245+   1001,  1014,  1325,  1003,  1329,     4,  1329,     6,  1336,  1336,
  246+   1010,  1028,  1319,  1011,  1359,  1345,  1343,  1010,  1028,  1319,
  247+   1011,  1359,  1345,     8,  1352,  1352,  1010,  1028,  1307,  1011,
  248+   1352,  1359,  1357,  1026,  1307,   999,  1359,  1000,  1366,  1364,
  249+   1026,  1319,   999,  1366,  1000,  1374,  1372,     4,  1345,  1374,
  250+      6,  1374,  1000,  1381,  1379,    10,  1345,   999,  1381,  1000,
  251+   1386,  1384,    12,  1386,    15,  1410,  1393,    22,  1010,  1536,
  252+   1556,  1011,  1399,    28,  1010,  1536,  1556,  1011,  1410,    34,
  253+   1010,  1001,    38,  1345,    10,  1345,    10,  1345,  1011,  1416,
  254+   1414,    40,  1013,  1416,  1000,  1423,  1421,    10,  1001,   999,
  255+   1423,  1000,  1428,  1426,    46,  1428,  1000,  1436,  1431,    54,
  256+   1433,    46,  1436,    59,    54,  1458,  1439,    46,  1441,    54,
  257+   1444,    59,  1428,  1447,    64,  1423,  1450,    69,  1689,  1453,
  258+     76,  1423,  1458,    81,     4,  1848,     6,  1465,  1461,    88,
  259+   1465,  1004,  1436,  1465,  1472,  1468,    96,  1470,    99,  1472,
  260+    103,  1488,  1478,  1436,  1493,  1001,  1416,  1484,  1458,  1488,
  261+   1001,  1416,  1501,  1488,   112,  1001,  1416,  1493,  1491,   112,
  262+   1493,  1000,  1501,  1497,   117,   112,  1499,   112,  1501,  1000,
  263+   1511,  1509,     4,  1010,  1472,  1011,  1511,     6,  1511,  1000,
  264+   1520,  1518,  1030,  1010,  1472,  1011,   999,  1520,  1000,  1531,
  265+   1524,   123,  1016,  1526,   133,  1529,   140,  1018,  1531,  1016,
  266+   1536,  1534,   147,  1536,  1000,  1550,  1542,  1345,  1032,  1345,
  267+   1550,  1547,     4,  1536,  1556,     6,  1550,   154,  1536,  1556,
  268+   1554,  1037,  1345,  1556,  1000,  1567,  1561,   158,  1536,  1567,
  269+   1565,   162,  1536,  1574,  1567,  1000,  1574,  1572,   158,  1536,
  270+    999,  1574,  1000,  1581,  1579,   162,  1536,   999,  1581,  1000,
  271+   1589,  1585,  1033,  1345,  1587,   165,  1589,  1000,  1595,  1593,
  272+    167,  1008,  1595,  1015,  1599,  1598,   167,  1599,  1608,  1606,
  273+     10,  1345,   165,  1345,  1599,  1608,  1000,  1617,  1613,  1493,
  274+   1001,  1416,  1617,   117,  1531,  1617,  1623,  1623,  1001,  1416,
  275+   1794,  1623,  1629,  1627,    10,  1617,  1629,  1000,  1646,  1639,
  276+   1493,  1595,  1010,  1001,  1410,  1802,  1011,  1646,  1646,   117,
  277+   1531,  1595,  1001,  1794,  1668,  1657,  1655,    10,  1010,  1001,
  278+   1410,  1802,  1011,  1646,  1657,  1000,  1668,  1660,   172,  1662,
  279+    176,  1664,   185,  1666,   195,  1668,   204,  1679,  1677,    38,
  280+   1012,  1028,  1319,  1359,  1689,  1679,  1679,  1000,  1689,  1687,
  281+     10,  1028,  1319,  1359,  1689,   999,  1689,  1000,  1696,  1694,
  282+      4,  1336,     6,  1696,  1000,  1703,  1701,    10,  1329,   999,
  283+   1703,  1000,  1708,  1706,   210,  1708,  1000,  1714,  1712,    10,
  284+   1345,  1714,  1000,  1727,  1725,    10,  1001,  1416,     4,  1345,
  285+    165,  1345,     6,   999,  1727,  1000,  1734,  1732,    28,  1536,
  286+   1556,  1734,  1000,  1747,  1737,  1019,  1739,  1006,  1744,  1381,
  287+   1536,  1556,  1006,  1747,  1386,  1006,  1761,  1751,   216,  1034,
  288+   1755,   222,   216,  1034,  1761,   222,  1010,  2008,  1011,  1767,
  289+   1767,  1765,   158,  2008,  1767,  1000,  1773,  1771,   227,  1773,
  290+   1773,  1000,  1786,  1777,   216,  1034,  1784,  1381,  1010,  1536,
  291+   1556,  1011,  1747,  1786,  2008,  1794,  1792,   232,  1001,  1366,
  292+   1786,  1794,  1000,  1802,  1802,     4,  1345,   165,  1345,  1599,
  293+      6,  1810,  1808,    38,  1028,  1319,  1359,  1810,  1000,  1819,
  294+   1813,   234,  1815,   176,  1817,   241,  1819,  1000,  1830,  1828,
  295+   1001,    38,  1345,    10,  1345,    10,  1345,  1830,  1000,  1837,
  296+   1835,    10,  1855,   999,  1837,  1000,  1848,  1841,   167,  1001,
  297+   1848,  1001,     4,  1855,  1830,  1873,     6,  1855,  1851,  1001,
  298+   1855,  1855,  1830,  1873,  1865,  1859,  1436,  1865,  1865,     4,
  299+   1855,  1830,  1873,     6,  1873,  1870,  1493,  1001,  1416,  1873,
  300+    117,  1617,  1881,  1879,   162,  1855,  1830,   999,  1881,  1000,
  301+   1898,  1886,   249,  1002,  1006,  1890,  1022,  1898,  1006,  1896,
  302+    254,  1009,    10,  1009,  1006,  1898,  1031,  1912,  1902,  1023,
  303+   1912,  1907,  1024,   260,  1951,  1956,  1912,  1025,  1005,    10,
  304+   1935,  1935,  1917,   263,  1001,   265,  1919,  1984,  1924,     4,
  305+   1984,  1973,     6,  1928,   267,  1984,     6,  1933,     4,   272,
  306+   1973,     6,  1935,   275,  1951,  1940,   263,  1001,   265,  1942,
  307+   1984,  1947,     4,   272,  1973,     6,  1951,   267,  1005,     6,
  308+   1956,  1954,   272,  1956,  1005,  1964,  1962,    10,  1005,    10,
  309+   1005,  1964,  1000,  1973,  1968,     0,  1005,  1971,     2,  1005,
  310+   1973,  1000,  1979,  1977,     0,   275,  1979,  1000,  1984,  1982,
  311+     38,  1984,  1000,  1999,  1989,  1979,  1300,  1003,  1992,  1001,
  312+   1964,  1997,     4,  1999,  1964,     6,  1999,   277,  2008,  2002,
  313+    281,  2004,   285,  2006,   289,  2008,   292,  2041,  2017,  1010,
  314+   1001,  1366,  1786,  1011,  1581,  1761,  2021,   296,  1001,  1366,
  315+   2023,   299,  2027,   306,  1033,  1345,  2030,   313,  1761,  2032,
  316+    321,  2037,   326,  1703,  1329,  1708,  2039,   333,  2041,   338,
  317+   2168,  2048,  1027,  1010,  2008,  1011,  1734,  2050,  1007,  2058,
  318+   1381,  1010,  1536,  1556,  1011,  1747,  1006,  2063,   347,  1035,
  319+   1767,  1006,  2068,   354,  1029,  1819,  1006,  2073,   360,  1036,
  320+   1727,  1006,  2078,  1386,   354,  1029,  1006,  2086,  1004,  1008,
  321+   1010,  1436,  1011,  1608,  1006,  2090,   367,  1520,  1006,  2095,
  322+     81,   147,  1837,  1006,  2105,  1010,  1810,  1458,  1011,  1589,
  323+   1001,  1410,  1501,  1006,  2110,  1657,  1436,  1629,  1006,  2114,
  324+    371,  1003,  1038,  2118,   379,  1015,  1006,  2127,   385,  1021,
  325+   1703,  1329,  1696,   216,  1034,  1006,  2138,   388,  1001,  1416,
  326+      4,  1345,   165,  1345,     6,  1714,  1006,  2142,   395,  1006,
  327+   1017,  2148,   227,  1035,  1039,  1034,  1006,  2151,     8,  1881,
  328+   2154,   400,  1006,  2158,   415,  1001,  1006,  2162,   422,  1003,
  329+   1006,  2166,  1001,   430,  1019,  2168,  1006
  330  
  331  
  332     %const %integer ss= 2041
  333     %const %integer comment= 2; ! alt of p<SS> of %comment
  334     %const %integer ownalt= 12; ! alt of p<SS> for owns
  335     %const %integer eisss= X'00017F00'; ! Flag declarative ss alts
  336     ! MAY CHANGE WITH NEW SYNTAX
  337     %const %integer %array opc(0:127)=
  338+     0, M' JCC', M' JAT', M' JAF', 0(4),
  339+     M' VAL', M' CYD', M'INCA', M'MODD', M'PRCL', M'   J', M' JLK', M'CALL',
  340+     M' ADB', M' SBB', M'DEBJ', M' CPB', M' SIG', M' MYB', M' VMY', M'CPIB',
  341+     M' LCT', M'MPSR', M'CPSR', M'STCT', M'EXIT', M'ESEX', M' OUT', M' ACT',
  342+     M'  SL', M'SLSS', M'SLSD', M'SLSQ', M'  ST', M'STUH', M'STXN', M'IDLE',
  343+     M' SLD', M' SLB', M'TDEC', M'INCT', M' STD', M' STB', M'STLN', M'STSF',
  344+     M'   L', M' LSS', M' LSD', M' LSQ', M'RRTC', M' LUH', M'RALN', M' ASF',
  345+     M'LDRL', M' LDA', M'LDTB', M' LDB', M'  LD', M'  LB', M' LLN', M' LXN',
  346+     M' TCH', M'ANDS', M' ORS', M'NEQS', M'EXPA', M' AND', M'  OR', M' NEQ',
  347+     M'  PK', M' INS', M'SUPK', M' EXP', M'COMA', M' DDV', M'DRDV', M'DMDV',
  348+     M'SWEQ', M'SWNE', M' CPS', M' TTR', M' FLT', M' IDV', M'IRDV', M'IMDV',
  349+     M' MVL', M'  MV', M'CHOV', M' COM', M' FIX', M' RDV', M'RRDV', M'RDVD',
  350+     M' UAD', M' USB', M'URSB', M' UCP', M' USH', M' ROT', M' SHS', M' SHZ',
  351+     M' DAD', M' DSB', M'DRSB', M' DCP', M' DSH', M' DMY', M'DMYD', M'CBIN',
  352+     M' IAD', M' ISB', M'IRSB', M' ICP', M' ISH', M' IMY', M'IMYD', M'CDEC',
  353+     M' RAD', M' RSB', M'RRSB', M' RCP', M' RSC', M' RMY', M'RMYD', M' PUT'
  354  
  355     %routine cnptf
  356  !***********************************************************************
  357  !*    Create New Page To File :- This is called when the output file   *
  358  !*    is full and must be extended to a new page.                      *
  359  !***********************************************************************
  360        %if filesizeptr<3 %then %c
  361+        filesizeptr = filesizeptr+1 %and filesize = fstable(filesizeptr) %else %c
  362+        filesize = filesize+fstable(3)
  363        changefilesize(workfile, filesize, eflag)
  364        %if eflag=261 %start
  365           ! V.M. hole is too small for the new file size.
  366           disconnect(workfile, eflag); %if eflag#0 %then fail(eflag, 5)
  367           changefilesize(workfile, filesize, eflag)
  368           %if eflag=0 %start
  369              writeaddress = writeaddress-conad
  370              connect(workfile, 3, 0, 0, rr, eflag)
  371              %if eflag#0 %then fail(eflag, 5)
  372              conad = rr_conad
  373              writeaddress = writeaddress+conad
  374              outrec == record(conad)
  375           %finish
  376        %finish
  377        %if eflag#0 %then fail(eflag, 5)
  378        outrec_filesize = filesize; ! Update file size in header.
  379     %end
  380  
  381     %routine transfer(%integer from, to)
  382  !***********************************************************************
  383  !*    Transfer copies the contents of OUTBUF from FROM to TO into the  *
  384  !*    output file or channel.                                          *
  385  !***********************************************************************
  386        %integer i, ch, last
  387        %if stream#terminal %start
  388           last = to-from+1+writeaddress-conad
  389           %if last>filesize %then cnptf
  390           outrec_dataend = last
  391        %finish
  392        %for i = from, 1, to %cycle
  393           ch = outbuf(i)&X'7F'
  394           %if ch&127=rs %then %continue
  395           %if ch=nl %start
  396              charsin = 0; line = line+1
  397              %unless stream=terminal %start
  398                 write address = write address-1 %while %c
  399+                 write address>wa0 %and byteinteger(write address-1)=' '
  400              %finish
  401           %finish %else charsin = charsin+1
  402           %if stream=terminal %then printsymbol(ch) %else %c
  403+           byteinteger(writeaddress) = ch %and writeaddress = writeaddress+1
  404        %repeat
  405     %end
  406  
  407     %routine outstring(%string (40) text)
  408  !***********************************************************************
  409  !*    Outstring copies TEXT to the output file or channel.             *
  410  !***********************************************************************
  411        %integer i, ch, last
  412        %if stream#terminal %start
  413           last = length(text)+writeaddress-conad
  414           %if last>filesize %then cnptf
  415           outrec_dataend = last
  416        %finish
  417        %for i = 1, 1, length(text) %cycle
  418           ch = charno(text, i)
  419           %if ch=nl %then charsin = 0 %and line = line+1 %else %c
  420+           charsin = charsin+1
  421           %if stream=terminal %then printsymbol(ch) %else %c
  422+           byteinteger(writeaddress) = ch %and writeaddress = writeaddress+1
  423        %repeat
  424     %end
  425  
  426     %routine dupl(%integer char, %integer times)
  427  !***********************************************************************
  428  !*    Dupl copies CHAR, TIMES times to the output file or channel.     *
  429  !***********************************************************************
  430        %integer i, last
  431        %if times<=0 %then %return
  432        charsin = charsin+times
  433        %if stream#terminal %start
  434           last = times+writeaddress-conad
  435           %if last>filesize %then cnptf
  436           outrec_dataend = last
  437        %finish
  438        %for i = 1, 1, times %cycle
  439           %if stream=terminal %then printsymbol(char) %else %c
  440+           byteinteger(writeaddress) = char %and writeaddress = writeaddress+1
  441        %repeat
  442     %end
  443  
  444     %routine insert(%integer chars, lsflag, rsflag)
  445  !***********************************************************************
  446  !*   This will place upto four characters into the OUTBUF buffer this  *
  447  !*   includes the option of have spaces around the characters.         *
  448  !***********************************************************************
  449        %if lsflag=true#inconst %then outbuf(obp) = ' ' %and obp = obp+1
  450        %cycle
  451           outbuf(obp) = chars&X'FF'
  452           chars = chars>>8
  453           obp = obp+1
  454        %repeat %until chars=0
  455        %if rsflag=true#inconst %then outbuf(obp) = ' ' %and obp = obp+1
  456     %end
  457  
  458  
  459  
  460  
  461     %routine closedown(%integer success)
  462  !***********************************************************************
  463  !*     Closedown is called when the program is to terminate execution  *
  464  !*     and is to print a suitable message and to close the output file *
  465  !*     if any.                                                         *
  466  !***********************************************************************
  467        %if success=true %start
  468           printstring(itos(line,0)." lines have been processed".snl)
  469        %finish %else %start
  470           printstring("Soap80 fails :- ".itos(errors,0))
  471           %if errors=1 %then printstring(" error.".snl) %else %c
  472+           printstring(" errors.".snl)
  473        %finish
  474        ! Is there a file to close?
  475        %if stream#terminal %start
  476           outrec_dataend = writeaddress-conad
  477           trim(workfile, eflag)
  478           disconnect(workfile, eflag)
  479           %if stream=samefile %start
  480              %if errors>0 %then %c
  481+              printstring("Output stored in ".workfile.", since ".infile. %c
  482+              " contains errors.".snl) %else %start
  483                 newgen(workfile, outf, eflag)
  484                 %if eflag#0 %start
  485                    printstring("Attempt to create ".outf." failed because ". %c
  486+                    failuremessage(eflag).snl)
  487                    printstring("Output stored in ".workfile.".".snl)
  488                 %finish
  489              %finish
  490           %finish %else %start
  491              %if stream=device %start
  492                 %if length(infile)>8 %then length(infile) = 8
  493                 sendfile(workfile, outf, "Soap80: ".infile, 1, 0, eflag)
  494                 %if eflag#0 %then fail(eflag, 5)
  495              %finish
  496           %finish
  497        %finish
  498        !! pprofile  REMOVED GT
  499        %stop; ! Exit from SOAP80.
  500     %end
  501  
  502     %routine punch
  503  !***********************************************************************
  504  !*     PUNCH is  for tranferring the contents of the OUTBUF array      *
  505  !*   to the output file or channel, using TRANSFER, OUTSTRING and DUPL.*
  506  !*                                                                     *
  507  !*    PUNCH decides where to break a line if it is too long.           *
  508  !***********************************************************************
  509        %integer lst, bk, i, ubp, lbp, bbp, tp, inn, ch, curlend
  510        inn = in
  511        inn = inn+1 %if 1<<ssalt&eisss=0 %and p_istat=true
  512        %if ssalt#comment %and semicolon=false %then dupl(' ', p_tab(inn)-charsin)
  513        %if outbuf(obp-1)=';' %then semicolon = true %else semicolon = false
  514        %if semicolon=true %and p_line-20<charsin+obp %then %c
  515+        semicolon = false %and outbuf(obp-1) = nl
  516        %if semicolon=true %then outbuf(obp) = ' ' %and obp = obp+1
  517  
  518        %if increm=true %start
  519           increm = false
  520           ! Is indenting value too near the line length limit?
  521           %if p_tab(in+1)+20>p_line %then fail(4, 2) %else in = in+1
  522        %finish
  523  
  524        lst = 1
  525  
  526        %if ssalt=comment %start
  527           ! Look for RS in comment.  If found, output as more than one line.
  528           %cycle
  529              %if chartype(sc(1))&rem=0 %or semicolon=true %start
  530                 ! Comment does not start in column 1.
  531                 %if semicolon!colon=false %and p_movecom=false %then %c
  532+                 dupl(' ', p_tab(inn)-charsin) %else dupl(' ', p_poscom-charsin)
  533              %finish
  534              i = lst
  535              i = i+1 %while i<obp %and outbuf(i)&127#rs
  536              ->final part %if i=obp
  537              transfer(lst, i-1)
  538              %if outbuf(i-1)&127=',' %then outstring(snl) %else %c
  539+              outstring(percentc.snl)
  540              i = i+1 %until i=obp %or outbuf(i)#' '
  541              lst = i
  542           %repeat
  543        %finish
  544  
  545        %cycle
  546           ubp = p_line+lst-charsin-4; ! RHMOST BREAK POINT
  547           lbp = (ubp+lst)//2
  548           bbp = (ubp+3*lst)//4
  549           curlend = 0
  550  
  551           ! First check for nl in string const or list
  552           %for bk = lst, 1, ubp+3 %cycle
  553              %exit %if bk>=obp
  554              ch = outbuf(bk)
  555              %if ch&127=nl %or (ch&127=rs %and ssalt=ownalt %and %c
  556+              p_lclist=true) %then ->printpart
  557           %repeat
  558           %if obp<ubp+3 %then %exit; ! 3 FOR " %C"
  559           %for bk = ubp, -1, bbp %cycle; ! CHECK FOR PRIMARY BREAK POINTS
  560              %if outbuf(bk)&bpoint#0 %start
  561                 bk = bk+1 %while outbuf(bk+1)=' '
  562                 ->printpart
  563              %finish
  564           %repeat
  565           %for bk = ubp, -1, bbp %cycle; ! CHECK FOR SECONDARY BREAK POINT
  566              %if outbuf(bk)&bpoint2#0 %start
  567                 bk = bk+1 %while outbuf(bk+1)=' '
  568                 ->printpart
  569              %finish
  570           %repeat
  571           %for bk = ubp, -1, bbp %cycle
  572              %if outbuf(bk)=',' %then ->printpart
  573           %repeat
  574           %if outbuf(ubp)&incurly#0 %start; ! IN A CURLY COMMENT
  575              curlend = 1
  576              %for bk = ubp, 1, obp-2 %cycle
  577                 curlend = 0 %and %exit %if outbuf(bk)&incurly=0
  578              %repeat
  579              ! curlend indicates whether the curly comment goes to the end of the line.
  580              %for bk = ubp, -1, bbp %cycle
  581                 %if outbuf(bk)&incurly=0 %then bk = bk-1 %and ->printpart
  582              %repeat
  583              ->final part %if curlend=1; ! Overlong curly comment.
  584              %for bk = ubp, 1, obp-2 %cycle
  585                 %if outbuf(bk)&incurly=0 %then ->printpart
  586              %repeat
  587           %finish
  588           %for bk = ubp+1, -1, lbp %cycle
  589              %if outbuf(bk)=' ' %and outbuf(bk-1)&underline#0 %then ->printpart
  590           %repeat
  591           %if p_spacnam=false %start; ! MUST OMIT IF NAMES ARE SPACED
  592              %for bk = ubp+1, -1, lbp %cycle
  593                 %if outbuf(bk)=' ' %then ->printpart
  594              %repeat
  595           %finish
  596           %for bk = ubp, -1, lbp %cycle
  597              %if outbuf(bk)='%' %then bk = bk-1 %and ->printpart
  598           %repeat
  599           %for bk = ubp, -1, lbp %cycle
  600              %if outbuf(bk)='.' %or outbuf(bk)=')' %then ->printpart
  601              %if outbuf(bk)='(' %then bk = bk-1 %and ->printpart
  602           %repeat
  603           %if outbuf(ubp)&instring#0 %start
  604              ! Break point is inside a string.
  605              %for bk = ubp, -1, bbp %cycle
  606                 %if outbuf(bk)=',' %or outbuf(bk)='.' %or outbuf(bk)='=' %then %c
  607+                 ->printpart
  608              %repeat
  609              %for i = ubp, -1, lst+3 %cycle
  610                 %if outbuf(i)=dquotes %then bk = i-1 %and ->printpart
  611              %repeat
  612              %for i = bk, -1, lst %cycle
  613                 %if outbuf(i)=squotes %start
  614                    %if chartype(outbuf(i-1))&constart=0 %then bk = i-1 %else %c
  615+                    bk = i-2
  616                    ->printpart
  617                 %finish
  618              %repeat
  619              ! Break string.
  620              printstring("Line:".itos(line,0)." problem:")
  621              printsymbol(outbuf(i)) %for i = lst, 1, ubp
  622              printstring(snl)
  623              tp = ubp-1
  624              transfer(lst, tp)
  625              outstring(""".".percentc.snl)
  626              dupl(' ', p_tab(inn)+p_icontin)
  627              outstring("""")
  628              lst = tp+1
  629              %continue
  630           %finish %else bk = ubp
  631           printstring("Line:".itos(line,0)." problem:")
  632           printsymbol(outbuf(i)) %for i = lst, 1, ubp
  633           printstring(snl)
  634  printpart:
  635           i = bk
  636           i = i-1 %while outbuf(i)=' ' %or outbuf(i)&127=rs
  637           transfer(lst, i)
  638           %if i<lst %or outbuf(i)&127#nl %start; ! NOT NATURAL BREAK
  639              %if outbuf(i)&127#',' %and outbuf(bk)#rs!128 %and curlend=0 %then %c
  640+              outstring(" ".percentc)
  641              outstring(snl)
  642              dupl(' ', p_tab(inn)+p_icontin) %if inconst=false
  643              outstring("%") %if %c
  644+              outbuf(bk+1)&underline#0 %and outbuf(bk+1)#rs!128
  645           %finish
  646           lst = bk+1
  647        %repeat
  648  finalpart:
  649        transfer(lst, obp-1)
  650        obp = 1
  651     %end
  652  
  653     %integer %fn nextnonsp(%integer print)
  654        ! If PRINT is True then ' ' or '%' or RS are transferred to the output
  655        ! buffer when encountered.
  656        %integer ch
  657        %cycle
  658           ch = sc(ptr)
  659           %if ch='{' %start
  660              outbuf(obp) = ' ' %and obp = obp+1 %if obp>1 %and print=false
  661              outbuf(obp) = '{'
  662              obp = obp+1; ptr = ptr+1
  663              %cycle
  664                 ch = sc(ptr)
  665                 outbuf(obp) = ch!incurly
  666                 obp = obp+1
  667                 ptr = ptr+1
  668              %repeat %until ch='}'
  669              %continue
  670           %finish
  671           %exit %unless ch=' ' %or ch='%' %or ch&127=rs
  672           %if print=true %then outbuf(obp) = ch %and obp = obp+1
  673           ptr = ptr+1
  674        %repeat
  675        %result = ch
  676     %end
  677  
  678     %routine getline(%integer initptr)
  679  !***********************************************************************
  680  !*    GETLINE :- take from the input file and processes the data and   *
  681  !*               it into the array SC.                                 *
  682  !*                                                                     *
  683  !*    The following processing is done:                                *
  684  !*       1) All delimiters have 128 added to each character in the word*
  685  !*       2) Lines are joined togther if there is a %c or ',' at the end*
  686  !*          of the first line. The newline position is marked by RS.   *
  687  !***********************************************************************
  688        %const %byte %integer %array itoi(0:255)= %c
  689+                   32(10),10,32(14),25,26,32(5),
  690+                   32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
  691+                   48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
  692+                   64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
  693+                   80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
  694+                   96,97,98,99,100,101,102,103,104,105,106,107,108,109,
  695+                   110,111,112,113,114,115,116,117,118,119,
  696+                   120,121,122,123,124,125,126,32,
  697+                   26(5),10,26(10),
  698+                   26(16),
  699+                   26(14),92,38,
  700+                   26(11),35,26(4),
  701+                   26(16),
  702+                   26(9),35,26(5),94,
  703+                   26(32)
  704        %short %integer %array scurl, ecurl(1:20)
  705        %integer in keyword, char, p, ncurl
  706        %own %integer strdelimiter
  707  
  708        %if initptr=1 %then startline = inptr
  709        ptr = initptr
  710  
  711        %cycle
  712           in keyword = false
  713           ncurl = 0
  714           %cycle
  715              %if ptr>ccsize %then fail(1, 1) %and %exit
  716              %if inptr>dataend %then fail(2, 1)
  717              char = itoi(byteinteger(inptr))
  718              inptr = inptr+1
  719  
  720              %if char=nl %start
  721                 inline = inline+1
  722                 sc(ptr) = nl
  723                 ptr = ptr+1
  724                 %exit
  725              %finish
  726  
  727              %if str=true %start
  728                 sc(ptr) = char; ptr = ptr+1
  729                 %if char=strdelimiter %then str = false
  730                 %continue
  731              %finish
  732  
  733              %if chartype(char)&endst#0 %then %c
  734+              sc(ptr) = char %and ptr = ptr+1 %and %exit
  735  
  736              ! Deal with curly bracket comments noting start so as to permit
  737              ! continuations of the form ...,{...}.
  738              ! Note that any missing closing brace is replaced.
  739              %if char='{' %start
  740                 ncurl = ncurl+1; scurl(ncurl) = ptr
  741                 sc(ptr) = char; ptr = ptr+1
  742                 %cycle
  743                    char = itoi(byteinteger(inptr))
  744                    %if char=nl %then char = '}' %else inptr = inptr+1
  745                    %if char='}' %then %exit
  746                    sc(ptr) = char
  747                    ptr = ptr+1
  748                 %repeat
  749                 ecurl(ncurl) = ptr
  750              %finish
  751  
  752              %if in keyword=true %start
  753                 %if chartype(char)&letter=0 %then in keyword = false %else %c
  754+                 sc(ptr) = onecase(char)!underline %and ptr = ptr+1 %and %c
  755+                 %continue
  756              %finish
  757  
  758              %if char='%' %then in keyword = true
  759  
  760              %if char=squotes %or char=dquotes %start
  761                 str = true; strdelimiter = char
  762              %finish
  763  
  764              sc(ptr) = char
  765              ptr = ptr+1
  766           %repeat
  767  
  768           %if char=nl %start; ! TRAILING SPACES CHECK
  769              ptr = ptr-1 %while ptr>2 %and sc(ptr-2)=' '
  770              sc(ptr-1) = nl
  771              %if str=false %start
  772                 p = ptr-2
  773                 %while ncurl>0 %and ecurl(ncurl)=p %cycle
  774                    ! Step past curly bracket.
  775                    p = scurl(ncurl)-1; ncurl = ncurl-1
  776                    p = p-1 %while p>0 %and sc(p)=' '
  777                 %repeat
  778                 ! Now p points at character determining continuation.
  779                 %if p>0 %start
  780                    char = sc(p)
  781                    %if char=',' %start
  782                       sc(ptr-1) = rs!128
  783                       %continue
  784                    %finish
  785                    %if char='C'+underline %start
  786                       %if p>1 %and sc(p-1)='%' %then sc(p-1) = ' '
  787                       sc(p) = ' '
  788                       sc(ptr-1) = rs
  789                       %continue
  790                    %finish
  791                    %if char&127=rs %then sc(ptr-1) = rs!128 %and %continue
  792                 %finish
  793              %finish
  794           %finish
  795           %exit
  796        %repeat
  797        ptr = initptr
  798  
  799     %end
  800  
  801     %integer %fn compare(%integer test)
  802        %integer i, ch, key, j
  803  
  804        %for i = 1, 1, clett(test) %cycle
  805           ch = nextnonsp(inconst)
  806           %if ch#clett(i+test) %then %result = false
  807           ptr = ptr+1
  808        %repeat
  809  
  810        %if test=offile %or test=ofprogram %then stop = true
  811  
  812        %if test=comma %then insert(',', false, p_spcomma) %and %result = true
  813        %if test=equals %start
  814           %if ssalt=ownalt %then inconst = p_lclist
  815           ! If in own or const declaration and p_lclist is set, then set
  816           ! inconst to true.  The effect of this is leave the declaration
  817           ! unformatted.  Inconst is not set earlier as we do not wish the
  818           ! leading spaces in the statement to be preserved - i.e. the first
  819           ! line of the statement is indented with the rest of the program.
  820           insert('=', p_spacass, p_spacass)
  821           %result = true
  822        %finish
  823        %if p_expkey=true %start
  824           test = function %if test=fn
  825           test = constant %if test=const
  826        %finish
  827        %if obp=1 %or (outbuf(obp-1)&underline=0 %and %c
  828+        outbuf(obp-1)&127#'%') %then key = false %else key = true
  829        ! Current state of outbuf.
  830        %for i = 1, 1, clett(test) %cycle
  831           ch = clett(test+i)
  832           %if ch<underline %and key=true %start
  833              outbuf(obp) = ' '
  834              obp = obp+1
  835              key = false
  836           %finish %else %if ch>underline %start
  837              %if key=false %start
  838                 %if obp>1 %and '('#outbuf(obp-1)#' ' %then %c
  839+                 outbuf(obp) = ' ' %and obp = obp+1
  840                 outbuf(obp) = '%'
  841                 obp = obp+1
  842                 key = true
  843              %finish %else %if i=1 %and p_sepkey=true %then %c
  844+              outbuf(obp) = ' ' %and outbuf(obp+1) = '%' %and obp = obp+2
  845           %finish
  846  
  847           %if ch&underline#0 %and p_uckey=false %and ch#rs!128 %then ch = ch!32
  848           outbuf(obp) = ch
  849           obp = obp+1
  850        %repeat
  851  
  852        %if (test=offile %or test=ofprogram) %and p_sepkey=true %start
  853           %if test=offile %then j = 4 %else j = 7
  854           obp = obp+2
  855           outbuf(obp-i) = outbuf(obp-i-2) %for i = 1, 1, j
  856           outbuf(obp-j-2) = ' '
  857           outbuf(obp-j-1) = '%'
  858        %finish
  859        %if test=if %or test=unless %or test=while %or test=until %or %c
  860+        test=else %or test=then %then outbuf(obp-1) = ch!bpoint
  861        %if test=and %or test=or %then outbuf(obp-1) = ch!bpoint2
  862        %result = true
  863     %end
  864  
  865     %integer %fn check(%integer pos)
  866        %integer defend, subdefend, subdefstart, res, item, rsptr, z,
  867+         strdelimiter, ch, rsobj, alt, i, j
  868        %own %string (19) fes="FINISH %ELSE %START"
  869        %own %integer uci
  870        %own %integer depth=0
  871        %switch bip(999:1039); ! Built-in phrases.
  872  
  873        alt = 0
  874        depth = depth+1; ! Depth of recursion in check.
  875        ssalt = 0 %if depth=1; ! Initialise ssalt if in top-level call.
  876  
  877        rsptr = ptr; rsobj = obp
  878        defend = symbol(pos)
  879        pos = pos+1
  880        %while pos<defend %cycle
  881           alt = alt+1
  882           %if depth=1 %start; ! Outer level - i.e. trying ss alternatives.
  883              ssalt = ssalt+1
  884              inconst = false
  885           %finish
  886           subdefend = symbol(pos)
  887           pos = pos+1
  888           res = true
  889           subdefstart = pos
  890           %while pos<subdefend %cycle
  891              item = symbol(pos)
  892              %if 999<=item<1300 %then ->bip(item)
  893              %if item<999 %then res = compare(item)
  894              %if item>=1300 %then res = check(item)
  895              pos = pos+1
  896              ->bypass
  897  
  898  bip(999):
  899              pos = subdefstart; ! Star function.
  900              rsptr = ptr; rsobj = obp
  901              ->bypass
  902  
  903  bip(1000):
  904              depth = depth-1; %result = true; ! Zero function.
  905  
  906  bip(1001):
  907              ! Name
  908              ch = nextnonsp(inconst)
  909              j = ptr; ptr = ptr+1; i = obp
  910              %if chartype(ch)&letter=0 %then res = false %and ->inc
  911              %if chartype(ch)&constart#0 %and %c
  912+              nextnonsp(inconst!p_spacnam)=squotes %then res = false %and ->inc
  913              ptr = j; obp = i; ! AVOID FUNNY SPACING ON 1 LETTER NAMES
  914              j = outbuf(obp-1); ! LAST CHAR OUT
  915              %if j>128 %or chartype(j)&letter#0 %or j=')' %then %c
  916+              outbuf(obp) = ' ' %and obp = obp+1
  917              %while chartype(ch)&(letter!number)#0 %cycle
  918                 %if chartype(ch)&letter#0 %and p_lcasnam=false %start
  919                    ! Letter case in names to be controlled by P_UCKEY.
  920                    %if p_uckey=true %then ch = ch&(\32) %else ch = ch!32
  921                 %finish
  922                 outbuf(obp) = ch; obp = obp+1
  923                 j = obp; ! Position after latest character of name.
  924                 ptr = ptr+1
  925                 ch = nextnonsp(inconst!p_spacnam)
  926              %repeat
  927              ! Now j gives posn in outbuf after last character of name, and obp
  928              ! gives next free posn in outbuf.
  929              %if p_spacnam=true %and inconst=false %and j<obp %start
  930                 ! Throw away bytes after name, apart from curly comments.
  931                 i = j
  932                 %cycle
  933                    i = i+1 %while i<obp %and outbuf(i)&127#'{'
  934                    %exit %if i=obp
  935                    %if j<i %start
  936                       outbuf(j) = ' '
  937                       %cycle
  938                          j = j+1
  939                          outbuf(j) = outbuf(i)
  940                          i = i+1
  941                       %repeat %until outbuf(j)&127='}'
  942                    %finish %else %start
  943                       j = j+1 %until outbuf(j)&127='}'
  944                       i = j+1
  945                    %finish
  946                    j = j+1
  947                 %repeat
  948                 obp = j
  949              %finish
  950              ->inc
  951  bip(1005):
  952              ! N - Number.
  953              ch = nextnonsp(inconst)
  954              %if chartype(ch)&number=0 %then res = false %and ->inc
  955  bip(1002):
  956              ! Iconst.
  957  bip(1003):
  958              ! Const.
  959              ch = nextnonsp(inconst)
  960              ptr = ptr+1
  961              res = false %and ->inc %unless %c
  962+              chartype(ch)&(quotes!constfirst)#0 %or %c
  963+              (chartype(ch)&constart#0 %and nextnonsp(inconst)=squotes)
  964              %if outbuf(obp-1)>128 %or chartype(outbuf(obp-1))&letter#0 %then %c
  965+              outbuf(obp) = ' ' %and obp = obp+1
  966              %if chartype(ch)&constfirst=0 %start
  967                 %if chartype(ch)&constart#0 %start
  968                    outbuf(obp) = ch; obp = obp+1
  969                    strdelimiter = nextnonsp(inconst)
  970                    ptr = ptr+1
  971                 %finish %else strdelimiter = ch
  972                 outbuf(obp) = strdelimiter; obp = obp+1
  973                 %cycle
  974                    %if sc(ptr)=strdelimiter %start
  975                       outbuf(obp) = strdelimiter!instring
  976                       %if sc(ptr+1)#strdelimiter %then %exit
  977                       outbuf(obp+1) = strdelimiter!instring
  978                       obp = obp+2; ptr = ptr+2
  979                    %finish %else %start
  980                       ch = sc(ptr)
  981                       outbuf(obp) = ch!instring
  982                       obp = obp+1; ptr = ptr+1
  983                       %if ch=nl %start
  984                          getline(ptr)
  985                       %finish
  986                    %finish
  987                 %repeat
  988                 ptr = ptr+1; obp = obp+1
  989              %finish %else %start
  990                 ptr = ptr-1
  991                 %cycle
  992                    %cycle
  993                       %exit %if chartype(ch)&constcont=0
  994                       outbuf(obp) = ch; obp = obp+1
  995                       ptr = ptr+1
  996                       ch = nextnonsp(inconst)
  997                    %repeat
  998                    %if '_'#ch#'@' %then %exit
  999                    %if ch='@' %then j = number %else j = number!letter
 1000                    ! Second part of @ and radix consts
 1001                    %cycle
 1002                       outbuf(obp) = ch; obp = obp+1
 1003                       ptr = ptr+1
 1004                       ch = nextnonsp(inconst)
 1005                    %repeat %until chartype(ch)&j=0
 1006                 %repeat
 1007              %finish
 1008              ->inc
 1009  bip(1004):! Phrase check extended type
 1010              ch = nextnonsp(inconst)
 1011              res = false %unless %c
 1012+              ch>underline %and X'80000000'>>(ch&31)&X'20C83000'#0
 1013              ->inc
 1014  bip(1038):! Include
 1015  bip(1006):! S - End statement.
 1016              ch = nextnonsp(inconst)
 1017              %if chartype(ch)&endst=0 %then res = false %and ->inc
 1018              obp = obp-1 %while obp>1 %and outbuf(obp-1)=' '
 1019              outbuf(obp) = ch; obp = obp+1
 1020              ->inc
 1021  bip(1007):! Text - comment string.
 1022              ch = nextnonsp(inconst)
 1023              %if chartype(ch)&rem=0 %then res = false %and ->inc
 1024              %if ch&underline#0 %and (outbuf(obp-1)&underline=0) %then %c
 1025+              outbuf(obp) = '%' %and obp = obp+1
 1026              outbuf(obp) = ch; obp = obp+1
 1027              ptr = ptr+1
 1028              %if ch='C'+underline %start
 1029                 outbuf(obp-1) = ch!32 %if p_uckey=false
 1030                 %for i = 2, 1, 7 %cycle
 1031                    ch = nextnonsp(inconst)
 1032                    %if ch#keycom(i)+underline %then res = false %and ->inc
 1033                    %if p_uckey=false %then ch = ch!32
 1034                    outbuf(obp) = ch
 1035                    obp = obp+1
 1036                    ptr = ptr+1
 1037                 %repeat
 1038              %finish
 1039              str = false
 1040              %cycle
 1041                 %while sc(ptr)#nl %and (str=true %or sc(ptr)#';') %cycle
 1042                    ch = sc(ptr)
 1043                    %if ch=squotes %or ch=dquotes %start
 1044                       %if str=false %then %c
 1045+                       strdelimiter = ch %and str = true %else %if %c
 1046+                       ch=strdelimiter %then str = false
 1047                    %finish
 1048                    %if ch&underline#0 %and p_uckey=false %and ch#rs!128 %then %c
 1049+                    ch = ch!32
 1050                    outbuf(obp) = ch; obp = obp+1
 1051                    ptr = ptr+1
 1052                 %repeat
 1053                 outbuf(obp) = sc(ptr); obp = obp+1
 1054                 ptr = ptr+1
 1055                 %exit %if outbuf(obp-1)=nl
 1056                 ! Semi-colon terminated input - carry on reading.
 1057                 getline(1)
 1058              %repeat
 1059              str = false
 1060              ->inc
 1061  bip(1009):! N255 - Test string declaration length.
 1062              ch = nextnonsp(inconst)
 1063              %unless '0'<=ch<='9' %then res = false %and ->inc
 1064              z = 0
 1065              %while '0'<=ch<='9' %cycle
 1066                 z = z*10+ch-'0'
 1067                 outbuf(obp) = ch; obp = obp+1
 1068                 ptr = ptr+1
 1069                 ch = nextnonsp(inconst)
 1070              %repeat
 1071              %if z>255 %then res = false
 1072              ->inc
 1073  bip(1012):! Readline?
 1074              ch = nextnonsp(inconst)
 1075              ! Deal with "FRED(1:10) = <nl> .. init vals .." constructions.
 1076              %if ch=nl %start
 1077                 outbuf(obp) = nl; obp = obp+1
 1078                 sc(ptr) = rs!128
 1079                 getline(ptr+1)
 1080              %finish
 1081              ->inc
 1082  bip(1015):! Down.
 1083              level = level+1
 1084              bheading = true
 1085              %if p_iblock=true %then increm = true
 1086              ->inc
 1087  bip(1016):! Up.
 1088              level = level-1
 1089              bheading = true
 1090              %if p_iblock=true %and in>0 %then in = in-1
 1091              ->inc
 1092  bip(1019):! Colon - Is previous character a colon ':'?
 1093              %if sc(ptr-1)#':' %then res = false %and ->inc
 1094              %if charsin>0 %then outstring(snl)
 1095              ch = nextnonsp(inconst)
 1096              transfer(1, obp-1)
 1097              obp = 1
 1098              %if p_seplab=true %and ch#nl %then outstring(snl)
 1099              inlabel = true
 1100              ->inc
 1101  bip(1022):! Setnem.
 1102              ch = nextnonsp(inconst)
 1103              z = M'    '
 1104              %while chartype(ch)&letter#0 %cycle
 1105                 z = z<<8!onecase(ch)
 1106                 outbuf(obp) = ch; obp = obp+1
 1107                 ptr = ptr+1
 1108                 ch = nextnonsp(inconst)
 1109              %repeat
 1110  
 1111              %unless ch='_' %and z#M'    ' %then res = false %and ->inc
 1112              outbuf(obp) = '_'; obp = obp+1
 1113              uci = z
 1114              ptr = ptr+1
 1115              ->inc
 1116  bip(1023):! Primform
 1117              %for i = 7, 1, 127 %cycle
 1118                 ->pfnd %if opc(i)=uci
 1119              %repeat
 1120              res = false
 1121              ->inc
 1122  pfnd:! Mnemonic found
 1123              res = false %if 8<=i>>3<=11 %and i&7<=3
 1124              ->inc
 1125  bip(1024):! Sectform.
 1126              %for i = 64, 8, 88 %cycle
 1127                 %for j = 0, 1, 3 %cycle
 1128                    %if opc(i+j)=uci %then ->inc
 1129                 %repeat
 1130              %repeat
 1131              res = false
 1132              ->inc
 1133  bip(1025):! Tertform.
 1134              %for i = 3, -1, 1 %cycle
 1135                 %if opc(i)=uci %then ->inc
 1136              %repeat
 1137              res = false
 1138              ->inc
 1139  bip(1026):! Op.
 1140              ch = nextnonsp(inconst)
 1141              ptr = ptr+1
 1142              %unless 32<ch<127 %and X'80000000'>>(ch&31)&X'4237000A'#0 %then %c
 1143+              res = false %and ->inc
 1144  
 1145              %if ch='&' %or ch='+' %or ch='-' %then %c
 1146+              insert(ch, p_spacop, p_spacop) %and ->inc
 1147  
 1148              %if ch='*' %start
 1149                 %if ch#nextnonsp(inconst) %then %c
 1150+                 insert('*', p_spacop, p_spacop) %and ->inc
 1151                 ptr = ptr+1; j = ptr
 1152                 ch = nextnonsp(inconst)
 1153                 ptr = ptr+1
 1154                 %if M'*'=ch=nextnonsp(inconst) %then %c
 1155+                 insert(M'****', p_spacop, p_spacop) %and ptr = ptr+1 %and ->inc
 1156                 insert(M'**', p_spacop, p_spacop)
 1157                 ptr = j; ->inc
 1158              %finish
 1159  
 1160              %if ch='/' %start
 1161                 %if ch#nextnonsp(inconst) %then %c
 1162+                 insert('/', p_spacop, p_spacop) %and ->inc
 1163                 insert(M'//', p_spacop, p_spacop)
 1164                 ptr = ptr+1; ->inc
 1165              %finish
 1166  
 1167              %if ch='!' %start
 1168                 %if ch#nextnonsp(inconst) %then %c
 1169+                 insert('!', p_spacop, p_spacop) %and ->inc
 1170                 insert(M'!!', p_spacop, p_spacop)
 1171                 ptr = ptr+1; ->inc
 1172              %finish
 1173  
 1174              %if ch='.' %then outbuf(obp) = '.' %and obp = obp+1 %and ->inc
 1175              %if ch=nextnonsp(inconst)='>' %start
 1176                 insert(M'>>', p_spacop, p_spacop)
 1177                 ptr = ptr+1
 1178                 ->inc
 1179              %finish
 1180  
 1181              %if ch=nextnonsp(inconst)='<' %start
 1182                 insert(M'<<', p_spacop, p_spacop)
 1183                 ptr = ptr+1
 1184                 ->inc
 1185              %finish
 1186  
 1187              %if ch='\' %start
 1188                 %if ch#nextnonsp(inconst) %then %c
 1189+                 insert('\', p_spacop, p_spacop) %and ->inc
 1190                 insert(M'\\', p_spacop, p_spacop)
 1191                 ptr = ptr+1; ->inc
 1192              %finish
 1193  
 1194              res = false; ->inc
 1195  
 1196  bip(1027):! Chui.
 1197              ch = nextnonsp(inconst)
 1198              %if chartype(ch)&letter=0 %and ch#'-' %and %c
 1199+              X'80000000'>>(ch&31)&X'14043000'=0 %then res = false
 1200              ->inc
 1201  bip(1028):! +'.
 1202              ch = nextnonsp(inconst)
 1203              %if ch='+' %or ch='-' %or ch='\' %or ch=X'7E' %then %c
 1204+              insert(ch, p_spacop, p_spacop) %and ptr = ptr+1
 1205              ->inc
 1206  bip(1031):! Ucwrong (unknown user code format - allow it through).
 1207              %cycle
 1208                 ch = nextnonsp(inconst)
 1209                 outbuf(obp) = ch; obp = obp+1
 1210                 ->inc %if chartype(ch)&endst#0
 1211                 ptr = ptr+1
 1212              %repeat
 1213  bip(1030):! ,'.
 1214              ch = nextnonsp(inconst)
 1215              res = false %if ch=')'
 1216              %if res=true %then insert(',', false, p_spcomma)
 1217              %if ch=',' %then ptr = ptr+1
 1218              ->inc
 1219  bip(1032):! Chcomp.
 1220  bip(1037):! Comp2
 1221              ch = nextnonsp(inconst)
 1222              ptr = ptr+1
 1223              %unless 32<ch<=92 %and X'80000000'>>(ch&31)&X'1004000E'#0 %then %c
 1224+              res = false %and ->inc
 1225              %if ch='=' %start
 1226                 %if nextnonsp(inconst)=ch %then %c
 1227+                 ptr = ptr+1 %and insert(M'==', p_spacop, p_spacop) %and ->inc
 1228                 insert('=', p_spacop, p_spacop)
 1229                 ->inc
 1230              %finish
 1231              %if ch='#' %start
 1232                 %if nextnonsp(inconst)=ch %then %c
 1233+                 ptr = ptr+1 %and insert(M'##', p_spacop, p_spacop) %and ->inc
 1234                 insert('#', p_spacop, p_spacop)
 1235                 ->inc
 1236              %finish
 1237              %if ch='\' %and nextnonsp(inconst)='=' %start
 1238                 ptr = ptr+1
 1239                 %if nextnonsp(inconst)='=' %then %c
 1240+                 ptr = ptr+1 %and insert(M'==\', p_spacop, p_spacop) %and ->inc
 1241                 insert(M'=\', p_spacop, p_spacop)
 1242                 ->inc
 1243              %finish
 1244              %if ch='>' %start
 1245                 %if nextnonsp(inconst)='=' %then %c
 1246+                 ptr = ptr+1 %and insert(M'=>', p_spacop, p_spacop) %and ->inc
 1247                 insert('>', p_spacop, p_spacop)
 1248                 ->inc
 1249              %finish
 1250              %if ch='<' %start
 1251                 %if nextnonsp(inconst)='=' %then %c
 1252+                 ptr = ptr+1 %and insert(M'=<', p_spacop, p_spacop) %and ->inc
 1253                 %if nextnonsp(inconst)='>' %then %c
 1254+                 ptr = ptr+1 %and insert(M'><', p_spacop, p_spacop) %and ->inc
 1255                 insert('<', p_spacop, p_spacop)
 1256                 ->inc
 1257              %finish
 1258              %if ch='-' %and nextnonsp(inconst)='>' %then %c
 1259+              ptr = ptr+1 %and insert(M'>-', p_spacop, p_spacop) %and ->inc
 1260              res = false
 1261              ->inc
 1262  bip(1033):! Assop.
 1263              ch = nextnonsp(inconst)
 1264              ptr = ptr+1
 1265              %if ch='=' %start
 1266                 %if nextnonsp(inconst)='=' %then %c
 1267+                 ptr = ptr+1 %and insert(M'==', p_spacass, p_spacass) %and ->inc
 1268                 insert('=', p_spacass, p_spacass)
 1269                 ->inc
 1270              %finish
 1271              %if ch='<' %and nextnonsp(inconst)='-' %then %c
 1272+              ptr = ptr+1 %and insert(M'-<', p_spacass, p_spacass) %and ->inc
 1273              %if ch='-' %and nextnonsp(inconst)='>' %then %c
 1274+              ptr = ptr+1 %and insert(M'>-', p_spacass, p_spacass) %and ->inc
 1275              res = false
 1276  bip(1008):! Bighole.
 1277              ->inc
 1278  bip(1010):! Hole.
 1279  bip(1011):! Mark.
 1280              ->inc
 1281  bip(1013):! Alias.
 1282              ch = nextnonsp(inconst)
 1283              ptr = ptr+1
 1284              %if ch#'"' %then res = false %and ->inc
 1285              outbuf(obp) = ' '; obp = obp+1
 1286              outbuf(obp) = '"'; obp = obp+1
 1287              %cycle
 1288                 %if sc(ptr)='"' %start
 1289                    outbuf(obp) = '"'!instring
 1290                    %if sc(ptr+1)#'"' %then %exit
 1291                    outbuf(obp+1) = '"'!instring
 1292                    obp = obp+2; ptr = ptr+2
 1293                 %finish %else %start
 1294                    ch = sc(ptr)
 1295                    outbuf(obp) = ch!instring
 1296                    obp = obp+1; ptr = ptr+1
 1297                    getline(ptr) %if ch=nl
 1298                 %finish
 1299              %repeat
 1300              ptr = ptr+1; obp = obp+1
 1301              ->inc
 1302  bip(1014):! Dummyapp.
 1303  bip(1017):! Liston.
 1304  bip(1018):! List off.
 1305  bip(1020):! Note const.
 1306  bip(1021):! Trace.
 1307              ->inc
 1308  bip(1039):! Dummy start
 1309              %if p_expkey=true %start; ! Expand %else to %finish %else %start
 1310                 obp = obp-4
 1311                 %for i = 1, 1, 19 %cycle
 1312                    j = charno(fes, i)
 1313                    %continue %if p_sepkey=false %and (j=' ' %or j='%')
 1314                    j = j!32 %if p_uckey=false %and 'A'<=j<='Z'
 1315                    outbuf(obp) = j; obp = obp+1
 1316                 %repeat
 1317              %finish
 1318  bip(1029):! Note cycle
 1319  bip(1034):! Note start
 1320              increm = true; ->inc
 1321  bip(1035):! Note finish
 1322  bip(1036):! Note repeat
 1323              %if in>0 %then in = in-1; ->inc
 1324  inc:
 1325              pos = pos+1
 1326  bypass:
 1327              %if res=false %start
 1328                 pos = subdefend
 1329                 obp = rsobj
 1330                 %if ptr>maxptr %then maxptr = ptr %and maxitem = item
 1331                 ptr = rsptr
 1332              %finish
 1333           %repeat
 1334           %if res=true %then depth = depth-1 %and %result = true
 1335        %repeat
 1336        ptr = rsptr; obp = rsobj
 1337        depth = depth-1
 1338        %result = false
 1339     %end
 1340  
 1341  
 1342  !***********************************************************************
 1343  !*                                                                     *
 1344  !*                Main calling routine.                                *
 1345  !*                                                                     *
 1346  !***********************************************************************
 1347     s = "test.imp,.out,SPCOMMA=Y,EXPKEY=Y"; ! cliparam
 1348  !printstring("preopt".snl)
 1349     opt(s, p); ! Call option setting routine to set parameters.
 1350  !printstring("preconnect ".infile.snl)
 1351     connect(infile, 0, 0, 0, rec, eflag); ! Open input file.
 1352  !printstring("postconnect".snl)
 1353     %if eflag#0 %then fail(eflag, 5)
 1354     %if rec_filetype#charfile %then setfname(infile) %and fail(267, 5)
 1355     inptr = rec_conad+rec_datastart; ! Start of data.
 1356     dataend = rec_conad+rec_dataend; ! End of data.
 1357  
 1358     ! Set output stream, possibilities are:
 1359     ! Terminal, file, same file or output device.
 1360     %if outf=".OUT" %then stream = terminal %else %start
 1361        %if infile=outf %then stream = samefile %else %start
 1362           %if charno(outf, 1)='.' %start
 1363              %if devcode(outf)<=0 %start
 1364                 ! Invalid output device.
 1365                 setfname(outf)
 1366                 fail(264, 5)
 1367              %finish %else stream = device
 1368           %finish %else stream = file
 1369        %finish
 1370     %finish
 1371  
 1372     ! Create tempory output file?
 1373     %if stream=samefile %or stream=device %then workfile = "T#".nexttemp %else %c
 1374+     workfile = outf
 1375     %if stream#terminal %start
 1376        filesizeptr = 1
 1377        filesize = fstable(filesizeptr)
 1378  !printstring("outfile: ".workfile.snl)
 1379        outfile(workfile, filesize, 0, 0, conad, eflag)
 1380        %if eflag#0 %then fail(eflag, 5)
 1381        outrec == record(conad)
 1382        writeaddress = conad+outrec_datastart; wa0 = write address
 1383        outrec_filetype = charfile
 1384        ! Rest of record elements to be fill in at end of indentation.
 1385     %finish
 1386  
 1387     outbuf(0) = 0; sc(0) = 0
 1388     level = 0; obp = 1; in = 0
 1389     inline = 1; line = 0 {output line}
 1390     errors = 0; erptr = 0; charsin = 0
 1391     str = false
 1392     stop = false; semicolon = false; increm = false; inlabel = false
 1393     ersave = false
 1394     %if p_uckey=true %then percentc = "%C" %else percentc = "%c"
 1395     %cycle
 1396        bheading = false
 1397        maxptr = 0
 1398        ! Is there more to analyse in this statement.
 1399        colon = inlabel
 1400        %if inlabel=false %then getline(1) %else inlabel = false
 1401        %if check(ss)=false %start
 1402           printstring(snl."Syntax analysis fails on input line ".itos(inline-1,0))
 1403           printstring(" (output line ".itos(line+1,0).")".snl)
 1404           z = 1
 1405           %while chartype(sc(z))&endst=0 %cycle
 1406              %if sc(z)&127=rs %then printstring(snl) %else printsymbol(sc(z)&127)
 1407              z = z+1
 1408           %repeat
 1409           %if sc(z)=';' %then printsymbol(';')
 1410           printstring(snl)
 1411           spaces(maxptr-1); printsymbol('!'); printstring(snl)
 1412           startline = startline+1 %while byteinteger(startline)=' '
 1413           %if stream#terminal %start
 1414              obp = 1
 1415              ! Line failed - Input line to output routine.
 1416              z = byteinteger(startline)
 1417              %while chartype(z)&endst=0 %cycle
 1418                 %if chartype(z)&quotes#0 %start
 1419                    strdelimiter = z
 1420                    outbuf(obp) = strdelimiter; obp = obp+1
 1421                    startline = startline+1
 1422                    z = byteinteger(startline)
 1423                    %while z#strdelimiter %cycle
 1424                       outbuf(obp) = z
 1425                       obp = obp+1; startline = startline+1
 1426                       z = byteinteger(startline)
 1427                    %repeat
 1428                 %finish
 1429                 outbuf(obp) = z
 1430                 obp = obp+1; startline = startline+1
 1431                 z = byteinteger(startline)
 1432              %repeat
 1433              outbuf(obp) = z; obp = obp+1
 1434              punch
 1435           %finish
 1436           str = false
 1437           errors = errors+1
 1438        %finish %else %start
 1439           %if inlabel=false %then punch
 1440        %finish
 1441  
 1442        %if stop=true %start
 1443           %if errors=0 %then closedown(true) %else closedown(false)
 1444        %finish
 1445     %repeat
 1446     ! DOES NOT  COME THROUGH HERE
 1447  
 1448     %routine fail(%integer type, action)
 1449        %if action#5 %start
 1450           %if action&2=0 %then %c
 1451+           printstring(snl."*** Error: ") %and errors = errors+1 %else %c
 1452+           printstring(snl."*** Warning: ")
 1453        %finish
 1454  
 1455        %if action&4=0 %start
 1456           printstring(fault(type).snl)
 1457           printstring("*** In input line ".itos(inline,0)." (output line ".itos(line,0).")".snl)
 1458        %finish %else printstring("*** Soap80 fails -".failuremessage(type)) %c
 1459+        %and %stop
 1460  
 1461        %if action&1=1 %then closedown(false)
 1462     %end
 1463  
 1464     %routine opt(%string (255) parm, %record (pformat) %name p)
 1465  !***********************************************************************
 1466  !*    THIS ROUTINE PROCESSES THE USER OPTION LIST                      *
 1467  !***********************************************************************
 1468        %routine %spec readline
 1469        %routine %spec setline
 1470        %integer %fn %spec stoi(%string (255) snum)
 1471        %routine %spec ask(%integer optno)
 1472        %integer i, j, temp, flag, prof vsn
 1473        %string (80) line, option, value, filename
 1474        %const %integer prog vsn= 3
 1475        %switch prof(0:prog vsn)
 1476  
 1477        prof vsn = 0; flag = 5;
 1478        !read profile("Soap80key", p, prof vsn, flag)
 1479        %if flag>4 %start
 1480           printstring( %c
 1481+           "Failed to read file SS#PROFILE.  Defaults options assumed.".snl)
 1482        %finish
 1483  
 1484        ->prof(prof vsn)
 1485  
 1486        ! In the following profile-handling code, we work with array p_a
 1487        ! (alternative format) rather than the actual option names (p_sepkey
 1488        ! etc.).  This is because the p_a operations remain valid even if the
 1489        ! record format is subsequently changed.
 1490  
 1491  prof(0):
 1492        ! Code to set up profile vsn 1 data:
 1493        ! This consists of 14 options followed by 21 tab values.
 1494  
 1495        ! original defaults
 1496        !p_a(1) = 80; ! line - lines are broken into two if length is greater than 80.
 1497        !p_a(2) = 3; ! icontin - continuation of line have an addition indentation of 3.
 1498        !p_a(3) = 41; ! poscom - position for right hand comments.
 1499        !p_a(4) = true; ! movecom - main comment are indented to POSCOM.
 1500        !p_a(5) = true; ! uckey - keywords output in upper case.
 1501        !p_a(6) = false; ! sepkey - adjacent keywords are compounded.
 1502        !p_a(7) = true; ! lcasnam - case of names left alone.
 1503        !p_a(8) = true; ! spacnam - spaces are left within names.
 1504        !p_a(9) = true; ! spacass - spaces are added round assignment operators.
 1505        !p_a(10) = false; ! spacop - spaces are not added round other operators.
 1506        !p_a(11) = true; ! lclist - const lists to be left alone.
 1507        !p_a(12) = true; ! iblock - block contents are indented w.r.t. block heading.
 1508        !p_a(13) = false; ! istat - statements are aligned with declarations.
 1509        !p_a(14) = false; ! seplab -  Labels and statements may occupy the same line.
 1510  
 1511        ! graham's preferred defaults
 1512        p_a(1) = 80; ! line - lines are broken into two if length is greater than 80.
 1513        p_a(2) = 2; ! icontin - continuation of line have an addition indentation of 3.
 1514        p_a(3) = 41; ! poscom - position for right hand comments.
 1515        p_a(4) = false; ! movecom - main comment are indented to POSCOM.
 1516        p_a(5) = false; ! uckey - keywords output in upper case.
 1517        p_a(6) = true; ! sepkey - adjacent keywords are compounded.
 1518        p_a(7) = false; ! lcasnam - case of names left alone.
 1519        p_a(8) = true; ! spacnam - spaces are left within names.
 1520        p_a(9) = true; ! spacass - spaces are added round assignment operators.
 1521        p_a(10) = false; ! spacop - spaces are not added round other operators.
 1522        p_a(11) = true; ! lclist - const lists to be left alone.
 1523        p_a(12) = true; ! iblock - block contents are indented w.r.t. block heading.
 1524        p_a(13) = false; ! istat - statements are aligned with declarations.
 1525        p_a(14) = false; ! seplab -  Labels and statements may occupy the same line.
 1526  
 1527  
 1528        ! Set default indentation values.
 1529        p_a(i+15) = 3*i %for i = 0, 1, 10
 1530        p_a(i+15) = 5*i-20 %for i = 11, 1, 20
 1531  
 1532  prof(1):
 1533        ! Code to set up profile vsn 2 data:
 1534        ! This consists of 15 options followed by 21 tab values.
 1535        p_a(i) = p_a(i-1) %for i = 36, -1, 16; ! Move tab values down to make room.
 1536        printstring("**New parameter available: SPCOMMA".snl)
 1537        printstring("      Y : One space character inserted after commas.".snl)
 1538        printstring( %c
 1539+        "      N : No space character inserted after commas (default).".snl.snl)
 1540        p_a(15) = false; ! spcomma - default false.
 1541  prof(2):
 1542        ! Code to set up profile vsn 3 data:
 1543        ! This consists of 21 tab values followed by 16 options.
 1544        %begin
 1545           %integer i
 1546           %byte %integer %array tab(0:20)
 1547           tab(i) = p_a(i+16) %for i = 0, 1, 20; ! Copy tab values out.
 1548           p_a(i+21) = p_a(i) %for i = 1, 1, 6; ! Move options down.
 1549           ! Item _a(28) will be the new parameter (expkey).
 1550           p_a(i+22) = p_a(i) %for i = 7, 1, 15; ! Move options down.
 1551           p_a(i+1) = tab(i) %for i = 0, 1, 20; ! Copy tab values back.
 1552        %end
 1553        printstring("**New parameter available: EXPKEY".snl)
 1554        printstring( %c
 1555+        "      Y : Keywords %FN, %CONST and (sometimes) %ELSE expanded.".snl)
 1556        printstring("      N : %FN, %CONST and %ELSE left alone (default).". %c
 1557+        snl.snl)
 1558        p_a(28) = false; ! expkey default - false.
 1559  
 1560        ! The following two lines should always be just before the final 'prof'
 1561        ! switch label.
 1562        prof vsn = prog vsn
 1563        %begin
 1564          %string(11) key
 1565          key = "Soap80key"
 1566          write profile(key, p, prof vsn, flag)
 1567        %end
 1568  prof(3):
 1569  
 1570        ! Split up parameters and change default values.
 1571        %if parm->filename.(",").outf %start
 1572           %unless outf->outf.(",").parm %then parm = ""
 1573        %finish %else filename = parm %and outf = parm %and parm = ""
 1574        infile = filename
 1575        %if outf="" %then outf = filename
 1576        %if parm="" %then %return
 1577  
 1578  
 1579        temp = charno(parm, length(parm))
 1580        %if temp#'*' %and temp#'?' %then parm = parm.",END"
 1581        %cycle
 1582           %if parm="" %then %start
 1583             %begin
 1584               %string(15) s
 1585               s = "Soap80: "
 1586               prompt(s); ! not a real imp prompt unfortunately
 1587             %end
 1588             readline
 1589           %finish %else %start
 1590             setline
 1591           %finish
 1592           %if line="END" %or line=".END" %then %return
 1593           ! End of parameter settings.
 1594           %if line="GO" %or line=".GO" %then %return
 1595           ! End of parameter settings.
 1596           %if line="STOP" %or line=".STOP" %then %stop; ! Abandon Soap80.
 1597  
 1598           %if line="SAVE" %or line=".SAVE" %start
 1599              %begin
 1600                %string(11) key
 1601                key = "Soap80key"
 1602                write profile(key, p, prof vsn, flag)
 1603              %end
 1604              printstring("Profile file SS#PROFILE created and cherished.".snl) %c
 1605+               %if flag=1
 1606           %finish %else %if line="?" %start
 1607              ! Print options so far.
 1608              printstring( %c
 1609+              "Option name:{current setting}Meaning of current setting".snl)
 1610              %for i = 1, 1, maxopt %cycle
 1611                 printstring(optname(i))
 1612                 spaces(7-length(optname(i)))
 1613                 printstring(":{")
 1614                 j = p_optarr(i)
 1615                 %if j=false %then printsymbol('N') %else %if j=true %then %c
 1616+                 printsymbol('Y') %else printstring(itos(j,0))
 1617                 j = 1 %if j>0
 1618                 printstring("}".optmess(j+i*2).snl)
 1619              %repeat
 1620              printstring("TAB    :{")
 1621              %for i = 1, 1, 20 %cycle
 1622                 printstring(itos(p_tab(i),0))
 1623                 printsymbol(':') %unless i=20
 1624              %repeat
 1625              printsymbol('}')
 1626              printstring(snl)
 1627              printstring("        Indenting values".snl)
 1628              printstring( %c
 1629+              "SAVE     : Save current option settings, for defaults henceforth.
 1630+ GO or END: Cause SOAP80 to start processing the input.
 1631+ STOP     : Cause SOAP80 to stop immediately.".snl)
 1632           %finish %else %start
 1633              %if line->option.("=").value %and value#"" %start
 1634                 flag = 0
 1635                 %for i = 1, 1, maxopt %cycle
 1636                    %continue %unless option=optname(i)
 1637                    flag = 1; ! Option identified.
 1638                    %if value="?" %start
 1639                       printstring(optname(i)); spaces(7-length(optname(i)))
 1640                       printstring(":{")
 1641                       j = p_optarr(i)
 1642                       %if j=false %then printsymbol('N') %else %if %c
 1643+                       j=true %then printsymbol('Y') %else printstring(itos(j,0))
 1644                       j = 1 %if j>0
 1645                       printstring("}".optmess(j+i*2).snl)
 1646                    %finish %else %start
 1647                       %if i<=numopt %start; ! Numerical value.
 1648                          temp = stoi(value)
 1649                          %if option="LINE" %and (temp<30 %or temp>160) %start
 1650                             printstring( %c
 1651+                             "Bad line length - Only from 30 to 160".snl)
 1652                             %exit
 1653                          %finish
 1654                          temp = -1 %if temp>255
 1655                          %if temp=-1 %then %c
 1656+                          printstring(value." - ".failure message(320)) %else %c
 1657+                          p_optarr(i) = temp
 1658                       %finish %else ask(i)
 1659                    %finish
 1660                    %exit
 1661                 %repeat
 1662                 %continue %if flag=1; ! Cycle found option name.
 1663                 %if option="TAB" %start
 1664                    ! Set indenting value.
 1665                    %if value="?" %start
 1666                       printstring("TAB    :{")
 1667                       %for i = 1, 1, 20 %cycle
 1668                          printstring(itos(p_tab(i),0))
 1669                          printsymbol(':') %unless i=20
 1670                       %repeat
 1671                       printsymbol('}')
 1672                       printstring(snl)
 1673                       printstring("        Indenting values".snl)
 1674                    %finish %else %start
 1675                       i = 1
 1676                       %while i<=20 %and value#"" %cycle
 1677                          temp = stoi(value)
 1678                          %if temp=-1 %then %c
 1679+                          printstring(value." - ".failuremessage(320)) %and %c
 1680+                          %exit
 1681                          p_tab(i) = temp
 1682                          %if length(value)=0 %then i = i+1 %and %exit
 1683                          %if charno(value, 1)#':' %start
 1684                             printstring(value." - ".failuremessage(320))
 1685                             i = 21
 1686                          %finish %else value = substring(value, 2,
 1687+                           length(value))
 1688                          i = i+1
 1689                       %repeat
 1690                       ! End of indenting value, make up the rest
 1691                       %for j = i, 1, 20 %cycle
 1692                          p_tab(j) = 2*p_tab(j-1)-p_tab(j-2)
 1693                          %if p_tab(j)>p_line %then p_tab(j) = p_line
 1694                       %repeat
 1695                    %finish
 1696                    %continue
 1697                 %finish
 1698                 printstring(option." - ".failuremessage(322))
 1699                 ! Keyword not recognised.
 1700              %finish %else %start
 1701                 printstring(line." -  invalid: format should be
 1702+       'keyword = value'      or     'keyword = ?'     or    '?'    or
 1703+       'SAVE'    or    'END'     or    'GO'     or     'STOP'".snl)
 1704              %finish
 1705           %finish
 1706        %repeat
 1707        !%return
 1708  
 1709        %routine readline
 1710  !***********************************************************************
 1711  !*    READLINE creates a line from the input device, converting all    *
 1712  !*    lower case characters to upper case.                             *
 1713  !***********************************************************************
 1714           %integer ch
 1715           %cycle
 1716              line = ""
 1717              %cycle
 1718                 readsymbol(ch); %if ch=nl %then %exit
 1719                 %if ch=' ' %then %continue
 1720                 ! Convert lower to upper.
 1721                 line = line.tostring(onecase(ch))
 1722              %repeat
 1723              ! Return only if the line has some thing on it.
 1724              %if length(line)>0 %then %return
 1725           %repeat
 1726        %end
 1727  
 1728        %routine setline
 1729  !***********************************************************************
 1730  !*    SETLINE breaks the parameter list into single commands.          *
 1731  !************************************************************************
 1732           %unless parm->line.(",").parm %start
 1733              ! Last command in parameter.
 1734              %if charno(parm, length(parm))='*' %then readline %else line = parm
 1735              parm = ""
 1736           %finish
 1737        %end
 1738  
 1739        %routine ask(%integer i)
 1740  !***********************************************************************
 1741  !*    ASK checks that value starts with Y or N and                     *
 1742  !*    assigns True or False accordingly to P_OPTARR(I).                *
 1743  !***********************************************************************
 1744           %integer s
 1745           s = charno(value, 1)
 1746           %if s='Y' %then p_optarr(i) = true %else %if s='N' %then %c
 1747+           p_optarr(i) = false %else printstring("Answer Yes or No or ?".snl)
 1748        %end
 1749  
 1750        %integer %fn stoi(%string (255) snum)
 1751  !***********************************************************************
 1752  !*    STOI builts up an integer in INUM from the string SNUM, in       *
 1753  !*    doing so characters are deleted from this string.                *
 1754  !*    It is an error if the first character of the string is not a     *
 1755  !*    number.  This is signalled by returning -1.                      *
 1756  !***********************************************************************
 1757           %integer i, inum
 1758           %unless '0'<=charno(snum, 1)<='9' %then %result = -1
 1759           i = 1; inum = 0
 1760           %while '0'<=charno(snum, i)<='9' %cycle
 1761              inum = inum*10+charno(snum, i)-'0'
 1762              i = i+1
 1763              %if i>length(snum) %then %exit
 1764           %repeat
 1765           %if i>=length(snum) %then snum = "" %else %c
 1766+           snum = substring(snum, i, length(snum))
 1767           %result = inum
 1768        %end
 1769     %end
 1770  %end %of %program

 1183 Statements compiled
