!***********************************************************************
!*              SOAP80 - IMP80 formatter                               *
!*                                               Last altered 15/06/83 *
!*                                                                     *
!*              Created by E.N.Gregory, UKC.                           *
!*              All syntax directed sections rewritten by P.D.S., ERCC *
!*                using IMP80 syntax version 02.                       *
!*              User interface and parameters revised by J.M.M., ERCC. *
!*                                                                     *
!***********************************************************************
%externalstring(255)%fnspec cliparam
%external %routine %spec prompt(%string (31) %name s)

!***********************************************************************
!*                                                                     *
!*                           Record formats.                           *
!*                                                                     *
!***********************************************************************

%record %format fhdr(%integer dataend, datastart, filesize, filetype)
%record %format chdr(%integer conad, filetype, datastart, dataend)
%constant %integer maxopt= 16,numopt = 3
%record %format pformat(%byte %integer %array tab(0:20),
  (%byte %integer line, icontin, poscom, movecom, uckey, sepkey, expkey,
  lcasnam, spacnam, spacass, spacop, lclist, iblock, istat, seplab,
  spcomma %or %byte %integer %array optarr(1:maxopt)) %or %c
 %byte %integer %array a(1:21+maxopt))


!***********************************************************************
!*                                                                     *
!*                           System routines.                          *
!*                                                                     *
!***********************************************************************

%external %string %function %spec itos(%integer i)
%external %routine %spec connect(%string (31) %name name, %integer mode, hole, prot,
  %record (chdr) %name rec, %integer %name eflag)
%external %routine %spec trim(%string (31) file, %integer %name eflag)
%external %routine %spec setfname(%string (31) file)
%external %string %function %spec nexttemp
%external %routine %spec sendfile(%string (31) file, device, header,
  %integer copies, form, %integer %name eflag)
%external %integer %function %spec devcode(%string (31) name)
%external %routine %spec disconnect(%string (31) %name filename, %integer %name eflag)
%external %string %function %spec failuremessage(%integer type)
%external %routine %spec changefilesize(%string (31) %name filename,
  %integer filesize, %integer %name eflag)
%external %routine %spec newgen(%string (31) %name filename, newfilename,
  %integer %name eflag)
%external %routine %spec outfile(%string (31) %name filename, %integer size, hole,
  prot, %integer %name conad, eflag)

%begin
   %string (255) s; ! argv[1]
!%external %routine soap80(%string (255) s)
   %integer ptr, dataend, inptr, z, in, obp, eflag, writeaddress, wa0,
     filesize, conad, errors, line, erptr, startline, stream, filesizeptr,
     ssalt, strdelimiter, str, semicolon, colon, maxptr, maxitem, level,
     stop, increm, inlabel, charsin, ersave, inconst, bheading, inline
   %string (255) outf
   %string (31) workfile, infile
   %string (2) percentc
   %record (pformat) p
   %record (chdr) rec, rr
   %record (fhdr) %name outrec
   %constant %integer ccsize= 16384
   %short %integer %array outbuf(0:ccsize+200)
   %byte %integer %array sc(0:ccsize)

   %constant %string (7) %array optname(1:maxopt)=   "LINE","ICONTIN","POSCOM",
    "MOVECOM","UCKEY","SEPKEY","EXPKEY","LCASNAM","SPACNAM","SPACASS","SPACOP",
    "LCLIST","IBLOCK","ISTAT","SEPLAB","SPCOMMA"
   %constant %string (39) %array optmess(0:1, 1:maxopt)= %c
    "Line length zero (!!!)","Maximum line length",
    "Continued lines not indented","Indentation of continued lines",
    "Right hand comments not positioned","Right hand comment position",
    "Whole line comments indented normally",
    "Whole line comments moved to POSCOM","Keywords output in lower case",
    "Keywords output in upper case","Keywords not split","Keywords split",
    "%FN, %CONST, %ELSE not expanded",
    "%FN, %CONST, (sometimes) %ELSE expanded",
    "Case of names controlled by UCKEY", "Case of names left alone",
    "Spaces removed from names","Spaces preserved within names",
    "No spaces round assignment operators",
    "Spaces added round assignment operators","No spaces round operators",
    "Spaces added round operators","Constant lists formatted",
    "Constant lists left alone","Block not indented w.r.t. block heading",
    "Block indented w.r.t. block heading",
    "Statements aligned with declarations",
    "Statements indented w.r.t. declarations",
    "Labels not on lines by themselves","Labels on lines by themselves",
    "No space character after commas","Space character after commas"

   %constant %integer charfile= 3; ! Code for a character file.
   %constant %integer underline= 128
   %constant %integer instring= 256,incurly = 512,bpoint = 1024,bpoint2 = 2048
   %constant %integer terminal= 1,file = 2,samefile = 3,device = 4
   %constant %integer true= 255,false = 0; ! Synthetic boolean values.
   %constant %integer nl= 10,dquotes = 34,squotes = 39
   %constant %integer rs= 30; ! RECORD SEPARATOR IS USED AS A DELETED(BY %c) NL
   %constant %integer rem= B'00000001'
   %constant %integer constart= B'00000010'
   %constant %integer quotes= B'00000100'
   %constant %integer endst= B'00001000'
   %constant %integer number= B'00010000'
   %constant %integer letter= B'00100000'
   %constant %byte %integer constfirst= B'01000000'
   %constant %integer constcont= B'10000000'
   !
   %constant %byte %integer %array onecase(0:127)=
   0,1,2,3,4,5,6,7,8,9,10,11,12,
   13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,
   35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,
   57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
   79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,65,66,67,68,
   69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,
   123,124,125,126,127
   %constant %byte %integer %array chartype(0:255)=     B'00000001',
 B'00000000',
          B'00000000',B'00000000',B'00000000',B'00000000',B'00000000',
          B'00000000',B'00000000',B'00000000',B'00001000',B'00000000'(22),
          B'00000001'{!},B'00000100',B'01000000',B'00000000',B'00000001'{%},
          B'00000000',B'00000100',B'00000000',B'00000000',B'00000000',
          B'00000000',B'00000000',B'00000000',B'11000000',B'00000000',
          B'11010000'(10),
          B'00000000',B'00001000',B'01000000',B'01000000',B'01000000',
          B'00000000',B'00000000',
          B'00100000',B'00100010',B'00100010',B'00100010',B'00100000',
          B'00100000',B'00100000',B'00100000',
          B'00100000',B'00100000',B'00100010',B'00100000',
          B'00100010',B'00100000',B'00100000',B'00100000',B'00100000',
          B'00100010',B'00100000',B'00100000',B'00100000',B'00100000'(2),
          B'00100010',B'00100000',B'00100000',B'00000000',B'00000000',
          B'00000000',B'00000000',B'00000000',B'00000000',
          B'00100000',B'00100010'{b},B'00100010',B'00100010',B'00100000'(6),
          B'00100010'{k},B'00100000',B'00100010'{m},B'00100000'(4),
          B'00100010'{r},B'00100000'(5),B'00100010'{x},B'00100000'(2),
          B'00000000',B'00000001'{|},B'00000000',B'00000000',B'00000000',
          B'0'(67),
          B'00000001'{%C},
          B'0'(60)
   %constant %byte %integer %array keycom(0:7)= '%','C','O','M','M','E','N','T'
   %constant %integer %array fstable(1:3)=     4096,16384,65536
   !
   ! Special delimiters noted by SOAP80.
   !
   %constant %integer offile= 133,ofprogram = 123,equals = 38,comma = 10,
 if = 12,
    unless = 15,while = 22,until = 28,else = 227,then = 222,and = 158,or = 162,
    const = 204, constant = 195, fn = 96, function = 103
   !
   %constant %string (1) snl= "
