!*********************************************************************** !* SOAP80 - IMP80 formatter * !* Last altered 15/06/83 * !* * !* Created by E.N.Gregory, UKC. * !* All syntax directed sections rewritten by P.D.S., ERCC * !* using IMP80 syntax version 02. * !* User interface and parameters revised by J.M.M., ERCC. * !* * !*********************************************************************** %externalstring(255)%fnspec cliparam %external %routine %spec prompt(%string (31) %name s) !*********************************************************************** !* * !* Record formats. * !* * !*********************************************************************** %record %format fhdr(%integer dataend, datastart, filesize, filetype) %record %format chdr(%integer conad, filetype, datastart, dataend) %constant %integer maxopt= 16,numopt = 3 %record %format pformat(%byte %integer %array tab(0:20), (%byte %integer line, icontin, poscom, movecom, uckey, sepkey, expkey, lcasnam, spacnam, spacass, spacop, lclist, iblock, istat, seplab, spcomma %or %byte %integer %array optarr(1:maxopt)) %or %c %byte %integer %array a(1:21+maxopt)) !*********************************************************************** !* * !* System routines. * !* * !*********************************************************************** %external %string %function %spec itos(%integer i) %external %routine %spec connect(%string (31) %name name, %integer mode, hole, prot, %record (chdr) %name rec, %integer %name eflag) %external %routine %spec trim(%string (31) file, %integer %name eflag) %external %routine %spec setfname(%string (31) file) %external %string %function %spec nexttemp %external %routine %spec sendfile(%string (31) file, device, header, %integer copies, form, %integer %name eflag) %external %integer %function %spec devcode(%string (31) name) %external %routine %spec disconnect(%string (31) %name filename, %integer %name eflag) %external %string %function %spec failuremessage(%integer type) %external %routine %spec changefilesize(%string (31) %name filename, %integer filesize, %integer %name eflag) %external %routine %spec newgen(%string (31) %name filename, newfilename, %integer %name eflag) %external %routine %spec outfile(%string (31) %name filename, %integer size, hole, prot, %integer %name conad, eflag) %begin %string (255) s; ! argv[1] !%external %routine soap80(%string (255) s) %integer ptr, dataend, inptr, z, in, obp, eflag, writeaddress, wa0, filesize, conad, errors, line, erptr, startline, stream, filesizeptr, ssalt, strdelimiter, str, semicolon, colon, maxptr, maxitem, level, stop, increm, inlabel, charsin, ersave, inconst, bheading, inline %string (255) outf %string (31) workfile, infile %string (2) percentc %record (pformat) p %record (chdr) rec, rr %record (fhdr) %name outrec %constant %integer ccsize= 16384 %short %integer %array outbuf(0:ccsize+200) %byte %integer %array sc(0:ccsize) %constant %string (7) %array optname(1:maxopt)= "LINE","ICONTIN","POSCOM", "MOVECOM","UCKEY","SEPKEY","EXPKEY","LCASNAM","SPACNAM","SPACASS","SPACOP", "LCLIST","IBLOCK","ISTAT","SEPLAB","SPCOMMA" %constant %string (39) %array optmess(0:1, 1:maxopt)= %c "Line length zero (!!!)","Maximum line length", "Continued lines not indented","Indentation of continued lines", "Right hand comments not positioned","Right hand comment position", "Whole line comments indented normally", "Whole line comments moved to POSCOM","Keywords output in lower case", "Keywords output in upper case","Keywords not split","Keywords split", "%FN, %CONST, %ELSE not expanded", "%FN, %CONST, (sometimes) %ELSE expanded", "Case of names controlled by UCKEY", "Case of names left alone", "Spaces removed from names","Spaces preserved within names", "No spaces round assignment operators", "Spaces added round assignment operators","No spaces round operators", "Spaces added round operators","Constant lists formatted", "Constant lists left alone","Block not indented w.r.t. block heading", "Block indented w.r.t. block heading", "Statements aligned with declarations", "Statements indented w.r.t. declarations", "Labels not on lines by themselves","Labels on lines by themselves", "No space character after commas","Space character after commas" %constant %integer charfile= 3; ! Code for a character file. %constant %integer underline= 128 %constant %integer instring= 256,incurly = 512,bpoint = 1024,bpoint2 = 2048 %constant %integer terminal= 1,file = 2,samefile = 3,device = 4 %constant %integer true= 255,false = 0; ! Synthetic boolean values. %constant %integer nl= 10,dquotes = 34,squotes = 39 %constant %integer rs= 30; ! RECORD SEPARATOR IS USED AS A DELETED(BY %c) NL %constant %integer rem= B'00000001' %constant %integer constart= B'00000010' %constant %integer quotes= B'00000100' %constant %integer endst= B'00001000' %constant %integer number= B'00010000' %constant %integer letter= B'00100000' %constant %byte %integer constfirst= B'01000000' %constant %integer constcont= B'10000000' ! %constant %byte %integer %array onecase(0:127)= 0,1,2,3,4,5,6,7,8,9,10,11,12, 13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34, 35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56, 57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78, 79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,65,66,67,68, 69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90, 123,124,125,126,127 %constant %byte %integer %array chartype(0:255)= B'00000001', B'00000000', B'00000000',B'00000000',B'00000000',B'00000000',B'00000000', B'00000000',B'00000000',B'00000000',B'00001000',B'00000000'(22), B'00000001'{!},B'00000100',B'01000000',B'00000000',B'00000001'{%}, B'00000000',B'00000100',B'00000000',B'00000000',B'00000000', B'00000000',B'00000000',B'00000000',B'11000000',B'00000000', B'11010000'(10), B'00000000',B'00001000',B'01000000',B'01000000',B'01000000', B'00000000',B'00000000', B'00100000',B'00100010',B'00100010',B'00100010',B'00100000', B'00100000',B'00100000',B'00100000', B'00100000',B'00100000',B'00100010',B'00100000', B'00100010',B'00100000',B'00100000',B'00100000',B'00100000', B'00100010',B'00100000',B'00100000',B'00100000',B'00100000'(2), B'00100010',B'00100000',B'00100000',B'00000000',B'00000000', B'00000000',B'00000000',B'00000000',B'00000000', B'00100000',B'00100010'{b},B'00100010',B'00100010',B'00100000'(6), B'00100010'{k},B'00100000',B'00100010'{m},B'00100000'(4), B'00100010'{r},B'00100000'(5),B'00100010'{x},B'00100000'(2), B'00000000',B'00000001'{|},B'00000000',B'00000000',B'00000000', B'0'(67), B'00000001'{%C}, B'0'(60) %constant %byte %integer %array keycom(0:7)= '%','C','O','M','M','E','N','T' %constant %integer %array fstable(1:3)= 4096,16384,65536 ! ! Special delimiters noted by SOAP80. ! %constant %integer offile= 133,ofprogram = 123,equals = 38,comma = 10, if = 12, unless = 15,while = 22,until = 28,else = 227,then = 222,and = 158,or = 162, const = 204, constant = 195, fn = 96, function = 103 ! %constant %string (1) snl= " " ! %constant %string (60) %array fault(1:4)= "Statement is too long and could not be compiled.", "End of file reached before end of program terminator found.", "%END found, but could not match it to a start of routine.", "Disaster *** Indentation too near line length limit." ! ! ! %routine %spec fail(%integer type, action) %routine %spec opt(%string (255) parm, %record (pformat) %name p) ! ! Produced by oldps from impalgs_imp80ps04 on 19/01/83 %constant %byte %integer %array clett(0:434)= 1, {1} 43, 1, 45, 1, 40, 1, 41, 1, 42, 1, 44, 2, 201, 198, {15} 6, 213, 206, 204, 197, 211, 211, 5, 215, 200, 201, 204, 197, 5, {29} 213, 206, 212, 201, 204, 3, 198, 207, 210, 1, 61, 5, 193, 204, {43} 201, 193, 211, 7, 201, 206, 212, 197, 199, 197, 210, 4, 210, 197, {57} 193, 204, 4, 204, 207, 206, 199, 4, 194, 217, 212, 197, 6, 211, {71} 212, 210, 201, 206, 199, 4, 200, 193, 204, 198, 6, 210, 197, 195, {85} 207, 210, 196, 7, 210, 207, 213, 212, 201, 206, 197, 2, 198, 206, {99} 3, 205, 193, 208, 8, 198, 213, 206, 195, 212, 201, 207, 206, 4, {113} 206, 193, 205, 197, 5, 193, 210, 210, 193, 217, 9, 207, 198, 208, {127} 210, 207, 199, 210, 193, 205, 6, 207, 198, 198, 201, 204, 197, 6, {141} 207, 198, 204, 201, 211, 212, 6, 198, 207, 210, 205, 193, 212, 3, {155} 206, 207, 212, 3, 193, 206, 196, 2, 207, 210, 1, 58, 4, 211, {169} 208, 197, 195, 3, 207, 215, 206, 8, 197, 216, 212, 197, 210, 206, {183} 193, 204, 9, 197, 216, 212, 210, 201, 206, 211, 201, 195, 8, 195, {197} 207, 206, 211, 212, 193, 206, 212, 5, 195, 207, 206, 211, 212, 5, {211} 197, 214, 197, 206, 212, 5, 211, 212, 193, 210, 212, 4, 212, 200, {225} 197, 206, 4, 197, 204, 211, 197, 1, 95, 6, 211, 217, 211, 212, {239} 197, 205, 7, 196, 217, 206, 193, 205, 201, 195, 4, 80, 85, 84, {253} 95, 5, 67, 78, 79, 80, 95, 2, 204, 61, 1, 60, 1, 62, {267} 4, 40, 196, 210, 43, 2, 196, 210, 1, 194, 3, 212, 207, 211, {281} 3, 204, 206, 194, 3, 216, 206, 194, 2, 208, 195, 3, 195, 212, {295} 194, 2, 45, 62, 6, 210, 197, 212, 213, 210, 206, 6, 210, 197, {309} 211, 213, 204, 212, 7, 205, 207, 206, 201, 212, 207, 210, 4, 211, {323} 212, 207, 208, 6, 211, 201, 199, 206, 193, 204, 4, 197, 216, 201, {337} 212, 8, 195, 207, 206, 212, 201, 206, 213, 197, 6, 198, 201, 206, {351} 201, 211, 200, 5, 195, 217, 195, 204, 197, 6, 210, 197, 208, 197, {365} 193, 212, 3, 197, 206, 196, 7, 201, 206, 195, 204, 213, 196, 197, {379} 5, 194, 197, 199, 201, 206, 2, 207, 206, 6, 211, 215, 201, 212, {393} 195, 200, 4, 204, 201, 211, 212, 14, 212, 210, 213, 211, 212, 197, {407} 196, 208, 210, 207, 199, 210, 193, 205, 6, 205, 193, 201, 206, 197, {421} 208, 7, 195, 207, 206, 212, 210, 207, 204, 4, 40, 42, 41, 58 %constant %integer %array symbol(1300:2167)= 1307, 1303, 0, 1305, 2, 1307, 1000, 1319, 1312, 1001, 1366, 1786, 1315, 1003, 1020, 1319, 4, 1345, 6, 1329, 1323, 1001, 1014, 1325, 1003, 1329, 4, 1329, 6, 1336, 1336, 1010, 1028, 1319, 1011, 1359, 1345, 1343, 1010, 1028, 1319, 1011, 1359, 1345, 8, 1352, 1352, 1010, 1028, 1307, 1011, 1352, 1359, 1357, 1026, 1307, 999, 1359, 1000, 1366, 1364, 1026, 1319, 999, 1366, 1000, 1374, 1372, 4, 1345, 1374, 6, 1374, 1000, 1381, 1379, 10, 1345, 999, 1381, 1000, 1386, 1384, 12, 1386, 15, 1410, 1393, 22, 1010, 1536, 1556, 1011, 1399, 28, 1010, 1536, 1556, 1011, 1410, 34, 1010, 1001, 38, 1345, 10, 1345, 10, 1345, 1011, 1416, 1414, 40, 1013, 1416, 1000, 1423, 1421, 10, 1001, 999, 1423, 1000, 1428, 1426, 46, 1428, 1000, 1436, 1431, 54, 1433, 46, 1436, 59, 54, 1458, 1439, 46, 1441, 54, 1444, 59, 1428, 1447, 64, 1423, 1450, 69, 1689, 1453, 76, 1423, 1458, 81, 4, 1848, 6, 1465, 1461, 88, 1465, 1004, 1436, 1465, 1472, 1468, 96, 1470, 99, 1472, 103, 1488, 1478, 1436, 1493, 1001, 1416, 1484, 1458, 1488, 1001, 1416, 1501, 1488, 112, 1001, 1416, 1493, 1491, 112, 1493, 1000, 1501, 1497, 117, 112, 1499, 112, 1501, 1000, 1511, 1509, 4, 1010, 1472, 1011, 1511, 6, 1511, 1000, 1520, 1518, 1030, 1010, 1472, 1011, 999, 1520, 1000, 1531, 1524, 123, 1016, 1526, 133, 1529, 140, 1018, 1531, 1016, 1536, 1534, 147, 1536, 1000, 1550, 1542, 1345, 1032, 1345, 1550, 1547, 4, 1536, 1556, 6, 1550, 154, 1536, 1556, 1554, 1037, 1345, 1556, 1000, 1567, 1561, 158, 1536, 1567, 1565, 162, 1536, 1574, 1567, 1000, 1574, 1572, 158, 1536, 999, 1574, 1000, 1581, 1579, 162, 1536, 999, 1581, 1000, 1589, 1585, 1033, 1345, 1587, 165, 1589, 1000, 1595, 1593, 167, 1008, 1595, 1015, 1599, 1598, 167, 1599, 1608, 1606, 10, 1345, 165, 1345, 1599, 1608, 1000, 1617, 1613, 1493, 1001, 1416, 1617, 117, 1531, 1617, 1623, 1623, 1001, 1416, 1794, 1623, 1629, 1627, 10, 1617, 1629, 1000, 1646, 1639, 1493, 1595, 1010, 1001, 1410, 1802, 1011, 1646, 1646, 117, 1531, 1595, 1001, 1794, 1668, 1657, 1655, 10, 1010, 1001, 1410, 1802, 1011, 1646, 1657, 1000, 1668, 1660, 172, 1662, 176, 1664, 185, 1666, 195, 1668, 204, 1679, 1677, 38, 1012, 1028, 1319, 1359, 1689, 1679, 1679, 1000, 1689, 1687, 10, 1028, 1319, 1359, 1689, 999, 1689, 1000, 1696, 1694, 4, 1336, 6, 1696, 1000, 1703, 1701, 10, 1329, 999, 1703, 1000, 1708, 1706, 210, 1708, 1000, 1714, 1712, 10, 1345, 1714, 1000, 1727, 1725, 10, 1001, 1416, 4, 1345, 165, 1345, 6, 999, 1727, 1000, 1734, 1732, 28, 1536, 1556, 1734, 1000, 1747, 1737, 1019, 1739, 1006, 1744, 1381, 1536, 1556, 1006, 1747, 1386, 1006, 1761, 1751, 216, 1034, 1755, 222, 216, 1034, 1761, 222, 1010, 2008, 1011, 1767, 1767, 1765, 158, 2008, 1767, 1000, 1773, 1771, 227, 1773, 1773, 1000, 1786, 1777, 216, 1034, 1784, 1381, 1010, 1536, 1556, 1011, 1747, 1786, 2008, 1794, 1792, 232, 1001, 1366, 1786, 1794, 1000, 1802, 1802, 4, 1345, 165, 1345, 1599, 6, 1810, 1808, 38, 1028, 1319, 1359, 1810, 1000, 1819, 1813, 234, 1815, 176, 1817, 241, 1819, 1000, 1830, 1828, 1001, 38, 1345, 10, 1345, 10, 1345, 1830, 1000, 1837, 1835, 10, 1855, 999, 1837, 1000, 1848, 1841, 167, 1001, 1848, 1001, 4, 1855, 1830, 1873, 6, 1855, 1851, 1001, 1855, 1855, 1830, 1873, 1865, 1859, 1436, 1865, 1865, 4, 1855, 1830, 1873, 6, 1873, 1870, 1493, 1001, 1416, 1873, 117, 1617, 1881, 1879, 162, 1855, 1830, 999, 1881, 1000, 1898, 1886, 249, 1002, 1006, 1890, 1022, 1898, 1006, 1896, 254, 1009, 10, 1009, 1006, 1898, 1031, 1912, 1902, 1023, 1912, 1907, 1024, 260, 1951, 1956, 1912, 1025, 1005, 10, 1935, 1935, 1917, 263, 1001, 265, 1919, 1984, 1924, 4, 1984, 1973, 6, 1928, 267, 1984, 6, 1933, 4, 272, 1973, 6, 1935, 275, 1951, 1940, 263, 1001, 265, 1942, 1984, 1947, 4, 272, 1973, 6, 1951, 267, 1005, 6, 1956, 1954, 272, 1956, 1005, 1964, 1962, 10, 1005, 10, 1005, 1964, 1000, 1973, 1968, 0, 1005, 1971, 2, 1005, 1973, 1000, 1979, 1977, 0, 275, 1979, 1000, 1984, 1982, 38, 1984, 1000, 1999, 1989, 1979, 1300, 1003, 1992, 1001, 1964, 1997, 4, 1999, 1964, 6, 1999, 277, 2008, 2002, 281, 2004, 285, 2006, 289, 2008, 292, 2041, 2017, 1010, 1001, 1366, 1786, 1011, 1581, 1761, 2021, 296, 1001, 1366, 2023, 299, 2027, 306, 1033, 1345, 2030, 313, 1761, 2032, 321, 2037, 326, 1703, 1329, 1708, 2039, 333, 2041, 338, 2168, 2048, 1027, 1010, 2008, 1011, 1734, 2050, 1007, 2058, 1381, 1010, 1536, 1556, 1011, 1747, 1006, 2063, 347, 1035, 1767, 1006, 2068, 354, 1029, 1819, 1006, 2073, 360, 1036, 1727, 1006, 2078, 1386, 354, 1029, 1006, 2086, 1004, 1008, 1010, 1436, 1011, 1608, 1006, 2090, 367, 1520, 1006, 2095, 81, 147, 1837, 1006, 2105, 1010, 1810, 1458, 1011, 1589, 1001, 1410, 1501, 1006, 2110, 1657, 1436, 1629, 1006, 2114, 371, 1003, 1038, 2118, 379, 1015, 1006, 2127, 385, 1021, 1703, 1329, 1696, 216, 1034, 1006, 2138, 388, 1001, 1416, 4, 1345, 165, 1345, 6, 1714, 1006, 2142, 395, 1006, 1017, 2148, 227, 1035, 1039, 1034, 1006, 2151, 8, 1881, 2154, 400, 1006, 2158, 415, 1001, 1006, 2162, 422, 1003, 1006, 2166, 1001, 430, 1019, 2168, 1006 %constant %integer ss= 2041 %constant %integer comment= 2; ! alt of p of %comment %constant %integer ownalt= 12; ! alt of p 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<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 ifinal 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 obpprintpart %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 i1 %and print=false outbuf(obp) = '{' obp = obp+1; ptr = ptr+1 %cycle ch = sc(ptr) outbuf(obp) = ch!incurly obp = obp+1 ptr = ptr+1 %repeat %until ch='}' %continue %finish %exit %unless ch=' ' %or ch='%' %or ch&127=rs %if print=true %then outbuf(obp) = ch %and obp = obp+1 ptr = ptr+1 %repeat %result = ch %end %routine getline(%integer initptr) !*********************************************************************** !* GETLINE :- take from the input file and processes the data and * !* it into the array SC. * !* * !* The following processing is done: * !* 1) All delimiters have 128 added to each character in the word* !* 2) Lines are joined togther if there is a %c or ',' at the end* !* of the first line. The newline position is marked by RS. * !*********************************************************************** %constant %byte %integer %array itoi(0:255)= %c 32(10),10,32(14),25,26,32(5), 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,97,98,99,100,101,102,103,104,105,106,107,108,109, 110,111,112,113,114,115,116,117,118,119, 120,121,122,123,124,125,126,32, 26(5),10,26(10), 26(16), 26(14),92,38, 26(11),35,26(4), 26(16), 26(9),35,26(5),94, 26(32) %short %integer %array scurl, ecurl(1:20) %integer in keyword, char, p, ncurl %own %integer strdelimiter %if initptr=1 %then startline = inptr ptr = initptr %cycle in keyword = false ncurl = 0 %cycle %if ptr>ccsize %then fail(1, 1) %and %exit %if inptr>dataend %then fail(2, 1) char = itoi(byteinteger(inptr)) inptr = inptr+1 %if char=nl %start inline = inline+1 sc(ptr) = nl ptr = ptr+1 %exit %finish %if str=true %start sc(ptr) = char; ptr = ptr+1 %if char=strdelimiter %then str = false %continue %finish %if chartype(char)&endst#0 %then %c sc(ptr) = char %and ptr = ptr+1 %and %exit ! Deal with curly bracket comments noting start so as to permit ! continuations of the form ...,{...}. ! Note that any missing closing brace is replaced. %if char='{' %start ncurl = ncurl+1; scurl(ncurl) = ptr sc(ptr) = char; ptr = ptr+1 %cycle char = itoi(byteinteger(inptr)) %if char=nl %then char = '}' %else inptr = inptr+1 %if char='}' %then %exit sc(ptr) = char ptr = ptr+1 %repeat ecurl(ncurl) = ptr %finish %if in keyword=true %start %if chartype(char)&letter=0 %then in keyword = false %else %c sc(ptr) = onecase(char)!underline %and ptr = ptr+1 %and %c %continue %finish %if char='%' %then in keyword = true %if char=squotes %or char=dquotes %start str = true; strdelimiter = char %finish sc(ptr) = char ptr = ptr+1 %repeat %if char=nl %start; ! TRAILING SPACES CHECK ptr = ptr-1 %while ptr>2 %and sc(ptr-2)=' ' sc(ptr-1) = nl %if str=false %start p = ptr-2 %while ncurl>0 %and ecurl(ncurl)=p %cycle ! Step past curly bracket. p = scurl(ncurl)-1; ncurl = ncurl-1 p = p-1 %while p>0 %and sc(p)=' ' %repeat ! Now p points at character determining continuation. %if p>0 %start char = sc(p) %if char=',' %start sc(ptr-1) = rs!128 %continue %finish %if char='C'+underline %start %if p>1 %and sc(p-1)='%' %then sc(p-1) = ' ' sc(p) = ' ' sc(ptr-1) = rs %continue %finish %if char&127=rs %then sc(ptr-1) = rs!128 %and %continue %finish %finish %finish %exit %repeat ptr = initptr %end %integer %function compare(%integer test) %integer i, ch, key, j %for i = 1, 1, clett(test) %cycle ch = nextnonsp(inconst) %if ch#clett(i+test) %then %result = false ptr = ptr+1 %repeat %if test=offile %or test=ofprogram %then stop = true %if test=comma %then insert(',', false, p_spcomma) %and %result = true %if test=equals %start %if ssalt=ownalt %then inconst = p_lclist ! If in own or const declaration and p_lclist is set, then set ! inconst to true. The effect of this is leave the declaration ! unformatted. Inconst is not set earlier as we do not wish the ! leading spaces in the statement to be preserved - i.e. the first ! line of the statement is indented with the rest of the program. insert('=', p_spacass, p_spacass) %result = true %finish %if p_expkey=true %start test = function %if test=fn test = constant %if test=const %finish %if obp=1 %or (outbuf(obp-1)&underline=0 %and %c outbuf(obp-1)&127#'%') %then key = false %else key = true ! Current state of outbuf. %for i = 1, 1, clett(test) %cycle ch = clett(test+i) %if chunderline %start %if key=false %start %if obp>1 %and '('#outbuf(obp-1)#' ' %then %c outbuf(obp) = ' ' %and obp = obp+1 outbuf(obp) = '%' obp = obp+1 key = true %finish %else %if i=1 %and p_sepkey=true %then %c outbuf(obp) = ' ' %and outbuf(obp+1) = '%' %and obp = obp+2 %finish %if ch&underline#0 %and p_uckey=false %and ch#rs!128 %then ch = ch!32 outbuf(obp) = ch obp = obp+1 %repeat %if (test=offile %or test=ofprogram) %and p_sepkey=true %start %if test=offile %then j = 4 %else j = 7 obp = obp+2 outbuf(obp-i) = outbuf(obp-i-2) %for i = 1, 1, j outbuf(obp-j-2) = ' ' outbuf(obp-j-1) = '%' %finish %if test=if %or test=unless %or test=while %or test=until %or %c test=else %or test=then %then outbuf(obp-1) = ch!bpoint %if test=and %or test=or %then outbuf(obp-1) = ch!bpoint2 %result = true %end %integer %function check(%integer pos) %integer defend, subdefend, subdefstart, res, item, rsptr, z, strdelimiter, ch, rsobj, alt, i, j %own %string (19) fes="FINISH %ELSE %START" %own %integer uci %own %integer depth=0 %switch bip(999:1039); ! Built-in phrases. alt = 0 depth = depth+1; ! Depth of recursion in check. ssalt = 0 %if depth=1; ! Initialise ssalt if in top-level call. rsptr = ptr; rsobj = obp defend = symbol(pos) pos = pos+1 %while posbip(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 jinc 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) = .. 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&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&31)&X'1004000E'#0 %then %c res = false %and ->inc %if ch='=' %start %if nextnonsp(inconst)=ch %then %c ptr = ptr+1 %and insert(M'==', p_spacop, p_spacop) %and ->inc insert('=', p_spacop, p_spacop) ->inc %finish %if ch='#' %start %if nextnonsp(inconst)=ch %then %c ptr = ptr+1 %and insert(M'##', p_spacop, p_spacop) %and ->inc insert('#', p_spacop, p_spacop) ->inc %finish %if ch='\' %and nextnonsp(inconst)='=' %start ptr = ptr+1 %if nextnonsp(inconst)='=' %then %c ptr = ptr+1 %and insert(M'==\', p_spacop, p_spacop) %and ->inc insert(M'=\', p_spacop, p_spacop) ->inc %finish %if ch='>' %start %if nextnonsp(inconst)='=' %then %c ptr = ptr+1 %and insert(M'=>', p_spacop, p_spacop) %and ->inc insert('>', p_spacop, p_spacop) ->inc %finish %if ch='<' %start %if nextnonsp(inconst)='=' %then %c ptr = ptr+1 %and insert(M'=<', p_spacop, p_spacop) %and ->inc %if nextnonsp(inconst)='>' %then %c ptr = ptr+1 %and insert(M'><', p_spacop, p_spacop) %and ->inc insert('<', p_spacop, p_spacop) ->inc %finish %if ch='-' %and nextnonsp(inconst)='>' %then %c ptr = ptr+1 %and insert(M'>-', p_spacop, p_spacop) %and ->inc res = false ->inc bip(1033):! Assop. ch = nextnonsp(inconst) ptr = ptr+1 %if ch='=' %start %if nextnonsp(inconst)='=' %then %c ptr = ptr+1 %and insert(M'==', p_spacass, p_spacass) %and ->inc insert('=', p_spacass, p_spacass) ->inc %finish %if ch='<' %and nextnonsp(inconst)='-' %then %c ptr = ptr+1 %and insert(M'-<', p_spacass, p_spacass) %and ->inc %if ch='-' %and nextnonsp(inconst)='>' %then %c ptr = ptr+1 %and insert(M'>-', p_spacass, p_spacass) %and ->inc res = false bip(1008):! Bighole. ->inc bip(1010):! Hole. bip(1011):! Mark. ->inc bip(1013):! Alias. ch = nextnonsp(inconst) ptr = ptr+1 %if ch#'"' %then res = false %and ->inc outbuf(obp) = ' '; obp = obp+1 outbuf(obp) = '"'; obp = obp+1 %cycle %if sc(ptr)='"' %start outbuf(obp) = '"'!instring %if sc(ptr+1)#'"' %then %exit outbuf(obp+1) = '"'!instring obp = obp+2; ptr = ptr+2 %finish %else %start ch = sc(ptr) outbuf(obp) = ch!instring obp = obp+1; ptr = ptr+1 getline(ptr) %if ch=nl %finish %repeat ptr = ptr+1; obp = obp+1 ->inc bip(1014):! Dummyapp. bip(1017):! Liston. bip(1018):! List off. bip(1020):! Note const. bip(1021):! Trace. ->inc bip(1039):! Dummy start %if p_expkey=true %start; ! Expand %else to %finish %else %start obp = obp-4 %for i = 1, 1, 19 %cycle j = charno(fes, i) %continue %if p_sepkey=false %and (j=' ' %or j='%') j = j!32 %if p_uckey=false %and 'A'<=j<='Z' outbuf(obp) = j; obp = obp+1 %repeat %finish bip(1029):! Note cycle bip(1034):! Note start increm = true; ->inc bip(1035):! Note finish bip(1036):! Note repeat %if in>0 %then in = in-1; ->inc inc: pos = pos+1 bypass: %if res=false %start pos = subdefend obp = rsobj %if ptr>maxptr %then maxptr = ptr %and maxitem = item ptr = rsptr %finish %repeat %if res=true %then depth = depth-1 %and %result = true %repeat ptr = rsptr; obp = rsobj depth = depth-1 %result = false %end !*********************************************************************** !* * !* Main calling routine. * !* * !*********************************************************************** s = "test.imp,.out,SPCOMMA=Y,EXPKEY=Y"; ! cliparam !printstring("preopt".snl) opt(s, p); ! Call option setting routine to set parameters. !printstring("preconnect ".infile.snl) connect(infile, 0, 0, 0, rec, eflag); ! Open input file. !printstring("postconnect".snl) %if eflag#0 %then fail(eflag, 5) %if rec_filetype#charfile %then setfname(infile) %and fail(267, 5) inptr = rec_conad+rec_datastart; ! Start of data. dataend = rec_conad+rec_dataend; ! End of data. ! Set output stream, possibilities are: ! Terminal, file, same file or output device. %if outf=".OUT" %then stream = terminal %else %start %if infile=outf %then stream = samefile %else %start %if charno(outf, 1)='.' %start %if devcode(outf)<=0 %start ! Invalid output device. setfname(outf) fail(264, 5) %finish %else stream = device %finish %else stream = file %finish %finish ! Create tempory output file? %if stream=samefile %or stream=device %then workfile = "T#".nexttemp %else %c workfile = outf %if stream#terminal %start filesizeptr = 1 filesize = fstable(filesizeptr) !printstring("outfile: ".workfile.snl) outfile(workfile, filesize, 0, 0, conad, eflag) %if eflag#0 %then fail(eflag, 5) outrec == record(conad) writeaddress = conad+outrec_datastart; wa0 = write address outrec_filetype = charfile ! Rest of record elements to be fill in at end of indentation. %finish outbuf(0) = 0; sc(0) = 0 level = 0; obp = 1; in = 0 inline = 1; line = 0 {output line} errors = 0; erptr = 0; charsin = 0 str = false stop = false; semicolon = false; increm = false; inlabel = false ersave = false %if p_uckey=true %then percentc = "%C" %else percentc = "%c" %cycle bheading = false maxptr = 0 ! Is there more to analyse in this statement. colon = inlabel %if inlabel=false %then getline(1) %else inlabel = false %if check(ss)=false %start printstring(snl."Syntax analysis fails on input line ".itos(inline-1)) printstring(" (output line ".itos(line+1).")".snl) z = 1 %while chartype(sc(z))&endst=0 %cycle %if sc(z)&127=rs %then printstring(snl) %else printch(sc(z)&127) z = z+1 %repeat %if sc(z)=';' %then printch(';') printstring(snl) spaces(maxptr-1); printch('!'); printstring(snl) startline = startline+1 %while byteinteger(startline)=' ' %if stream#terminal %start obp = 1 ! Line failed - Input line to output routine. z = byteinteger(startline) %while chartype(z)&endst=0 %cycle %if chartype(z)"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 %function %spec stoi(%string %name snum) %routine %spec ask(%integer optno) %integer i, j, temp, flag, prof vsn %string (80) line, option, value, filename %constant %integer prog vsn= 3 %switch prof(0:prog vsn) %external %routine %spec read profile(%string (11) key, %record (pformat) %name info, %integer %name version, uflag) %external %routine %spec write profile(%string (11) %name key, %record (pformat) %name info, %integer %name version, uflag) prof vsn = 0; flag = 5; !read profile("Soap80key", p, prof vsn, flag) %if flag>4 %start printstring( %c "Failed to read file SS#PROFILE. Defaults options assumed.".snl) %finish ->prof(prof vsn) ! In the following profile-handling code, we work with array p_a ! (alternative format) rather than the actual option names (p_sepkey ! etc.). This is because the p_a operations remain valid even if the ! record format is subsequently changed. prof(0): ! Code to set up profile vsn 1 data: ! This consists of 14 options followed by 21 tab values. ! original defaults !p_a(1) = 80; ! line - lines are broken into two if length is greater than 80. !p_a(2) = 3; ! icontin - continuation of line have an addition indentation of 3. !p_a(3) = 41; ! poscom - position for right hand comments. !p_a(4) = true; ! movecom - main comment are indented to POSCOM. !p_a(5) = true; ! uckey - keywords output in upper case. !p_a(6) = false; ! sepkey - adjacent keywords are compounded. !p_a(7) = true; ! lcasnam - case of names left alone. !p_a(8) = true; ! spacnam - spaces are left within names. !p_a(9) = true; ! spacass - spaces are added round assignment operators. !p_a(10) = false; ! spacop - spaces are not added round other operators. !p_a(11) = true; ! lclist - const lists to be left alone. !p_a(12) = true; ! iblock - block contents are indented w.r.t. block heading. !p_a(13) = false; ! istat - statements are aligned with declarations. !p_a(14) = false; ! seplab - Labels and statements may occupy the same line. ! graham's preferred defaults p_a(1) = 80; ! line - lines are broken into two if length is greater than 80. p_a(2) = 2; ! icontin - continuation of line have an addition indentation of 3. p_a(3) = 41; ! poscom - position for right hand comments. p_a(4) = false; ! movecom - main comment are indented to POSCOM. p_a(5) = false; ! uckey - keywords output in upper case. p_a(6) = true; ! sepkey - adjacent keywords are compounded. p_a(7) = false; ! lcasnam - case of names left alone. p_a(8) = true; ! spacnam - spaces are left within names. p_a(9) = true; ! spacass - spaces are added round assignment operators. p_a(10) = false; ! spacop - spaces are not added round other operators. p_a(11) = true; ! lclist - const lists to be left alone. p_a(12) = true; ! iblock - block contents are indented w.r.t. block heading. p_a(13) = false; ! istat - statements are aligned with declarations. p_a(14) = false; ! seplab - Labels and statements may occupy the same line. ! Set default indentation values. p_a(i+15) = 3*i %for i = 0, 1, 10 p_a(i+15) = 5*i-20 %for i = 11, 1, 20 prof(1): ! Code to set up profile vsn 2 data: ! This consists of 15 options followed by 21 tab values. p_a(i) = p_a(i-1) %for i = 36, -1, 16; ! Move tab values down to make room. printstring("**New parameter available: SPCOMMA".snl) printstring(" Y : One space character inserted after commas.".snl) printstring( %c " N : No space character inserted after commas (default).".snl.snl) p_a(15) = false; ! spcomma - default false. prof(2): ! Code to set up profile vsn 3 data: ! This consists of 21 tab values followed by 16 options. %begin %byte %integer %array tab(0:20) tab(i) = p_a(i+16) %for i = 0, 1, 20; ! Copy tab values out. p_a(i+21) = p_a(i) %for i = 1, 1, 6; ! Move options down. ! Item _a(28) will be the new parameter (expkey). p_a(i+22) = p_a(i) %for i = 7, 1, 15; ! Move options down. p_a(i+1) = tab(i) %for i = 0, 1, 20; ! Copy tab values back. %end printstring("**New parameter available: EXPKEY".snl) printstring( %c " Y : Keywords %FN, %CONST and (sometimes) %ELSE expanded.".snl) printstring(" N : %FN, %CONST and %ELSE left alone (default).". %c snl.snl) p_a(28) = false; ! expkey default - false. ! The following two lines should always be just before the final 'prof' ! switch label. prof vsn = prog vsn %begin %string(11) key key = "Soap80key" write profile(key, p, prof vsn, flag) %end prof(3): ! Split up parameters and change default values. %if parm->filename.(",").outf %start %unless outf->outf.(",").parm %then parm = "" %finish %else filename = parm %and outf = parm %and parm = "" infile = filename %if outf="" %then outf = filename %if parm="" %then %return temp = charno(parm, length(parm)) %if temp#'*' %and temp#'?' %then parm = parm.",END" %cycle %if parm="" %then %start %begin %string(15) s s = "Soap80: " prompt(s); ! not a real imp prompt unfortunately %end readline %finish %else %start setline %finish %if line="END" %or line=".END" %then %return ! End of parameter settings. %if line="GO" %or line=".GO" %then %return ! End of parameter settings. %if line="STOP" %or line=".STOP" %then %stop; ! Abandon Soap80. %if line="SAVE" %or line=".SAVE" %start %begin %string(11) key key = "Soap80key" write profile(key, p, prof vsn, flag) %end printstring("Profile file SS#PROFILE created and cherished.".snl) %c %if flag=1 %finish %else %if line="?" %start ! Print options so far. printstring( %c "Option name:{current setting}Meaning of current setting".snl) %for i = 1, 1, maxopt %cycle printstring(optname(i)) spaces(7-length(optname(i))) printstring(":{") j = p_optarr(i) %if j=false %then printsymbol('N') %else %if j=true %then %c printsymbol('Y') %else printstring(itos(j)) j = 1 %if j>0 printstring("}".optmess(j, i).snl) %repeat printstring("TAB :{") %for i = 1, 1, 20 %cycle printstring(itos(p_tab(i))) printsymbol(':') %unless i=20 %repeat printsymbol('}') printstring(snl) printstring(" Indenting values".snl) printstring( %c "SAVE : Save current option settings, for defaults henceforth. GO or END: Cause SOAP80 to start processing the input. STOP : Cause SOAP80 to stop immediately.".snl) %finish %else %start %if line->option.("=").value %and value#"" %start flag = 0 %for i = 1, 1, maxopt %cycle %continue %unless option=optname(i) flag = 1; ! Option identified. %if value="?" %start printstring(optname(i)); spaces(7-length(optname(i))) printstring(":{") j = p_optarr(i) %if j=false %then printsymbol('N') %else %if %c j=true %then printsymbol('Y') %else printstring(itos(j)) j = 1 %if j>0 printstring("}".optmess(j, i).snl) %finish %else %start %if i<=numopt %start; ! Numerical value. temp = stoi(value) %if option="LINE" %and (temp<30 %or temp>160) %start printstring( %c "Bad line length - Only from 30 to 160".snl) %exit %finish temp = -1 %if temp>255 %if temp=-1 %then %c printstring(value." - ".failure message(320)) %else %c p_optarr(i) = temp %finish %else ask(i) %finish %exit %repeat %continue %if flag=1; ! Cycle found option name. %if option="TAB" %start ! Set indenting value. %if value="?" %start printstring("TAB :{") %for i = 1, 1, 20 %cycle printstring(itos(p_tab(i))) printsymbol(':') %unless i=20 %repeat printsymbol('}') printstring(snl) printstring(" Indenting values".snl) %finish %else %start i = 1 %while i<=20 %and value#"" %cycle temp = stoi(value) %if temp=-1 %then %c printstring(value." - ".failuremessage(320)) %and %c %exit p_tab(i) = temp %if length(value)=0 %then i = i+1 %and %exit %if charno(value, 1)#':' %start printstring(value." - ".failuremessage(320)) i = 21 %finish %else value = substring(value, 2, length(value)) i = i+1 %repeat ! End of indenting value, make up the rest %for j = i, 1, 20 %cycle p_tab(j) = 2*p_tab(j-1)-p_tab(j-2) %if p_tab(j)>p_line %then p_tab(j) = p_line %repeat %finish %continue %finish printstring(option." - ".failuremessage(322)) ! Keyword not recognised. %finish %else %start printstring(line." - invalid: format should be 'keyword = value' or 'keyword = ?' or '?' or 'SAVE' or 'END' or 'GO' or 'STOP'".snl) %finish %finish %repeat %return %routine readline !*********************************************************************** !* READLINE creates a line from the input device, converting all * !* lower case characters to upper case. * !*********************************************************************** %integer ch %cycle line = "" %cycle readsymbol(ch); %if ch=nl %then %exit %if ch=' ' %then %continue ! Convert lower to upper. line = line.tostring(onecase(ch)) %repeat ! Return only if the line has some thing on it. %if length(line)>0 %then %return %repeat %end %routine setline !*********************************************************************** !* SETLINE breaks the parameter list into single commands. * !************************************************************************ %unless parm->line.(",").parm %start ! Last command in parameter. %if charno(parm, length(parm))='*' %then readline %else line = parm parm = "" %finish %end %routine ask(%integer i) !*********************************************************************** !* ASK checks that value starts with Y or N and * !* assigns True or False accordingly to P_OPTARR(I). * !*********************************************************************** %integer s s = charno(value, 1) %if s='Y' %then p_optarr(i) = true %else %if s='N' %then %c p_optarr(i) = false %else printstring("Answer Yes or No or ?".snl) %end %integer %function stoi(%string %name snum) !*********************************************************************** !* STOI builts up an integer in INUM from the string SNUM, in * !* doing so characters are deleted from this string. * !* It is an error if the first character of the string is not a * !* number. This is signalled by returning -1. * !*********************************************************************** %integer i, inum %unless '0'<=charno(snum, 1)<='9' %then %result = -1 i = 1; inum = 0 %while '0'<=charno(snum, i)<='9' %cycle inum = inum*10+charno(snum, i)-'0' i = i+1 %if i>length(snum) %then %exit %repeat %if i>=length(snum) %then snum = "" %else %c snum = substring(snum, i, length(snum)) %result = inum %end %end %end %of %program