!*********************************************************************** !* * !* SOAP80 - IMP indenter. * !* Created by E.N.Gregory. * !* All syntax directed sections rewritten by P.D.S * !* Using IMP80 syntax version 02. * !* * !*********************************************************************** %EXTERNALROUTINESPEC PROMPT(%STRING(31) S) !*********************************************************************** !* * !* Record formats. * !* * !*********************************************************************** %RECORDFORMAT FHDR(%INTEGER DATAEND,DATASTART,FILESIZE,FILETYPE) %RECORDFORMAT CHDR(%INTEGER CONAD,FILETYPE,DATASTART,DATAEND) %CONSTINTEGER MAXOPT = 13,NUMOPT = 3 %RECORDFORMAT PFORMAT((%BYTEINTEGER LINE,ICONTIN,POSCOM,MOVECOM,UCKEY,SEPKEY, SPACNAM,SPACASS,SPACOP,LCLIST,IBLOCK,ISTAT,SEPLAB %OR %C %BYTEINTEGERARRAY OPTARR(1:MAXOPT)), %BYTEINTEGERARRAY TAB(0:20)) !********************************************************************** !* !* System routines. !* !********************************************************************** %SYSTEMSTRINGFNSPEC ITOS(%INTEGER I) %SYSTEMROUTINESPEC CONNECT(%STRING(31) NAME, %INTEGER MODE,HOLE,PROT, %RECORD(CHDR) %NAME REC, %INTEGERNAME EFLAG) %SYSTEMROUTINESPEC TRIM(%STRING(31) FILE, %INTEGERNAME EFLAG) %SYSTEMROUTINESPEC SETFNAME(%STRING(31) FILE) %SYSTEMSTRINGFNSPEC NEXTTEMP %SYSTEMROUTINESPEC SENDFILE(%STRING(31) FILE,DEVICE,HEADER, %INTEGER COPIES, FORM, %INTEGERNAME EFLAG) %SYSTEMINTEGERFNSPEC DEVCODE(%STRING(31) NAME) %SYSTEMROUTINESPEC DISCONNECT(%STRING(31) FILENAME, %INTEGERNAME EFLAG) %SYSTEMSTRINGFNSPEC FAILUREMESSAGE(%INTEGER TYPE) %SYSTEMROUTINESPEC CHANGEFILESIZE(%STRING(31) FILENAME, %INTEGER FILESIZE, %INTEGERNAME EFLAG) %SYSTEMROUTINESPEC NEWGEN(%STRING(31) FILENAME,NEWFILENAME, %INTEGERNAME EFLAG) %SYSTEMROUTINESPEC OUTFILE(%STRING(31) FILENAME, %INTEGER SIZE,HOLE,PROT, %INTEGERNAME CONAD,EFLAG) %EXTERNALROUTINE SOAP80(%STRING(255) S) %INTEGER PTR,DATAEND,INPTR,Z,IN,OBP,EFLAG,Writeaddress,filesize,CONAD,Errors, Line,ERPTR,STRDEL,Startline,STREAM,filesizeptr,SSALT,STRDELIMITER,STR, SEMICOLON,COLON,MAXPTR,MAXITEM,Level,STOP,INCREM,INLABEL,CHARSIN,ERSAVE, Inconst,Bheading %STRING(31) Workfile,Infile,Outf %RECORD(PFORMAT) P %RECORD(CHDR) REC,RR %RECORD(FHDR) %NAME OUTREC %CONSTINTEGER CCSIZE = 8192 %HALFINTEGERARRAY OUTBUF(0:CCSIZE+200) %BYTEINTEGERARRAY SC(0:CCSIZE) %CONSTSTRING(8) %ARRAY OPTNAME(1:MAXOPT) = "LINE","ICONTIN","POSCOM", "MOVECOM","UCKEY","SEPKEY","SPACNAM","SPACASS","SPACOP","LCLIST", "IBLOCK","ISTAT","SEPLAB" %CONSTSTRING(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", "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" %CONSTINTEGER CHARFILE = 3; ! Code for a character file. %CONSTINTEGER Underline = 128 %CONSTINTEGER INSTRING = 256,INCURLY = 512,BPOINT = 1024,BPOINT2 = 2048 %CONSTINTEGER TERMINAL = 1,FILE = 2,SAMEFILE = 3,DEVICE = 4 %CONSTINTEGER True = 255,False = 0; ! Synthetic boolean values. %CONSTINTEGER NL = 10,DQUOTES = 34,SQUOTES = 39 %CONSTINTEGER RS = 30; ! RECORD SEPARATOR IS USED ! AS A DELETED(BY %C) NL %CONSTINTEGER REM = B'00000001' %CONSTINTEGER CONSTART = B'00000010' %CONSTINTEGER QUOTES = B'00000100' %CONSTINTEGER ENDST = B'00001000' %CONSTINTEGER NUMBER = B'00010000' %CONSTINTEGER LETTER = B'00100000' %CONSTBYTEINTEGER CONSTFIRST = B'01000000' %CONSTINTEGER CONSTCONT = B'10000000' ! %CONSTBYTEINTEGERARRAY 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 %CONSTBYTEINTEGERARRAY 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'00000000', 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', B'0'(60) %CONSTBYTEINTEGERARRAY KEYCOM(0:7) = '%','C','O','M','M','E','N','T' %CONSTINTEGERARRAY FSTABLE(1:3) = 4096,16384,65536 ! ! Special delimiters noted by SOAP80. ! %CONSTINTEGER Offile = 133,Ofprogram = 123,Equals = 38,If = 12,Unless = 15, While = 22,Until = 28,Else = 227,Then = 222,And = 158,Or = 162 ! %CONSTSTRING(1) SNL = " " ! %CONSTSTRING(60) %ARRAY FAULT(1:4) = %C "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." ! ! ! %ROUTINESPEC FAIL(%INTEGER TYPE,ACTION) %ROUTINESPEC OPT(%STRING(255) PARM, %RECORD(PFORMAT) %NAME P) ! ! PRODUCED BY OLDPS FROM IMP80PS03 ON 23/06/82 %CONSTBYTEINTEGERARRAY CLETT(0:442) = 1, 43, 1, 45, 1, 40, 1, 41, 1, 42, 1, 44, 2, 201, 198, 6, 213, 206, 204, 197, 211, 211, 5, 215, 200, 201, 204, 197, 5, 213, 206, 212, 201, 204, 3, 198, 207, 210, 1, 61, 5, 193, 204, 201, 193, 211, 7, 201, 206, 212, 197, 199, 197, 210, 4, 210, 197, 193, 204, 4, 204, 207, 206, 199, 4, 194, 217, 212, 197, 6, 211, 212, 210, 201, 206, 199, 4, 200, 193, 204, 198, 6, 210, 197, 195, 207, 210, 196, 7, 210, 207, 213, 212, 201, 206, 197, 2, 198, 206, 3, 205, 193, 208, 8, 198, 213, 206, 195, 212, 201, 207, 206, 4, 206, 193, 205, 197, 5, 193, 210, 210, 193, 217, 9, 207, 198, 208, 210, 207, 199, 210, 193, 205, 6, 207, 198, 198, 201, 204, 197, 6, 207, 198, 204, 201, 211, 212, 6, 198, 207, 210, 205, 193, 212, 3, 206, 207, 212, 3, 193, 206, 196, 2, 207, 210, 1, 58, 4, 211, 208, 197, 195, 3, 207, 215, 206, 8, 197, 216, 212, 197, 210, 206, 193, 204, 9, 197, 216, 212, 210, 201, 206, 211, 201, 195, 8, 195, 207, 206, 211, 212, 193, 206, 212, 5, 195, 207, 206, 211, 212, 5, 197, 214, 197, 206, 212, 5, 211, 212, 193, 210, 212, 4, 212, 200, 197, 206, 4, 197, 204, 211, 197, 1, 95, 6, 211, 217, 211, 212, 197, 205, 7, 196, 217, 206, 193, 205, 201, 195, 4, 80, 85, 84, 95, 5, 67, 78, 79, 80, 95, 2, 204, 61, 1, 60, 1, 62, 4, 40, 196, 210, 43, 2, 196, 210, 1, 194, 3, 212, 207, 211, 3, 204, 206, 194, 3, 216, 206, 194, 2, 208, 195, 3, 195, 212, 194, 2, 45, 62, 6, 210, 197, 212, 213, 210, 206, 6, 210, 197, 211, 213, 204, 212, 7, 205, 207, 206, 201, 212, 207, 210, 4, 211, 212, 207, 208, 6, 211, 201, 199, 206, 193, 204, 4, 197, 216, 201, 212, 8, 195, 207, 206, 212, 201, 206, 213, 197, 6, 198, 201, 206, 201, 211, 200, 5, 195, 217, 195, 204, 197, 6, 210, 197, 208, 197, 193, 212, 3, 197, 206, 196, 7, 201, 206, 195, 204, 213, 196, 197, 5, 194, 197, 199, 201, 206, 2, 207, 206, 6, 211, 215, 201, 212, 195, 200, 4, 204, 201, 211, 212, 7, 211, 208, 197, 195, 201, 193, 204, 14, 212, 210, 213, 211, 212, 197, 196, 208, 210, 207, 199, 210, 193, 205, 6, 205, 193, 201, 206, 197, 208, 7, 195, 207, 206, 212, 210, 207, 204, 4, 40, 42, 41, 58 %CONSTINTEGERARRAY SYMBOL(1300:2173) = 1307, 1303, 0, 1305, 2, 1307, 1000, 1319, 1312, 1001, 1366, 1803, 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, 1553, 1573, 1011, 1399, 28, 1010, 1553, 1573, 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, 1453, 1439, 46, 1441, 54, 1444, 59, 1428, 1447, 64, 1423, 1450, 69, 1706, 1453, 76, 1423, 1475, 1456, 46, 1458, 54, 1461, 59, 1428, 1464, 64, 1423, 1467, 69, 1706, 1470, 76, 1423, 1475, 81, 4, 1854, 6, 1482, 1478, 88, 1482, 1031, 1436, 1482, 1489, 1485, 96, 1487, 99, 1489, 103, 1505, 1495, 1453, 1510, 1001, 1416, 1501, 1475, 1505, 1001, 1416, 1518, 1505, 112, 1001, 1416, 1510, 1508, 112, 1510, 1000, 1518, 1514, 117, 112, 1516, 112, 1518, 1000, 1528, 1526, 4, 1010, 1489, 1011, 1528, 6, 1528, 1000, 1537, 1535, 1030, 1010, 1489, 1011, 999, 1537, 1000, 1548, 1541, 123, 1016, 1543, 133, 1546, 140, 1018, 1548, 1016, 1553, 1551, 147, 1553, 1000, 1567, 1559, 1345, 1032, 1345, 1567, 1564, 4, 1553, 1573, 6, 1567, 154, 1553, 1573, 1571, 1037, 1345, 1573, 1000, 1584, 1578, 158, 1553, 1584, 1582, 162, 1553, 1591, 1584, 1000, 1591, 1589, 158, 1553, 999, 1591, 1000, 1598, 1596, 162, 1553, 999, 1598, 1000, 1606, 1602, 1033, 1345, 1604, 165, 1606, 1000, 1612, 1610, 167, 1008, 1612, 1015, 1616, 1615, 167, 1616, 1625, 1623, 10, 1345, 165, 1345, 1616, 1625, 1000, 1634, 1630, 1510, 1001, 1416, 1634, 117, 1548, 1634, 1640, 1640, 1001, 1416, 1811, 1640, 1646, 1644, 10, 1634, 1646, 1000, 1663, 1656, 1510, 1612, 1010, 1001, 1410, 1819, 1011, 1663, 1663, 117, 1548, 1612, 1001, 1811, 1685, 1674, 1672, 10, 1010, 1001, 1410, 1819, 1011, 1663, 1674, 1000, 1685, 1677, 172, 1679, 176, 1681, 185, 1683, 195, 1685, 204, 1696, 1694, 38, 1012, 1028, 1319, 1359, 1706, 1696, 1696, 1000, 1706, 1704, 10, 1028, 1319, 1359, 1706, 999, 1706, 1000, 1713, 1711, 4, 1336, 6, 1713, 1000, 1720, 1718, 10, 1329, 999, 1720, 1000, 1725, 1723, 210, 1725, 1000, 1731, 1729, 10, 1345, 1731, 1000, 1744, 1742, 10, 1001, 1416, 4, 1345, 165, 1345, 6, 999, 1744, 1000, 1751, 1749, 28, 1553, 1573, 1751, 1000, 1764, 1754, 1019, 1756, 1006, 1761, 1381, 1553, 1573, 1006, 1764, 1386, 1006, 1778, 1768, 216, 1034, 1772, 222, 216, 1034, 1778, 222, 1010, 2009, 1011, 1784, 1784, 1782, 158, 2009, 1784, 1000, 1790, 1788, 227, 1790, 1790, 1000, 1803, 1794, 216, 1034, 1801, 1381, 1010, 1553, 1573, 1011, 1764, 1803, 2009, 1811, 1809, 232, 1001, 1366, 1803, 1811, 1000, 1819, 1819, 4, 1345, 165, 1345, 1616, 6, 1827, 1825, 38, 1028, 1319, 1359, 1827, 1000, 1836, 1830, 234, 1832, 176, 1834, 241, 1836, 1000, 1847, 1845, 1001, 38, 1345, 10, 1345, 10, 1345, 1847, 1000, 1854, 1852, 10, 1861, 999, 1854, 1000, 1861, 1857, 1001, 1861, 1861, 1847, 1879, 1871, 1865, 1453, 1871, 1871, 4, 1861, 1847, 1879, 6, 1879, 1876, 1510, 1001, 1416, 1879, 117, 1634, 1887, 1885, 162, 1861, 1847, 999, 1887, 1000, 1899, 1891, 249, 1002, 1894, 1022, 1899, 1899, 254, 1009, 10, 1009, 1913, 1903, 1023, 1913, 1908, 1024, 260, 1952, 1957, 1913, 1025, 1005, 10, 1936, 1936, 1918, 263, 1001, 265, 1920, 1985, 1925, 4, 1985, 1974, 6, 1929, 267, 1985, 6, 1934, 4, 272, 1974, 6, 1936, 275, 1952, 1941, 263, 1001, 265, 1943, 1985, 1948, 4, 272, 1974, 6, 1952, 267, 1005, 6, 1957, 1955, 272, 1957, 1005, 1965, 1963, 10, 1005, 10, 1005, 1965, 1000, 1974, 1969, 0, 1005, 1972, 2, 1005, 1974, 1000, 1980, 1978, 0, 275, 1980, 1000, 1985, 1983, 38, 1985, 1000, 2000, 1990, 1980, 1300, 1003, 1993, 1001, 1965, 1998, 4, 2000, 1965, 6, 2000, 277, 2009, 2003, 281, 2005, 285, 2007, 289, 2009, 292, 2042, 2018, 1010, 1001, 1366, 1803, 1011, 1598, 1778, 2022, 296, 1001, 1366, 2024, 299, 2028, 306, 1033, 1345, 2031, 313, 1778, 2033, 321, 2038, 326, 1720, 1329, 1725, 2040, 333, 2042, 338, 2174, 2049, 1027, 1010, 2009, 1011, 1751, 2051, 1007, 2059, 1381, 1010, 1553, 1573, 1011, 1764, 1006, 2064, 347, 1035, 1784, 1006, 2069, 354, 1029, 1836, 1006, 2074, 360, 1036, 1744, 1006, 2079, 1386, 354, 1029, 1006, 2087, 1004, 1008, 1010, 1453, 1011, 1625, 1006, 2091, 367, 1537, 1006, 2101, 81, 147, 1001, 4, 1861, 1847, 1879, 6, 1006, 2111, 1010, 1827, 1475, 1011, 1606, 1001, 1410, 1518, 1006, 2116, 1674, 1453, 1646, 1006, 2120, 371, 1003, 1038, 2124, 379, 1015, 1006, 2133, 385, 1021, 1720, 1329, 1713, 216, 1034, 1006, 2144, 388, 1001, 1416, 4, 1345, 165, 1345, 6, 1731, 1006, 2148, 395, 1006, 1017, 2153, 400, 112, 1001, 1006, 2157, 8, 1887, 1006, 2160, 408, 1006, 2164, 423, 1001, 1006, 2168, 430, 1003, 1006, 2172, 1001, 438, 1019, 2174, 1006 %CONSTINTEGER SS = 2042 %CONSTINTEGER Comment = 2; ! alt of p of %COMMENT %CONSTINTEGER Ownalt = 12; ! alt of p for owns %CONSTINTEGER EISSS = X'00FA20FA'; ! FLAG NON DECLARATIVE SS ALTS ! MAY CHANGE WITH NEW SYNTAX %CONSTINTEGERARRAY 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 %C filesize = FSTABLE(filesizeptr) %ELSE 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=RS %THENCONTINUE %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 OUTSTRING(%STRING(40) TEXT) !*********************************************************************** !* Outstring copies TEXT to the output file or channel. * !*********************************************************************** %INTEGER I,CH,LAST %IF STREAM#TERMINAL %THENSTART 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 %THENRETURN CHARSIN = CHARSIN+TIMES %IF STREAM#TERMINAL %THENSTART 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,SFLAG) !*********************************************************************** !* This will place upto four characters into the OUTBUF buffer this * !* includes the option of have spaces around the characters. * !*********************************************************************** %IF SFLAG=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 SFLAG=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) %FINISHELSESTART PRINTSTRING("Soap80 fails :- ".ITOS(Errors)." 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) %ELSESTART 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 %FINISHELSESTART %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 INN = IN INN = INN+1 %IF 1<P_LINE %THEN FAIL(4,2) %ELSE IN = IN+1 %FINISH LST = 1 %IF SSALT=2 %THEN ->FINALPART; ! DONT TRY TO SPLIT COMMENTS %CYCLE UBP = P_LINE+LST-CHARSIN-4; ! RHMOST BREAK POINT LBP = (UBP+LST)//2 BBP = (UBP+3*LST)//4 ! ! FIRST CHECK FOR NL IN STRING CONST OR LIST ! %FOR BK = LST,1,UBP+3 %CYCLE %EXITIF BK>=OBP CH = OUTBUF(BK) %IF CH&X'7F'=NL %OR(CH=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 %FOR BK = UBP,-1,BBP %CYCLE %IF OUTBUF(BK)&INCURLY=0 %THEN BK = BK-1 %AND ->PRINTPART %REPEAT %FOR BK = UBP,1,OBP-2 %CYCLE %IF OUTBUF(BK)&INCURLY=0 %THEN ->PRINTPART %REPEAT ->FINALPART; ! OVER LONG CURLY IGNORE %FINISH %FOR BK = UBP+1,-1,LBP %CYCLE %IF OUTBUF(BK)=' ' %AND OUTBUF(BK-1)&Underline#0 %THEN ->PRINTPART %REPEAT %IF P_SPACNAM=False %START; ! MUST OMIT IF NAMES ARE SPACED %FOR BK = UBP+1,-1,LBP %CYCLE %IF OUTBUF(BK)=' ' %THEN ->PRINTPART %REPEAT %FINISH %FOR BK = UBP,-1,LBP %CYCLE %IF OUTBUF(BK)='%' %THEN BK = BK-1 %AND ->PRINTPART %REPEAT %FOR BK = UBP,-1,LBP %CYCLE %IF OUTBUF(BK)='.' %OR OUTBUF(BK)=')' %THEN ->PRINTPART %IF OUTBUF(BK)='(' %THEN BK = BK-1 %AND ->PRINTPART %REPEAT %IF OUTBUF(UBP)&INSTRING#0 %START ! Break point is inside a string. %FOR BK = UBP,-1,BBP %CYCLE %IF OUTBUF(BK)=',' %OR OUTBUF(BK)='.' %OR OUTBUF(BK)='=' %THEN %C ->PRINTPART %REPEAT %FOR I = UBP,-1,LST+3 %CYCLE %IF OUTBUF(I)=DQUOTES %THEN BK = I-1 %AND ->PRINTPART %REPEAT %FOR I = BK,-1,LST %CYCLE %IF OUTBUF(I)=SQUOTES %START %IF CHARTYPE(OUTBUF(I-1))&CONSTART=0 %THEN BK = I-1 %ELSE %C BK = I-2 ->PRINTPART %FINISH %REPEAT ! Break string. PRINTSTRING("Line:".ITOS(LINE)." problem:") PRINTSYMBOL(OUTBUF(I)) %FOR I = LST,1,UBP NEWLINE TP = UBP-1 TRANSFER(LST,TP) OUTSTRING(""".%C".SNL) DUPL(' ',P_TAB(INN)+P_ICONTIN) OUTSTRING("""") LST = TP+1 %CONTINUE %FINISHELSE BK = UBP PRINTSTRING("Line:".ITOS(LINE)." problem:") PRINTSYMBOL(OUTBUF(I)) %FOR I = LST,1,UBP NEWLINE PRINTPART: I = BK I = I-1 %WHILE OUTBUF(I)=' ' %OR OUTBUF(I)=RS %IF LST>I %THEN LST = BK+1 %ANDCONTINUE TRANSFER(LST,I) %IF OUTBUF(I)&X'7F'#NL %THENSTART; ! NOT NATURAL BREAK %IF OUTBUF(I)&X'7F'#',' %THEN OUTSTRING(" %C") OUTSTRING(SNL) DUPL(' ',P_TAB(INN)+P_ICONTIN) %IF Inconst=False OUTSTRING("%") %IF OUTBUF(BK+1)&Underline#0 %FINISH LST = BK+1 %REPEAT FINALPART: TRANSFER(LST,OBP-1) %IF CHARSIN>=P_LINE %THEN OUTSTRING(SNL); ! LONG COMMENT... OBP = 1 %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) Line are joined togther if there is a %C at the end of the * !* first line. The newline position is marked by RS. * !*********************************************************************** %INTEGER STRDEL,CHAR,COMST %IF INITPTR=1 %THEN Startline = INPTR PTR = INITPTR STRDEL = False COMST = 0 %CYCLE %CYCLE %IF PTR>CCSIZE %THEN FAIL(1,1) %ANDEXIT %IF INPTR>DATAEND %THEN FAIL(2,1) CHAR = BYTEINTEGER(INPTR) INPTR = INPTR+1 %IF CHAR=NL %THEN SC(PTR) = CHAR %AND PTR = PTR+1 %ANDEXIT %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 %ANDEXIT ! ! DEAL WITH CURLY BRACKET COMMENTS NOTING START SO AS TO PERMIT ! CONTINUATIONS 0F THE FORM....,{...}! ANY MISSING CLOSING BRACE IS REPLACED ! %IF CHAR='{' %START COMST = PTR-1 SC(PTR) = CHAR; PTR = PTR+1 %CYCLE CHAR = BYTEINTEGER(INPTR) %IF CHAR=NL %THEN CHAR = '}' %ELSE INPTR = INPTR+1 %IF CHAR='}' %THENEXIT SC(PTR) = CHAR PTR = PTR+1 %REPEAT %FINISH %IF STRDEL=True %START %IF CHARTYPE(CHAR)&LETTER=0 %THEN STRDEL = False %ELSE %C SC(PTR) = ONECASE(CHAR)!Underline %AND PTR = PTR+1 %AND %C %CONTINUE %FINISH %IF CHAR='%' %THEN STRDEL = 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 PTR>3 %AND STR=False %START %IF SC(PTR-2)='C'+Underline %START %IF SC(PTR-3)='%' %THEN PTR = PTR-2 %ELSE PTR = PTR-1 SC(PTR-1) = RS STRDEL = False %CONTINUE %FINISH %IF SC(PTR-2)=',' %THEN SC(PTR-1) = RS %ANDCONTINUE %IF SC(PTR-2)='}' %START COMST = COMST-1 %WHILE COMST>2 %AND SC(COMST)=' ' %IF SC(COMST)=',' %THEN SC(PTR-1) = RS %ANDCONTINUE %IF SC(COMST)='C'+Underline %THEN %C SC(COMST) = ' ' %AND SC(PTR-1) = RS %ANDCONTINUE %FINISH %FINISH %FINISH %EXIT %REPEAT PTR = INITPTR %END %INTEGERFN NEXTNONSP(%INTEGER PRINT) %INTEGER CH AGN: CH = SC(PTR) %IF CH='{' %THENSTART OUTBUF(OBP) = CH OBP = OBP+1; PTR = PTR+1 %UNTIL CH='}' %CYCLE CH = SC(PTR) OUTBUF(OBP) = CH!INCURLY OBP = OBP+1 PTR = PTR+1 %REPEAT ->AGN %FINISH %IF CH=' ' %OR CH='%' %OR CH=RS %START %IF PRINT=True %THEN OUTBUF(OBP) = CH %AND OBP = OBP+1 PTR = PTR+1 ->AGN %FINISH %RESULT = CH %END %INTEGERFN COMPARE(%INTEGER TEST) %INTEGER I,CH,KEY %FOR I = 1,1,CLETT(TEST) %CYCLE CH = NEXTNONSP(Inconst) %IF CH#CLETT(I+TEST) %THENRESULT = False PTR = PTR+1 %REPEAT %IF TEST=Offile %OR TEST=Ofprogram %THEN STOP = True %IF TEST=Equals %THEN INSERT('=',P_SPACASS) %ANDRESULT = True %IF OBP=1 %OR OUTBUF(OBP-1)&Underline=0 %THEN KEY = False %ELSE %C KEY = True %IF CLETT(TEST+1)Underline %AND OBP>1 %START %IF KEY=False %START %IF '('#OUTBUF(OBP-1)#' ' %THEN OUTBUF(OBP) = ' ' %AND OBP = OBP+1 OUTBUF(OBP) = '%' OBP = OBP+1 %FINISHELSEIF P_SEPKEY=True %THEN %C OUTBUF(OBP) = ' ' %AND OUTBUF(OBP+1) = '%' %AND OBP = OBP+2 %FINISHELSEIF CLETT(TEST+1)>Underline %THEN %C OUTBUF(OBP) = '%' %AND OBP = OBP+1 %FOR I = 1,1,CLETT(TEST) %CYCLE CH = CLETT(TEST+I) %IF CH&Underline#0 %AND P_UCKEY=False %THEN CH = CH!32 OUTBUF(OBP) = CH OBP = OBP+1 %REPEAT %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 %INTEGERFN CHECK(%INTEGER POS) %INTEGER DEFEND,SUBDEFEND,SUBDEFSTART,RES,ITEM,rsptr,Z,STRDEL,CH,rsobj,ALT,I,J %OWNINTEGER UCI %SWITCH BIP(999:1038) ALT = 0 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): SSALT = ALT; %RESULT = True; ! Zero function. BIP(1001):! Name CH = NEXTNONSP(Inconst) J = PTR; PTR = PTR+1; I = OBP %IF CHARTYPE(CH)&CONSTART#0 %AND %C NEXTNONSP(Inconst!P_SPACNAM)=SQUOTES %THEN %C RES = False %AND ->INC %IF CHARTYPE(CH)&LETTER=0 %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 OUTBUF(OBP) = CH; OBP = OBP+1 J = OBP; PTR = PTR+1 CH = NEXTNONSP(Inconst!P_SPACNAM) %REPEAT %IF Inconst=False %THEN OBP = J ->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 STRDEL = NEXTNONSP(Inconst) PTR = PTR+1 %FINISHELSE STRDEL = CH OUTBUF(OBP) = STRDEL; OBP = OBP+1 %CYCLE %IF SC(PTR)=STRDEL %START OUTBUF(OBP) = STRDEL!INSTRING %IF SC(PTR+1)#STRDEL %THENEXIT OUTBUF(OBP+1) = STRDEL!INSTRING OBP = OBP+2; PTR = PTR+2 %FINISHELSESTART CH = SC(PTR) OUTBUF(OBP) = CH!INSTRING OBP = OBP+1; PTR = PTR+1 %IF CH=NL %THENSTART GETLINE(PTR) %FINISH %FINISH %REPEAT PTR = PTR+1; OBP = OBP+1 %FINISHELSESTART PTR = PTR-1 %CYCLE %CYCLE %EXITIF CHARTYPE(CH)&CONSTCONT=0 OUTBUF(OBP) = CH; OBP = OBP+1 PTR = PTR+1 CH = NEXTNONSP(Inconst) %REPEAT %IF '_'#CH#'@' %THENEXIT %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(1006):! S - End statement. CH = NEXTNONSP(Inconst) %IF CHARTYPE(CH)&ENDST=0 %THEN RES = False %AND ->INC 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 %FOR I = 2,1,7 %CYCLE CH = NEXTNONSP(Inconst) %IF CH#KEYCOM(I)+Underline %THEN RES = False %AND ->INC %IF P_UCKEY=True %THEN CH = CH!32 OUTBUF(OBP) = CH OBP = OBP+1 PTR = PTR+1 %REPEAT %FINISH %WHILE CHARTYPE(SC(PTR))&ENDST=0 %CYCLE OUTBUF(OBP) = SC(PTR); OBP = OBP+1 PTR = PTR+1 %REPEAT OUTBUF(OBP) = SC(PTR); OBP = OBP+1 PTR = PTR+1 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? %IF P_LCLIST=True %THEN Inconst = True CH = NEXTNONSP(Inconst) %IF CH#NL %THEN ->INC OUTBUF(OBP) = NL OBP = OBP+1 PUNCH GETLINE(1) ->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) %IF P_SEPLAB=True %AND CH#NL %THEN OUTSTRING(SNL) INLABEL = True %IF OUTBUF(OBP-1)=NL %THEN GETLINE(1) OBP = 1 ->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) %AND ->INC %IF CH='*' %START %IF CH#NEXTNONSP(Inconst) %THEN INSERT('*',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) %AND PTR = PTR+1 %AND ->INC INSERT(M'**',P_SPACOP) PTR = J; ->INC %FINISH %IF CH='/' %START %IF CH#NEXTNONSP(Inconst) %THEN INSERT('/',P_SPACOP) %AND ->INC INSERT(M'//',P_SPACOP) PTR = PTR+1; ->INC %FINISH %IF CH='!' %START %IF CH#NEXTNONSP(Inconst) %THEN INSERT('!',P_SPACOP) %AND ->INC INSERT(M'!!',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) PTR = PTR+1 ->INC %FINISH %IF CH=NEXTNONSP(Inconst)='<' %START INSERT(M'<<',P_SPACOP) PTR = PTR+1 ->INC %FINISH %IF CH='\' %START %IF CH#NEXTNONSP(Inconst) %THEN INSERT('\',P_SPACOP) %AND ->INC INSERT(M'\\',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) %AND PTR = PTR+1 ->INC BIP(1031): ! Chtype. CH = NEXTNONSP(Inconst) RES = False %UNLESS %C CH>Underline %AND X'80000000'>>(CH&31)&X'20C83000'#0 ->INC BIP(1030): ! ,'. CH = NEXTNONSP(Inconst) Res = False %IF CH=')' %IF Res=True %THEN OUTBUF(OBP) = ',' %AND OBP = OBP+1 %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='=' %THENSTART %IF NEXTNONSP(Inconst)=CH %THEN %C PTR = PTR+1 %AND INSERT(M'==',P_SPACOP) %AND ->INC INSERT('=',P_SPACOP) ->INC %FINISH %IF CH='#' %THENSTART %IF NEXTNONSP(Inconst)=CH %THEN %C PTR = PTR+1 %AND INSERT(M'##',P_SPACOP) %AND ->INC INSERT('#',P_SPACOP) ->INC %FINISH %IF CH='\' %AND NEXTNONSP(Inconst)='=' %THENSTART PTR = PTR+1 %IF NEXTNONSP(Inconst)='=' %THEN %C PTR = PTR+1 %AND INSERT(M'==\',P_SPACOP) %AND ->INC INSERT(M'=\',P_SPACOP) ->INC %FINISH %IF CH='>' %THENSTART %IF NEXTNONSP(Inconst)='=' %THEN %C PTR = PTR+1 %AND INSERT(M'=>',P_SPACOP) %AND ->INC INSERT('>',P_SPACOP) ->INC %FINISH %IF CH='<' %THENSTART %IF NEXTNONSP(Inconst)='=' %THEN %C PTR = PTR+1 %AND INSERT(M'=<',P_SPACOP) %AND ->INC %IF NEXTNONSP(Inconst)='>' %THEN %C PTR = PTR+1 %AND INSERT(M'><',P_SPACOP) %AND ->INC INSERT('<',P_SPACOP) ->INC %FINISH %IF CH='-' %AND NEXTNONSP(Inconst)='>' %THEN %C PTR = PTR+1 %AND INSERT(M'>-',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) %AND ->INC INSERT('=',P_SPACASS) ->INC %FINISH %IF CH='<' %AND NEXTNONSP(Inconst)='-' %THEN %C PTR = PTR+1 %AND INSERT(M'-<',P_SPACASS) %AND ->INC %IF CH='-' %AND NEXTNONSP(Inconst)='>' %THEN %C PTR = PTR+1 %AND INSERT(M'>-',P_SPACASS) %AND ->INC RES = False BIP(1008): ! Bighole. BIP(1010): ! Hole. BIP(1011): ! Mark. BIP(1013): ! Chkimps. BIP(1014): ! Dummyapp. BIP(1017): ! Liston. BIP(1018): ! List off. BIP(1020): ! Note const. BIP(1021): ! Trace. ->INC 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 BIP(1038): ! INCLUDE 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 SSALT = ALT %ANDRESULT = True %REPEAT %IF OBP>rsobj %START %FINISH PTR = rsptr; OBP = rsobj %RESULT = False %END !*********************************************************************** !* * !* Main calling routine. * !* * !*********************************************************************** OPT(S,P); ! Call option setting routine to set parameters. CONNECT(INFILE,0,0,0,REC,EFLAG); ! Open input file. %IF EFLAG#0 %THEN FAIL(EFLAG,5) %IF REC_FILETYPE#CHARFILE %THEN SETFNAME(INFILE) %AND FAIL(267,5) INPTR = REC_CONAD+REC_DATASTART; ! Start of data. DATAEND = REC_CONAD+REC_DATAEND; ! End of data. ! Set output stream, possibilities are: ! Terminal, file, same file or output device. %IF OUTF=".OUT" %THEN STREAM = TERMINAL %ELSESTART %IF INFILE=OUTF %THEN STREAM = SAMEFILE %ELSESTART %IF CHARNO(OUTF,1)='.' %START %IF DEVCODE(OUTF)<=0 %START ! Invalid output device. SETFNAME(OUTF) FAIL(264,5) %FINISHELSE STREAM = DEVICE %FINISHELSE STREAM = FILE %FINISH %FINISH ! Create tempory output file? %IF STREAM=SAMEFILE %OR STREAM=DEVICE %THEN %C Workfile = "T#".NEXTTEMP %ELSE Workfile = OUTF %IF STREAM#TERMINAL %START filesizeptr = 1 filesize = FSTABLE(filesizeptr) OUTFILE(Workfile,filesize,0,0,CONAD,EFLAG) %IF EFLAG#0 %THEN FAIL(EFLAG,5) OUTREC == RECORD(CONAD) Writeaddress = CONAD+OUTREC_DATASTART 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 Errors = 0; Line = 0; ERPTR = 0; CHARSIN = 0 STR = False STOP = False; SEMICOLON = False; INCREM = False; INLABEL = False ERSAVE = False %CYCLE Inconst = False; 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 line ".ITOS(Line+1). %C " ".ITOS(MAXITEM).SNL) Z = 1 %WHILE CHARTYPE(SC(Z))&ENDST=0 %CYCLE PRINTCH(SC(Z)) Z = Z+1 %REPEAT %IF SC(Z)=';' %THEN PRINTCH(';') NEWLINE SPACES(MAXPTR-1); PRINTCH('!'); NEWLINE Startline = Startline+1 %WHILE BYTEINTEGER(Startline)=' ' %IF STREAM#TERMINAL %START OBP = 1 ! Line failed - Input line to output routine. Z = BYTEINTEGER(Startline) %WHILE CHARTYPE(Z)&ENDST=0 %CYCLE %IF CHARTYPE(Z)"ES#0 %START STRDEL = Z OUTBUF(OBP) = STRDEL; OBP = OBP+1; Startline = Startline+1 Z = BYTEINTEGER(Startline) %WHILE Z#STRDEL %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 Errors = Errors+1 %FINISHELSESTART %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 line ".ITOS(Line).SNL) %FINISHELSE PRINTSTRING("SOAP80 fails -".FAILUREMESSAGE(TYPE)) %ANDSTOP %IF ACTION&1=1 %THEN CLOSEDOWN(False) %END %ROUTINE OPT(%STRING(255) PARM, %RECORD(PFORMAT) %NAME P) !*********************************************************************** !* THIS ROUTINE PROCESSES THE USER OPTION LIST * !*********************************************************************** %ROUTINESPEC READLINE %ROUTINESPEC SETLINE %INTEGERFNSPEC STOI(%STRINGNAME SNUM) %ROUTINESPEC ASK(%INTEGER OPTNO) %INTEGER I,J,TEMP,FLAG,PFILEVSN %STRING(80) LINE,OPTION,VALUE,FILENAME %CONSTINTEGER PROFVSN = 1 %SWITCH PROF(0:PROFVSN) %EXTERNALROUTINESPEC readprofile(%STRING(11) key, %NAME info, %INTEGERNAME version,uflag) %EXTERNALROUTINESPEC writeprofile(%STRING(11) key, %NAME info, %INTEGERNAME version,uflag) readprofile("Soap80",p,pfilevsn,flag) %IF flag>4 %START printstring( %C "Failed to read file SS#PROFILE. Defaults options assumed.".snl) pfilevsn = profvsn ->prof(0) %FINISH ->prof(pfilevsn) prof(0): ! Set default parameters for indenting. P_LINE = 80; ! Lines are broken into two if length is greater than 80 P_ICONTIN = 3; ! Continuation of line have an addition indentation of 3. P_POSCOM = 41; ! Position for right hand comments. P_MOVECOM = False; ! Main comment are indented with the program. P_UCKEY = True; ! Keywords output in upper case P_SEPKEY = False; ! Keywords togther are not split into two parts. P_SPACNAM = False; ! Spaces not left within names P_SPACASS = True; ! Spaces are added round assignment operators P_SPACOP = False; ! Spaces are not added round operators P_LCLIST = True; ! Const lists to be left alone P_IBLOCK = False; ! Block contents not indented w.r.t. block heading. P_ISTAT = False; ! Statements are aligned with declarations P_SEPLAB = False; ! Labels and statements may occupy the same line. ! Set default indentation values. P_TAB(0) = 0 P_TAB(1) = 6 P_TAB(I) = 3+3*I %FOR I = 2,1,10 P_TAB(I) = 5*I-15 %FOR I = 11,1,15 P_TAB(I) = 80 %FOR I = 16,1,20 prof(1): %IF pfilevsn#profvsn %START pfilevsn = profvsn writeprofile("Soap80",p,pfilevsn,flag) printstring("Profile file SS#PROFILE created and cherished.".snl) %C %IF flag=1 %FINISH ! Split up parameters and change default values. %IF PARM->FILENAME.(",").OUTF %START %UNLESS OUTF->OUTF.(",").PARM %THEN PARM = "" %FINISHELSE FILENAME = PARM %AND OUTF = PARM %AND PARM = "" INFILE = FILENAME %IF OUTF="" %THEN OUTF = FILENAME %IF PARM="" %THENRETURN %IF LENGTH(PARM)>0 %START TEMP = CHARNO(PARM,LENGTH(PARM)) %IF TEMP#'*' %AND TEMP#'?' %THEN PARM = PARM.",.END" %FINISH PROMPT("Soap80: ") %CYCLE %IF PARM="" %THEN READLINE %ELSE SETLINE %IF LINE="END" %OR LINE=".END" %THENRETURN ! End of parameter settings. %IF LINE="GO" %OR LINE=".GO" %THENRETURN ! End of parameter settings. %IF LINE="STOP" %OR LINE=".STOP" %THENSTOP; ! Abandon Soap80. %IF LINE="SAVE" %THEN WRITEPROFILE("Soap80",P,PFILEVSN,FLAG) %ELSEIF %C LINE="?" %START ! Print options so far. PRINTSTRING("Current option settings, given as".SNL) PRINTSTRING( %C " Option name:{current setting}Meaning of current setting". %C SNL.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') %ELSEIF j=true %THEN %C printsymbol('Y') %ELSE printstring(itos(j)) j = 1 %IF j>0 printstring("}".optmess(j,i).snl) %REPEAT PRINTSTRING("TAB :Indenting values are:".SNL) spaces(8) %FOR I = 1,1,20 %CYCLE PRINTSTRING(ITOS(P_TAB(I))) PRINTSYMBOL(':') %UNLESS I=20 %REPEAT NEWLINE %FINISHELSESTART %IF LINE->OPTION.("=").VALUE %AND VALUE#"" %START flag = 0 %FOR i = 1,1,maxopt %CYCLE %CONTINUEUNLESS 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') %ELSEIF j=true %THEN %C printsymbol('Y') %ELSE printstring(itos(j)) j = 1 %IF j>0 printstring("}".optmess(j,i).snl) %FINISHELSESTART %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." - ".failuremessage(320)) %ELSE %C p_optarr(i) = temp %FINISHELSE ask(i) %FINISH %EXIT %REPEAT %CONTINUEIF flag=1; ! Cycle found option name. %IF OPTION="TAB" %START ! Set indenting value. %IF value="?" %START PRINTSTRING("TAB :Indenting values are:".SNL) spaces(8) %FOR I = 1,1,20 %CYCLE PRINTSTRING(ITOS(P_TAB(I))) PRINTSYMBOL(':') %UNLESS I=20 %REPEAT NEWLINE %FINISHELSESTART I = 1 %WHILE I<=20 %AND VALUE#"" %AND VALUE#"*" %CYCLE TEMP = STOI(VALUE) %IF TEMP=-1 %THEN %C PRINTSTRING(VALUE." - ".FAILUREMESSAGE(320)) %AND %C VALUE = "*" %ANDEXIT P_TAB(I) = TEMP %IF LENGTH(VALUE)=0 %THEN %C VALUE = "*" %AND I = I+1 %ANDEXIT %IF CHARNO(VALUE,1)#':' %THENSTART PRINTSTRING(VALUE." - ".FAILUREMESSAGE(320)) I = 21 %FINISHELSE 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. %FINISHELSE PRINTSTRING(LINE." - ".FAILUREMESSAGE(321)) ! Ambiguous keyword. %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 %THENEXIT %IF CH=' ' %THENCONTINUE ! Convert lower to upper. LINE = LINE.TOSTRING(ONECASE(CH)) %REPEAT ! Return only if the line has some thing on it. %IF LENGTH(LINE)>0 %THENRETURN %REPEAT %END %ROUTINE SETLINE !*********************************************************************** !* SETLINE break 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 %ELSEIF S='N' %THEN %C p_optarr(i) = false %ELSE printstring("Answer Yes or No or ?".snl) %END %INTEGERFN STOI(%STRINGNAME 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 signaled by returning -1. * !*********************************************************************** %INTEGER I,INUM %UNLESS '0'<=CHARNO(SNUM,1)<='9' %THENRESULT = -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) %THENEXIT %REPEAT %IF I>=LENGTH(SNUM) %THEN SNUM = "" %ELSE %C SNUM = SUBSTRING(SNUM,I,LENGTH(SNUM)) %RESULT = INUM %END %END %END %ENDOFFILE