"
   !
   %constant %string (60) %array fault(1:4)=
              "Statement is too long and could not be compiled.",
              "End of file reached before end of program terminator found.",
              "%END found, but could not match it to a start of routine.",
              "Disaster *** Indentation too near line length limit."
   !
   !
   !
   %routine %spec fail(%integer type, action)
   %routine %spec opt(%string (255) parm, %record (pformat) %name p)
   !
   ! Produced by oldps from impalgs_imp80ps04 on 19/01/83
   %constant %byte %integer %array clett(0:434)=   1,
{1}  43,   1,  45,   1,  40,   1,  41,   1,  42,   1,  44,   2, 201, 198,
{15}   6, 213, 206, 204, 197, 211, 211,   5, 215, 200, 201, 204, 197,   5,
{29} 213, 206, 212, 201, 204,   3, 198, 207, 210,   1,  61,   5, 193, 204,
{43} 201, 193, 211,   7, 201, 206, 212, 197, 199, 197, 210,   4, 210, 197,
{57} 193, 204,   4, 204, 207, 206, 199,   4, 194, 217, 212, 197,   6, 211,
{71} 212, 210, 201, 206, 199,   4, 200, 193, 204, 198,   6, 210, 197, 195,
{85} 207, 210, 196,   7, 210, 207, 213, 212, 201, 206, 197,   2, 198, 206,
{99}   3, 205, 193, 208,   8, 198, 213, 206, 195, 212, 201, 207, 206,   4,
{113} 206, 193, 205, 197,   5, 193, 210, 210, 193, 217,   9, 207, 198, 208,
{127} 210, 207, 199, 210, 193, 205,   6, 207, 198, 198, 201, 204, 197,   6,
{141} 207, 198, 204, 201, 211, 212,   6, 198, 207, 210, 205, 193, 212,   3,
{155} 206, 207, 212,   3, 193, 206, 196,   2, 207, 210,   1,  58,   4, 211,
{169} 208, 197, 195,   3, 207, 215, 206,   8, 197, 216, 212, 197, 210, 206,
{183} 193, 204,   9, 197, 216, 212, 210, 201, 206, 211, 201, 195,   8, 195,
{197} 207, 206, 211, 212, 193, 206, 212,   5, 195, 207, 206, 211, 212,   5,
{211} 197, 214, 197, 206, 212,   5, 211, 212, 193, 210, 212,   4, 212, 200,
{225} 197, 206,   4, 197, 204, 211, 197,   1,  95,   6, 211, 217, 211, 212,
{239} 197, 205,   7, 196, 217, 206, 193, 205, 201, 195,   4,  80,  85,  84,
{253}  95,   5,  67,  78,  79,  80,  95,   2, 204,  61,   1,  60,   1,  62,
{267}   4,  40, 196, 210,  43,   2, 196, 210,   1, 194,   3, 212, 207, 211,
{281}   3, 204, 206, 194,   3, 216, 206, 194,   2, 208, 195,   3, 195, 212,
{295} 194,   2,  45,  62,   6, 210, 197, 212, 213, 210, 206,   6, 210, 197,
{309} 211, 213, 204, 212,   7, 205, 207, 206, 201, 212, 207, 210,   4, 211,
{323} 212, 207, 208,   6, 211, 201, 199, 206, 193, 204,   4, 197, 216, 201,
{337} 212,   8, 195, 207, 206, 212, 201, 206, 213, 197,   6, 198, 201, 206,
{351} 201, 211, 200,   5, 195, 217, 195, 204, 197,   6, 210, 197, 208, 197,
{365} 193, 212,   3, 197, 206, 196,   7, 201, 206, 195, 204, 213, 196, 197,
{379}   5, 194, 197, 199, 201, 206,   2, 207, 206,   6, 211, 215, 201, 212,
{393} 195, 200,   4, 204, 201, 211, 212,  14, 212, 210, 213, 211, 212, 197,
{407} 196, 208, 210, 207, 199, 210, 193, 205,   6, 205, 193, 201, 206, 197,
{421} 208,   7, 195, 207, 206, 212, 210, 207, 204,   4,  40,  42,  41,  58


   %constant %integer %array symbol(1300:2167)=  1307,
  1303,     0,  1305,     2,  1307,  1000,  1319,  1312,  1001,  1366,
  1786,  1315,  1003,  1020,  1319,     4,  1345,     6,  1329,  1323,
  1001,  1014,  1325,  1003,  1329,     4,  1329,     6,  1336,  1336,
  1010,  1028,  1319,  1011,  1359,  1345,  1343,  1010,  1028,  1319,
  1011,  1359,  1345,     8,  1352,  1352,  1010,  1028,  1307,  1011,
  1352,  1359,  1357,  1026,  1307,   999,  1359,  1000,  1366,  1364,
  1026,  1319,   999,  1366,  1000,  1374,  1372,     4,  1345,  1374,
     6,  1374,  1000,  1381,  1379,    10,  1345,   999,  1381,  1000,
  1386,  1384,    12,  1386,    15,  1410,  1393,    22,  1010,  1536,
  1556,  1011,  1399,    28,  1010,  1536,  1556,  1011,  1410,    34,
  1010,  1001,    38,  1345,    10,  1345,    10,  1345,  1011,  1416,
  1414,    40,  1013,  1416,  1000,  1423,  1421,    10,  1001,   999,
  1423,  1000,  1428,  1426,    46,  1428,  1000,  1436,  1431,    54,
  1433,    46,  1436,    59,    54,  1458,  1439,    46,  1441,    54,
  1444,    59,  1428,  1447,    64,  1423,  1450,    69,  1689,  1453,
    76,  1423,  1458,    81,     4,  1848,     6,  1465,  1461,    88,
  1465,  1004,  1436,  1465,  1472,  1468,    96,  1470,    99,  1472,
   103,  1488,  1478,  1436,  1493,  1001,  1416,  1484,  1458,  1488,
  1001,  1416,  1501,  1488,   112,  1001,  1416,  1493,  1491,   112,
  1493,  1000,  1501,  1497,   117,   112,  1499,   112,  1501,  1000,
  1511,  1509,     4,  1010,  1472,  1011,  1511,     6,  1511,  1000,
  1520,  1518,  1030,  1010,  1472,  1011,   999,  1520,  1000,  1531,
  1524,   123,  1016,  1526,   133,  1529,   140,  1018,  1531,  1016,
  1536,  1534,   147,  1536,  1000,  1550,  1542,  1345,  1032,  1345,
  1550,  1547,     4,  1536,  1556,     6,  1550,   154,  1536,  1556,
  1554,  1037,  1345,  1556,  1000,  1567,  1561,   158,  1536,  1567,
  1565,   162,  1536,  1574,  1567,  1000,  1574,  1572,   158,  1536,
   999,  1574,  1000,  1581,  1579,   162,  1536,   999,  1581,  1000,
  1589,  1585,  1033,  1345,  1587,   165,  1589,  1000,  1595,  1593,
   167,  1008,  1595,  1015,  1599,  1598,   167,  1599,  1608,  1606,
    10,  1345,   165,  1345,  1599,  1608,  1000,  1617,  1613,  1493,
  1001,  1416,  1617,   117,  1531,  1617,  1623,  1623,  1001,  1416,
  1794,  1623,  1629,  1627,    10,  1617,  1629,  1000,  1646,  1639,
  1493,  1595,  1010,  1001,  1410,  1802,  1011,  1646,  1646,   117,
  1531,  1595,  1001,  1794,  1668,  1657,  1655,    10,  1010,  1001,
  1410,  1802,  1011,  1646,  1657,  1000,  1668,  1660,   172,  1662,
   176,  1664,   185,  1666,   195,  1668,   204,  1679,  1677,    38,
  1012,  1028,  1319,  1359,  1689,  1679,  1679,  1000,  1689,  1687,
    10,  1028,  1319,  1359,  1689,   999,  1689,  1000,  1696,  1694,
     4,  1336,     6,  1696,  1000,  1703,  1701,    10,  1329,   999,
  1703,  1000,  1708,  1706,   210,  1708,  1000,  1714,  1712,    10,
  1345,  1714,  1000,  1727,  1725,    10,  1001,  1416,     4,  1345,
   165,  1345,     6,   999,  1727,  1000,  1734,  1732,    28,  1536,
  1556,  1734,  1000,  1747,  1737,  1019,  1739,  1006,  1744,  1381,
  1536,  1556,  1006,  1747,  1386,  1006,  1761,  1751,   216,  1034,
  1755,   222,   216,  1034,  1761,   222,  1010,  2008,  1011,  1767,
  1767,  1765,   158,  2008,  1767,  1000,  1773,  1771,   227,  1773,
  1773,  1000,  1786,  1777,   216,  1034,  1784,  1381,  1010,  1536,
  1556,  1011,  1747,  1786,  2008,  1794,  1792,   232,  1001,  1366,
  1786,  1794,  1000,  1802,  1802,     4,  1345,   165,  1345,  1599,
     6,  1810,  1808,    38,  1028,  1319,  1359,  1810,  1000,  1819,
  1813,   234,  1815,   176,  1817,   241,  1819,  1000,  1830,  1828,
  1001,    38,  1345,    10,  1345,    10,  1345,  1830,  1000,  1837,
  1835,    10,  1855,   999,  1837,  1000,  1848,  1841,   167,  1001,
  1848,  1001,     4,  1855,  1830,  1873,     6,  1855,  1851,  1001,
  1855,  1855,  1830,  1873,  1865,  1859,  1436,  1865,  1865,     4,
  1855,  1830,  1873,     6,  1873,  1870,  1493,  1001,  1416,  1873,
   117,  1617,  1881,  1879,   162,  1855,  1830,   999,  1881,  1000,
  1898,  1886,   249,  1002,  1006,  1890,  1022,  1898,  1006,  1896,
   254,  1009,    10,  1009,  1006,  1898,  1031,  1912,  1902,  1023,
  1912,  1907,  1024,   260,  1951,  1956,  1912,  1025,  1005,    10,
  1935,  1935,  1917,   263,  1001,   265,  1919,  1984,  1924,     4,
  1984,  1973,     6,  1928,   267,  1984,     6,  1933,     4,   272,
  1973,     6,  1935,   275,  1951,  1940,   263,  1001,   265,  1942,
  1984,  1947,     4,   272,  1973,     6,  1951,   267,  1005,     6,
  1956,  1954,   272,  1956,  1005,  1964,  1962,    10,  1005,    10,
  1005,  1964,  1000,  1973,  1968,     0,  1005,  1971,     2,  1005,
  1973,  1000,  1979,  1977,     0,   275,  1979,  1000,  1984,  1982,
    38,  1984,  1000,  1999,  1989,  1979,  1300,  1003,  1992,  1001,
  1964,  1997,     4,  1999,  1964,     6,  1999,   277,  2008,  2002,
   281,  2004,   285,  2006,   289,  2008,   292,  2041,  2017,  1010,
  1001,  1366,  1786,  1011,  1581,  1761,  2021,   296,  1001,  1366,
  2023,   299,  2027,   306,  1033,  1345,  2030,   313,  1761,  2032,
   321,  2037,   326,  1703,  1329,  1708,  2039,   333,  2041,   338,
  2168,  2048,  1027,  1010,  2008,  1011,  1734,  2050,  1007,  2058,
  1381,  1010,  1536,  1556,  1011,  1747,  1006,  2063,   347,  1035,
  1767,  1006,  2068,   354,  1029,  1819,  1006,  2073,   360,  1036,
  1727,  1006,  2078,  1386,   354,  1029,  1006,  2086,  1004,  1008,
  1010,  1436,  1011,  1608,  1006,  2090,   367,  1520,  1006,  2095,
    81,   147,  1837,  1006,  2105,  1010,  1810,  1458,  1011,  1589,
  1001,  1410,  1501,  1006,  2110,  1657,  1436,  1629,  1006,  2114,
   371,  1003,  1038,  2118,   379,  1015,  1006,  2127,   385,  1021,
  1703,  1329,  1696,   216,  1034,  1006,  2138,   388,  1001,  1416,
     4,  1345,   165,  1345,     6,  1714,  1006,  2142,   395,  1006,
  1017,  2148,   227,  1035,  1039,  1034,  1006,  2151,     8,  1881,
  2154,   400,  1006,  2158,   415,  1001,  1006,  2162,   422,  1003,
  1006,  2166,  1001,   430,  1019,  2168,  1006


   %constant %integer ss= 2041
   %constant %integer comment= 2; ! alt of p<SS> of %comment
   %constant %integer ownalt= 12; ! alt of p<SS> for owns
   %constant %integer eisss= X'00017F00'; ! Flag declarative ss alts
   ! MAY CHANGE WITH NEW SYNTAX
   %constant %integer %array opc(0:127)=
    0, M' JCC', M' JAT', M' JAF', 0(4),
    M' VAL', M' CYD', M'INCA', M'MODD', M'PRCL', M'   J', M' JLK', M'CALL',
    M' ADB', M' SBB', M'DEBJ', M' CPB', M' SIG', M' MYB', M' VMY', M'CPIB',
    M' LCT', M'MPSR', M'CPSR', M'STCT', M'EXIT', M'ESEX', M' OUT', M' ACT',
    M'  SL', M'SLSS', M'SLSD', M'SLSQ', M'  ST', M'STUH', M'STXN', M'IDLE',
    M' SLD', M' SLB', M'TDEC', M'INCT', M' STD', M' STB', M'STLN', M'STSF',
    M'   L', M' LSS', M' LSD', M' LSQ', M'RRTC', M' LUH', M'RALN', M' ASF',
    M'LDRL', M' LDA', M'LDTB', M' LDB', M'  LD', M'  LB', M' LLN', M' LXN',
    M' TCH', M'ANDS', M' ORS', M'NEQS', M'EXPA', M' AND', M'  OR', M' NEQ',
    M'  PK', M' INS', M'SUPK', M' EXP', M'COMA', M' DDV', M'DRDV', M'DMDV',
    M'SWEQ', M'SWNE', M' CPS', M' TTR', M' FLT', M' IDV', M'IRDV', M'IMDV',
    M' MVL', M'  MV', M'CHOV', M' COM', M' FIX', M' RDV', M'RRDV', M'RDVD',
    M' UAD', M' USB', M'URSB', M' UCP', M' USH', M' ROT', M' SHS', M' SHZ',
    M' DAD', M' DSB', M'DRSB', M' DCP', M' DSH', M' DMY', M'DMYD', M'CBIN',
    M' IAD', M' ISB', M'IRSB', M' ICP', M' ISH', M' IMY', M'IMYD', M'CDEC',
    M' RAD', M' RSB', M'RRSB', M' RCP', M' RSC', M' RMY', M'RMYD', M' PUT'

   %routine cnptf
