!***********************************************************************
!* 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. *
!* *
!***********************************************************************
! We'll need to supply some lookalike routines for the various
! EMAS system library calls below. I've converted the external specs
! into bodies, but haven't written them yet. - GT
externalstring(255)fnspec cliparam
external routine prompt(string (*) name s)
end
!***********************************************************************
!* *
!* 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 (255) fn spec itos(integer i)
external routine connect(string (31) name name, integer mode, hole, prot, record (chdr) name rec, integer name eflag)
end
external routine spec trim(string (31) file, integer name eflag)
external routine setfname(string (31) file)
end
external string (255) fn nexttemp
result = ""
end
external routine sendfile(string (31) file, device, header, integer copies, form, integer name eflag)
end
external integer fn devcode(string (31) name)
result = 0
end
external routine disconnect(string (31) name filename, integer name eflag)
end
external string (255) fn failuremessage(integer type)
result = ""
end
external routine changefilesize(string (31) name filename, integer filesize, integer name eflag)
end
external routine newgen(string (31) name filename, string(*)name newfilename, integer name eflag)
end
external routine outfile(string (31) name filename, integer size, hole, prot, integer name conad, eflag)
end
external routine read profile(string (11) key, record (pformat) name info, integer name version, uflag)
end
external routine write profile(string (11) name key, record (pformat) name info, integer name version, uflag)
end
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 (255) %array optmess(0:1, 1:maxopt)=
constant string (255) array optmess(2:33)=
"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 printsymbol(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 printsymbol(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 printsymbol(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
cycle
outbuf(obp) = chars&X'FF'
chars = chars>>8
obp = obp+1
repeat until chars=0
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 REMOVED GT
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 fn 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 fn 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 fn 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
cycle
outbuf(obp) = ch; obp = obp+1
ptr = ptr+1
ch = nextnonsp(inconst)
repeat until chartype(ch)&j=0
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 printsymbol(sc(z)&127)
z = z+1
repeat
if sc(z)=';' then printsymbol(';')
printstring(snl)
spaces(maxptr-1); printsymbol('!'); 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)"es#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 fn spec stoi(string (255) 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)
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
integer i
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*2).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*2).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 fn stoi(string (255) 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