compilers/imputils/soap80/soap80s.imp

!***********************************************************************
!* 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. *
!* *
!***********************************************************************
external routine spec prompt(string (31) 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. *
!* *
!***********************************************************************
system string function spec itos(integer i)
system routine spec connect(string (31) name, integer mode, hole, prot,
 record (chdr) name rec, integer name eflag)
system routine spec trim(string (31) file, integer name eflag)
system routine spec setfname(string (31) file)
system string function spec nexttemp
system routine spec sendfile(string (31) file, device, header,
 integer copies, form, integer name eflag)
system integer function spec devcode(string (31) name)
system routine spec disconnect(string (31) filename, integer name eflag)
system string function spec failuremessage(integer type)
system routine spec changefilesize(string (31) filename,
 integer filesize, integer name eflag)
system routine spec newgen(string (31) filename, newfilename,
 integer name eflag)
system routine spec outfile(string (31) filename, integer size, hole,
 prot, integer name conad, eflag)
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
 half 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
 newline
 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
 newline
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)
 half 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
 constant 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. *
!* *
!***********************************************************************
 opt(s, p); ! Call option setting routine to set parameters.
 connect(infile, 0, 0, 0, rec, eflag); ! Open input file.
 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)
 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 newline else printch(sc(z)&127)
 z = z+1
 repeat 
 if sc(z)=';' then printch(';')
 newline
 spaces(maxptr-1); printch('!'); newline
 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, name info,
 integer name version, uflag)
 external routine spec write profile(string (11) key, name info,
 integer name version, uflag)
 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.
 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.
 ! 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
 write profile("Soap80key", p, prof vsn, flag)
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"
 prompt("Soap80: ")
 cycle 
 if parm="" then readline else setline
 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 
 write profile("Soap80key", p, prof vsn, flag)
 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('}')
 newline
 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.")
 newline
 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('}')
 newline
 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 
end of file