!***********************************************************************
!*    Create New Page To File :- This is called when the output file   *
!*    is full and must be extended to a new page.                      *
!***********************************************************************
      %if filesizeptr<3 %then %c
       filesizeptr = filesizeptr+1 %and filesize = fstable(filesizeptr) %else %c
       filesize = filesize+fstable(3)
      changefilesize(workfile, filesize, eflag)
      %if eflag=261 %start
         ! V.M. hole is too small for the new file size.
         disconnect(workfile, eflag); %if eflag#0 %then fail(eflag, 5)
         changefilesize(workfile, filesize, eflag)
         %if eflag=0 %start
            writeaddress = writeaddress-conad
            connect(workfile, 3, 0, 0, rr, eflag)
            %if eflag#0 %then fail(eflag, 5)
            conad = rr_conad
            writeaddress = writeaddress+conad
            outrec == record(conad)
         %finish
      %finish
      %if eflag#0 %then fail(eflag, 5)
      outrec_filesize = filesize; ! Update file size in header.
   %end

   %routine transfer(%integer from, to)
!***********************************************************************
!*    Transfer copies the contents of OUTBUF from FROM to TO into the  *
!*    output file or channel.                                          *
!***********************************************************************
      %integer i, ch, last
      %if stream#terminal %start
         last = to-from+1+writeaddress-conad
         %if last>filesize %then cnptf
         outrec_dataend = last
      %finish
      %for i = from, 1, to %cycle
         ch = outbuf(i)&X'7F'
         %if ch&127=rs %then %continue
         %if ch=nl %start
            charsin = 0; line = line+1
            %unless stream=terminal %start
               write address = write address-1 %while %c
                write address>wa0 %and byteinteger(write address-1)=' '
            %finish
         %finish %else charsin = charsin+1
         %if stream=terminal %then printch(ch) %else %c
          byteinteger(writeaddress) = ch %and writeaddress = writeaddress+1
      %repeat
   %end

   %routine outstring(%string (40) text)
!***********************************************************************
!*    Outstring copies TEXT to the output file or channel.             *
!***********************************************************************
      %integer i, ch, last
      %if stream#terminal %start
         last = length(text)+writeaddress-conad
         %if last>filesize %then cnptf
         outrec_dataend = last
      %finish
      %for i = 1, 1, length(text) %cycle
         ch = charno(text, i)
         %if ch=nl %then charsin = 0 %and line = line+1 %else %c
          charsin = charsin+1
         %if stream=terminal %then printch(ch) %else %c
          byteinteger(writeaddress) = ch %and writeaddress = writeaddress+1
      %repeat
   %end

   %routine dupl(%integer char, %integer times)
!***********************************************************************
!*    Dupl copies CHAR, TIMES times to the output file or channel.     *
!***********************************************************************
      %integer i, last
      %if times<=0 %then %return
      charsin = charsin+times
      %if stream#terminal %start
         last = times+writeaddress-conad
         %if last>filesize %then cnptf
         outrec_dataend = last
      %finish
      %for i = 1, 1, times %cycle
         %if stream=terminal %then printch(char) %else %c
          byteinteger(writeaddress) = char %and writeaddress = writeaddress+1
      %repeat
   %end

   %routine insert(%integer chars, lsflag, rsflag)
!***********************************************************************
!*   This will place upto four characters into the OUTBUF buffer this  *
!*   includes the option of have spaces around the characters.         *
!***********************************************************************
      %if lsflag=true#inconst %then outbuf(obp) = ' ' %and obp = obp+1
      %until chars=0 %cycle
         outbuf(obp) = chars&X'FF'
         chars = chars>>8
         obp = obp+1
      %repeat
      %if rsflag=true#inconst %then outbuf(obp) = ' ' %and obp = obp+1
   %end




   %routine closedown(%integer success)
!***********************************************************************
!*     Closedown is called when the program is to terminate execution  *
!*     and is to print a suitable message and to close the output file *
!*     if any.                                                         *
!***********************************************************************
      %if success=true %start
         printstring(itos(line)." lines have been processed".snl)
      %finish %else %start
         printstring("Soap80 fails :- ".itos(errors))
         %if errors=1 %then printstring(" error.".snl) %else %c
          printstring(" errors.".snl)
      %finish
      ! Is there a file to close?
      %if stream#terminal %start
         outrec_dataend = writeaddress-conad
         trim(workfile, eflag)
         disconnect(workfile, eflag)
         %if stream=samefile %start
            %if errors>0 %then %c
             printstring("Output stored in ".workfile.", since ".infile. %c
             " contains errors.".snl) %else %start
               newgen(workfile, outf, eflag)
               %if eflag#0 %start
                  printstring("Attempt to create ".outf." failed because ". %c
                   failuremessage(eflag).snl)
                  printstring("Output stored in ".workfile.".".snl)
               %finish
            %finish
         %finish %else %start
            %if stream=device %start
               %if length(infile)>8 %then length(infile) = 8
               sendfile(workfile, outf, "Soap80: ".infile, 1, 0, eflag)
               %if eflag#0 %then fail(eflag, 5)
            %finish
         %finish
      %finish
      pprofile
      %stop; ! Exit from SOAP80.
   %end

   %routine punch
!***********************************************************************
!*     PUNCH is  for tranferring the contents of the OUTBUF array      *
!*   to the output file or channel, using TRANSFER, OUTSTRING and DUPL.*
!*                                                                     *
!*    PUNCH decides where to break a line if it is too long.           *
!***********************************************************************
      %integer lst, bk, i, ubp, lbp, bbp, tp, inn, ch, curlend
      inn = in
      inn = inn+1 %if 1<<ssalt&eisss=0 %and p_istat=true
      %if ssalt#comment %and semicolon=false %then dupl(' ', p_tab(inn)-charsin)
      %if outbuf(obp-1)=';' %then semicolon = true %else semicolon = false
      %if semicolon=true %and p_line-20<charsin+obp %then %c
       semicolon = false %and outbuf(obp-1) = nl
      %if semicolon=true %then outbuf(obp) = ' ' %and obp = obp+1

      %if increm=true %start
         increm = false
         ! Is indenting value too near the line length limit?
         %if p_tab(in+1)+20>p_line %then fail(4, 2) %else in = in+1
      %finish

      lst = 1

      %if ssalt=comment %start
         ! Look for RS in comment.  If found, output as more than one line.
         %cycle
            %if chartype(sc(1))&rem=0 %or semicolon=true %start
               ! Comment does not start in column 1.
               %if semicolon!colon=false %and p_movecom=false %then %c
                dupl(' ', p_tab(inn)-charsin) %else dupl(' ', p_poscom-charsin)
            %finish
            i = lst
            i = i+1 %while i<obp %and outbuf(i)&127#rs
            ->final part %if i=obp
            transfer(lst, i-1)
            %if outbuf(i-1)&127=',' %then outstring(snl) %else %c
             outstring(percentc.snl)
            i = i+1 %until i=obp %or outbuf(i)#' '
            lst = i
         %repeat
      %finish

      %cycle
         ubp = p_line+lst-charsin-4; ! RHMOST BREAK POINT
         lbp = (ubp+lst)//2
         bbp = (ubp+3*lst)//4
         curlend = 0

         ! First check for nl in string const or list
         %for bk = lst, 1, ubp+3 %cycle
            %exit %if bk>=obp
            ch = outbuf(bk)
            %if ch&127=nl %or (ch&127=rs %and ssalt=ownalt %and %c
             p_lclist=true) %then ->printpart
         %repeat
         %if obp<ubp+3 %then %exit; ! 3 FOR " %C"
         %for bk = ubp, -1, bbp %cycle; ! CHECK FOR PRIMARY BREAK POINTS
            %if outbuf(bk)&bpoint#0 %start
               bk = bk+1 %while outbuf(bk+1)=' '
               ->printpart
            %finish
         %repeat
         %for bk = ubp, -1, bbp %cycle; ! CHECK FOR SECONDARY BREAK POINT
            %if outbuf(bk)&bpoint2#0 %start
               bk = bk+1 %while outbuf(bk+1)=' '
               ->printpart
            %finish
         %repeat
         %for bk = ubp, -1, bbp %cycle
            %if outbuf(bk)=',' %then ->printpart
         %repeat
         %if outbuf(ubp)&incurly#0 %start; ! IN A CURLY COMMENT
            curlend = 1
            %for bk = ubp, 1, obp-2 %cycle
               curlend = 0 %and %exit %if outbuf(bk)&incurly=0
            %repeat
            ! curlend indicates whether the curly comment goes to the end of the line.
            %for bk = ubp, -1, bbp %cycle
               %if outbuf(bk)&incurly=0 %then bk = bk-1 %and ->printpart
            %repeat
            ->final part %if curlend=1; ! Overlong curly comment.
            %for bk = ubp, 1, obp-2 %cycle
               %if outbuf(bk)&incurly=0 %then ->printpart
            %repeat
         %finish
         %for bk = ubp+1, -1, lbp %cycle
            %if outbuf(bk)=' ' %and outbuf(bk-1)&underline#0 %then ->printpart
         %repeat
         %if p_spacnam=false %start; ! MUST OMIT IF NAMES ARE SPACED
            %for bk = ubp+1, -1, lbp %cycle
               %if outbuf(bk)=' ' %then ->printpart
            %repeat
         %finish
         %for bk = ubp, -1, lbp %cycle
            %if outbuf(bk)='%' %then bk = bk-1 %and ->printpart
         %repeat
         %for bk = ubp, -1, lbp %cycle
            %if outbuf(bk)='.' %or outbuf(bk)=')' %then ->printpart
            %if outbuf(bk)='(' %then bk = bk-1 %and ->printpart
         %repeat
         %if outbuf(ubp)&instring#0 %start
            ! Break point is inside a string.
            %for bk = ubp, -1, bbp %cycle
               %if outbuf(bk)=',' %or outbuf(bk)='.' %or outbuf(bk)='=' %then %c
                ->printpart
            %repeat
            %for i = ubp, -1, lst+3 %cycle
               %if outbuf(i)=dquotes %then bk = i-1 %and ->printpart
            %repeat
            %for i = bk, -1, lst %cycle
               %if outbuf(i)=squotes %start
                  %if chartype(outbuf(i-1))&constart=0 %then bk = i-1 %else %c
                   bk = i-2
                  ->printpart
               %finish
            %repeat
            ! Break string.
            printstring("Line:".itos(line)." problem:")
            printsymbol(outbuf(i)) %for i = lst, 1, ubp
            printstring(snl)
            tp = ubp-1
            transfer(lst, tp)
            outstring(""".".percentc.snl)
            dupl(' ', p_tab(inn)+p_icontin)
            outstring("""")
            lst = tp+1
            %continue
         %finish %else bk = ubp
         printstring("Line:".itos(line)." problem:")
         printsymbol(outbuf(i)) %for i = lst, 1, ubp
         printstring(snl)
printpart:
         i = bk
         i = i-1 %while outbuf(i)=' ' %or outbuf(i)&127=rs
         transfer(lst, i)
         %if i<lst %or outbuf(i)&127#nl %start; ! NOT NATURAL BREAK
            %if outbuf(i)&127#',' %and outbuf(bk)#rs!128 %and curlend=0 %then %c
             outstring(" ".percentc)
            outstring(snl)
            dupl(' ', p_tab(inn)+p_icontin) %if inconst=false
            outstring("%") %if %c
             outbuf(bk+1)&underline#0 %and outbuf(bk+1)#rs!128
         %finish
         lst = bk+1
      %repeat
finalpart:
      transfer(lst, obp-1)
      obp = 1
   %end

   %integer %function nextnonsp(%integer print)
      ! If PRINT is True then ' ' or '%' or RS are transferred to the output
      ! buffer when encountered.
      %integer ch
      %cycle
         ch = sc(ptr)
         %if ch='{' %start
            outbuf(obp) = ' ' %and obp = obp+1 %if obp>1 %and print=false
            outbuf(obp) = '{'
            obp = obp+1; ptr = ptr+1
            %cycle
               ch = sc(ptr)
               outbuf(obp) = ch!incurly
               obp = obp+1
               ptr = ptr+1
            %repeat %until ch='}'
            %continue
         %finish
         %exit %unless ch=' ' %or ch='%' %or ch&127=rs
         %if print=true %then outbuf(obp) = ch %and obp = obp+1
         ptr = ptr+1
      %repeat
      %result = ch
   %end

   %routine getline(%integer initptr)
!***********************************************************************
!*    GETLINE :- take from the input file and processes the data and   *
!*               it into the array SC.                                 *
!*                                                                     *
!*    The following processing is done:                                *
!*       1) All delimiters have 128 added to each character in the word*
!*       2) Lines are joined togther if there is a %c or ',' at the end*
!*          of the first line. The newline position is marked by RS.   *
!***********************************************************************
      %constant %byte %integer %array itoi(0:255)= %c
                  32(10),10,32(14),25,26,32(5),
                  32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
                  48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
                  64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
                  80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
                  96,97,98,99,100,101,102,103,104,105,106,107,108,109,
                  110,111,112,113,114,115,116,117,118,119,
                  120,121,122,123,124,125,126,32,
                  26(5),10,26(10),
                  26(16),
                  26(14),92,38,
                  26(11),35,26(4),
                  26(16),
                  26(9),35,26(5),94,
                  26(32)
      %short %integer %array scurl, ecurl(1:20)
      %integer in keyword, char, p, ncurl
      %own %integer strdelimiter

      %if initptr=1 %then startline = inptr
      ptr = initptr

      %cycle
         in keyword = false
         ncurl = 0
         %cycle
            %if ptr>ccsize %then fail(1, 1) %and %exit
            %if inptr>dataend %then fail(2, 1)
            char = itoi(byteinteger(inptr))
            inptr = inptr+1

            %if char=nl %start
               inline = inline+1
               sc(ptr) = nl
               ptr = ptr+1
               %exit
            %finish

            %if str=true %start
               sc(ptr) = char; ptr = ptr+1
               %if char=strdelimiter %then str = false
               %continue
            %finish

            %if chartype(char)&endst#0 %then %c
             sc(ptr) = char %and ptr = ptr+1 %and %exit

            ! Deal with curly bracket comments noting start so as to permit
            ! continuations of the form ...,{...}.
            ! Note that any missing closing brace is replaced.
            %if char='{' %start
               ncurl = ncurl+1; scurl(ncurl) = ptr
               sc(ptr) = char; ptr = ptr+1
               %cycle
                  char = itoi(byteinteger(inptr))
                  %if char=nl %then char = '}' %else inptr = inptr+1
                  %if char='}' %then %exit
                  sc(ptr) = char
                  ptr = ptr+1
               %repeat
               ecurl(ncurl) = ptr
            %finish

            %if in keyword=true %start
               %if chartype(char)&letter=0 %then in keyword = false %else %c
                sc(ptr) = onecase(char)!underline %and ptr = ptr+1 %and %c
                %continue
            %finish

            %if char='%' %then in keyword = true

            %if char=squotes %or char=dquotes %start
               str = true; strdelimiter = char
            %finish

            sc(ptr) = char
            ptr = ptr+1
         %repeat

         %if char=nl %start; ! TRAILING SPACES CHECK
            ptr = ptr-1 %while ptr>2 %and sc(ptr-2)=' '
            sc(ptr-1) = nl
            %if str=false %start
               p = ptr-2
               %while ncurl>0 %and ecurl(ncurl)=p %cycle
                  ! Step past curly bracket.
                  p = scurl(ncurl)-1; ncurl = ncurl-1
                  p = p-1 %while p>0 %and sc(p)=' '
               %repeat
               ! Now p points at character determining continuation.
               %if p>0 %start
                  char = sc(p)
                  %if char=',' %start
                     sc(ptr-1) = rs!128
                     %continue
                  %finish
                  %if char='C'+underline %start
                     %if p>1 %and sc(p-1)='%' %then sc(p-1) = ' '
                     sc(p) = ' '
                     sc(ptr-1) = rs
                     %continue
                  %finish
                  %if char&127=rs %then sc(ptr-1) = rs!128 %and %continue
               %finish
            %finish
         %finish
         %exit
      %repeat
      ptr = initptr

   %end

   %integer %function compare(%integer test)
      %integer i, ch, key, j

      %for i = 1, 1, clett(test) %cycle
         ch = nextnonsp(inconst)
         %if ch#clett(i+test) %then %result = false
         ptr = ptr+1
      %repeat

      %if test=offile %or test=ofprogram %then stop = true

      %if test=comma %then insert(',', false, p_spcomma) %and %result = true
      %if test=equals %start
         %if ssalt=ownalt %then inconst = p_lclist
         ! If in own or const declaration and p_lclist is set, then set
         ! inconst to true.  The effect of this is leave the declaration
         ! unformatted.  Inconst is not set earlier as we do not wish the
         ! leading spaces in the statement to be preserved - i.e. the first
         ! line of the statement is indented with the rest of the program.
         insert('=', p_spacass, p_spacass)
         %result = true
      %finish
      %if p_expkey=true %start
         test = function %if test=fn
         test = constant %if test=const
      %finish
      %if obp=1 %or (outbuf(obp-1)&underline=0 %and %c
       outbuf(obp-1)&127#'%') %then key = false %else key = true
      ! Current state of outbuf.
      %for i = 1, 1, clett(test) %cycle
         ch = clett(test+i)
         %if ch<underline %and key=true %start
            outbuf(obp) = ' '
            obp = obp+1
            key = false
         %finish %else %if ch>underline %start
            %if key=false %start
               %if obp>1 %and '('#outbuf(obp-1)#' ' %then %c
                outbuf(obp) = ' ' %and obp = obp+1
               outbuf(obp) = '%'
               obp = obp+1
               key = true
            %finish %else %if i=1 %and p_sepkey=true %then %c
             outbuf(obp) = ' ' %and outbuf(obp+1) = '%' %and obp = obp+2
         %finish

         %if ch&underline#0 %and p_uckey=false %and ch#rs!128 %then ch = ch!32
         outbuf(obp) = ch
         obp = obp+1
      %repeat

      %if (test=offile %or test=ofprogram) %and p_sepkey=true %start
         %if test=offile %then j = 4 %else j = 7
         obp = obp+2
         outbuf(obp-i) = outbuf(obp-i-2) %for i = 1, 1, j
         outbuf(obp-j-2) = ' '
         outbuf(obp-j-1) = '%'
      %finish
      %if test=if %or test=unless %or test=while %or test=until %or %c
       test=else %or test=then %then outbuf(obp-1) = ch!bpoint
      %if test=and %or test=or %then outbuf(obp-1) = ch!bpoint2
      %result = true
   %end

   %integer %function check(%integer pos)
      %integer defend, subdefend, subdefstart, res, item, rsptr, z,
        strdelimiter, ch, rsobj, alt, i, j
      %own %string (19) fes="FINISH %ELSE %START"
      %own %integer uci
      %own %integer depth=0
      %switch bip(999:1039); ! Built-in phrases.

      alt = 0
      depth = depth+1; ! Depth of recursion in check.
      ssalt = 0 %if depth=1; ! Initialise ssalt if in top-level call.

      rsptr = ptr; rsobj = obp
      defend = symbol(pos)
      pos = pos+1
      %while pos<defend %cycle
         alt = alt+1
         %if depth=1 %start; ! Outer level - i.e. trying ss alternatives.
            ssalt = ssalt+1
            inconst = false
         %finish
         subdefend = symbol(pos)
         pos = pos+1
         res = true
         subdefstart = pos
         %while pos<subdefend %cycle
            item = symbol(pos)
            %if 999<=item<1300 %then ->bip(item)
            %if item<999 %then res = compare(item)
            %if item>=1300 %then res = check(item)
            pos = pos+1
            ->bypass

bip(999):
            pos = subdefstart; ! Star function.
            rsptr = ptr; rsobj = obp
            ->bypass

bip(1000):
            depth = depth-1; %result = true; ! Zero function.

bip(1001):
            ! Name
            ch = nextnonsp(inconst)
            j = ptr; ptr = ptr+1; i = obp
            %if chartype(ch)&letter=0 %then res = false %and ->inc
            %if chartype(ch)&constart#0 %and %c
             nextnonsp(inconst!p_spacnam)=squotes %then res = false %and ->inc
            ptr = j; obp = i; ! AVOID FUNNY SPACING ON 1 LETTER NAMES
            j = outbuf(obp-1); ! LAST CHAR OUT
            %if j>128 %or chartype(j)&letter#0 %or j=')' %then %c
             outbuf(obp) = ' ' %and obp = obp+1
            %while chartype(ch)&(letter!number)#0 %cycle
               %if chartype(ch)&letter#0 %and p_lcasnam=false %start
                  ! Letter case in names to be controlled by P_UCKEY.
                  %if p_uckey=true %then ch = ch&(\32) %else ch = ch!32
               %finish
               outbuf(obp) = ch; obp = obp+1
               j = obp; ! Position after latest character of name.
               ptr = ptr+1
               ch = nextnonsp(inconst!p_spacnam)
            %repeat
            ! Now j gives posn in outbuf after last character of name, and obp
            ! gives next free posn in outbuf.
            %if p_spacnam=true %and inconst=false %and j<obp %start
               ! Throw away bytes after name, apart from curly comments.
               i = j
               %cycle
                  i = i+1 %while i<obp %and outbuf(i)&127#'{'
                  %exit %if i=obp
                  %if j<i %start
                     outbuf(j) = ' '
                     %cycle
                        j = j+1
                        outbuf(j) = outbuf(i)
                        i = i+1
                     %repeat %until outbuf(j)&127='}'
                  %finish %else %start
                     j = j+1 %until outbuf(j)&127='}'
                     i = j+1
                  %finish
                  j = j+1
               %repeat
               obp = j
            %finish
            ->inc
bip(1005):
            ! N - Number.
            ch = nextnonsp(inconst)
            %if chartype(ch)&number=0 %then res = false %and ->inc
bip(1002):
            ! Iconst.
bip(1003):
            ! Const.
            ch = nextnonsp(inconst)
            ptr = ptr+1
            res = false %and ->inc %unless %c
             chartype(ch)&(quotes!constfirst)#0 %or %c
             (chartype(ch)&constart#0 %and nextnonsp(inconst)=squotes)
            %if outbuf(obp-1)>128 %or chartype(outbuf(obp-1))&letter#0 %then %c
             outbuf(obp) = ' ' %and obp = obp+1
            %if chartype(ch)&constfirst=0 %start
               %if chartype(ch)&constart#0 %start
                  outbuf(obp) = ch; obp = obp+1
                  strdelimiter = nextnonsp(inconst)
                  ptr = ptr+1
               %finish %else strdelimiter = ch
               outbuf(obp) = strdelimiter; obp = obp+1
               %cycle
                  %if sc(ptr)=strdelimiter %start
                     outbuf(obp) = strdelimiter!instring
                     %if sc(ptr+1)#strdelimiter %then %exit
                     outbuf(obp+1) = strdelimiter!instring
                     obp = obp+2; ptr = ptr+2
                  %finish %else %start
                     ch = sc(ptr)
                     outbuf(obp) = ch!instring
                     obp = obp+1; ptr = ptr+1
                     %if ch=nl %start
                        getline(ptr)
                     %finish
                  %finish
               %repeat
               ptr = ptr+1; obp = obp+1
            %finish %else %start
               ptr = ptr-1
               %cycle
                  %cycle
                     %exit %if chartype(ch)&constcont=0
                     outbuf(obp) = ch; obp = obp+1
                     ptr = ptr+1
                     ch = nextnonsp(inconst)
                  %repeat
                  %if '_'#ch#'@' %then %exit
                  %if ch='@' %then j = number %else j = number!letter
                  ! Second part of @ and radix consts
                  %until chartype(ch)&j=0 %cycle
                     outbuf(obp) = ch; obp = obp+1
                     ptr = ptr+1
                     ch = nextnonsp(inconst)
                  %repeat
               %repeat
            %finish
            ->inc
bip(1004):! Phrase check extended type
            ch = nextnonsp(inconst)
            res = false %unless %c
             ch>underline %and X'80000000'>>(ch&31)&X'20C83000'#0
            ->inc
bip(1038):! Include
bip(1006):! S - End statement.
            ch = nextnonsp(inconst)
            %if chartype(ch)&endst=0 %then res = false %and ->inc
            obp = obp-1 %while obp>1 %and outbuf(obp-1)=' '
            outbuf(obp) = ch; obp = obp+1
            ->inc
bip(1007):! Text - comment string.
            ch = nextnonsp(inconst)
            %if chartype(ch)&rem=0 %then res = false %and ->inc
            %if ch&underline#0 %and (outbuf(obp-1)&underline=0) %then %c
             outbuf(obp) = '%' %and obp = obp+1
            outbuf(obp) = ch; obp = obp+1
            ptr = ptr+1
            %if ch='C'+underline %start
               outbuf(obp-1) = ch!32 %if p_uckey=false
               %for i = 2, 1, 7 %cycle
                  ch = nextnonsp(inconst)
                  %if ch#keycom(i)+underline %then res = false %and ->inc
                  %if p_uckey=false %then ch = ch!32
                  outbuf(obp) = ch
                  obp = obp+1
                  ptr = ptr+1
               %repeat
            %finish
            str = false
            %cycle
               %while sc(ptr)#nl %and (str=true %or sc(ptr)#';') %cycle
                  ch = sc(ptr)
                  %if ch=squotes %or ch=dquotes %start
                     %if str=false %then %c
                      strdelimiter = ch %and str = true %else %if %c
                      ch=strdelimiter %then str = false
                  %finish
                  %if ch&underline#0 %and p_uckey=false %and ch#rs!128 %then %c
                   ch = ch!32
                  outbuf(obp) = ch; obp = obp+1
                  ptr = ptr+1
               %repeat
               outbuf(obp) = sc(ptr); obp = obp+1
               ptr = ptr+1
               %exit %if outbuf(obp-1)=nl
               ! Semi-colon terminated input - carry on reading.
               getline(1)
            %repeat
            str = false
            ->inc
bip(1009):! N255 - Test string declaration length.
            ch = nextnonsp(inconst)
            %unless '0'<=ch<='9' %then res = false %and ->inc
            z = 0
            %while '0'<=ch<='9' %cycle
               z = z*10+ch-'0'
               outbuf(obp) = ch; obp = obp+1
               ptr = ptr+1
               ch = nextnonsp(inconst)
            %repeat
            %if z>255 %then res = false
            ->inc
bip(1012):! Readline?
            ch = nextnonsp(inconst)
            ! Deal with "FRED(1:10) = <nl> .. init vals .." constructions.
            %if ch=nl %start
               outbuf(obp) = nl; obp = obp+1
               sc(ptr) = rs!128
               getline(ptr+1)
            %finish
            ->inc
bip(1015):! Down.
            level = level+1
            bheading = true
            %if p_iblock=true %then increm = true
            ->inc
bip(1016):! Up.
            level = level-1
            bheading = true
            %if p_iblock=true %and in>0 %then in = in-1
            ->inc
bip(1019):! Colon - Is previous character a colon ':'?
            %if sc(ptr-1)#':' %then res = false %and ->inc
            %if charsin>0 %then outstring(snl)
            ch = nextnonsp(inconst)
            transfer(1, obp-1)
            obp = 1
            %if p_seplab=true %and ch#nl %then outstring(snl)
            inlabel = true
            ->inc
bip(1022):! Setnem.
            ch = nextnonsp(inconst)
            z = M'    '
            %while chartype(ch)&letter#0 %cycle
               z = z<<8!onecase(ch)
               outbuf(obp) = ch; obp = obp+1
               ptr = ptr+1
               ch = nextnonsp(inconst)
            %repeat

            %unless ch='_' %and z#M'    ' %then res = false %and ->inc
            outbuf(obp) = '_'; obp = obp+1
            uci = z
            ptr = ptr+1
            ->inc
bip(1023):! Primform
            %for i = 7, 1, 127 %cycle
               ->pfnd %if opc(i)=uci
            %repeat
            res = false
            ->inc
pfnd:! Mnemonic found
            res = false %if 8<=i>>3<=11 %and i&7<=3
            ->inc
bip(1024):! Sectform.
            %for i = 64, 8, 88 %cycle
               %for j = 0, 1, 3 %cycle
                  %if opc(i+j)=uci %then ->inc
               %repeat
            %repeat
            res = false
            ->inc
bip(1025):! Tertform.
            %for i = 3, -1, 1 %cycle
               %if opc(i)=uci %then ->inc
            %repeat
            res = false
            ->inc
bip(1026):! Op.
            ch = nextnonsp(inconst)
            ptr = ptr+1
            %unless 32<ch<127 %and X'80000000'>>(ch&31)&X'4237000A'#0 %then %c
             res = false %and ->inc

            %if ch='&' %or ch='+' %or ch='-' %then %c
             insert(ch, p_spacop, p_spacop) %and ->inc

            %if ch='*' %start
               %if ch#nextnonsp(inconst) %then %c
                insert('*', p_spacop, p_spacop) %and ->inc
               ptr = ptr+1; j = ptr
               ch = nextnonsp(inconst)
               ptr = ptr+1
               %if M'*'=ch=nextnonsp(inconst) %then %c
                insert(M'****', p_spacop, p_spacop) %and ptr = ptr+1 %and ->inc
               insert(M'**', p_spacop, p_spacop)
               ptr = j; ->inc
            %finish

            %if ch='/' %start
               %if ch#nextnonsp(inconst) %then %c
                insert('/', p_spacop, p_spacop) %and ->inc
               insert(M'//', p_spacop, p_spacop)
               ptr = ptr+1; ->inc
            %finish

            %if ch='!' %start
               %if ch#nextnonsp(inconst) %then %c
                insert('!', p_spacop, p_spacop) %and ->inc
               insert(M'!!', p_spacop, p_spacop)
               ptr = ptr+1; ->inc
            %finish

            %if ch='.' %then outbuf(obp) = '.' %and obp = obp+1 %and ->inc
            %if ch=nextnonsp(inconst)='>' %start
               insert(M'>>', p_spacop, p_spacop)
               ptr = ptr+1
               ->inc
            %finish

            %if ch=nextnonsp(inconst)='<' %start
               insert(M'<<', p_spacop, p_spacop)
               ptr = ptr+1
               ->inc
            %finish

            %if ch='\' %start
               %if ch#nextnonsp(inconst) %then %c
                insert('\', p_spacop, p_spacop) %and ->inc
               insert(M'\\', p_spacop, p_spacop)
               ptr = ptr+1; ->inc
            %finish

            res = false; ->inc

bip(1027):! Chui.
            ch = nextnonsp(inconst)
            %if chartype(ch)&letter=0 %and ch#'-' %and %c
             X'80000000'>>(ch&31)&X'14043000'=0 %then res = false
            ->inc
bip(1028):! +'.
            ch = nextnonsp(inconst)
            %if ch='+' %or ch='-' %or ch='\' %or ch=X'7E' %then %c
             insert(ch, p_spacop, p_spacop) %and ptr = ptr+1
            ->inc
bip(1031):! Ucwrong (unknown user code format - allow it through).
            %cycle
               ch = nextnonsp(inconst)
               outbuf(obp) = ch; obp = obp+1
               ->inc %if chartype(ch)&endst#0
               ptr = ptr+1
            %repeat
bip(1030):! ,'.
            ch = nextnonsp(inconst)
            res = false %if ch=')'
            %if res=true %then insert(',', false, p_spcomma)
            %if ch=',' %then ptr = ptr+1
            ->inc
bip(1032):! Chcomp.
bip(1037):! Comp2
            ch = nextnonsp(inconst)
            ptr = ptr+1
            %unless 32<ch<=92 %and X'80000000'>>(ch&31)&X'1004000E'#0 %then %c
             res = false %and ->inc
            %if ch='=' %start
               %if nextnonsp(inconst)=ch %then %c
                ptr = ptr+1 %and insert(M'==', p_spacop, p_spacop) %and ->inc
               insert('=', p_spacop, p_spacop)
               ->inc
            %finish
            %if ch='#' %start
               %if nextnonsp(inconst)=ch %then %c
                ptr = ptr+1 %and insert(M'##', p_spacop, p_spacop) %and ->inc
               insert('#', p_spacop, p_spacop)
               ->inc
            %finish
            %if ch='\' %and nextnonsp(inconst)='=' %start
               ptr = ptr+1
               %if nextnonsp(inconst)='=' %then %c
                ptr = ptr+1 %and insert(M'==\', p_spacop, p_spacop) %and ->inc
               insert(M'=\', p_spacop, p_spacop)
               ->inc
            %finish
            %if ch='>' %start
               %if nextnonsp(inconst)='=' %then %c
                ptr = ptr+1 %and insert(M'=>', p_spacop, p_spacop) %and ->inc
               insert('>', p_spacop, p_spacop)
               ->inc
            %finish
            %if ch='<' %start
               %if nextnonsp(inconst)='=' %then %c
                ptr = ptr+1 %and insert(M'=<', p_spacop, p_spacop) %and ->inc
               %if nextnonsp(inconst)='>' %then %c
                ptr = ptr+1 %and insert(M'><', p_spacop, p_spacop) %and ->inc
               insert('<', p_spacop, p_spacop)
               ->inc
            %finish
            %if ch='-' %and nextnonsp(inconst)='>' %then %c
             ptr = ptr+1 %and insert(M'>-', p_spacop, p_spacop) %and ->inc
            res = false
            ->inc
bip(1033):! Assop.
            ch = nextnonsp(inconst)
            ptr = ptr+1
            %if ch='=' %start
               %if nextnonsp(inconst)='=' %then %c
                ptr = ptr+1 %and insert(M'==', p_spacass, p_spacass) %and ->inc
               insert('=', p_spacass, p_spacass)
               ->inc
            %finish
            %if ch='<' %and nextnonsp(inconst)='-' %then %c
             ptr = ptr+1 %and insert(M'-<', p_spacass, p_spacass) %and ->inc
            %if ch='-' %and nextnonsp(inconst)='>' %then %c
             ptr = ptr+1 %and insert(M'>-', p_spacass, p_spacass) %and ->inc
            res = false
bip(1008):! Bighole.
            ->inc
bip(1010):! Hole.
bip(1011):! Mark.
            ->inc
bip(1013):! Alias.
            ch = nextnonsp(inconst)
            ptr = ptr+1
            %if ch#'"' %then res = false %and ->inc
            outbuf(obp) = ' '; obp = obp+1
            outbuf(obp) = '"'; obp = obp+1
            %cycle
               %if sc(ptr)='"' %start
                  outbuf(obp) = '"'!instring
                  %if sc(ptr+1)#'"' %then %exit
                  outbuf(obp+1) = '"'!instring
                  obp = obp+2; ptr = ptr+2
               %finish %else %start
                  ch = sc(ptr)
                  outbuf(obp) = ch!instring
                  obp = obp+1; ptr = ptr+1
                  getline(ptr) %if ch=nl
               %finish
            %repeat
            ptr = ptr+1; obp = obp+1
            ->inc
bip(1014):! Dummyapp.
bip(1017):! Liston.
bip(1018):! List off.
bip(1020):! Note const.
bip(1021):! Trace.
            ->inc
bip(1039):! Dummy start
            %if p_expkey=true %start; ! Expand %else to %finish %else %start
               obp = obp-4
               %for i = 1, 1, 19 %cycle
                  j = charno(fes, i)
                  %continue %if p_sepkey=false %and (j=' ' %or j='%')
                  j = j!32 %if p_uckey=false %and 'A'<=j<='Z'
                  outbuf(obp) = j; obp = obp+1
               %repeat
            %finish
bip(1029):! Note cycle
bip(1034):! Note start
            increm = true; ->inc
bip(1035):! Note finish
bip(1036):! Note repeat
            %if in>0 %then in = in-1; ->inc
inc:
            pos = pos+1
bypass:
            %if res=false %start
               pos = subdefend
               obp = rsobj
               %if ptr>maxptr %then maxptr = ptr %and maxitem = item
               ptr = rsptr
            %finish
         %repeat
         %if res=true %then depth = depth-1 %and %result = true
      %repeat
      ptr = rsptr; obp = rsobj
      depth = depth-1
      %result = false
   %end


!***********************************************************************
!*                                                                     *
!*                Main calling routine.                                *
!*                                                                     *
!***********************************************************************
   s = "test.imp,.out,SPCOMMA=Y,EXPKEY=Y"; ! cliparam
!printstring("preopt".snl)
   opt(s, p); ! Call option setting routine to set parameters.
!printstring("preconnect ".infile.snl)
   connect(infile, 0, 0, 0, rec, eflag); ! Open input file.
!printstring("postconnect".snl)
   %if eflag#0 %then fail(eflag, 5)
   %if rec_filetype#charfile %then setfname(infile) %and fail(267, 5)
   inptr = rec_conad+rec_datastart; ! Start of data.
   dataend = rec_conad+rec_dataend; ! End of data.

   ! Set output stream, possibilities are:
   ! Terminal, file, same file or output device.
   %if outf=".OUT" %then stream = terminal %else %start
      %if infile=outf %then stream = samefile %else %start
         %if charno(outf, 1)='.' %start
            %if devcode(outf)<=0 %start
               ! Invalid output device.
               setfname(outf)
               fail(264, 5)
            %finish %else stream = device
         %finish %else stream = file
      %finish
   %finish

   ! Create tempory output file?
   %if stream=samefile %or stream=device %then workfile = "T#".nexttemp %else %c
    workfile = outf
   %if stream#terminal %start
      filesizeptr = 1
      filesize = fstable(filesizeptr)
!printstring("outfile: ".workfile.snl)
      outfile(workfile, filesize, 0, 0, conad, eflag)
      %if eflag#0 %then fail(eflag, 5)
      outrec == record(conad)
      writeaddress = conad+outrec_datastart; wa0 = write address
      outrec_filetype = charfile
      ! Rest of record elements to be fill in at end of indentation.
   %finish

   outbuf(0) = 0; sc(0) = 0
   level = 0; obp = 1; in = 0
   inline = 1; line = 0 {output line}
   errors = 0; erptr = 0; charsin = 0
   str = false
   stop = false; semicolon = false; increm = false; inlabel = false
   ersave = false
   %if p_uckey=true %then percentc = "%C" %else percentc = "%c"
   %cycle
      bheading = false
      maxptr = 0
      ! Is there more to analyse in this statement.
      colon = inlabel
      %if inlabel=false %then getline(1) %else inlabel = false
      %if check(ss)=false %start
         printstring(snl."Syntax analysis fails on input line ".itos(inline-1))
         printstring(" (output line ".itos(line+1).")".snl)
         z = 1
         %while chartype(sc(z))&endst=0 %cycle
            %if sc(z)&127=rs %then printstring(snl) %else printch(sc(z)&127)
            z = z+1
         %repeat
         %if sc(z)=';' %then printch(';')
         printstring(snl)
         spaces(maxptr-1); printch('!'); printstring(snl)
         startline = startline+1 %while byteinteger(startline)=' '
         %if stream#terminal %start
            obp = 1
            ! Line failed - Input line to output routine.
            z = byteinteger(startline)
            %while chartype(z)&endst=0 %cycle
               %if chartype(z)&quotes#0 %start
                  strdelimiter = z
                  outbuf(obp) = strdelimiter; obp = obp+1
                  startline = startline+1
                  z = byteinteger(startline)
                  %while z#strdelimiter %cycle
                     outbuf(obp) = z
                     obp = obp+1; startline = startline+1
                     z = byteinteger(startline)
                  %repeat
               %finish
               outbuf(obp) = z
               obp = obp+1; startline = startline+1
               z = byteinteger(startline)
            %repeat
            outbuf(obp) = z; obp = obp+1
            punch
         %finish
         str = false
         errors = errors+1
      %finish %else %start
         %if inlabel=false %then punch
      %finish

      %if stop=true %start
         %if errors=0 %then closedown(true) %else closedown(false)
      %finish
   %repeat
   ! DOES NOT  COME THROUGH HERE

   %routine fail(%integer type, action)
      %if action#5 %start
         %if action&2=0 %then %c
          printstring(snl."*** Error: ") %and errors = errors+1 %else %c
          printstring(snl."*** Warning: ")
      %finish

      %if action&4=0 %start
         printstring(fault(type).snl)
         printstring("*** In input line ".itos(inline)." (output line ".itos %c
          (line).")".snl)
      %finish %else printstring("*** Soap80 fails -".failuremessage(type)) %c
       %and %stop

      %if action&1=1 %then closedown(false)
   %end

   %routine opt(%string (255) parm, %record (pformat) %name p)
!***********************************************************************
!*    THIS ROUTINE PROCESSES THE USER OPTION LIST                      *
!***********************************************************************
      %routine %spec readline
      %routine %spec setline
      %integer %function %spec stoi(%string %name snum)
      %routine %spec ask(%integer optno)
      %integer i, j, temp, flag, prof vsn
      %string (80) line, option, value, filename
      %constant %integer prog vsn= 3
      %switch prof(0:prog vsn)
      %external %routine %spec read profile(%string (11) key, 
        %record (pformat) %name info,
        %integer %name version, uflag)
      %external %routine %spec write profile(%string (11) %name key,
        %record (pformat) %name info,
        %integer %name version, uflag)

      prof vsn = 0; flag = 5;
      !read profile("Soap80key", p, prof vsn, flag)
      %if flag>4 %start
         printstring( %c
          "Failed to read file SS#PROFILE.  Defaults options assumed.".snl)
      %finish

      ->prof(prof vsn)

      ! In the following profile-handling code, we work with array p_a
      ! (alternative format) rather than the actual option names (p_sepkey
      ! etc.).  This is because the p_a operations remain valid even if the
      ! record format is subsequently changed.

prof(0):
      ! Code to set up profile vsn 1 data:
      ! This consists of 14 options followed by 21 tab values.

      ! original defaults
      !p_a(1) = 80; ! line - lines are broken into two if length is greater than 80.
      !p_a(2) = 3; ! icontin - continuation of line have an addition indentation of 3.
      !p_a(3) = 41; ! poscom - position for right hand comments.
      !p_a(4) = true; ! movecom - main comment are indented to POSCOM.
      !p_a(5) = true; ! uckey - keywords output in upper case.
      !p_a(6) = false; ! sepkey - adjacent keywords are compounded.
      !p_a(7) = true; ! lcasnam - case of names left alone.
      !p_a(8) = true; ! spacnam - spaces are left within names.
      !p_a(9) = true; ! spacass - spaces are added round assignment operators.
      !p_a(10) = false; ! spacop - spaces are not added round other operators.
      !p_a(11) = true; ! lclist - const lists to be left alone.
      !p_a(12) = true; ! iblock - block contents are indented w.r.t. block heading.
      !p_a(13) = false; ! istat - statements are aligned with declarations.
      !p_a(14) = false; ! seplab -  Labels and statements may occupy the same line.

      ! graham's preferred defaults
      p_a(1) = 80; ! line - lines are broken into two if length is greater than 80.
      p_a(2) = 2; ! icontin - continuation of line have an addition indentation of 3.
      p_a(3) = 41; ! poscom - position for right hand comments.
      p_a(4) = false; ! movecom - main comment are indented to POSCOM.
      p_a(5) = false; ! uckey - keywords output in upper case.
      p_a(6) = true; ! sepkey - adjacent keywords are compounded.
      p_a(7) = false; ! lcasnam - case of names left alone.
      p_a(8) = true; ! spacnam - spaces are left within names.
      p_a(9) = true; ! spacass - spaces are added round assignment operators.
      p_a(10) = false; ! spacop - spaces are not added round other operators.
      p_a(11) = true; ! lclist - const lists to be left alone.
      p_a(12) = true; ! iblock - block contents are indented w.r.t. block heading.
      p_a(13) = false; ! istat - statements are aligned with declarations.
      p_a(14) = false; ! seplab -  Labels and statements may occupy the same line.


      ! Set default indentation values.
      p_a(i+15) = 3*i %for i = 0, 1, 10
      p_a(i+15) = 5*i-20 %for i = 11, 1, 20

prof(1):
      ! Code to set up profile vsn 2 data:
      ! This consists of 15 options followed by 21 tab values.
      p_a(i) = p_a(i-1) %for i = 36, -1, 16; ! Move tab values down to make room.
      printstring("**New parameter available: SPCOMMA".snl)
      printstring("      Y : One space character inserted after commas.".snl)
      printstring( %c
       "      N : No space character inserted after commas (default).".snl.snl)
      p_a(15) = false; ! spcomma - default false.
prof(2):
      ! Code to set up profile vsn 3 data:
      ! This consists of 21 tab values followed by 16 options.
      %begin
         %byte %integer %array tab(0:20)
         tab(i) = p_a(i+16) %for i = 0, 1, 20; ! Copy tab values out.
         p_a(i+21) = p_a(i) %for i = 1, 1, 6; ! Move options down.
         ! Item _a(28) will be the new parameter (expkey).
         p_a(i+22) = p_a(i) %for i = 7, 1, 15; ! Move options down.
         p_a(i+1) = tab(i) %for i = 0, 1, 20; ! Copy tab values back.
      %end
      printstring("**New parameter available: EXPKEY".snl)
      printstring( %c
       "      Y : Keywords %FN, %CONST and (sometimes) %ELSE expanded.".snl)
      printstring("      N : %FN, %CONST and %ELSE left alone (default).". %c
       snl.snl)
      p_a(28) = false; ! expkey default - false.

      ! The following two lines should always be just before the final 'prof'
      ! switch label.
      prof vsn = prog vsn
      %begin
        %string(11) key
        key = "Soap80key"
        write profile(key, p, prof vsn, flag)
      %end
prof(3):

      ! Split up parameters and change default values.
      %if parm->filename.(",").outf %start
         %unless outf->outf.(",").parm %then parm = ""
      %finish %else filename = parm %and outf = parm %and parm = ""
      infile = filename
      %if outf="" %then outf = filename
      %if parm="" %then %return


      temp = charno(parm, length(parm))
      %if temp#'*' %and temp#'?' %then parm = parm.",END"
      %cycle
         %if parm="" %then %start
           %begin
             %string(15) s
             s = "Soap80: "
             prompt(s); ! not a real imp prompt unfortunately
           %end
           readline
         %finish %else %start
           setline
         %finish
         %if line="END" %or line=".END" %then %return
         ! End of parameter settings.
         %if line="GO" %or line=".GO" %then %return
         ! End of parameter settings.
         %if line="STOP" %or line=".STOP" %then %stop; ! Abandon Soap80.

         %if line="SAVE" %or line=".SAVE" %start
            %begin
              %string(11) key
              key = "Soap80key"
              write profile(key, p, prof vsn, flag)
            %end
            printstring("Profile file SS#PROFILE created and cherished.".snl) %c
              %if flag=1
         %finish %else %if line="?" %start
            ! Print options so far.
            printstring( %c
             "Option name:{current setting}Meaning of current setting".snl)
            %for i = 1, 1, maxopt %cycle
               printstring(optname(i))
               spaces(7-length(optname(i)))
               printstring(":{")
               j = p_optarr(i)
               %if j=false %then printsymbol('N') %else %if j=true %then %c
                printsymbol('Y') %else printstring(itos(j))
               j = 1 %if j>0
               printstring("}".optmess(j, i).snl)
            %repeat
            printstring("TAB    :{")
            %for i = 1, 1, 20 %cycle
               printstring(itos(p_tab(i)))
               printsymbol(':') %unless i=20
            %repeat
            printsymbol('}')
            printstring(snl)
            printstring("        Indenting values".snl)
            printstring( %c
             "SAVE     : Save current option settings, for defaults henceforth.
GO or END: Cause SOAP80 to start processing the input.
STOP     : Cause SOAP80 to stop immediately.".snl)
         %finish %else %start
            %if line->option.("=").value %and value#"" %start
               flag = 0
               %for i = 1, 1, maxopt %cycle
                  %continue %unless option=optname(i)
                  flag = 1; ! Option identified.
                  %if value="?" %start
                     printstring(optname(i)); spaces(7-length(optname(i)))
                     printstring(":{")
                     j = p_optarr(i)
                     %if j=false %then printsymbol('N') %else %if %c
                      j=true %then printsymbol('Y') %else printstring(itos(j))
                     j = 1 %if j>0
                     printstring("}".optmess(j, i).snl)
                  %finish %else %start
                     %if i<=numopt %start; ! Numerical value.
                        temp = stoi(value)
                        %if option="LINE" %and (temp<30 %or temp>160) %start
                           printstring( %c
                            "Bad line length - Only from 30 to 160".snl)
                           %exit
                        %finish
                        temp = -1 %if temp>255
                        %if temp=-1 %then %c
                         printstring(value." - ".failure message(320)) %else %c
                         p_optarr(i) = temp
                     %finish %else ask(i)
                  %finish
                  %exit
               %repeat
               %continue %if flag=1; ! Cycle found option name.
               %if option="TAB" %start
                  ! Set indenting value.
                  %if value="?" %start
                     printstring("TAB    :{")
                     %for i = 1, 1, 20 %cycle
                        printstring(itos(p_tab(i)))
                        printsymbol(':') %unless i=20
                     %repeat
                     printsymbol('}')
                     printstring(snl)
                     printstring("        Indenting values".snl)
                  %finish %else %start
                     i = 1
                     %while i<=20 %and value#"" %cycle
                        temp = stoi(value)
                        %if temp=-1 %then %c
                         printstring(value." - ".failuremessage(320)) %and %c
                         %exit
                        p_tab(i) = temp
                        %if length(value)=0 %then i = i+1 %and %exit
                        %if charno(value, 1)#':' %start
                           printstring(value." - ".failuremessage(320))
                           i = 21
                        %finish %else value = substring(value, 2,
                          length(value))
                        i = i+1
                     %repeat
                     ! End of indenting value, make up the rest
                     %for j = i, 1, 20 %cycle
                        p_tab(j) = 2*p_tab(j-1)-p_tab(j-2)
                        %if p_tab(j)>p_line %then p_tab(j) = p_line
                     %repeat
                  %finish
                  %continue
               %finish
               printstring(option." - ".failuremessage(322))
               ! Keyword not recognised.
            %finish %else %start
               printstring(line." -  invalid: format should be
      'keyword = value'      or     'keyword = ?'     or    '?'    or
      'SAVE'    or    'END'     or    'GO'     or     'STOP'".snl)
            %finish
         %finish
      %repeat
      %return

      %routine readline
!***********************************************************************
!*    READLINE creates a line from the input device, converting all    *
!*    lower case characters to upper case.                             *
!***********************************************************************
         %integer ch
         %cycle
            line = ""
            %cycle
               readsymbol(ch); %if ch=nl %then %exit
               %if ch=' ' %then %continue
               ! Convert lower to upper.
               line = line.tostring(onecase(ch))
            %repeat
            ! Return only if the line has some thing on it.
            %if length(line)>0 %then %return
         %repeat
      %end

      %routine setline
!***********************************************************************
!*    SETLINE breaks the parameter list into single commands.          *
!************************************************************************
         %unless parm->line.(",").parm %start
            ! Last command in parameter.
            %if charno(parm, length(parm))='*' %then readline %else line = parm
            parm = ""
         %finish
      %end

      %routine ask(%integer i)
!***********************************************************************
!*    ASK checks that value starts with Y or N and                     *
!*    assigns True or False accordingly to P_OPTARR(I).                *
!***********************************************************************
         %integer s
         s = charno(value, 1)
         %if s='Y' %then p_optarr(i) = true %else %if s='N' %then %c
          p_optarr(i) = false %else printstring("Answer Yes or No or ?".snl)
      %end

      %integer %function stoi(%string %name snum)
!***********************************************************************
!*    STOI builts up an integer in INUM from the string SNUM, in       *
!*    doing so characters are deleted from this string.                *
!*    It is an error if the first character of the string is not a     *
!*    number.  This is signalled by returning -1.                      *
!***********************************************************************
         %integer i, inum
         %unless '0'<=charno(snum, 1)<='9' %then %result = -1
         i = 1; inum = 0
         %while '0'<=charno(snum, i)<='9' %cycle
            inum = inum*10+charno(snum, i)-'0'
            i = i+1
            %if i>length(snum) %then %exit
         %repeat
         %if i>=length(snum) %then snum = "" %else %c
          snum = substring(snum, i, length(snum))
         %result = inum
      %end
   %end
%end %of %program
