!* modified 06/03/86 !* %include "ftn_ht" %include "ftn_consts1" %include "ftn_fmts1" !* %include "ftn_asynt62" !* !*********************************************************************** !* Exports * !*********************************************************************** !* %integerfnspec Analstart(%record(Triadf)%arrayname Triads, %integer Adcom,%integername Count) !* !*********************************************************************** !* Imports * !*********************************************************************** !* %externalintegerfnspec Freesp(%integer I) %externalintegerfnspec Newlistcell(%integername Head,%integer N) %externalroutinespec Freelistcell(%integername Head,%integer N) %externalintegerfnspec Setlab(%integer Lab,%integername Ptr) %externalroutinespec Fault(%integer Er) %externalroutinespec Lfault(%integer Er) %externalroutinespec Ifault(%integer Er,I) %externalroutinespec Dicful %externalroutinespec Namesful %externalintegerfnspec Outputful %externalintegerfnspec Analful %externalroutinespec Alloc(%integer Ptr) %externalintegerfnspec Stack Space(%integer Length) %externalroutinespec Init Alloc(%integer Mode,Comad,Rel,Vers) %externalintegerfnspec Conin(%integer Val) %externalintegerfnspec Dictspace(%integer Len) %externalintegerfnspec Scalar Space(%integer Len,%integername IIN) %externalintegerfnspec Genfmt(%byteintegerarrayname Input,Type, %string(*)%name S) {%externalroutinespec Setfun(%integer Ptr)} %externalintegerfnspec New Subprogram(%integer Ptr,P1,Ctyp,%integername Er) %externalintegerfnspec Formal Parameter(%integer Ptr,Mode,Ctyp) %externalroutinespec Add Data Item(%integer Ptr,Count,Disp,L,Ad) %externalintegerfnspec Coerce Const(%integer A,Oldmode,Newmode, Adict,%integername Dptr) %externalintegerfnspec Generate(%record(Triadf)%arrayname Triads, %integername Nexttriad, %integer Lin,Path,Labrecad,Comad, %integerarrayname Output) %externalintegerfnspec Set Constant(%integer P1, %integername Pi21length,Pi21mode,Ctyp,Er, %record(Resf)%name Res, %byteintegerarrayname Input,Type) %externalintegerfnspec Setconrec(%record(Resf) Res) %externalroutinespec Init Input(%integer Acom) %externalintegerfnspec Readline(%byteintegerarrayname Input,Type, %integername Ltype) %externalroutinespec Read Next %externalintegerfnspec Next Label %externalroutinespec First Stat %externalintegerfnspec Include File(%string(255) S) %externalroutinespec Dumpdict(%integer I) !* !*********************************************************************** !* OWN variables * !*********************************************************************** !* %ownrecord(Comfmt)%name Com !* %owninteger CTYP,TTYP !* %ownintegerarray LHEAD(0:154) !* %OWNSTRING (32) IDENTIFIER,ERRIDEN,BLOCKDATAID !* !****** INITIALISE FOLLOWING TO ZERO AT START OF EACH SUBPROG %owninteger CGOLAB %owninteger NOTFLAG, PCT %owninteger BLOCKIFSTATE %owninteger DATAHEAD %owninteger CHARMASK %owninteger ASS CHECKLIST !****** %owninteger HASHVALUE %owninteger LIN %owninteger WARNLEN %owninteger COMAD;! address of common data %owninteger LTYPE %owninteger CRM4, CRM5 %owninteger DATALAST;! FOR DEFERRED INIT DATA %owninteger STATFNREC %owninteger SAVELIST !* %ownbyteintegerarray DEFAULT SIZE(0:8)= %c 0,X'51',X'52',X'53',X'54',X'05',X'62',X'31',X'63' !* %ownbyteintegerarray INPUT(0:1329) %ownbyteintegerarray TYPE(0:1329) !* %ownintegerarray IMPTYPE(65 : 90) = %C 2,2,2,2,2,2,2,2,1,1,1,1,1,1,2, 2,2,2,2,2,2,2,2,2,2,2 !* %constbyteintegerarray HEX(0 : 15) = %C '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F' !* %constbyteintegerarray MAPLTYPE(0 : 7) = 0,0,1,2,4,4,5,5;! USED IN MAIN !* %constbyteintegerarray NUMBYTES(0:7)=0(3),1,2,4,8,16 !* {%CONSTSTRING(6)%ARRAY GEN NAME(1:24)= %C } { "SQRT" ,"EXP" ,"LOG" ,"LOG10" , } { "SIN" ,"COS" ,"TAN" ,"COT" , } { "ASIN" ,"ACOS" ,"ATAN" ,"ATAN2" , } { "SINH" ,"COSH" ,"TANH" ,"ERF" , } { "ERFC" ,"GAMMA" ,"LGAMMA","ABS", } { "LGE" ,"LGT", "LLE", "LLT" } !* %constintegerarray FNHASH(0: 186)= %C X'00000000',X'00900366',X'00000000',X'00000000', X'00000000',X'002400D4',X'A934013E',X'00000000', X'0059021C',X'952500D8',X'00350144',X'00000000', X'00180090',X'002A00FA',X'00000000',X'001B00A0', X'00190094',X'002C0106',X'00000000',X'A51C00A6', X'00000000',X'00000000',X'002600DE',X'872700E4', X'00000000',X'00000000',X'00000000',X'9E2800EA', X'A6660272',X'83070028',X'007202BA',X'962B0100', X'840A0038',X'0008002C',X'007302C0',X'002D010C', X'9F0B003E',X'B265026C',X'0083031A',X'00870332', X'002900F2',X'00000000',X'8B1E00B2',X'002F011C', X'B37102B4',X'8E2100C2',X'85090032',X'A1310128', X'B02E0114',X'860C0044',X'00850326',X'90140072', X'88150078',X'004601AC',X'004A01C6',X'92160080', X'91380156',X'004701B2',X'005B0228',X'8F2000BC', X'A25A0222',X'A3300122',X'002300CE',X'0086032C', X'A44F01E6',X'0032012E',X'00580216',X'00000000', X'94170088',X'9D39015E',X'9C5F0240',X'0043019C', X'00690284',X'006B0290',X'00000000',X'004401A0', X'00000000',X'007802DC',X'97330136',X'00920370', X'00930376',X'005401FE',X'006D029C',X'980D004A', X'000E004E',X'00810310',X'80010000',X'000F0054', X'934501A6',X'00040012',X'81020006',X'00000000', X'00000000',X'00050018',X'00000000',X'00000000', X'B591036A',X'00000000',X'B65E023A',X'0040018A', X'0010005A',X'003D0178',X'0097038E',X'8203000C', X'00000000',X'003E017E',X'89060020',X'00000000', X'00620256',X'00000000',X'003B016C',X'00000000', X'0063025C',X'00000000',X'00000000',X'00980396', X'00420196',X'007D02FA',X'003F0184',X'00000000', X'00550204',X'007F0304',X'00000000',X'003C0172', X'0056020A',X'00640264',X'007E02FE',X'00000000', X'00110060',X'00120066',X'8A13006C',X'001A009A', X'001D00AC',X'8C1F00B6',X'002200C8',X'A736014A', X'00370150',X'003A0166',X'00410190',X'8D4801B8', X'AC4901BE',X'004B01CE',X'AF4C01D6',X'9B4D01DE', X'004E01E2',X'9A5001EA',X'005101EE',X'005201F2', X'005301F8',X'00570210',X'A05C022E',X'995D0234', X'B4600248',X'AA610250',X'00670278',X'0068027E', X'006A028A',X'006C0296',X'006E02A4',X'A86F02A8', X'007002AE',X'AB7402C6',X'007502CC',X'B17602D0', X'007702D6',X'007902E2',X'007A02E8',X'007B02EE', X'AE7C02F4',X'AD80030A',X'00820316',X'00840320', X'00880338',X'0089033E',X'008A0342',X'008B0348', X'008C034E',X'008D0354',X'008E035A',X'008F0360', X'0094037C',X'00950382',X'00960388',X'00000000', X'00000000',X'00000000',X'00000000' !* %ownbyteintegerarray Fnnames(0: 925)= %C 4, 83, 81, 82, 84, 0, 5, 68, 83, 81, 82, 84, 5, 81, 83, 81, 82, 84, 5, 67, 83, 81, 82, 84, 6, 67, 68, 83, 81, 82, 84, 0, 6, 67, 81, 83, 81, 82, 84, 0, 3, 69, 88, 80, 4, 68, 69, 88, 80, 0, 4, 81, 69, 88, 80, 0, 4, 67, 69, 88, 80, 0, 5, 67, 68, 69, 88, 80, 5, 67, 81, 69, 88, 80, 3, 76, 79, 71, 4, 65, 76, 79, 71, 0, 4, 68, 76, 79, 71, 0, 4, 81, 76, 79, 71, 0, 4, 67, 76, 79, 71, 0, 5, 67, 68, 76, 79, 71, 5, 67, 81, 76, 79, 71, 5, 76, 79, 71, 49, 48, 6, 65, 76, 79, 71, 49, 48, 0, 6, 68, 76, 79, 71, 49, 48, 0, 6, 81, 76, 79, 71, 49, 48, 0, 3, 83, 73, 78, 4, 68, 83, 73, 78, 0, 4, 81, 83, 73, 78, 0, 4, 67, 83, 73, 78, 0, 5, 67, 68, 83, 73, 78, 5, 67, 81, 83, 73, 78, 3, 67, 79, 83, 4, 68, 67, 79, 83, 0, 4, 81, 67, 79, 83, 0, 4, 67, 67, 79, 83, 0, 5, 67, 68, 67, 79, 83, 5, 67, 81, 67, 79, 83, 3, 84, 65, 78, 4, 68, 84, 65, 78, 0, 4, 81, 84, 65, 78, 0, 5, 67, 79, 84, 65, 78, 6, 68, 67, 79, 84, 65, 78, 0, 6, 81, 67, 79, 84, 65, 78, 0, 4, 65, 83, 73, 78, 0, 5, 65, 82, 83, 73, 78, 5, 68, 65, 83, 73, 78, 6, 68, 65, 82, 83, 73, 78, 0, 6, 81, 65, 82, 83, 73, 78, 0, 4, 65, 67, 79, 83, 0, 5, 65, 82, 67, 79, 83, 5, 68, 65, 67, 79, 83, 6, 68, 65, 82, 67, 79, 83, 0, 6, 81, 65, 82, 67, 79, 83, 0, 4, 65, 84, 65, 78, 0, 5, 68, 65, 84, 65, 78, 5, 81, 65, 84, 65, 78, 5, 65, 84, 65, 78, 50, 6, 68, 65, 84, 65, 78, 50, 0, 6, 81, 65, 84, 65, 78, 50, 0, 4, 83, 73, 78, 72, 0, 5, 68, 83, 73, 78, 72, 5, 81, 83, 73, 78, 72, 4, 67, 79, 83, 72, 0, 5, 68, 67, 79, 83, 72, 5, 81, 67, 79, 83, 72, 4, 84, 65, 78, 72, 0, 5, 68, 84, 65, 78, 72, 5, 81, 84, 65, 78, 72, 3, 69, 82, 70, 4, 68, 69, 82, 70, 0, 4, 81, 69, 82, 70, 0, 4, 69, 82, 70, 67, 0, 5, 68, 69, 82, 70, 67, 5, 71, 65, 77, 77, 65, 6, 68, 71, 65, 77, 77, 65, 0, 6, 76, 71, 65, 77, 77, 65, 0, 6, 65, 76, 71, 65, 77, 65, 0, 6, 68, 76, 71, 65, 77, 65, 0, 3, 76, 71, 69, 3, 76, 71, 84, 3, 76, 76, 69, 3, 76, 76, 84, 3, 73, 78, 84, 4, 73, 70, 73, 88, 0, 5, 73, 68, 73, 78, 84, 5, 73, 81, 73, 78, 84, 4, 82, 69, 65, 76, 0, 5, 68, 82, 69, 65, 76, 5, 81, 82, 69, 65, 76, 5, 70, 76, 79, 65, 84, 4, 83, 78, 71, 76, 0, 5, 83, 78, 71, 76, 81, 4, 68, 66, 76, 69, 0, 5, 68, 66, 76, 69, 81, 4, 81, 69, 88, 84, 0, 5, 81, 69, 88, 84, 68, 6, 68, 70, 76, 79, 65, 84, 0, 6, 81, 70, 76, 79, 65, 84, 0, 4, 81, 69, 88, 84, 0, 5, 67, 77, 80, 76, 88, 6, 68, 67, 77, 80, 76, 88, 0, 6, 81, 67, 77, 80, 76, 88, 0, 5, 73, 67, 72, 65, 82, 4, 67, 72, 65, 82, 0, 4, 65, 73, 78, 84, 0, 4, 68, 73, 78, 84, 0, 4, 81, 73, 78, 84, 0, 5, 65, 78, 73, 78, 84, 5, 68, 78, 73, 78, 84, 4, 78, 73, 78, 84, 0, 6, 73, 68, 78, 73, 78, 84, 0, 3, 65, 66, 83, 4, 73, 65, 66, 83, 0, 4, 68, 65, 66, 83, 0, 4, 81, 65, 66, 83, 0, 4, 67, 65, 66, 83, 0, 5, 67, 68, 65, 66, 83, 5, 67, 81, 65, 66, 83, 3, 77, 79, 68, 4, 65, 77, 79, 68, 0, 4, 68, 77, 79, 68, 0, 4, 81, 77, 79, 68, 0, 4, 83, 73, 71, 78, 0, 5, 73, 83, 73, 71, 78, 5, 68, 83, 73, 71, 78, 5, 81, 83, 73, 71, 78, 3, 68, 73, 77, 4, 73, 68, 73, 77, 0, 4, 68, 68, 73, 77, 0, 4, 81, 68, 73, 77, 0, 5, 68, 80, 82, 79, 68, 3, 77, 65, 88, 4, 77, 65, 88, 48, 0, 5, 65, 77, 65, 88, 49, 5, 68, 77, 65, 88, 49, 5, 81, 77, 65, 88, 49, 5, 65, 77, 65, 88, 48, 4, 77, 65, 88, 49, 0, 3, 77, 73, 78, 4, 77, 73, 78, 48, 0, 5, 65, 77, 73, 78, 49, 5, 68, 77, 73, 78, 49, 5, 81, 77, 73, 78, 49, 5, 65, 77, 73, 78, 48, 4, 77, 73, 78, 49, 0, 3, 76, 69, 78, 5, 73, 78, 68, 69, 88, 4, 73, 77, 65, 71, 0, 5, 65, 73, 77, 65, 71, 5, 68, 73, 77, 65, 71, 5, 81, 73, 77, 65, 71, 5, 67, 79, 78, 74, 71, 6, 68, 67, 79, 78, 74, 71, 0, 6, 81, 67, 79, 78, 74, 71, 0 !* %constintegerarray Fndetails(0: 156)= %C X'00000000',X'01000065',X'01446225',X'01557205', X'01665345',X'01776345',X'01887305',X'02000065', X'02446225',X'02557205',X'02665345',X'02776345', X'02887305',X'03000065',X'03335265',X'03446225', X'03557205',X'03665345',X'03776345',X'03887305', X'04000025',X'04335225',X'04446225',X'04557205', X'05000065',X'05446225',X'05557205',X'05665345', X'05776345',X'05887305',X'06000065',X'06446225', X'06557205',X'06665345',X'06776345',X'06887305', X'07000025',X'07446225',X'07557205',X'08000025', X'08446225',X'08557205',X'09000025',X'09000025', X'09446225',X'09446225',X'09557205',X'0A000025', X'0A000025',X'0A446225',X'0A446225',X'0A557205', X'0B000025',X'0B446225',X'0B557205',X'0C000026', X'0C446226',X'0C557205',X'0D000025',X'0D446225', X'0D557205',X'0E000025',X'0E446225',X'0E557205', X'0F000025',X'0F446225',X'0F557205',X'10000025', X'10446225',X'10557205',X'11000025',X'11446225', X'12000025',X'12446225',X'13000025',X'13000025', X'13446225',X'15DB0506',X'16DB0506',X'17DB0506', X'18DB0506',X'81010079',X'81315209',X'81416209', X'81517209',X'8303007D',X'83746309',X'83857309', X'83135109',X'83436209',X'83537209',X'84040079', X'84547209',X'84355209',X'84456209',X'84145109', X'84155109',X'85050029',X'8606007A',X'8607007A', X'8658720A',X'87D10509',X'881D5109',X'89000029', X'89446229',X'89557209',X'8A000029',X'8A446229', X'8B010029',X'8B416209',X'8C000079',X'8C115119', X'8C446229',X'8C557209',X'14635305',X'14746305', X'14857305',X'8D00003A',X'8D33522A',X'8D44622A', X'8D55720A',X'8E00003A',X'8E00001A',X'8E44622A', X'8E55720A',X'8F00003A',X'8F00001A',X'8F44622A', X'8F55720A',X'9034520A',X'9100003F',X'9111513F', X'9133522F',X'9144622F',X'9155720F',X'9213510F', X'9331520F',X'9400003F',X'9411513F',X'9433522F', X'9444622F',X'9455720F',X'9513510F',X'9631520F', X'97D10509',X'98D1050A',X'9900004D',X'9963534D', X'9974630D',X'9987730D',X'9A66534D',X'9A77634D', X'9A88730D',X'00000000',X'00000000',X'00000000', X'00000000' !* %ownintegerarray Fnspecials(0: 156)= %C X'00000000',X'00036000',X'00046006',X'0005A00C', X'00066012',X'0007A018',X'0008A020',X'00036028', X'0004602C',X'0005A032',X'00066038',X'0007A03E', X'0008A044',X'0003604A',X'0003604E',X'00046054', X'0005A05A',X'00066060',X'0007A066',X'0008A06C', X'00036072',X'00036078',X'00046080',X'0005A088', X'00036090',X'00046094',X'0005A09A',X'000660A0', X'0007A0A6',X'0008A0AC',X'000360B2',X'000460B6', X'0005A0BC',X'000660C2',X'0007A0C8',X'0008A0CE', X'000360D4',X'000460D8',X'0005A0DE',X'0003A0E4', X'0004A0EA',X'0005A0F2',X'000360FA',X'0003A100', X'00046106',X'0004A10C',X'0005A114',X'0003611C', X'00036122',X'00046128',X'0004A12E',X'0005A136', X'0003613E',X'00046144',X'0005A14A',X'00036150', X'00046156',X'0005A15E',X'00036166',X'0004616C', X'0005A172',X'00036178',X'0004617E',X'0005A184', X'0003618A',X'00046190',X'0005A196',X'0003A19C', X'0004A1A0',X'0005A1A6',X'0003A1AC',X'0004A1B2', X'0003A1B8',X'0004A1BE',X'0003A1C6',X'0004A1CE', X'000461D6',X'000041DE',X'000041E2',X'000041E6', X'000041EA',X'000041EE',X'000041F2',X'000041F8', X'000081FE',X'00004204',X'0000820A',X'00008210', X'00004216',X'0000421C',X'00008222',X'00004228', X'0000822E',X'00008234',X'0000823A',X'00008240', X'00008248',X'00008250',X'00004256',X'0000425C', X'00008264',X'0000426C',X'00004272',X'00036278', X'0004627E',X'0005A284',X'0003628A',X'00046290', X'00036296',X'0004629C',X'000362A4',X'000162A8', X'000462AE',X'0005A2B4',X'000662BA',X'0007A2C0', X'0008A2C6',X'000162CC',X'000362D0',X'000462D6', X'0005A2DC',X'000362E2',X'000162E8',X'000462EE', X'0005A2F4',X'000362FA',X'000162FE',X'00046304', X'0005A30A',X'00046310',X'00004316',X'0000431A', X'00004320',X'00004326',X'0000832C',X'00004332', X'00004338',X'0000433E',X'00004342',X'00004348', X'0000434E',X'00008354',X'0000435A',X'00004360', X'00006366',X'0000636A',X'00008370',X'00006376', X'0000437C',X'00008382',X'00006388',X'0000438E', X'00008396',X'00000000',X'00000000',X'00000000', X'00000000' !* %conststring(7)%array Bitfns(0:13)= "", "AND", "OR", "XOR", "NOT", "ISHFT", "IBITS", "IBSET", "BTEST", "IBCLR", "ISHFTC", "IAND", "IOR", "IEOR" !* %constintegerarray Bitfnsdet(0:13)= 0, X'C111511A',X'C211511A',X'C311511A',X'C4115119',X'C511511A', X'C611511B',X'C711511A',X'C81B511A',X'C911511A',X'CA11511A', X'CB11511A',X'CC11511A',X'CD11511A' !* %ownbyteintegerarray Bitfnsperm(0:13) !* %CONSTBYTEINTEGERARRAY IFCHECK(0:15)= %C 1, 229, 229, 230, 1, 2, 3, 0, 1, 2, 3, 0, 1, 207, 207, 0 !* %include "ftn_copy1" !* %integerfn FINDA(%integer PTR) !*********************************************************************** !* SEARCHES FOR NAME, SET IN IDENTIFIER, ON LIST WITH PTR AT THE * !* FIRST ITEM. HOWEVER, IF THE CURRENT STATEMENT IS A STATEMENT FN THE * !* LIST ON SFNPTR (THE FORMAL PARAMETER LIST) IS SEARCHED FIRST. IF * !* SUCCESSFUL TTYP IS SET FROM THE ENTRY, OTHERWISE A NEW ENTRY IS * !* ESTABLISHED AT DPTR, POINTED AT BY PTR AND WITH TYPE TTYP * !*********************************************************************** %integer I,J %record(PRECF) %name PP %record(SRECF) %name SS %if Com_Sfmk # 0 %thenstart; ! STATEMENT FN I = PTR PTR = Com_Sfptr %finishelse I = 0 SEARCH: %while PTR # 0 %cycle PP == record(Com_Adict+PTR) %if STRING(Com_Anames+PP_IDEN) = IDENTIFIER %thenstart TTYP = PP_TYPE %if Com_Xref#0 %and I=0 %thenstart;! XREF (not a stat fn param) J=FREESP(2) SS==record(Com_Adict+J) SS_INF0=Com_Linest SS_LINK1=PP_XREF PP_XREF=J %finish %result=PTR %finish PTR = PP_LINK1 %repeat %if I # 0 %thenstart; ! NOT A STATEMENT FN PARAMETER PTR = I I = 0 -> SEARCH %finish !* !******** NEW ENTRY SO CONSOLIDATE DICT ENTRY !* J=IDRECSIZE %if Com_Xref#0 %then J=J+XREFSIZE Ptr = Dictspace(J) PP == record(Com_Adict+PTR) %if Com_Namesfree+32 > Com_Nameslen %then NAMESFUL J=Com_Namesfree %if HOST=PERQPNX %or HOST=ACCENT %thenstart J=J>>1;! strings based on word addressing %finish STRING(Com_Anames+J) = IDENTIFIER PP_IDEN=J PP_COORD=0 PP_IIN=0 Com_Namesfree = Com_Namesfree + (LENGTH(IDENTIFIER) + 2)&X'FFFE' %if Com_Xref#0 %thenstart PP_LINE=Com_Linest;! line no of start of statement PP_XREF=0;! XREF chain %finish %if TTYP&X'F'=5 %thenstart;! CHARACTER PP_LEN=TTYP>>8 TTYP=5 %finish PP_TYPE=TTYP PP_LINK1 = LHEAD(HASHVALUE) LHEAD(HASHVALUE) = PTR CTYP = -1; ! TYPE NOT ABSOLUTELY DETERMINED %if Com_Warnlength#0 %thenstart %if LENGTH(IDENTIFIER)>6 %thenstart ERRIDEN=IDENTIFIER LENGTH(ERRIDEN)=4 LFAULT(201);! iden too long %finish %finish Com_Idcnt=Com_Idcnt+1;! for Op4 %result=PTR %end; ! FINDA !* %routine SETNAME !*********************************************************************** !* EXTRACT IDEN FROM INPUT RECORD AND SET IN IDENTIFIER * !*********************************************************************** %integer I,J %OWNBYTEINTEGERARRAY A(0 : 32) HASHVALUE = 0 WARNLEN = 0 I = 1 %while 1 <= TYPE(Com_Inp) <= 3 %cycle; ! A - Z, 0 - 9 %if I <= 32 %thenstart J = INPUT(Com_Inp) A(I) = J J=J&31 HASHVALUE = HASHVALUE+J %finishelsestart I=I-1 %finish I = I+1 Com_Inp = Com_Inp+1 %repeat A(0) = I-1 IDENTIFIER = STRING(ADDR(A(0))) %if I=2 %thenstart HASHVALUE=J+127 %finishelsestart HASHVALUE = (HASHVALUE-J+J<<3)&127 %finish %end; ! SETNAME !* %INTEGERFN LOCATE NAME(%STRING(*)%NAME NAME) !*********************************************************************** !* LOCATE DICTIONARY ENTRY FOR NAME. USE EXISTING ENTRY IF IT EXISTS * !* OTHERWISE CREATE A NEW ONE * !*********************************************************************** %integer I,J,K,PTR %OWNBYTEINTEGERARRAY A(0 : 32) HASHVALUE = 0; ! FOR HASH VALUE STRING(ADDR(A(0))) = NAME K=A(0);! to avoid pnximp bug %cycle I = 1,1,K J=A(I)&31 HASHVALUE = HASHVALUE+J %repeat IDENTIFIER = NAME HASHVALUE = (HASHVALUE-J+J<<3)&127 PTR = LHEAD(HASHVALUE) WARNLEN = 0 %result=FINDA(PTR) %end; ! LOCATE NAME !* %routine Check Do Index(%integer Rd,Dohead) %record(Dorecf) %name Dorec %while Dohead#0 %cycle Dorec==record(Com_Adict+Dohead) %if Dorec_Indexrd_W=Rd %thenstart;! NESTED USE OF DO VAR Lfault(147) %return %finish Dohead=Dorec_Link1 %repeat %end;! Check Do Index !* %routine CHECK SAVELIST !*********************************************************************** !* Check that all items in SAVE lists are valid * !*********************************************************************** %integer I,J,ER %record(SRECF) %name SS %record(PRECF) %name PP I=SAVELIST %while I#0 %cycle SS==record(Com_Adict+I) PP==record(Com_Adict+SS_INF0) IDENTIFIER=STRING(Com_Anames+PP_IDEN) J=PP_CLASS&X'1F' %if SS_INF3=1 %thenstart;! common %unless J=12 %thenstart ER=188;! not a common block ERROR: IFAULT(ER,SS_INF2) %finish %finishelsestart %if J&1#0 %then ER=184 %and ->ERROR;! argument %if J&2#0 %then ER=186 %and ->ERROR;! in common %if J&8#0 %thenstart %if J=12 %then ER=187 %else ER=185;! is a common block else procedure ->ERROR %finish %finish I=SS_LINK1 %repeat %end;! CHECK SAVELIST !* %routine CHECK ASSLIST %record(PRECF)%name ARR %record(SRECF)%name SS %integer I I=ASS CHECKLIST %while I#0 %cycle SS==record(Com_Adict+I) ARR==record(Com_Adict+SS_INF0) %if (ARR_CLASS&1=0 %or ARR_CLASS=8) %C %and ARR_CLASS#16 %thenstart;! not a dummy argument or 'this' fn or const %unless ARR_TYPE=CHARTYPE %and ARR_LEN#0 %thenstart IDENTIFIER=STRING(Com_Anames+ARR_IDEN) LFAULT(189);! assumed size invalid unless dummy argument %finish %finish I=SS_LINK1 %repeat Ass Checklist=0 %end;! CHECK ASSLIST !* %routine ADD TO ASSLIST(%integer REC) %record(SRECF)%name SS %integer PTR PTR=NEW LIST CELL(ASS CHECKLIST,2) SS==record(Com_Adict+PTR) SS_INF0=REC %end;! ADD TO ASSLIST !* !* !* !======================================================================= !* %routine TRACE(%STRING(63) S,%integer VAL) PRINTSTRING(S." ") WRITE(VAL,8) NEWLINE %end !* %integerfn ANALYSE(%record(TRIADF)%arrayname TRIADS, %integername NEXTTRIAD, %integer LTYPE,ADICT,%integername LINVAL, %integerarrayname Output) %routinespec FIND %routinespec CBNAME %integerfnspec SCAN(%integer CHAR) %routinespec GENERATERD %routinespec STRACE %integerfnspec GET NEXT VARIABLE %integerfnspec DATA IMPLIED DO %integerfnspec EQUIVALENCE %routinespec Notype %routinespec Report Error(%integer Index,Type,Errno) %integerfnspec Include %integer SAVELINK, II, IJ, PARAM, PATH, ROUT %integer ICOMP,OUTP,P,P1,P2,P3,TINP,DOIO,LL1,PTR,ER %integer I,J,K,L,M,N,SAVEP1,SPTR,RESL,RESR,PISW %integer GSTATE,SCOMP0,SCOMP1,LMAXOUTPUT %integer CHARLEN,CMNBLKPTR %integer CRM1,CRM3,CRM8,CRM10 %integer DIMSCOUNT %integer DOIOP,FNMK,HGOLAB,PI21LENGTH,PI21MODE %integer CCOUNT,VLISTHEAD,VLISTTAIL,VCOUNT,VMODE,VLENGTH,VDISP %integer IMPDOHEAD,CEXMODE,REPORTED ERROR,DOLEVEL %integer SAVEPTR,AINPUT,SAVEINDEX,IIN %record(RESF) RES %integerARRAY LDIM,UDIM(0:8) %record(PRECF) %name PP %record(PRECF) %name QQ %record(PRECF) %name DD %record(PRECF) %name CMNBLK %record(SRECF) %name SS %record(SRECF) %name SSS %record(ARRAYDVF) %name DVREC %record(PRECF) %name ARRAYREC %record(PRECF) %name STATFN %record(DORECF) %name DOREC %record(IFRECF) %name IFREC %record(LABRECF) %name LABREC %record(IMPDORECF) %name IMPDOREC !* %recordFORMAT SAVEFMT(%integer PARAM,II,IJ,SL,PATH,ROUT) !* %CONSTBYTEINTEGERARRAY STATE(0 : 14) = %C 3,8,0,0,0,7, 2,2,4,5,0,1,0,0,1 %CONSTINTEGERARRAY VALIDT(0 : 31) = 0,4,4,8,4,0,16,0, 0,2,8,16,1,0,0,0, 0,8,16,32,8,0,0,0, 0,0,0,0,2,0,0,0 %CONSTINTEGERARRAY VALIDST(0:31)=0,X'51',X'52',X'53',X'54',0,0,0, 0,X'41',X'62',X'63',X'34',0,0,0, 0,X'61',X'72',X'73',X'64',0,0,0, 0, 0, 0, 0,X'44',0,0,0 %recordformat DDOFMT(%integer START,CONTID,VALUE,INIT,INCR,FINAL,LEFT) %record(DDOFMT) %ARRAY DDO(1:7) %SWITCH PIEXIT(1 : 4) %SWITCH UP(0 : 3) %SWITCH PI(0 : 150) %SWITCH P210(1 : 18), P59(1 : 15), P53(1 : 14) !* {%include "pf_anal0"} !* %integerfunction SAVE %record (SAVEFMT) %name SAVEF %integer I !!printstring("Save ") !!write(saveindex,4) !!write(II,4) !!write(ij,4) !!write(savelink,4) !!write(path,4) !!write(rout,4) !!write(param,4) !!newline I=SAVEINDEX %if HOST=PERQPNX %or HOST=ACCENT %thenstart Saveindex=Saveindex+12 %finishelsestart Saveindex=Saveindex+24 %finish %if SAVEINDEX>=Com_Maxanal %thenstart %if ANALFUL#0 %thenstart ER=307 %result=1 %finish %finish SAVEF==record(Com_Saveanal+I) SAVEF_II=II SAVEF_IJ=IJ SAVEF_SL=SAVELINK SAVEF_PATH=PATH SAVEF_ROUT=ROUT SAVEF_PARAM=PARAM %result=0 %end;! SAVE !* %routine RESTORE %record (SAVEFMT) %name SAVE %integer I %if HOST=PERQPNX %or HOST=ACCENT %thenstart Saveindex=Saveindex-12 %finishelsestart Saveindex=Saveindex-24 %finish I=SAVEINDEX %if I<0 %then %MONITOR %and %STOP SAVE==record(Com_Saveanal+I) II=SAVE_II IJ=SAVE_IJ SAVELINK=SAVE_SL PATH=SAVE_PATH ROUT=SAVE_ROUT PARAM=SAVE_PARAM !!printstring("Restore") !!write(saveindex,4) !!write(II,4) !!write(ij,4) !!write(savelink,4) !!write(path,4) !!write(rout,4) !!write(param,4) !!newline %end;! RESTORE !* {end "pf_anal0"} !* AINPUT=ADDR(INPUT(0)) LMAXOUTPUT=Com_Maxoutput;! for faster local access GSTATE=1 DOIO=0 FNMK=0 Statfnrec=0 HGOLAB=0 DOIOP=0 IMPDOHEAD=0 CEXMODE=0 LL1=0 Com_Curstatclass=0 REPORTED ERROR=0 Com_Statement=0;! WILL NOTE CURRENT STATEMENT TYPE IF NEED TO KNOW ICOMP=SUB(2+LTYPE) II=0 IJ=0 ROUT=0 PARAM=0 PATH = 0 SAVELINK=0 OUTP=1 SAVEINDEX=0 PTR=0 !* {%include "pf_anal1"} !* I=Save !* {end "pf_anal1"} !* SAVELINK=1 ->L4 ! META-VARIABLE PI(1):II = ICOMP ICOMP = SUB(P1) PATH = 1 IJ = Com_Inp L7: !* {%include "pf_anal2"} !* %if SAVE#0 %then ->EXIT4 ROUT = PATH !* {end "pf_anal2"} !* L4: PIEXIT(1): EXIT1: %if HOST=PERQPNX %or HOST=ICL2900 %thenstart P=halfinteger(Com_Acomp+Icomp>>BSCALE) %finishelsestart P=shortinteger(Com_Acomp+Icomp>>BSCALE) %finish P1 = P&255 P = (P>>8)&255 ICOMP = ICOMP+2 ! ->PI(P) %if Com_Ptrace#0 %thenstart STRACE %finish -> PI(P) ! SINGLE CHARACTER PI(2): -> L2 %if P1 # Com_Nextch L11: Com_Inp = Com_Inp+1 L10: ICOMP = ICOMP+2 Com_Nextch = INPUT(Com_Inp) -> L4 ! SINGLE (OBLIGATORY) CHARACTER PI(3):%if P1#Com_Nextch %then ->SYNERR ->L11 ! STRING PI(4):I = SHEADS(P1) %unless Com_Nextch=SSTRING(I+1) %then ->L2 J = SSTRING(I) %cycle K = 1,1,J-1 -> L2 %if INPUT(Com_Inp+K) # SSTRING(I+K+1) %repeat Com_Inp = Com_Inp+J -> L10 ! @ SYMBOL PI(6):PARAM = RES_W II = ICOMP ICOMP = ICOMP+2 IJ = Com_Inp PATH = 2 -> L7 ! SINGLE (OPTIONAL) CHARACTER PI(7):%if P1=Com_Nextch %thenstart Com_Inp=Com_Inp+1 Com_Nextch=INPUT(Com_Inp) %finish ICOMP=ICOMP+2 ->L4 ! PI(9): %if HOST=PERQPNX %or HOST=ICL2900 %thenstart Icomp=halfinteger(Com_Acomp+Icomp>>BSCALE) %finishelsestart Icomp=shortinteger(Com_Acomp+Icomp>>BSCALE) %finish ->L4 ! PIZERO: ! END OF DEFINITION PI(0): -> L1 %if ROUT = 1 !* %if HOST=PERQPNX %or HOST=ICL2900 %thenstart Param=halfinteger(Com_Acomp+Icomp>>BSCALE) %finishelsestart Param=shortinteger(Com_Acomp+Icomp>>BSCALE) %finish !* LIN = -OUTP UP2: UP(2): OUTPUT(OUTP) = PARAM OUTP = OUTP+1 %if OUTP>=LMAXOUTPUT %thenstart %if OUTPUTFUL#0 %thenstart ER=307 ->EXIT4 %finish LMAXOUTPUT=Com_Maxoutput %finish RET: !* {%include "pf_anal4"} !* RESTORE !* {%include "pf_anal4"} !* %if SAVELINK=0 %then LINVAL=LIN %and %result=1 %if PATH=2 %then ->UP2 %if PATH=0 %then ->UP0 UP(1):ICOMP = II+2 PARAM = LIN II = ICOMP+2 IJ = Com_Inp PATH = 2 -> L7 UP0: UP(0):ICOMP = II %if Com_Maxinp>BSCALE) %finishelsestart Icomp=shortinteger(Com_Acomp+Icomp>>BSCALE) %finish !* -> L4 %unless ICOMP = 0 !* {%include "pf_anal6"} !* RESTORE !* {end "pf_anal6"} !* PATH = 0 %if SAVELINK=0 %then LINVAL=LIN %and %result=1 ->UP(PATH) !* L1: %if HOST=PERQPNX %or HOST=ICL2900 %thenstart Lin=halfinteger(Com_Acomp+Icomp>>BSCALE) %finishelsestart Lin=shortinteger(Com_Acomp+Icomp>>BSCALE) %finish ->RET !* SYNERR:ER=100;! SYNTAX ERROR PIEXIT(4): EXIT4P:FAULT(ER);! WITH POINTER ->UP3 EXIT4:LFAULT(ER) UP3: %if Com_Sfmk#0 %then STATFN_CLASS=0 %and STATFN_X0=0;! prevent consequent failure after bad stat fn UP(3):%result = 3 ! ---------------------------------------------------------------------- LLFAULT:LFAULT(ER) ->EXIT1 !* PI(127): !*********************************************************************** !* Fast search for statements * !*********************************************************************** %if 'A'<=Com_Nextch<='Z' %then ICOMP=LOOKUP(Com_Nextch-'A') ->EXIT1 !* PI(128): !*********************************************************************** !* Avoid operator search if not possible * !*********************************************************************** ICOMP=ICOMP+2 %unless 9<=TYPE(Com_Inp)<=10 %then ->EXIT2;! unless * / + - > ! & ^ # ICOMP=ICOMP+2 ->EXIT1 !* PI(17): !*********************************************************************** !* FOLLOWING ARITHMETIC IF LABEL CHECK IF SAME AS NEXT LABEL * !*********************************************************************** %if CRM1 = Next Label %then RES = 0 -> EXIT1 !* PI(18): !*********************************************************************** !* BEFORE PROCESSING LABEL LIST TO ARITHMETIC IF DETERMINE * !* VALUE OF LABEL (IF ANY) TO NEXT STATEMENT * !*********************************************************************** CRM1 = Next Label -> EXIT1 !* PI(19): !*********************************************************************** !* P1=1 END STATEMENT * !* 0 ENTRY * !*********************************************************************** Com_Labwarn = 0 %if P1=0 %then ->EXIT1;! ENTRY %if Com_Statordermode>3 %and Com_Subprogtype=5 %then LFAULT(305);! exec stats in BLOCKDATA %if BLOCKIFSTATE#0 %then LFAULT(208);! missing ENDIF CHECK SAVELIST CHECK ASSLIST {2900 %if Com_Itsmode=1 %then FAULTNUM(173);! comment re ITS} !PPROFILE -> EXIT1 !* PI(20): !*********************************************************************** !* NOTE DATA TYPE * !* P1 =X'00' undefined * !* X'01' INTEGER * !* X'02' REAL * !* X'03' COMPLEX * !* X'04' LOGICAL * !* X'05' CHARACTER * !* X'06' DOUBLE PRECISION * !* X'07' BYTE * !* X'08' DOUBLE COMPLEX * !*********************************************************************** CRM8 = DEFAULT SIZE(P1) CHARLEN=1 -> EXIT1 !* PI(21): PI21: !*********************************************************************** !* SET UP NEXT IDENTIFIER OR CONSTANT FROM THE INPUT RECORD * !* ON ENTRY P1 INDICATES THE TYPE OF FIELD EXPECTED, AS FOLLOWS * !* P1 = 0 ANY FIELD * !* 1 IDENTIFIER * !* 3 INTEGER * !* 4 CONSTANT * !* 5 DATA CONSTANT * !* 6 COMPLEX CONSTANT (IF NOT EXITS TO ALTERNATIVE SYNTAX) * !* 7 OPTIONAL IDEN * !* ON EXIT CTYP IS SET AS FOLLOWS * !* CTYP = -1 'NEW' IDENTIFIER * !* 0 IDENTIFIER * !* 1 INTEGER * !* 2,10 REAL * !* 3,11 COMPLEX * !* 4 LOGICAL * !* 5 CHARACTER OR HOLLERITH * !* 6 HEX * !* 7 BLOCKDATA IDENTIFIER * !* FOR CTYP = -1 OR 0 PTR ADDRESSES THE DICT RECORD * !* CONSTANTS ARE SET IN A RECORD AT DPTR * !* PI21INT CONTAINS THE VALUE SET FOR INTEGER AND LOGICAL CONSTANTS * !* PI21LENGTH CONTAINS THE LENGTH OF THE CONSTANT FOR CTYP > 0 * !*********************************************************************** P3 = 0 P2 = 0 TINP = Com_Inp SAVEP1=P1 %if SAVEP1=7 %then P1=1 %and BLOCKDATAID="" DD == record(Com_Adict+Com_Dptr) -> P210(TYPE(Com_Inp)) !******** $ P210(2): -> Synerr !******** A - Z P210(1): TTYP = IMPTYPE(INPUT(Com_Inp)); ! IMPLICIT TYPE FOR ALPHABETIC CHAR PI21IDEN: %if P1 <= 2 %or P1=5 %thenstart;! IDENTIFIER REQUIRED, OR ACCEPTABLE CTYP = 0; ! IDENTIFIER %if TYPE(Com_Inp+1)>3 %thenstart;! single letter - try fast search %if P1=5 %and Input(Com_Inp+1)='''' %thenstart %if Com_Nextch='X' %or Com_Nextch='Z' %or Com_Nextch='O' %c %or Com_Nextch='B' %thenstart;! could be a hex const N=Com_Nextch I=Com_Inp+2 K=I Hloop1: J=Input(K) %if J=10 %or K>1328 %then ->Bad Const %if J='''' %thenstart %if I=K %or I+16Bad Const Com_Inp=K+1 Com_Nextch=Input(Com_Inp) ->Set Hex %finish K=K+1 ->Hloop1 %finish %finish %if Com_Sfmk=0 %and Com_Xref=0 %thenstart J=INPUT(Com_Inp) PTR=LHEAD(J+63) %if PTR#0 %thenstart;! seen it before PP==record(Com_Adict+PTR) LENGTH(IDENTIFIER)=1 CHARNO(IDENTIFIER,1)=J TTYP=PP_TYPE Com_Inp=Com_Inp+1 Hashvalue=J&31+127 ->GOTID %finish %finish %finish SETNAME FIND; ! WILL SET CTYP=-1 IF A 'NEW' IDENTIFIER GOTID: RES_W=PTR PI21MODE=SETMODE(TTYP&X'3F');! TO ALLOW DIMENSION EXPRESSION ANALYSIS %if P1=5 %thenstart;! must be a constant name %if PP_CLASS=16 %thenstart CTYP=PP_TYPE RES_W=PP_CONSTRES Com_Pi21int=RES_H0 %if Res_Form=1 %and Res_Mode=1 %then %C Com_Pi21int=integer(Com_Adict+Com_Pi21int<PI21EXIT %finishelsestart %if Input(Tinp)='Z' %thenstart;! could be 'old' hex I=Tinp+1 K=Com_Inp N='Z' Set Hex: integer(Com_Adict+Com_Dptr)=0 L=K-I;! no of hex chars M=0 %if N='O' %thenstart %while L>0 %cycle J=Input(I) I=I+1 %unless '0'<=J<='7' %then ->Bad Const M=(M<<3)!(J&7) L=L-1 %repeat ->Set Hex2 %finish %if N='B' %thenstart %while L>0 %cycle J=Input(I) I=I+1 %unless '0'<=J<='1' %then ->Bad Const M=(M<<1)!(J&1) L=L-1 %repeat Set Hex2: %if Bscale=1 %then N=2 %else N=4 integer(Com_Adict+Com_Dptr+N)=M %finish %while L>0 %cycle J = Input(I) I=I+1 %if 'A'<=J<='F' %or 'a'<=J<='f' %thenstart J=J&15+9 %finishelsestart %if '0'<=J<='9' %then J=J&15 %else ->Bad Const %finish M=(M<<4)!J L=L-1 %if L&7=0 %thenstart N=4-L>>1 %if Bscale=1 %then N=N>>1 integer(Com_Adict+Com_Dptr+N)=M M=0 %finish %repeat Res_H0=Com_Dptr>>DSCALE; RES_H1=X'100'!HEXCONST Com_Dptr=Com_Dptr+8 Ctyp = 6; ! hex constant Pi21length=8 Pi21mode=HEXCONST !! Report Error(8,0,353);! non-standard -> Pi21exit %finish Bad Const: Er=116 ->Exit4p %finish %finish %if SAVEP1=7 %then BLOCKDATAID=IDENTIFIER PI21EXIT:Com_Nextch = INPUT(Com_Inp) -> EXIT1 %finish %if P1 = 6 %thenstart; ! SWITCH TO ALTERNATIVE SYNTAX(NOT COMPLEX CONST) SWITCH: Com_Inp = TINP ICOMP = ICOMP+2 Com_Nextch = INPUT(Com_Inp) -> EXIT2 %finish ->Bad Const !* !******** 0 - 9 P210(3): ER = 144; ! VARIABLE NOT FOUND WHEN EXPECTED -> EXIT4P %if P1 = 1; ! IDENTIFIER REQUIRED !* !****** NON-ALPHANUMERICS P210(4): P210(7): P210(8): P210(9): P210(10): P210(11): P210(13): P210(14): P210(15): P210(16): P210(17): P210(18): !****** CHARACTER P210(5): Call Set: I=Set Constant(P1,Pi21length,Pi21mode,Ctyp,Er,Res,Input,Type) %if I=0 %then ->Pi21exit %if I=2 %then ->Switch ->Exit4p !* !****** END OF STATEMENT P210(12): ER = 104 %if SAVEP1=7 %then ->PI112 -> EXIT4 !* PI(22): !*********************************************************************** !* CHECK THAT INT AFTER * IS VALID - MODIFY CRM8 IF NECESSARY * !*********************************************************************** %if CRM8=5 %thenstart;! CHARACTER %unless 0EXIT1 %finish L22A: LFAULT(242);! warn about use of * Com_Inhibop4=1 L = CRM8&7 %unless Com_Pi21int = VALIDT(L) %thenstart L = L+8 %unless Com_Pi21int=VALIDT(L) %thenstart L=L+8 %unless Com_Pi21int=VALIDT(L) %thenstart L=L+8 %unless Com_Pi21int=VALIDT(L) %then FAULT(124) %and ->EXIT1 %finish %finish %finish %if P=24 %then PP_TYPE=VALIDST(L) %else CRM8=VALIDST(L) -> EXIT1 !* PI(23): !*********************************************************************** !* EXPLICITLY SETS TYPE (CRM8) IN CURRENT PREC, CHECKING VALIDITY * !*********************************************************************** SAVEPTR=PTR;! saved for resetting in PI24 if necesary I = PP_CLASS %if I = 12 %then CBNAME %and I = PP_CLASS IDENTIFIER =STRING(Com_Anames+PP_IDEN) J = PP_X0 %if J&8 = 0 %thenstart; ! NOT ALREADY TYPED %if I&X'1F' <= 8 %or (I = 11 %and Com_Subprogtype = 2) %C %thenstart ! SCALAR OR ARRAY OR EXTERNAL FN OR 'THIS FN' ! CONSTANT NAME TREATED AS SCALAR PP_X0=J!8; ! INDICATES THAT TYPE IS SET EXPLICITLY PP_TYPE=CRM8 %if CRM8 = 5 %thenstart PP_LEN=CHARLEN;! default character length %if CHARLEN=0 %thenstart L231: ADD TO ASSLIST(ADDR(PP_CLASS)-Com_Adict) %finish %finish -> EXIT1 %finishelsestart %if I&X'10'#0 %then J=239 %else J=270 ! name cannot be typed after it has appeared in a PARAMETER statement ! else name must not appear in a type statement LFAULT(J) ->EXIT1 %finish %finish LFAULT(269); ! already typed ->EXIT1 !* PI(24): !*********************************************************************** !* OVERRIDE EXPLICIT TYPE SETTING AFTER * * !*********************************************************************** %if CRM8=5 %thenstart %unless 0L231;! check that it is an arg ->EXIT1 %finish -> L22A !* PI(25): !*********************************************************************** !* AFTER ( IN DIMENSION LIST * !*********************************************************************** %cycle I = PP_CLASS %if I&X'C' = 0 = PP_X1&3 %then %exit; ! NOT SUBPROG OR ARRAY OR USED ER = 254; ! WRONG CLASS OF VAR DIMENSIONED OR ARRAY ALREADY %if I&X'C'=4 %then ER=262;! ALREADY AN ARRAY %unless I = 12 %then -> EXIT4; ! FAULT UNLESS COMMON BLOCK NAME CBNAME %repeat ARRAYREC==record(Com_Adict+PTR);! REMEMBER THE CURRENT IDEN RECORD CEXMODE=3 DIMSCOUNT = 0 Com_Cexpdict=0 -> EXIT1 !* PI(26): !*********************************************************************** !* Following dimension value * !* P1 = 0 after lower, or only, bound * !* 1 after upper bound * !*********************************************************************** Com_Curstatclass=1 %if Com_Statordermode>2 %then LFAULT(236) Com_Statordermode=2 GENERATE RD I=RES_FORM&X'F';! form of expression %if I<=1 %thenstart;! integer const K=RES_H0 %if I#0 %thenstart K=K<>DSCALE; Res_Form=7; Res_Mode=1 %finish K=RES_W!X'80000000' %if ARRAYREC_CLASS&1=0 %thenstart %if ARRAYREC_CLASS=2 %thenstart IDENTIFIER=STRING(Com_Anames+ARRAYREC_IDEN) ER=251;! adjustable dims ->EXIT4 %finish ARRAYREC_CLASS=X'61' I=PTR PTR=NEW LIST CELL(Com_Checklist,3) SS==record(Com_Adict+PTR) SS_INF0=ADDR(ARRAYREC_CLASS)-Com_Adict SS_INF2=1;! CHECK IF PARAM PTR=I %finishelsestart %unless ARRAYREC_CLASS=X'61' %then ARRAYREC_CLASS=X'41' %finish %finish !***** entered from PI(114) after *) in dimension list PI26B:%if DIMSCOUNT <= 7 %thenstart %if P1=0 %thenstart;! after lower, or only, bound DIMSCOUNT=DIMSCOUNT+1 LDIM(DIMSCOUNT)=1 %finishelsestart LDIM(DIMSCOUNT)=UDIM(DIMSCOUNT) %finish UDIM(DIMSCOUNT)=K %finish Com_Cexpdict=0 -> EXIT1 !* PI(27): !*********************************************************************** !* INTRODUCE BLANK COMMON, I.E. AFTER COMMON OR // * !*********************************************************************** PTR = BLCMPTR PP == record(Com_Adict+PTR) %if PP_LAST = BLCMPTR %then CTYP = -1 %else CTYP = 0 !* PI(28): !*********************************************************************** !* INTRODUCE LABELLED COMMON, I.E. AFTER // * !*********************************************************************** Com_Curstatclass=1 %if Com_Statordermode>2 %then ER=236 %and ->EXIT4 Com_Statordermode=2 { %cycle } Pi28b: CMNBLKPTR = PTR %if CTYP = -1 %thenstart; ! FIRST USE - ESTABLISH REFERENCE Pi28a: PP_CLASS=12; ! COMMON BLOCK NAME PP_ADDR4 = Com_Cbnptr Com_Cbnptr = PTR PP_CMNLENGTH = 0 PP_LAST = PTR; ! LAST ITEM LINK TO ITSELF I=Dictspace(CMNRECEXT); ! RESERVE THE EXTRA DICT WORDS PP_CMNREFAD=0;! no reference set -> EXIT1 %finish I = PP_CLASS -> EXIT1 %if I = 12; ! COMMON BLOCK ENTRY ALREADY ESTABLISHED ER = 121; ! ILLEGAL USE OF BLOCK NAME CMNBLKPTR = -1; ! UNLESS SET > 0 WILL INDICATE INVALID BLOCK NAME -> LLFAULT %if 8 < I < 12 CBNAME ->Pi28b { %repeat } !* PI(29): !*********************************************************************** !* AFTER IDEN IN COMMON LIST * !*********************************************************************** %if CMNBLKPTR < 0 %then -> EXIT1; ! INVALID BLOCK NAME ALREADY REPORTED %if PP_CLASS = 12 %then CBNAME I = PP_CLASS J = PP_X1 %unless I&X'7B' = 0 %and J&1=0 %thenstart; ! IF PARAM, (ALREADY) COMMON, INITIALISED OR USED J=I&X'7B' %if J#0 %thenstart ER=142;! SUBPROGRAM NAME %if J=1 %then ER=123;! PARAMETER %if J=2 %then ER=122;! ALREADY IN COMMON %if J=16 %then ER=240;! SYMBOLIC CONSTANT NAME %if J&64#0 %then ER=251;! adjustable dims %finishelse ER=236;! ALREADY USED OR INITIALISED ->LLFAULT %finish PP_CLASS=I!2; ! SET COMMON MARKER PP_X0=PP_X0!4; ! scalar in array or common area PP_Link3 = CMNBLKPTR>>DSCALE CMNBLK == record(Com_Adict+CMNBLKPTR) QQ == record(Com_Adict+CMNBLK_LAST); ! PREVIOUS LAST ITEM IN THIS COMMON AREA QQ_LINK2 = PTR CMNBLK_LAST = PTR %if J&4 # 0 %thenstart; ! IF 'EQUIVALENCED FROM' L = PP_LINK2; ! LINK TO CORRESPONDING EQUIV CHAIN ENTRY PP_LINK2=0 PP_X1=J&X'F3'; ! CLEAR EQUIVALENCE MARKERS ! ALLOC(PTR); ! FORCES ALLOCATION OF COMPLETE COMMON AREA ! SS == record(Com_Adict+L); ! EQUIV CHAIN ENTRY ! SS == record(Com_Adict+SS_LINK1); ! NEXT CHAIN ENTRY ! PTR = SS_INF0; ! CORRESPONDING DICT RECORD ! ALLOC(PTR); ! COMPLETE CHAIN %finish -> EXIT1 !* PI(30): !*********************************************************************** !* INITIALISATION FOR DATA OR EQUIVALENCE LIST * !*********************************************************************** Com_Curstatclass=1 CRM3 = 0; ! -1 ERROR DETECTED VLISTHEAD = 0; ! LISTHEAD OF LIST RECORDS FORMAT SS CCOUNT = 1; ! DEFAULT MULTIPLIER IN DATA INIT, USED IN EQUIV TO ! CHECK THAT <= 1 COMMON IS INCLUDED VCOUNT=0;! to ensure data init calls GET NEXT VARIABLE Com_Labwarn=0;! to avoid 'inaccessable statement' messages -> EXIT1 !* PI(31): !*********************************************************************** !* MAKE A SCALAR ENTRY TO LIST (IN TYPE STATEMENT AFTER / INDICATING * !* INITIALISATION FOR PREVIOUS ITEM) * !*********************************************************************** %if P1=1 %thenstart PTR=DOIOP;! saved by PI32(1) PP==record(Com_Adict+PTR) %finish %if PP_CLASS = 12 %then CBNAME ER = 301; ! WRONG CLASS OF VARIABLE IN DATA OR EQUIVALENCE LIST %if PP_CLASS&X'19' # 0 %then CRM3 = -1 %and -> LLFAULT ! CONFLICT WITH PARAM OR SUBPROG NAME I = 0 PI31A: -> EXIT1 %if CRM3 = -1; ! PREVIOUS ERROR L = PTR PTR=FREESP(5) SS==record(Com_Adict+PTR) !****** Following code inserted to process char substrings %if P1=1 %thenstart;! substring RES_W=Com_Rescom1; J=RES_H0; %if J=0 %then J=1;! lower bound RES_W=Com_Rescom2; K=RES_H0; %if K=0 %then K=PP_LEN;! upper bound SS_INF4=K-J+1;! substring length I=I+J-1 Com_Rescom1=0 Com_Rescom2=0 %finishelse SS_INF4=0 SS_INF2 = I; ! DISPLACEMENT FROM BASE ADDRESS (!X'1000000' FOR ARRAY ELEMENT) SS_INF3=Com_Linest SS_INF0 = L %unless VLISTHEAD = 0 %thenstart SS == record(Com_Adict+VLISTTAIL) SS_LINK1 = PTR %finishelse VLISTHEAD = PTR VLISTTAIL = PTR; ! POINTER TO LAST ITEM ON LIST -> EXIT1 !* PI(32): !*********************************************************************** !* SAVE DPTR VALUE BEFORE PROCESSING DIMENSION IN LIST ARRAY ELEMENT * !*********************************************************************** %if P1=1 %thenstart;! insertion for substrings DOIOP=PTR;! saved for resetting in PI31(1) Com_Rescom1=0 Com_Rescom2=0 %if SCAN(':')=0 %thenstart;! no substring ICOMP=ICOMP+2 ->EXIT2 %finish %finishelse DIMSCOUNT=0 -> EXIT1 !* PI(33): !*********************************************************************** !* PRESERVE INTEGER DIMENSION VALUE EVALUATED BY PI21 * !*********************************************************************** Com_Rescom1=0 Com_Rescom2=0 DIMSCOUNT = DIMSCOUNT+1 %if DIMSCOUNT <= 7 %then LDIM(DIMSCOUNT) = Com_Pi21int -> EXIT1 !* PI(34): !*********************************************************************** !* AFTER ) TO DIMENSION LIST IN DATA STATEMENT * !* CALCULATE BYTE DISPLACEMENT OF ELEMENT AND MAKE LIST ENTRY * !*********************************************************************** %if P1=1 %thenstart PTR=DOIOP;! saved by PI32(1) PP==record(Com_Adict+PTR) %finish %if PP_CLASS=12 %then CBNAME ER = 245; ! SUBSCRIPTED VARIABLE NOT ARRAY NAME %unless PP_CLASS&13 = 4 %thenstart %if PP_CLASS&4#0 %then ER=301 PI34ERR: CRM3 = -1 -> EXIT4 %finish DVREC == record(Com_Adict+PP_ADDR4) J = DVREC_DIMS PI34A:I=1;! to avoid IMP compiler bug L = LDIM(I)-DVREC_B(I)_L ER = 264; ! WRONG NO. OF SUBSCRIPTS %if Dimscount # J %thenstart %if Dimscount#1 %or Com_Allowvax=NO %then ->Pi34err %cycle I=1,1,J %unless Dvrec_B(I)_L=1 %then ->Pi34err %repeat Lfault(337) %finish %if DIMSCOUNT > 1 %thenstart L = L+DVREC_B(1)_L %cycle I = 2,1,J L = L+DVREC_B(I-1)_M*LDIM(I) %repeat L = L-DVREC_ZEROTOFIRST %finish ER = 232 %unless 0 <= L < DVREC_NUMELS %then %C IDENTIFIER=STRING(Com_Anames+PP_IDEN) %and -> PI34ERR ! OUTSIDE DECLARED BOUNDS %if PP_TYPE=5 %then J=PP_LEN %else %C J=NUMBYTES(PP_TYPE>>4);! BYTES PER ITEM %if PP_TYPE&7=3 %then J=J<<1;! COMPLEX I = (L*J)!X'1000000' -> PI31A !* PI(35): !*********************************************************************** !* FOLLOWING CLOSING ) TO ARRAY DECLARATION * !*********************************************************************** Com_Curstatclass=1 %if Com_Statordermode>2 %then LFAULT(236) Com_Statordermode=2 ER = 247; ! MORE THAN 7 DIMENSIONS %if DIMSCOUNT > 7 %then -> EXIT4 J = ARRAYREC_CLASS ARRAYREC_CLASS=J!4;! array marker I = Dictspace(DVRECSIZE+12*DIMSCOUNT);! LINK TO DOPE VECTOR DVREC == record(Com_Adict+I) DVREC_DIMS = DIMSCOUNT %if J&1 # 0 %thenstart; ! PARAMETER ARRAY DVREC_ADFIRST = ARRAYREC_ADDR4;! DVAREA ADDRESS OF PARAM DESCRIPTOR %finishelse DVREC_ADFIRST=0 ARRAYREC_ADDR4 = I N=0 L=0; M=1 %cycle I=1,1,DIMSCOUNT J=LDIM(I) K=UDIM(I) DVREC_B(I)_L=J DVREC_B(I)_U=K %if J&X'E0000000'=X'80000000' %or %C K&X'E0000000'=X'80000000' %thenstart;! adjustable dimension %if J&X'E0000000'#X'80000000' %and N=0 %then L=L+M*J N=1 PI35A: DVREC_B(I)_M=-1 Com_Inhibop4=1 %finishelsestart %unless J<=K %or K&X'E0000000'=X'A0000000' %C %then FAULT(231) %and K=J;! bounds inside out %if N#0 %then ->PI35A;! already know it is adjustable %if K&X'E0000000'=X'A0000000' %then K=0;! AVOID INTOVERFLOW L=L+M*J M=M*(K-J+1) DVREC_B(I)_M=M %finish %repeat %if DVREC_B(DIMSCOUNT)_U&X'E0000000'=X'A0000000' %thenstart ARRAYREC_CLASS=ARRAYREC_CLASS!X'80';! assumed size ADD TO ASSLIST(ADDR(ARRAYREC_CLASS)-Com_Adict) %finish DVREC_NUMELS = M;! at least as far as can be DVREC_ZEROTOFIRST = L;! computed at compile time DVREC_ELLENGTH=NUMBYTES(ARRAYREC_TYPE>>4);! will be updated if nec. by ALLOC Dvrec_Addrzero=Dvrec_Zerotofirst*Dvrec_Ellength -> EXIT1 !* PI(36): !*********************************************************************** !* FOLLOWING MULTIPLIER IN DATA INITIALISATION LIST * !*********************************************************************** %unless CTYP&7 = 1 %then -> PI34ERR; ! MUST BE AN INTEGER -> EXIT1 %if CRM3 = -1 CCOUNT = Com_Pi21int -> EXIT1 !* PI(37): !*********************************************************************** !* INITIALISE NEXT ENTRY IN DATA LIST * !*********************************************************************** !! %if Com_Statordermode<3 %then Com_Statordermode=3;! must not do this if type -> EXIT1 %if CRM3 = -1 !* !* CCOUNT number of consts !* PI21LENGTH actual length of const !* PI21MODE mode of const !* %if Res_Form=0 %thenstart;! handle short literals like all others %if TARGET=ACCENT %and HOST#ACCENT %thenstart integer(Com_Adict)=Res_H0<<16 %finishelsestart integer(Com_Adict)=Res_H0 %finish RES_W=0 %finishelse Res_W=Res_H0<EXIT4 %finishelse ->EXIT4P %finish SAVEPTR=PTR %finishelse PTR=SAVEPTR;! in case it has been changed by a const name ref %if VCOUNT=0 %thenstart ER=286;! too many consts specified ->EXIT4P %finish !* I=PI21MODE J=RES_W K=PI21LENGTH %if I=VMODE %thenstart;! type and size(except char) matches %if I=CHARMODE %thenstart;! char, check const length PI37D: %if KCCOUNT %then L=CCOUNT;! L=MIN(VCOUNT,CCOUNT) %if TARGET=ACCENT %thenstart %if HOST#ACCENT %thenstart %if J#0 %and I#CHARMODE %and I#HOLMODE %thenstart %if Pi21length=4 %thenstart N=integer(Com_Adict+J) %finishelsestart N=integer(Com_Adict+J) M=N>>16 N=(N<<16)!M integer(Com_Adict+W1)=N N=integer(Com_Adict+J+W1) %finish M=N>>16 N=(N<<16)!M integer(Com_Adict)=N J=0 %finish %finish %finish ADD DATA ITEM(PTR,L,VDISP,VLENGTH,J) VCOUNT=VCOUNT-L CCOUNT=CCOUNT-L VDISP=VDISP+L*VLENGTH %if CCOUNT=0 %then CCOUNT=1 %and ->EXIT1;! for the next const ->PI37A;! to prepare next variable %finish !* %if Pi21mode=HEXCONST %thenstart %if Vmode=CHARMODE %thenstart %unless Vlength=1 %then ->PI37E %finish N=8-Vlength %if BSCALE=1 %then N=N>>1 J=Res_W+N ->PI37B %finish !* %if 1<=I<=8 %and 1<=VMODE<=8 %thenstart;! arithmetic coercion required M=VMODE PI37C: K=Com_Dptr J=COERCE CONST(J,I,M,Com_Adict,Com_Dptr) Com_Dptr=K ->PI37B %finish !* %if I=INT4 %thenstart %if VMODE=INT2 %thenstart;! I*2 init %if TARGET#ACCENT %thenstart %if Host=PERQPNX %then J=J+1 %else J=J+2 %finish ->PI37B %finish %if Vlength=1 %thenstart I=integer(Com_Adict+J) %if -127<=I<=255 %thenstart %if TARGET#ACCENT %thenstart %if Host=PERQPNX %then J=J+1 %else J=J+3 %finish ->PI37B %finish %finish %finish !* ! %if I=INT8 %and VMODE=INT2 %thenstart ! J=J+6 ! ->PI37B ! %finish !* %if I=LOG4 %thenstart;! logical const - must be logical var %if VMODE=LOG1 %thenstart;! L*1 var %if TARGET#ACCENT %thenstart %if Host=PERQPNX %then J=J+1 %else J=J+3 %finish ->PI37B %finish %if VMODE=LOG2 %thenstart;! L*2 init %if TARGET#ACCENT %thenstart %if Host=PERQPNX %then J=J+1 %else J=J+2 %finish ->PI37B %finish ! %if VMODE=LOG8 %thenstart;! L*8 var ! I=1 ! M=2 ! ->PI37C;! use I*4 -> I*8 coercion ! %finish %finish !* %if I=HOLMODE %thenstart;! Hollerith - init any non-char %if VMODE=CHARMODE %then FAULT(285);! wrong type %if K>VLENGTH %thenstart Report Error(1,0,277);! Hollerith larger than item K=VLENGTH %finish Report Error(2,1,193);! Hollerith non-standard ->PI37D %finish !* %if I=CHARMODE %thenstart;! char Report Error(4,1,194);! char initialising non-char is non-standard ->PI37D %finish !* PI37E:ER=285;! const not compatible ->EXIT4P !* PI(38): !*********************************************************************** !* AFTER / TERMINATING INITIALISATION DATA * !* UNWIND LIST AND REMOVE REDUNDANT ENTRIES * !*********************************************************************** %unless CRM3 = -1 %thenstart %if VLISTHEAD#0 %then ER=GET NEXT VARIABLE;! TO ENABLE CLOSURE OF IMP DO LISTS %if VLISTHEAD#0 %or VCOUNT#0 %then FAULT(287);! not enough consts %finish UNWIND: %while VLISTHEAD#0 %cycle FREE LIST CELL(VLISTHEAD,5) %repeat -> EXIT1 !* PI(39): !*********************************************************************** !* AFTER IMPLICIT LIST * !* P1 = 0 MODIFY FUNCTION AND PARAM TYPES IF NECESSARY * !* 1 IMPLICIT NONE * !*********************************************************************** Com_Curstatclass=1 %if Com_Statordermode>1 %thenstart %if Com_Statordermode=2 %then ER=238 %else ER=236 LFAULT(ER) %finish %if P1=1 %thenstart;! IMPLICIT NONE %cycle I='A',1,'Z' Imptype(I)=0 %repeat ->Exit1 %finish -> EXIT1 %unless 1 < Com_Subprogtype < 4; ! NECESSARY FOR FUNCTIONS AND SUBROUTINES ONLY PTR = Com_Subprogptr PP == record(Com_Adict+PTR) %if PP_X0&8 = 0 %thenstart; ! NOT EXPLICITLY TYPED J=Com_Anames+PP_Iden I = Imptype(Getbyte(J,1));! first char %if I&X'F'=5 %thenstart;! CHAR PP_LEN=I>>8 I=5 %finish PP_TYPE=I %finish PTR = PP_LINK2; ! LINK TO PARAMETER CHAIN %while PTR # 0 %cycle; ! THROUGH ALL PARAMETERS SS == record(Com_Adict+PTR) PTR = SS_INF0 PP == record(Com_Adict+PTR) %if PP_X0&8 = 0 %thenstart J=Com_Anames+PP_Iden I = Imptype(Getbyte(J,1));! first char %if I&X'F'=5 %thenstart;! CHAR PP_LEN=I>>8 I=5 %finish PP_TYPE=I %finish PTR = SS_LINK1 %repeat -> EXIT1 !* PI(40): !*********************************************************************** !* AFTER %PRINTD , DUMP CONTENTS OF DICTIONARY * !*********************************************************************** Dumpdict(p1) -> EXIT1 !* PI(41): !*********************************************************************** !* Process DATA-implied-do * !*********************************************************************** I=DATA IMPLIED DO %if I=0 %then ->EXIT1 %if I=1 %then ->EXIT4P %if I=2 %then ->EXIT4 ->PI34ERR !* PI(42): !*********************************************************************** !* AFTER FIRST OR ONLY LETTER IN IMPLICIT LIST ITEM * !*********************************************************************** CRM4 = Com_Nextch !* PI(43): !*********************************************************************** !* AFTER SECOND LETTER IN IMPLICIT LIST ITEM * !*********************************************************************** %if TYPE(Com_Inp) = 1 %thenstart CRM5 = Com_Nextch %if CRM4 <= CRM5 %thenstart K=CRM8 %if K=5 %then K=CHARLEN<<8!5;! CARRY CHARLEN %cycle I = CRM4,1,CRM5 J=1<<(I-'A') %if CHARMASK&J#0 %thenstart %unless P=43 %and I=CRM4 %thenstart IDENTIFIER=TOSTRING(I) FAULT(274);! already specified %finish %finish CHARMASK=CHARMASK!J IMPTYPE(I) = K %repeat %finishelse LFAULT(273);! invalid alphabetic sequence %finishelse LFAULT(106);! invalid char Com_Inp = Com_Inp+1 Com_Nextch = INPUT(Com_Inp) -> EXIT1 !* PI(44): !*********************************************************************** !* FOLLOWING CLOSING ) OF AN EQUIVALENCE LIST * !* VLISTHEAD IS THE HEAD OF THE LIST OF ITEMS CREATED BY PI(31),PI(34) * !* VLISTTAIL POINTS TO THE LAST ENTRY ON THE LIST * !*********************************************************************** %if Com_Statordermode>2 %then ER=236 %and ->EXIT4 Com_Statordermode=2 Com_Inhibop4=1 I=EQUIVALENCE %if I#0 %then ->UNWIND %else ->EXIT1 !* PI(45): !*********************************************************************** !* FOLLOWING [POSSIBLE] LABEL IN DO * !* P1 = 0 conventional DO * !* 1 DO WHILE * !* RES = NESTLEVEL<<24!@ OF LABEL RECORD IN DICT * !*********************************************************************** %if Com_Doptr = 0 %then I = 1 %elsestart DOREC==record(Com_Adict+Com_Doptr) I = DOREC_LABEL>>24+1;! nesting level %finish %if Com_Pi21int=-1 %thenstart;! no label specified Res_W=I<<24 %if P1=0 %then Gstate=9 %else Gstate=1 ->Exit1 %finish ER = 110;! INVALID STATEMENT NO. -> EXIT4 %unless 0 < Com_Pi21int <= 99999 J=SETLAB(Com_Pi21int,PTR) LABREC==record(Com_Adict+PTR) %if LABREC_X0&3#0 %thenstart IFAULT(227,LABREC_Line);! label already set at line # %finishelsestart %if LABREC_X0&8#0 %then IFAULT(228,LABREC_LINK5);! already ref. as FORMAT label %finish RES_W = I<<24!(PTR>>DSCALE) %if P1=0 %then Gstate=9 %else Gstate=1 -> EXIT1 !* PI(46): !*********************************************************************** !* FOLLOWING COMPUTED GOTO INDEX,ASSIGNED IDEN, * !* DO CONTROLLED VARIABLE * !* IDENTIFIERS MUST BE SIMPLE VARIABLES * !*********************************************************************** ER=125;! INVALID CONST %if CTYP>0 %thenstart;! NOT AN IDENTIFIER ->EXIT4P %unless CTYP&7=1;! MUST BE A SIMPLE INTEGER %if 0EXIT1 %finish PTR=SETCONREC(RES) P3=CNSTID;! CONST RECORD %finishelsestart;! AN IDENTIFIER !****** ENTRY FROM PI(55) TO PROCESS IDEN IN ASSIGNED GOTO L460: %if PP_CLASS=12 %then CBNAME %if P1=0 %then ER=126 %else ER=293 %if PP_CLASS&X'1C'#0 %then ->EXIT4P J=PP_TYPE&7 %if (P1=0 %and J#1) %or (P1=1 %and J>2) %then ->EXIT4P %if PP_TYPE=X'41' %then ER=190 %and ->EXIT4P ALLOC(PTR) J=PP_CLASS %if J=0 %thenstart;! LOCAL %if PP_X0&X'10'#0 %then P3=ASCALID %else P3=OSCALID %finishelsestart %if J=1 %thenstart;! PARAM P3=PSCALID;! DICT RECORD FOR SCALAR PARAM PP_X0=PP_X0!2 PP_X1=PP_X1!2 %finishelsestart;! COMMON P3=CSCALID;! DICT RECORD FOR COMMON SCALAR %finish %finish %finish Res_H0=PTR>>DSCALE; Res_Form=P3; Res_Mode=SETMODE(PP_TYPE&X'3F');! R.D. TO LOCATION ->EXIT1 !* PI(47): !*********************************************************************** !* SET RES TO DESC TO SMALL INT VALUE P1 * !* USED TO SET DEFAULT DATA SET NUMS,DO INCREMENTS AND POSITION PARS * !*********************************************************************** Res_H0=P1; Res_Form=LIT; Res_Mode=INT4 -> EXIT1 !* PI(48): !*********************************************************************** !* PAUSE OR PAUSE ' ' * !* STOP OR STOP '' * !*********************************************************************** %if Ctyp&7=1 %thenstart Res_W=Conin(Com_Pi21int) %finishelsestart %unless Ctyp=CHARTYPE %then -> Synerr %finish -> Exit1 !* PI(49): !*********************************************************************** !* FOLLOWING * I.E. LABEL PARAMETER TO SUBROUTINE * !* LABEL IN COMPUTED GOTO * !*********************************************************************** ER = 110;! STATEMENT NO. INVALID -> EXIT4 %unless 0 < Com_Pi21int <= 99999 I=SETLAB(Com_Pi21int,PTR) LABREC==record(Com_Adict+PTR) RES=0 %if LABREC_X0&8#0 %then IFAULT(228,LABREC_LINK5) LABREC_X1=LABREC_X1!1;! referenced I = PTR PTR=FREESP(3);! 3 words required for later use in forward ref. list SS==record(Com_Adict+PTR) SS_INF0=I %if CGOLAB = 0 %then HGOLAB = PTR %elsestart LABREC==record(Com_Adict+CGOLAB) LABREC_LINK1=PTR %finish CGOLAB = PTR -> EXIT1 !* PI(50): !*********************************************************************** !* FOLLOWING PARAMLIST TO CALL (TO PROCESS ANY LABEL PARAMS) * !* LABEL LIST TO COMPUTED GOTO * !*********************************************************************** RES_W = HGOLAB -> EXIT1 !* PI(51): !*********************************************************************** !* FOLLOWING CLOSING ) TO ARRAY ELEMENT SUBSCRIPT LIST IN EXP. * !*********************************************************************** CRM1 = 1; ! CRM1=0 IF ARRAY ELEMENT ON LHS OF ASSIGNMENT - SET BY PI(78) L511: SS==record(Com_Adict+Com_Fnlst) FREE LIST CELL(Com_Fnlst,5) I = SS_INF0 NOTFLAG = I>>8 GSTATE = I&X'FF' I = SS_INF3 P1 = (I>>8)&X'FF'; ! NO. OF SUBSCRIPT EXPRESSIONS ER = 264; ! WRONG NO. OF SUBSCRIPTS %unless P1 = PCT %thenstart IDENTIFIER=STRING(Com_Anames+SS_INF4) ->EXIT4 %finish PCT = I&X'FF' CTYP = I>>16 -> L582 !* PI(54): !*********************************************************************** !* REFERENCE TO SCALAR VARIABLE ON LHS OF ASSIGNMENT * !*********************************************************************** PI54: CRM1 = 0 -> L533 !* PI(126): ! in param list PI(53): !*********************************************************************** !* REFERENCE TO SCALAR IN EXPRESSION * !*********************************************************************** PI53: CRM1 = 1 %if CTYP > 0 %thenstart; ! SCALAR IS A CONSTANT PI53A: P2 = 0 %if CTYP=X'51' %or CTYP&7=4 %thenstart;! INTEGER OR LOGICAL %if 0<=Com_Pi21int<=X'7FFF' %thenstart RES_H0=Com_Pi21int RES_Form=LIT Res_Mode=SETMODE(CTYP&X'3F') ->L536 %finish %finish RES_H0=SETCONREC(RES)>>DSCALE Res_Form=CNSTID %if PI21MODE=HOLMODE %thenstart Res_Mode=HOLMODE %finishelse Res_Mode=SETMODE(CTYP&X'3F') -> L536 %finish L533: %if PP_CLASS = 12 %then CBNAME P2=PP_CLASS&X'1F' %if Ttyp=0 %and (P2&8)#8 %then Notype;! explicit type required and not set RES_H0=PTR>>DSCALE %if P2=0 %thenstart %if PP_X1=X'21' %thenstart;! stat fn param RES_H0=PP_ADDR4;! index RES_Form=VALTEMP %finishelsestart;! local scalar ALLOC(PTR) RES_Form=OSCALID %finish %finishelsestart %if P2<=2 %thenstart Alloc(Ptr) %if P2 = 2 %thenstart; ! common scalar RES_Form=CSCALID %finishelsestart; ! scalar param RES_Form=PSCALID %if CRM1=0 %or P=126 %then PP_X0=PP_X0!2;! MARK AS ASSIGNED TO %if CRM1=1 %or P=126 %then PP_X1=PP_X1!2;! mark as referenced %finish %finishelsestart %if P2=16 %thenstart;! constant name %if CRM1=0 %then ER=180 %and ->EXIT4P RES_W=PP_CONSTRES CTYP=PP_TYPE Com_Pi21int=RES_H0;! for compatability %if Res_Form=1 %and Res_Mode=1 %then %C Com_Pi21int=integer(Com_Adict+Com_Pi21int<PI53A %finish ER = 127; ! ILLEGAL USE OF SUBPROGRAM OR ARRAY NAME %if P2 = 11 %thenstart; !'CURRENT' SUBPROGRAM -> EXIT4 %unless Com_Subprogtype = 2; ! CAN ONLY BE VALID IF A FUNCTION RES_Form=PROCID CTYP = PP_TYPE %if CRM1=0 %thenstart;! fn assigned a value PP_X1=PP_X1!2 QQ==record(Com_Adict+Com_Subprogptr) QQ_X1=QQ_X1!2 %finish %if PP_X1&1 = 0 %thenstart; ! NOT YET USED PP_X1 = PP_X1!1 %if Com_Funresdisp=0 %thenstart %if CTYP=5 %thenstart;! char fn Com_Funresdisp=Scalar Space(8,IIN) %finishelsestart Com_Funresdisp=Scalar Space(16,IIN) %finish %finishelse IIN=SCALARS PP_IIN=IIN PP_ADDR4 = Com_Funresdisp %finish %finishelsestart;! must be external function or array name -> Exit4 %if P2 > 10; ! COMMON BLOCK OR STATEMENT FUNCTION %if P2 = 8 %thenstart; ! EXTERNAL SUBPROGRAM %if P=126 %thenstart;! in param list %if PP_X0&6=4 %thenstart Er=199;! this intrinsic fn cannot be a param ->Exit4 %finish %finishelsestart -> Exit4 %unless PP_X0&7 = 0 %finish { Setfun(Ptr) } %finishelse Alloc(Ptr) -> Exit4 %unless Gstate = 1 %and Crm1 = 1 %if 4<=P2<=6 %thenstart;! array name Res_Form=ARRID %finishelsestart Res_Form=PROCID %finish Res_Mode=Setmode(PP_Type&X'3F') Gstate = 15 -> Exit1 %finish %finish %finish Ctyp = PP_Type !* L532: RES_Mode=SETMODE(CTYP&X'3F') L536: I=RES_Mode L536A: %if MODETOST(I)&15 = LOGTYPE %thenstart; ! LOGICAL P1 = 1 NOTFLAG = 2 %finishelse P1 = 0 ER = 130; ! INVALID EXPRESSION IN ARITHMETIC STATEMENT -> P53(GSTATE) P53(1): P53(7): %if CRM1 = 0 %thenstart %if P1 = 0 %then GSTATE = 9 %else GSTATE = 1 -> EXIT1 %finish GSTATE = STATE(P1) -> EXIT1 P53(2): -> EXIT4P %unless P1 = 0 GSTATE = 3 -> EXIT1 P53(3): P53(6): P53(8): P53(14): -> EXIT4P P53(4): P53(5): %if P1#0 %then ->EXIT4P GSTATE = 6 -> EXIT1 P53(9): P53(10): %if P1#0 %then ->EXIT4P GSTATE = 11 -> EXIT1 P53(12): P53(13): ER = 131 -> EXIT4P %unless CTYP&15 <= 1 GSTATE = 14 -> EXIT1 !* PI(55): !*********************************************************************** !* FOLLOWING GOTO * !* GOTO (ASSIGNED GOTO) * !* ASSIGN ... (P1=1) * !* ERR= * !* END= * !* LABEL IN ARITHMETIC IF * !*********************************************************************** %if CTYP<1 %thenstart;! ONLY POSS IN ASSIGNED GOTO %while TYPE(Com_Inp)#12 %cycle Com_Inp=Com_Inp+1;! SKIP ASSIGNED LABEL LIST %repeat Com_Nextch=INPUT(Com_Inp) ->L460;! TO SET APPROPRIATE R.D. %finishelsestart;! INTEGER LABEL %if P1=1 %then Com_Inhibop4=1 %unless 0 < Com_Pi21int <= 99999 %thenstart FAULT(110);! INVALID STATEMENT NO. Com_Pi21int=0 %finish I=SETLAB(Com_Pi21int,PTR) LABREC==record(Com_Adict+PTR) CRM1=Com_Pi21int;! SAVE LABEL NO. FOR ARITH IF CHECK %if LABREC_X0=1 %then ER=225 %and ->EXIT4;! non-exec statement ER=228;! LABEL ALREADY USED AS A FORMAT LABEL Com_Pi21int=LABREC_LINE;! DECLARED LINE NO. (FOR ERROR MESSAGES) %if P1#1 %thenstart;! except ASSIGN I=1;! label in explicit GOTO ->EXIT4 %if LABREC_X0&8#0 %finishelsestart I=2;! label in ASSIGN %if LABREC_X0&14=0 %then LABREC_X0=16;! may be exec or format %finish LABREC_X1=LABREC_X1!I Res_H0=PTR>>DSCALE; Res_Form=LABID; Res_Mode=INT4;! DICT RECORD FOR LABEL ->EXIT1 %finish !* PI(56): !*********************************************************************** !* AFTER ( IN EXPRESSION * !* ALLOCATE EXTERNAL REFERENCE AND SET FN TYPE IF IMPLICITLY RECOGNISED* !* SET FNMK * !* RES= POINTER TO FN ENTRY IN DICT * !* PUSHDOWN ENTRY IN FNLST * !* RESET GSTATE * !*********************************************************************** %if PP_CLASS = 12 %then CBNAME %if CTYP>0 %then ER=130 %and ->EXIT4P I = PP_CLASS&X'1F';! to remove param array markers -> L561 %if 3 < I < 7; ! ARRAY -> L562 %if I = 13; ! STATEMENT FN. %if I = 8 %thenstart; ! EXTERNAL FUNCTION %if PP_X0&X'4'#0 %then ->L56B;! actually an intrinsic function ->L567 %finish %if I = 9 %thenstart; ! EXTERNAL FUNCTION PARAM L569: ALLOC(PTR) PP_X0=PP_X0&X'F8';!CLEAR PARAM 'VALUE' MARKER IF SET -> L564 %finish %if (0<=I<=2 %or I=16) %and PP_TYPE=5 %thenstart;! may be char substring %if PP_X1&X'F'#0 %or SCAN(':')#0 %thenstart PISW=12;! for PI69 switch ->PI53 %finish %finish ER = 245; ! NOT AN ARRAY BEING SUBSCRIPTED -> EXIT4 %unless 0 <= I <= 1; ! LOCAL OR PARAMETER SCALAR (DEFAULT) -> EXIT4 %unless PP_X1&15 = 0; ! FAULT IF ALREADY USED AS A SCALAR PP_CLASS = I!8; ! SET FUNCTION BIT -> L569 %if I = 1; ! TO PROCESS AS FUNCTION PARAM !****** SEARCH INTRINSIC FUNCTION LIST L56B: I=FN HASH(HASH VALUE) J=ADDR(FN NAMES(0)) L56A: K=I&X'FFFF' %if Host=PERQPNX %or HOST=ACCENT %then K=K>>1;! index in words %if STRING(J+K)=IDENTIFIER %thenstart;! INTRINSIC FN L=I>>16&X'FF' I=FN DETAILS(L) K=FNSPECIALS(L) %if TARGET#IBM %thenstart %if K&X'8000'#0 %thenstart;! not there? %if K&X'800000'=0 %thenstart;! don't ignore the 'not there' bit !!! LFAULT(178);! comment - not an intrinsic fn ->L567 %finish %finish %finish %if PP_X0&X'4'#0 %thenstart COPY(24,Com_Adict+PTR,0,Com_Adict+Com_Dptr,0) PTR=Dictspace(12) PP==record(Com_Adict+PTR) %finishelsestart %if Com_Dptr<=PTR+IDRECSIZE+XREFSIZE %thenstart;! RECOVER DICT SPACE !! Com_Dptr=PTR+W6;! KEEP MINIMAL RECORD LHEAD(HASH VALUE)=PP_LINK1;! REMOVE FROM IDEN LIST %finish %finish {following code only relevant if I8 and R8 defaults supported} ! J=I>>20&15;! modify parm requirements if necessary ! %if (J=1 %and INTEGER LENGTH=8) %or %C ! (3<=J<=7 %and REAL LENGTH=8) %then I=I+X'00101000' ! J=I>>16&15;! modify fn result size if necessary ! %if (J=1 %and INTEGER LENGTH=8) %or %C ! (3<=J<=7 %and REAL LENGTH=8) %then I=I+X'00010000' L56C: PP_LINK2=I;! FN DETAILS FOR SUBSEQUENT CHECKING/MODIFICATION J=I>>16&X'F';! FN MODE %if I#0 %then PP_TYPE=MODETOST(J);! N.B. WHAT IF ALREADY TYPED PP_X0=I>>2&3;! FN TYPE PP_X1=1 ->L564 %finishelsestart %if I>>24#0 %thenstart I=FNHASH(I>>24) ->L56A %finish %finish %cycle I=1,1,13 %if Bitfnsperm(I)#0 %and Bitfns(I)=Identifier %thenstart PP_Class=8 I=Bitfnsdet(I) ->L56C %finish %repeat !****** STANDARD FUNCTION L567:{SETFUN(PTR) } L564: RES_W = PTR TTYP = PP_TYPE %if Ttyp=0 %then Notype;! explicit type required and not set PTR=NEW LIST CELL(Com_Fnlst,5) SS==record(Com_Adict+PTR) SS_INF2 = (PP_X0&7+1)<<8!TTYP; ! FNMK 1 FOR EXT FN, >1 FOR INTRINSIC AND STANDARD FNS SS_INF3 = PCT; ! SAVE INTRINSIC CODE FOR PARAMETER TYPE AND COUNT FNMK = 0 PISW = 2;! for PI69 switch I = 1 PP_X1=(PP_X1&X'CF')!X'10' -> PI56EXIT !****** ARRAY ELEMENT REFERENCE L561: ALLOC(PTR) TTYP = PP_TYPE %if Ttyp=0 %then Notype;! explicit type required and not set Res_H0=PTR>>DSCALE; Res_Form=ARRID; Res_Mode=SETMODE(TTYP&X'3F');! DICT RECORD FOR ARRAY DVREC == record(Com_Adict+PP_ADDR4); ! DOPE VECTOR IN DICT PTR=NEW LIST CELL(Com_Fnlst,5) SS==record(Com_Adict+PTR) SS_INF2 = PP_ADDR4; ! DOPE VECTOR IN DICT SS_INF3 = TTYP<<16!DVREC_DIMS<<8!PCT SS_INF4 = PP_IDEN;! FOR ERROR MESSAGES PISW = 6;! for PI69 switch I = 12;! RESTRICT TO INTEGER SUBSCRIPTS -> PI56EXIT !****** STATEMENT FN REFERENCE L562: %if Ptr=Statfnrec %thenstart Er=140 ->Exit4p %finish {ER = 135; ! NESTED STATEMENT FUNCTION REFERENCE} {-> EXIT4P %if PP_X1&1 # 0 this restriction is no longer necessary 26/11/85} ER = 136; ! INVALID ARRAY SUBSCRIPT IN IMPLIED DO -> EXIT4P %if DOIOP > 0 PP_X1 = PP_X1!1; ! WILL FAULT ANY STATEMENT FN REFERENCE IN PARAMS %if Ttyp=0 %then Notype;! explicit type required and not set RES_W = PTR PTR=NEW LIST CELL(Com_Fnlst,5) SS==record(Com_Adict+PTR) SS_INF2 = RES_W SS_INF3 = PCT I = 1 PISW=10;! for PI69 switch PI56EXIT: SS_INF0=NOTFLAG<<8!GSTATE NOTFLAG = 0 GSTATE = I PCT = 0 -> EXIT1 !* PI(57): !*********************************************************************** !* AFTER PARAMETER IN EXTERNAL FN/ROUTINE CALL * !*********************************************************************** SS == record(Com_Adict+Com_Fnlst) RES_H0=FNMK; RES_H1=SS_INF3&X'FF00'!PCT;! FNMK,PARAM TYPE,PCT PCT = PCT+1 %if Com_Nextch = ',' %then FNMK = 0;! NOT LAST PARAM GSTATE = 1 NOTFLAG = 0 -> EXIT1 !* PI(58): !*********************************************************************** !* FOLLOWING CLOSING ) OF PARAMETER LIST TO SUBPROGRAM CALL * !*********************************************************************** CRM1 = 1 SS==record(Com_Adict+Com_Fnlst) FREE LIST CELL(Com_Fnlst,5) I = SS_INF0 NOTFLAG = I>>8 GSTATE = I&X'FF' I = SS_INF2 %if FNMK = 0 %or FNMK = 4 %then FNMK = I>>8 CTYP = I&X'FF' PCT = SS_INF3&X'FF' RES_W=PCT !***** merge with PI(51) - following array element reference L582: %if CTYP&7 = 4 %thenstart; ! LOGICAL P1 = 1 NOTFLAG = 2 %finishelsestart P1 = 0 %finish ER = 130;! INVALID EXPRESSION -> P53(GSTATE) !* PI(59): !*********************************************************************** !* STATE TRANSITION TO CHECK VALIDITY OF SEQUENCE OF LOGICAL AND * !* ARITHMETIC OPERANDS AND OPERATORS * !*********************************************************************** ER = 132 %if P1=8 %thenstart;! reject char as DO param %if RES_MODE=CHARMODE %then ER=296 %and ->EXIT4P P1=7 %finish -> P59(GSTATE) P59(1): GSTATE = STATE(P1) -> EXIT4P %if GSTATE = 0 %if P1 = 5 %then NOTFLAG = 1 -> L591 P59(2): P59(5): P59(10): P59(13): -> EXIT4P P59(3): -> EXIT4P %if 7 > P1 > 3 %if P1 = 7 %thenstart %if NOTFLAG#0 %then ->EXIT4P -> L591 %finish GSTATE = STATE(P1+5) %if P1 = 3 %then NOTFLAG = 2 -> EXIT1 P59(4): -> EXIT4P %unless P1 = 6 GSTATE = 5 -> EXIT1 P59(6): GSTATE = STATE(P1+7) -> EXIT4P %if GSTATE = 0 -> L591 P59(7): -> EXIT4P %unless P1 = 6 GSTATE = 2 -> EXIT1 P59(8): %unless P1 = 4 %or P1 = 7 %then ->EXIT4P GSTATE = 1 -> L591 P59(9): P59(12): -> EXIT4P %unless P1 = 6 GSTATE = GSTATE+1 -> EXIT1 P59(11): P59(14): -> EXIT4P %if 2 < P1 < 7 GSTATE = GSTATE-1 %unless P1=7 -> L591 P59(15): -> EXIT4P %unless P1 = 7 L591: -> EXIT1 %unless P1 = 7 RES_W = NOTFLAG NOTFLAG = 0 -> EXIT1 !* PI(60): !*********************************************************************** !* RES = COMPARATOR CODE FOLLOWING > SET BY READLINE * !* 1 .LT. 4 .GT. * !* 2 .LE. 5 .GT. * !* 3 .EQ. 6 .NE. * !*********************************************************************** RES_W = INPUT(Com_Inp)&15 ER = 106;! INVALID CHAR -> EXIT4P %unless TYPE(Com_Inp) = 6;! CONFIRMS THAT ENTRY IS COMPARATOR CODE L601: Com_Inp = Com_Inp+1 L602: Com_Nextch = INPUT(Com_Inp) -> EXIT1 !* PI(61): !*********************************************************************** !* FOLLOWING ( INTRODUCING A BRACKETED EXPRESSION * !*********************************************************************** PTR=NEW LIST CELL(LL1,2) SS==record(Com_Adict+PTR) SS_INF0 = NOTFLAG<<8!GSTATE %if GSTATE = 1 %or GSTATE = 7 %then GSTATE = 1 %elsestart %if GSTATE > 10 %then GSTATE = 12 %else GSTATE = 9 %finish -> EXIT1 !* PI(62): !*********************************************************************** !* FOLLOWING ) TERMINATING A BRACKETED EXPRESSION * !*********************************************************************** SS==record(Com_Adict+LL1) FREE LIST CELL(LL1,2) NOTFLAG = SS_INF0>>8 I = SS_INF0&X'FF' %if I>8 %thenstart %if I=11 %then GSTATE=11 ->EXIT1 %finish %if 5 < GSTATE < 11 %then NOTFLAG = 2 -> EXIT1 %if GSTATE < 11 %if I=2 %or I=3 %or NOTFLAG=0 %then GSTATE=3 %else GSTATE=6 -> EXIT1 !* PI(63): !*********************************************************************** !* FOLLOWING IF ( ) TO DETERMINE WHETHER ARITH OR LOG. * !*********************************************************************** ICOMP = ICOMP+2 %if RES_W # 0 %thenstart Com_Statement=3;! logical IF (required by EMAS ITS) -> EXIT2 %finish ! TEST COMPLEX ICOMP = ICOMP+2 -> EXIT1 !* PI(64): !*********************************************************************** !* FOLLOWING RECOGNITION OF SUBSCRIPT TO ARRAY ELEMENT * !*********************************************************************** PCT = PCT+1 RES_W=PCT GSTATE = 12;! RESTRICT TO INTEGER SUBSCRIPTS -> EXIT1 !* PI(65): !*********************************************************************** !* FOLLOWING ( ON LHS OF ASSIGNMENT * !* DETERMINE WHETHER ARRAY ELEMENT OR STATEMENT FN DEFINITION * !*********************************************************************** %if PP_CLASS = 12 %then CBNAME %unless PP_Class=8 %then PP_X0=PP_X0!2;! to indicate assigned to {unless classed as fn due to previous error} I = PP_CLASS&X'1F';! to remove param array markers ER = 245;! IDEN IS NOT AN ARRAY NAME %if (0<=I<=2 %or I=11) %and PP_TYPE=5 %thenstart;! may be char substring PISW=8 %if SCAN(':')#0 %then ->PI54 %finish %if I # 0 %thenstart -> EXIT4 %unless 4 <= I <= 6; ! I.E. ONLY LOCAL PARAMETER OR COMMON ARRAY ALLOWED HERE -> L561; ! TO PROCESS IT %finishelsestart; ! CAN ONLY BE A STATEMENT FN DEFINITION -> EXIT4 %unless PP_X1 = 0 STATFN==record(Com_Adict+PTR) STATFNREC=PTR STATFN_CLASS = 13 J=NUMBYTES(STATFN_TYPE>>4) %if STATFN_TYPE&15=3 %then J=J+J I = (J+3)&X'FFFFFC';! SPACE FOR RESULT %if STATFN_TYPE=5 %then I=8;! for descriptor J=Generate(Triads,Nexttriad,0,-3,0,Comad,Output);! to register start of sf RES_H0=Scalar Space(I,IIN) RES_FORM=GLALIT RES_MODE=SETMODE(STATFN_TYPE&X'3F') STATFN_LINK2=RES_W RES_W = PTR QQ == record(Com_Adict+Com_Subprogptr) PCT = 0 GSTATE = 1 PISW=2;! for PI84 switch -> EXIT1 %finish !* PI(66): !*********************************************************************** !* FOLLOWING CALL * !*********************************************************************** I = PP_CLASS RES_W = PTR -> L661 %if I = 8 %or I = 9; ! SUBPROGRAM(MAY BE AS PARAMETER) %if I=11 %then ER=244 %and ->EXIT4 ER = 128; ! INVALID SUBPROGRAM NAME -> EXIT4 %unless 0 <= I <= 1; ! ONLY SETTING PERMITTED IS SCALAR PARAMETER -> EXIT4 %unless PP_X1 = 0; ! ALREADY USED AS SCALAR I = I!8; ! SET 'SUBPROGRAM' MARKER PP_CLASS = I L661: %if I # 8 %then ALLOC(PTR) {%else SETFUN(PTR)}; ! SET REFERENCE OR ALLOCATE PARAMETER SPACE PP==record(Com_Adict+PTR) PP_X1=(PP_X1&X'CF')!X'20' PP_X0=PP_X0&X'F8';! CLEAR PARAM 'VALUE' MARKER IF SET -> EXIT1 !* PI(67): !*********************************************************************** !* FOLLOWING IN EXTERNAL LIST * !*********************************************************************** I=Com_Externals %while I#0 %cycle SS==record(Com_Adict+I) %if PTR=SS_INF0 %then FAULT(181) I=SS_LINK1 %repeat %if PP_X0&X'40'#0 %then FAULT(179) %and ->EXIT1;! already in an INTRINSIC statement %if CRM8=1 %then PP_X0=PP_X0!X'80' I=PP_CLASS -> EXIT1 %if 8 <= I <= 9; ! ALREADY MARKED AS A SUBPROGRAM ER = 128; ! ILLEGAL IDENTIFIER IN AN EXTERNAL LIST -> EXIT4 %unless I&14 = 0; ! ONLY VALID SETTING IS 'PARAM' -> EXIT4 %if PP_X1 # 0 PP_CLASS=PP_CLASS!8 %if CRM8=3 %thenstart;! INTRINSIC I=FNHASH(HASH VALUE) J=ADDR(FN NAMES(0)) L67A: K=I&X'FFFF' %if HOST=PERQPNX %or HOST=ACCENT %thenstart K=K>>1;! index in words %finish %if STRING(J+K)=IDENTIFIER %thenstart K=I>>16&X'FF' L=FN SPECIALS(K) %if L&X'80C000'=X'4000' %thenstart;! valid in list PP_X0=PP_X0!4;! intrinsic marker FN SPECIALS(K)=L!X'400000' %if L&X'2000'#0 %then PP_X0=PP_X0!2 PP_LINK2=FN DETAILS(K) PP_INF3=FN SPECIALS(K) ->EXIT1 %finish %finishelsestart %if I>>24#0 %thenstart I=FNHASH(I>>24) ->L67A %finish %finish %if Com_Allowvax=YES %thenstart %cycle I=1,1,13 %if Bitfns(I)=Identifier %thenstart Lfault(178);! warn about non-standard fn Bitfnsperm(I)=1 PP_X0=PP_X0!4;! intrinsic marker PP_Link2=Bitfnsdet(I) PP_Inf3=0 ->Exit1 %finish %repeat %finish LFAULT(279);! not a valid intrinsic name ->EXIT1 %finish I=PTR PTR=NEW LIST CELL(Com_Externals,2) SS==record(Com_Adict+PTR) SS_INF0=I -> EXIT1 !* PI(68): !*********************************************************************** !* SYNTAX CHECK AFTER , IN DEFN OF (PART OF DEFN) * !*********************************************************************** ER = 100;! SYNTAX %if Com_Nextch = NL %then -> EXIT4P %else -> EXIT1 !* PI(69): !*********************************************************************** !* following ( switches to appropriate syntax * !* PISW has been set by PI(56) * !* 2 external function * !* 6 array element * !* 10 statement function * !* 12 possible character scalar substring * !*********************************************************************** ICOMP = ICOMP+PISW ->EXIT2 %unless PISW=12 -> EXIT1; ! character scalar substring !* PI(70): !*********************************************************************** !* FOLLOWING SUBPROGRAM STATEMENT * !* P1 = 1 PROGRAM * !* 2 FUNCTION * !* 3 SUBROUTINE * !* 4 ENTRY * !* 5 BLOCKDATA * !*********************************************************************** PI70: Com_Curstatclass=1 %unless P1=4 %thenstart Com_Statordermode=1 DATAHEAD=0 DATALAST=0 ASS CHECKLIST=0 %finish I=NEW SUBPROGRAM(PTR,P1,CTYP,ER) %if Com_Subprogtype#5 %and I#4 %thenstart J=Generate(Triads,Nexttriad,0,-2,Com_Rescom1,Comad,Output);! register private label %finish -> PIEXIT(I) !* PI(72): !*********************************************************************** !* FOLLOWING IN * !*********************************************************************** %if Com_Nextch='=' %thenstart;! controlled variable of implied-DO loop %if PP_CLASS&X'1C'#0 %or PP_TYPE&X'F'>2 %thenstart ER=293;! invalid iden ->EXIT4P %finish CRM4=RES_W RES_W=0;! will avoid attempt to process as I/O list item ->EXIT1 %finish ! PP==record(Com_Adict+RES_H0<= ARRID %then ->EXIT1;! UNLESS SPECIAL IDEN ! -> EXIT4 %unless PP_CLASS&12 = 4;! MUST BE AN ARRAY NAME ! RES_MODE = SETMODE(PP_TYPE&X'3F') -> EXIT1 !* PI(73): !*********************************************************************** !* FOLLOWING ( IN IOLIST, I.E. START OF IMPLIED DO * !*********************************************************************** %if SCAN(')')=1 %thenstart;! not start of implied DO Com_Inp=Com_Inp-1 Com_Nextch=INPUT(Com_Inp) ICOMP=ICOMP-4 ->L2 %finish DOIOP = DOIOP+1 -> EXIT1 !* PI(74): !*********************************************************************** !* FOLLOWING * IN FORMAL PARAMETER LIST * !*********************************************************************** ER = 243; ! LABEL PARAMETER NOT ALLOWED IN FUNCTION -> EXIT4P %if Com_Subprogtype = 2 -> EXIT1 !* PI(75): !*********************************************************************** !* AFTER 'VALUE' FORMAL PARAMETER NAME * !*********************************************************************** ER=129 -> PIEXIT(FORMAL PARAMETER(PTR,0,CTYP)) !* PI(76): !*********************************************************************** !* AFTER = IN IMPLIED DO * !*********************************************************************** DOIOP = DOIOP-1 RES_W=CRM4 CHECK DO INDEX(RES_W,Com_Doptr) -> EXIT1 !* PI(77): !*********************************************************************** !* FOLLOWING IF ( ) WHEN FOLLOWS * !*********************************************************************** Com_Statement=3;! logical IF (required by EMAS ITS) ER = 133 -> EXIT4 %if RES_W = 0 -> EXIT1 !* PI(78): !*********************************************************************** !* FOLLOWING CLOSING ) IN SUBSCRIPT LIST TO ARRAY ELEMENT ON * !* LHS OF ASSIGNMENT, ALSO IN I/0 LIST * !*********************************************************************** CRM1 = 0 CRM10 = 0;! WILL TRIGGER FAULT IF USED AS CONTROL VAR IN IMPLIED DO -> L511 !* PI(79): !*********************************************************************** !* CODE OR CODEX TO CONTROL LISTING OF COMPILED CODE * !* CODE0 CLEARS BUFFER THEN SETS FLAG FOR CODE LISTING * !*********************************************************************** Com_Curstatclass=1 Com_Listcode=0 Com_Ptrace=0 %if Com_Nextch = NL %then Com_Listcode=1 %and ->EXIT1 !!# %if Com_Nextch='0' %then PUSHBUFFER(1) %and Com_Listcode=1 %if '1'<=Com_Nextch<='2' %then Com_Ptrace=Com_Nextch&3 -> L601;! TO SKIP CHAR !* PI(80): !*********************************************************************** !* FOLLOWING CLOSING ) TO PARAMETER LIST ON LHS OF STATEMENT FN * !* DEFINITION * !*********************************************************************** Com_Curstatclass=1 %if Com_Statordermode>3 %then LFAULT(237) Com_Statordermode=3 STATFN_DISP = PCT PCT = 0 Com_Sfmk = STATFNREC TTYP = STATFN_TYPE %if TTYP&4 = 4 %then GSTATE = 1 %else GSTATE = 9 -> EXIT1 !* PI(81): !*********************************************************************** !* AFTER STATEMENT FUNCTION FORMAL PARAM * !* CREATE NEW DICT ENTRY * !*********************************************************************** I=Com_Sfptr PTR=NEW LIST CELL(Com_Sfptr,8) QQ==record(Com_Adict+PTR) ZERO(Com_Adict+PTR,32) QQ_LINK1=I QQ_IDEN=PP_IDEN TTYP=PP_TYPE QQ_TYPE=TTYP QQ_X1=X'21';! AREA CODE(I.E. ON STACK), ALLOCATED QQ_INF3=STATFNREC PCT = PCT+1 QQ_ADDR4=PCT -> EXIT1 !* PI(82): !*********************************************************************** !* FOLLOWING CLOSING ) IN PARAMETER LIST TO STATEMENT FN REFERENCE * !*********************************************************************** SS==record(Com_Adict+Com_Fnlst) FREE LIST CELL(Com_Fnlst,5) QQ == record(SS_INF2+Com_Adict) QQ_X1 = QQ_X1&X'FE'; ! CLEAR MARKER WHICH INHIBITED NESTED STAT FN CALLS ER = 139; ! WRONG NO OF PARAMETERS IN STAT FN REFERENCE -> EXIT4 %unless QQ_DISP = PCT CTYP = QQ_TYPE CRM1 = 1 NOTFLAG = SS_INF0>>8 GSTATE = SS_INF0&X'FF' FNMK = 1 PCT = SS_INF3&X'FF' -> L582 !* PI(83): !*********************************************************************** !* FOLLOWING RECOGNITION OF A PARAMETER IN A STATEMENT FN. REFERENCE * !*********************************************************************** ER = 139; !WRONG NO. OF PARAMETERS -> EXIT4 %if GSTATE = 15 GSTATE = 1 SS == record(Com_Adict+Com_Fnlst) QQ==record(Com_Adict+SS_INF2);! STATEMENT FN RECORD J=QQ_Link3<EXIT4 %finish J=SS_LINK1 SS == record(Com_Adict+J) %repeat %finish PCT = PCT+1 RES_W = J -> EXIT1 !* PI(84): !*********************************************************************** !* SWITCH FOLLOWING ( ON LHS OF ASSIGNMENT TO PROCESS A * !* STATEMENT FN DEFINITION OR ARRAY ELEMENT REFERENCE * !*********************************************************************** ICOMP = ICOMP+PISW -> EXIT2 %unless PISW=8;! unless character substring -> EXIT1 !* !* PI(87): !*********************************************************************** !* RESET GSTATE AFTER SCALAR OR ARRAY ELEMENT ITEM IN * !*********************************************************************** GSTATE=1 ->EXIT1 !* PI(88): !*********************************************************************** !* FORMAT * !* PROCESS TEXT AND STORE IN GLA * !*********************************************************************** Com_Curstatclass=1 %if Com_Lab = 0 %thenstart ER = 149;! NO LABEL ON FORMAT STATEMENT -> EXIT4 %finish ER=GENFMT(INPUT,TYPE,IDENTIFIER) %if ER # 0 %then -> EXIT4 Com_Nextch = INPUT(Com_Inp) -> EXIT1 !* PI(89): !*********************************************************************** !* AVOID UNNECESSARY SEARCH IF NEXTCH IS NEWLINE * !* USED AFTER ,RETURN,PAUSE,STOP * !*********************************************************************** PI89: %if Com_Nextch = NL %thenstart;! SKIP ALTERNATIVE SWITCH ICOMP = ICOMP+4 -> EXIT1 %finish ICOMP = ICOMP+2;! SWITCH TO ALTERNATIVE DEFN -> EXIT2 !* PI(90): !*********************************************************************** !* CONTROL * !*********************************************************************** Com_Control=Com_Pi21int -> EXIT1 !* PI(92): !*********************************************************************** !* CHECK WHETHER CURRENT SUBSCRIPT IS SCALAR (DURING ) * !* RES = 1 SCALAR * !* 0 EXPRESSION (REQUIRING CO-ROUTINE IF IN IMPLIED DO OR READ * !*********************************************************************** K = Com_Inp ER = 100;! SYNTAX GSTATE = 12 %while TYPE(K)<4 %cycle;! THROUGH ALPHANUMERICS K = K+1 %repeat -> EXIT4 %if TYPE(K) = 12;! END OF STATEMENT %if TYPE(K)=7 %then RES_W=1 %and -> EXIT1;! , or ) RES_W=0;! C0-ROUTINE ALL SUBSCRIPT EXPRESSIONS -> EXIT1 !* PI(93): !*********************************************************************** !* FOLLOWING CLOSING ) IN I/0 LIST - REDUNDANT BRACKET PAIR * !*********************************************************************** DOIOP = DOIOP-1 -> EXIT1 !* PI(98): !*********************************************************************** !* %MONITOR * !*********************************************************************** %MONITOR %STOP -> EXIT1 !* PI(99): !*********************************************************************** !* FOLLOWING , * !* SET FREE FORMAT MARKER * !* BACKSPACE OVER , FOR PROCESSING * !*********************************************************************** Com_Inp = Com_Inp-1 -> L602;! RESET Com_Nextch !* PI(102): !*********************************************************************** !* Following = in PARAMETER statement * !* Check that that no conflict exists * !*********************************************************************** Com_Curstatclass=1 %if Com_Statordermode>2 %then LFAULT(236) GSTATE=1 I=PP_CLASS %if I=16 %thenstart PI102A: ER=240;! already a PARAMETER ->EXIT4P %finish %if I&4#0 %thenstart;! AN ARRAY ERRIDEN="as an array" PI102B: ER=241 ->EXIT4P %finish %if I&3#0 %thenstart ERRIDEN="as an argument" ->PI102B %finish %if I>7 %thenstart ERRIDEN="as an external name" ->PI102B %finish %if PP_X1&X'80'#0 %thenstart ERRIDEN="in an EQUIVALENCE statement" ->PI102B %finish PP_CLASS=16;! constant name PP_LINK2=Com_Scptr PP_CONSTRES=0 PP_ADDR4=0 PP_X1=1 RES_W=PTR ->EXIT1 !* PI(103): !*********************************************************************** !* Set RES for constant or 'restricted' identifier * !* Check for permitted content as determined by CEXMODE * !* CEXMODE = 0 any constant expression * !* 1 integer constant expression * !* 2 integer expression in DATA implied-D0 subscript * !* 3 integer dimension expression * !* P1 = 0 after var or non-complex const * !* 1 after complex const * !*********************************************************************** %if CEXMODE=2 %thenstart;! DATA implied-DO subscript %if CTYP>0 %thenstart;! constant %if PI21MODE=1 %then ->PI103C;! integer value ER=253;! subscript must be integer ->EXIT4P PI103C: I=1;! TYPE INT PI103D: CRM1=1 ->L536A %finishelsestart;! iden - note it I=IMPDOHEAD %while I#0 %cycle IMPDOREC==record(Com_Adict+I) %if STRING(Com_Anames+IMPDOREC_IDEN)=IDENTIFIER %thenstart Res_H0=I; Res_Form=0; Res_Mode=1;! first word of record will hold const ->PI103C %finish I=IMPDOREC_LINK %repeat IMPDOREC==record(Com_Adict+PTR) IMPDOREC_LINK=IMPDOHEAD;! add new item to list STRING(Com_Anames+Com_Namesfree)=IDENTIFIER IMPDOREC_IDEN=Com_Namesfree Com_Namesfree=Com_Namesfree+LENGTH(IDENTIFIER) IMPDOHEAD=Com_Dptr Com_Dptr=Com_Dptr+IMPDORECSIZE ->PI103C %finish %finish %if CEXMODE=3 %thenstart;! dimension expression %if PI21MODE>2 %thenstart ER=249;! dimension must be integer ->EXIT4P %finish %if CTYP>0 %then ->PI103C;! const I=PP_CLASS PP_X1=PP_X1!2;! ensure that params are copied in %if 1<=I<=2 %thenstart;! common or param scalar %if I=1 %then Alloc(Ptr);! temp solution +++++++++++ Res_H0=PTR>>DSCALE; Res_Form=I+2; Res_Mode=Pi21mode ->PI103C %finish %if I>2 %thenstart %if I=16 %thenstart PI103B: RES_W=PP_CONSTRES;! pick up result descriptor %if RES_W=0 %then ->PI103E I=PP_TYPE&7 ->PI103C %finish ER=246;! name invalid in dimension expression ->EXIT4P %finish CTYP=0;! to avoid untoward failure in PI(53) state check Res_H0=PTR>>DSCALE; Res_Form=5; Res_Mode=1;! name as yet unknown ->PI103C %finish %if P1=1 %then ->EXIT1;! no further checks for complex const I=CTYP&7 %if CTYP>0 %then ->PI103D;! const I=PP_TYPE&7 %if PP_CLASS=16 %then ->PI103B;! const name PI103E:ER=275;! not symbolic name of a constant ->EXIT4P !* PI(104): !*********************************************************************** !* P1 = 0 EXTERNAL * !* 1 EXTERNAL /ALGOL/ * !* 2 GENERIC * !* 3 INTRINSIC * !*********************************************************************** Com_Inhibop4=1 Com_Curstatclass=1 %if Com_Statordermode>2 %then ER=236 %and ->EXIT4 Com_Statordermode=2 %if P1=2 %then ->UP3;! IGNORE THIS STATEMENT (77+) %if P1=1 %thenstart %if Com_Options1&1#0 %then ER=100 %and ->EXIT4P;! allow /ALGOL/ on EMAS only Com_Algolref=1 %finish CRM8=P1 ->EXIT1 !* PI(106): !*********************************************************************** !* SKIP REST OF STATEMENT * !*********************************************************************** ->UP3 !* PI(107): !*********************************************************************** !* Scan potential expression for first non-alphanumeric or dot or EOL * !* If , or ) or EOL then take alternate path to simplify analysis * !*********************************************************************** I=Com_Inp %while TYPE(I)<7 %cycle I=I+1 %repeat ICOMP=ICOMP+2 J=TYPE(I) %if J=7 %or J=12 %then ->EXIT2;! if , or ) ICOMP=ICOMP+2 ->EXIT1 !* PI(108): !*********************************************************************** !* Skip rest of statement * !*********************************************************************** ->UP3;! SKIP REST OF STATEMENT !* PI(110): !*********************************************************************** !* Primarily to set GSTATE=12 prior to evaluating integer expressions * !*********************************************************************** %if P1=3 %then ->EXIT1 GSTATE=P1 NOTFLAG=0 ->EXIT1 !* PI(111): !*********************************************************************** !* Check if RETURN valid in context * !* Follow by PI(89) * !*********************************************************************** %if Com_Subprogtype=1 %then LFAULT(202) Com_Statement=1;! classification for ITS ->PI89 !* PI(112): !*********************************************************************** !* Set default identifier for unnamed BLOCKDATA * !*********************************************************************** PI112:PTR=0;! to avoid unassigned check in call of NEWSUBPROGRAM P1=5;! TO INDICATE BLOCKDATA {2900} BLOCKDATAID="ICL9HFBLKDTA" !{PERQ} BLOCKDATAID="BLKDTA" ->PI70 !* PI(113): !*********************************************************************** !* Check sequencing of block IF statements * !*********************************************************************** Com_Labwarn=0 Com_Statement=10+P1;! needed to ensure that forward refs to ENDIF label are not rejected ER=IFCHECK(BLOCKIFSTATE<<2!P1) %if ER>200 %thenstart;! invalid seqence ->EXIT4 %finish BLOCKIFSTATE=ER %if BLOCKIFSTATE=0 %thenstart I=Com_Ifptr %while I#0 %cycle IFREC==record(Com_Adict+I) I=IFREC_LINK1 %if IFREC_TYPE=0 %then %EXIT;! matching IF %repeat %if I#0 %thenstart;! nested IFs IFREC==record(Com_Adict+I) BLOCKIFSTATE=IFREC_TYPE+1 %finish %finish ->EXIT1 PI(114): !*********************************************************************** !* after *) in dimension list * !*********************************************************************** K=X'A0000000' ->PI26B !* PI(116): !*********************************************************************** !* Note integer value in the analysis tree * !*********************************************************************** RES_W=P1 ->EXIT1 !* PI(118): !*********************************************************************** !* Call GENERATE to evaluate a const expression * !*********************************************************************** GENERATE RD ->EXIT1 !* PI(120): !*********************************************************************** !* Note previous character position for errors reported by GENERATE * !*********************************************************************** RES_W=Com_Inp-1 ->EXIT1 !* PI(121): !*********************************************************************** !* Check statement order for type statement * !*********************************************************************** Com_Curstatclass=1 %if Com_Statordermode>2 %then LFAULT(236) %and ->EXIT1 Com_Statordermode=2 ->EXIT1 !* PI(122): !*********************************************************************** !* Report end of definition if NEXTCH is EOL * !*********************************************************************** %if Com_Nextch=10 %then ->PIZERO ->EXIT1 !* PI(123): !*********************************************************************** !* Process char length of form (*) or * !*********************************************************************** Com_Inhibop4=1 %if P1#1 %thenstart;! (*) %if P1#0 %then Com_Pi21int=0 %and ->PI24A;! ADJUST IDENTIFIER RECORD CHARLEN=0 ->EXIT1 %finish GENERATE RD Com_Pi21int=RES_H0 %if RES_FORM=1 %thenstart %if RES_MODE=2 %thenstart Com_Pi21int=INTEGER(Com_Adict+Com_Pi21int<EXIT4;! bad character length ->EXIT1 !* PI(124): !*********************************************************************** !* Following recognition of an identifier in a SAVE list * !* P1 = 0 not a common block name * !* 1 a common block name * !*********************************************************************** Com_Dptr=Com_Dptr+W4;! in case record just created for a common block PTR=FREESP(4) SS==record(Com_Adict+PTR) SS_INF0=RES_W;! dict @ of iden record SS_INF2=Com_Linest SS_INF3=P1 SS_LINK1=SAVELIST SAVELIST=PTR %if P1=1 %and Ctyp<0 %thenstart;! new iden - set common block Ptr=Res_W PP==record(Com_Adict+Ptr) -> Pi28a;! to complete initialisation of a common block record %finish ->EXIT1 !* PI(125): !*********************************************************************** !* Before I/O list item * !* Scan for EOL or iden only before , ) = EOL * !*********************************************************************** GSTATE=1 %if Com_Nextch=NL %thenstart;! skip alternatives ICOMP=ICOMP+8 ->EXIT1 %finish %unless TYPE(Com_Inp)=1 %thenstart;! constant or expression PI125A: ICOMP=ICOMP+2 ->EXIT2 %finish I=Com_Inp+1 %cycle J=TYPE(I) %if J>3 %thenstart %if J=7 %or J=12 %or INPUT(I)='=' %thenstart ICOMP=ICOMP+6 ->EXIT2 %finishelse ->PI125A %finish I=I+1 %repeat !* PI(129): !*********************************************************************** !* Following END DO statement * !*********************************************************************** %if Com_Doptr=0 %then Er=334 %and ->Exit4;! no Do to match ->Exit1 !* PI(130): !*********************************************************************** !* Following DO statement - traditional or DO WHILE * !* Investigate whether label is specified * !*********************************************************************** %if Type(Com_Inp)&X'7F'=3 %then P1=3 %and ->PI21;! label specified Com_Pi21int=-1 ->Exit1 !* PI(131): !*********************************************************************** !* following recognition of DO WHILE () * !*********************************************************************** ->Exit1 !* PI(132): !*********************************************************************** !* following recognition of INCLUDE * !*********************************************************************** %if Include=0 %then ->Up3 %else ->Exit4 ->Exit1 !* %routine FIND !*********************************************************************** !* SET PTR TO HEAD OF IDEN HASH LIST AND SEARCH * !*********************************************************************** PTR=FINDA(LHEAD(HASHVALUE)) PP==record(Com_Adict+PTR) %end !* %routine CBNAME !*********************************************************************** !* NAME SEARCH HAS LOCATED A COMMON BLOCK NAME. IGNORE THIS AND * !* SEARCH FOR THE PERMITTED ALTERNATIVE DEFN. * !*********************************************************************** PP == record(Com_Adict+PTR) PTR=FINDA(PP_LINK1) PP==record(Com_Adict+PTR) %end; ! CBNAME !* %integerfn SCAN(%integer CHAR) !*********************************************************************** !* Scan for CHAR before next , or ) at current bracket level * !* Result = 0 not found * !* 1 found * !*********************************************************************** %integer I,J,BC BC=0 I=Com_Inp J=INPUT(Com_Inp) %while J#10 %cycle;! to EOL %if BC=0 %thenstart %if J=CHAR %then %result=1 %if J=',' %or J=')' %then %result=0 %if J='(' %then BC=BC+1 %finishelsestart %if J='(' %then BC=BC+1 %if J=')' %then BC=BC-1 %finish I=I+1 J=INPUT(I) %repeat %result=0 %end;! SCAN !* %routine GENERATE RD !*********************************************************************** !* Call generate to evaluate (what should be) a const expression * !*********************************************************************** %integer I I=Generate(Triads,Nexttriad,Lin,-1,0,Comad,Output) RES_W=Com_Rescom1 RESL=RES_W RESR=Com_Rescom2 %if RES_MODE=1 %thenstart;! integer %if RES_FORM=0 %thenstart;! value in RES Com_Pi21int=RES_H0 %finishelsestart %if RES_FORM=1 %then Com_Pi21int=INTEGER(Com_Adict+RES_H0<Error Charno(S,I)=J %repeat %finish %result=0 %end;! Include !* %routine Notype Lfault(333) Ttyp=X'51' PP_Type=Ttyp %end !* %routine WRIT(%integer I,J) %integer K K=I//1000 %if K#0 %thenstart PRINTSYMBOL(HEX(K)) I=I-K*1000 %finish K=I//100 %if K#0 %thenstart PRINTSYMBOL(HEX(K)) I=I-K*100 %finish J=I//10 %unless J=0 %and K=0 %thenstart PRINTSYMBOL(HEX(J)) %finish PRINTSYMBOL(HEX(I-10*J)) %end !* %routine STRACE WRITE(ICOMP-2,4) %if Com_Ptrace=2 WRITE(Com_Nextch,4) %if P > 9 %thenstart PRINTSTRING(" $") WRIT(P,2) PRINTSTRING("(") WRIT(P1,1) PRINTSTRING(")") NEWLINE %finishelsestart %if Com_Ptrace=2 %thenstart SPACES(4) %if P = 2 %then PRINTSYMBOL(P1) %and SPACES(5) %if P = 6 %then PRINTSTRING("<@>") %and SPACES(5) %if P = 1 %thenstart PRINTSTRING("<".SUBNAMES(P1).">") SPACES(5) %finish %if P=0 %then PRINTSTRING("===") %and SPACES(5) %if P=4 %thenstart PRINTSTRING(STRING(ADDR(SSTRING(SHEADS(P1))))) SPACES(5) %finish %if P=7 %thenstart PRINTSTRING("[") PRINTSYMBOL(P1) PRINTSTRING("]") %finish %if P=3 %thenstart PRINTSYMBOL(P1) PRINTSYMBOL('"') %finish NEWLINE %finish %finish %end;! STRACE !* !* %integerfn GET NEXT VARIABLE %integerfnspec IMPDO %CONSTBYTEINTEGERARRAY VSIZE(0:15)=2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1 %CONSTBYTEINTEGERARRAY LOGMODE(0:6)=0(3),9,10,11,12 %integer VTYPE,RES,ARRAY %record(SRECF) %name SS START:%if VLISTHEAD=0 %then %result=0;! VCOUNT still zero to provoke error 286 SS==record(Com_Adict+VLISTHEAD) %if SS_INF3<=0 %thenstart;! IMPLIED DO RES=IMPDO %if RES>0 %then %result=-RES %if RES<0 %thenstart VLISTHEAD=SS_LINK1 ->START %finish %finish PTR=SS_INF0 PP==record(Com_Adict+PTR) IDENTIFIER=STRING(Com_Anames+PP_IDEN) VTYPE=PP_TYPE VMODE=SETMODE(VTYPE&X'3F') %if VTYPE&X'F'=4 %then VMODE=LOGMODE(VTYPE>>4) %if VTYPE=5 %thenstart %if SS_INF4#0 %then VLENGTH=SS_INF4 %C %else VLENGTH=PP_LEN %finishelse VLENGTH=VSIZE(VMODE) VCOUNT=1 VDISP=0 ALLOC(PTR) %if PP_CLASS&2=0 %or PP_X0&16#0 %thenstart;! not in comon %if Com_Subprogtype=5 %then %result=284;! name not in common %finishelsestart;! in common %if Com_Subprogtype#5 %then %result=-282;! init common only in BLOCKDATA %if PP_Link3<0 %then FREE LIST CELL(VLISTHEAD,5) %result=0 !* %integerfn IMPDO %integer INIT,INC,FINAL,I,J,L,C,AD,ER %switch A(0:5) !* %integerfn VAL(%integer P) %integer I %record(PRECF) %name PP %record(RESF) RES %if P&X'C0000000'#X'80000000' %then %result=P P=P&X'7FFFFFFF' %cycle I=DOLEVEL,-1,1 %if DDO(I)_CONTID=P %then %result=DDO(I)_VALUE %repeat PP==record(Com_Adict+P) IDENTIFIER=STRING(Com_Anames+PP_IDEN) %if PP_CLASS=16 %thenstart;! CONST RES_W=PP_CONSTRES %if RES_MODE#1 %then LFAULT(253) %and %result=1 J= RES_H0 %if Res_Form=1 %and Res_Mode=1 %then J=INTEGER(Com_Adict+J<9 %thenstart J=Val(SS_Inf0) L=Ldim(SS_Inf2) %if I=10 %thenstart L=L*J Ass: Ldim(SS_Inf2)=L ->Check %finish %if I=11 %thenstart L=L//J ->Ass %finish %if I=12 %thenstart L=L+J ->Ass %finish L=L-J ->Ass %finish ->A(-SS_INF3) !* A(0): ! INITIALISE L=SS_INF0 DOLEVEL=L INIT=VAL(DDO(L)_INIT) INC=VAL(DDO(L)_INCR) FINAL=VAL(DDO(L)_FINAL) %if ER#0 %then %result=ER %if INC=0 %then %result=295 C=(FINAL-INIT+INC)//INC %if C<=0 %then %result=290 DDO(L)_LEFT=C-1 DDO(L)_VALUE=INIT %result=-1 !* A(1): ! ARRAY NAME ARRAY=VLISTHEAD PP==record(Com_Adict+SS_INF0) DVREC==record(Com_Adict+PP_ADDR4) %result=-1 !* A(2): ! SUBSCRIPT LDIM(SS_INF2)=VAL(SS_INF0) Check:%if ER#0 %then %result=ER %result=-1 !* A(3): ! END OF SUBSCRIPT LIST VLISTHEAD=SS_LINK1 SS==record(Com_Adict+ARRAY) J = DVREC_DIMS I=1;! to avoid IMP compiler bug L = LDIM(I)-DVREC_B(I)_L %if J > 1 %thenstart %cycle I = 2,1,J L = L+DVREC_B(I-1)_M*(LDIM(I)-DVREC_B(I)_L) %repeat %finish %unless 0 <= L < DVREC_NUMELS %then %C IDENTIFIER=STRING(Com_Anames+PP_IDEN) %and %result=232 ! OUTSIDE DECLARED BOUNDS %if PP_TYPE=CHARTYPE %then J=PP_LEN %else %C J=NUMBYTES(PP_TYPE>>4);! BYTES PER ITEM %if PP_TYPE&7=CMPLXTYPE %then J=J<<1;! COMPLEX I = (L*J)!X'1000000' SS_INF2=I %result=0 !* A(4): ! END OF DO LOOP L=SS_INF0 C=DDO(L)_LEFT %if C=0 %then %result=-1 DDO(L)_LEFT=C-1 DDO(L)_VALUE=DDO(L)_VALUE+VAL(DDO(L)_INCR) SS==record(Com_Adict+DDO(L)_START) %result=-1 %end;! IMPDO %end;! GET NEXT VARIABLE !* %integerfn DATA IMPLIED DO %SWITCH P41(0:10) K=0 %if P1>9 %thenstart K=Dimscount I=-P1 ->PI41C %finish ->P41(P1) !* P41(0): ! ( DOIO=DOIO+1 DOLEVEL=DOIO I=0 J=DOIO PI41A:PTR=FREESP(5) SS==record(Com_Adict+PTR) SS_INF0=J; SS_INF4=0;! 5-word record needed for consistency with char substrings SS_INF2=K SS_INF3=I;! action switch %unless VLISTHEAD=0 %thenstart SS==record(Com_Adict+VLISTTAIL) SS_LINK1=PTR %finishelse VLISTHEAD=PTR VLISTTAIL=PTR %if P1=0 %then DDO(DOIO)_START=PTR %result=0 !* P41(1): ! arrayid( %if PP_CLASS=12 %then CBNAME ER=245 %unless PP_CLASS&13=4 %then %result=3 {PI34ERR} ERRIDEN=STRING(Com_Anames+PP_IDEN);! for subscript errors DVREC==record(Com_Adict+PP_ADDR4) DIMSCOUNT=0 I=-1 J=PTR ->PI41A;! to enter array record !* P41(2): ! after controlled iden DDO(DOLEVEL)_CONTID=PTR %result=0 !* P41(3): ! initial P41(4): ! final P41(5): ! increment %if CTYP<=0 %thenstart J=1<<31!PTR %finishelsestart;! const %unless CTYP&15=1 %then ER=131 %and %result=1 {EXIT4P} J=Com_Pi21int %finish %if P1=3 %then DDO(DOLEVEL)_INIT=J %elsestart %if P1=4 %then DDO(DOLEVEL)_FINAL=J %else DDO(DOLEVEL)_INCR=J %finish %result=0 !* P41(6): ! default incr DDO(DOLEVEL+1)_INCR=1 %result=0 !* P41(7): ! ) I=-4 J=DOLEVEL DOLEVEL=DOLEVEL-1 ->PI41A !* P41(8): ! after subscript %if DIMSCOUNT>DVREC_DIMS %thenstart PI41B: ER=264 IDENTIFIER=ERRIDEN %result=2 {EXIT4} %finish DIMSCOUNT=DIMSCOUNT+1 K=DIMSCOUNT I=-2 PI41C:%if CTYP<=0 %thenstart;! var J=1<<31!PTR %finishelsestart %unless CTYP&15=1 %then ER=136 %and %result=1 {EXIT4P} J=Com_Pi21int %finish ->PI41A P41(9): ! ) following aray element %unless DIMSCOUNT=DVREC_DIMS %then ->PI41B I=-3 J=0 ->PI41A %end;! DATA IMPLIED DO !* %integerfn EQUIVALENCE %if CRM3 = -1 %then %result=1; ! FAULT ALREADY DETECTED %if VLISTHEAD = VLISTTAIL %thenstart; ! < 2 ITEMS IN LIST ER = 265 EQUIVERR:LFAULT(ER) %result=1 %finish SPTR = VLISTHEAD %cycle SS == record(Com_Adict+SPTR) PTR = SS_INF0 PP == record(Com_Adict+PTR) %if SS_INF2&X'FF000000'=X'01000000' %then %C SS_INF2 = SS_INF2&X'FFFFFF'; ! CLEAR FLAG SET BY PI(34) FOR ARRAY ELEMENT(NOT RELEVANT FOR EQUIV) PP_X1=PP_X1!X'80' %if PP_CLASS&2 # 0 %thenstart; ! COMMON ELEMENT ER = 266; ! > 1 COMMON ELEMENT IN LIST %if CCOUNT # 1 %then -> EQUIVERR CCOUNT = PTR; ! SAVE COMMON ITEM POINTER %finishelsestart; ! NOT A COMMON ITEM K = PP_X1; ! EQUIV TO : EQUIV FROM : DATA : ALLOCATED ER = 236; ! VARIABLE ALREADY ALLOCATED %if K&1 # 0 %then %C IDENTIFIER=STRING(Com_Anames+PP_IDEN) %and -> EQUIVERR P=PTR J = VLISTHEAD PI44A: %if J # SPTR %thenstart; ! CHAIN THROUGH PREVIOUS ENTRIES TO CHECK CONTRADICTIONS SSS == RECORD(Com_Adict+J) %if SSS_INF0 # PTR %thenstart J = SSS_LINK1 -> PI44A %finishelsestart; ! SPTR ITEM ALREADY INCLUDED IN CURRENT LIST ER = 267; ! CONTRADICTION IN EQUIV LIST Com_Pi21int=SS_INF3 %if SSS_INF2 # SS_INF2 %then -> EQUIVERR QQ_LINK1 = SS_LINK1; ! REMOVE DUPLICATE ENTRY FROM LIST FREE LIST CELL(SPTR,5) -> PI44B; ! LINK TO NEXT ITEM ALREADY SET %finish %finish %if (K&4#0 %and SPTR#PP_LINK2) %thenstart ! NOW LINK IN EXISTING EQUIVALENCE CHAIN J = SS_LINK1; ! SAVE LINK TO NEXT (AS YET UNCHECKED) ITEM L = PP_LINK2; ! TO CORRESPONDING ENTRY ALREADY IN AN EQUIV LOOP SSS == record(Com_Adict+L) K = SS_INF2-SSS_INF2; ! ADJUSTMENT REQUIRED TO ALLIGN EXISTING CHAIN N = SSS_LINK1 SS_LINK1 = N; ! START EQUIV CHAIN FROM THE NEW RECORD %cycle SSS == record(Com_Adict+N) SSS_INF2 = SSS_INF2+K N = SSS_LINK1 %if N=0 %then %result=1;! previously reported error %repeat %until N = L FREE LIST CELL(L,5) SSS_LINK1 = J %finishelse PP_X1= K!4; ! SET 'EQUIV FROM' BIT PP_LINK2 = SPTR %finish QQ == record(Com_Adict+SPTR) SPTR = SS_LINK1 PI44B: %repeat %until SPTR = 0 QQ_LINK1 = VLISTHEAD; ! COMPLETE THE LOOP %if CCOUNT # 1 %thenstart; ! COMMON ITEM IN CHAIN PTR=FREESP(2) SS==record(Com_Adict+PTR) SS_INF0=P;! will be allocated late to ensure correct common size SS_LINK1=Com_Equchk Com_Equchk=PTR %finish %result=0 %end;! EQUIVALENCE !* %routine Report Error(%integer Index,Type,Errno) %if Reported Error&Index=0 %thenstart %if Type=0 %then Fault(Errno) %else Lfault(Errno) %finish Reported Error=Reported Error!Index %end;! Report Error !* %end;! ANALYSE !* %routine ANALINIT !*********************************************************************** !* Re-initialise at start of each subprogram * !*********************************************************************** %integer I,J,Ptr %integer C %record(Precf) %name PP %string(15) S Init Input(Comad) Init Alloc(1,Comad,0,0) Zero(addr(Lhead(0)),620) Zero(Com_Adict,256) %cycle I=0,1,13 Bitfnsperm(I)=0 %repeat Com_Cbnptr=0 Com_Doptr=0 Com_Scptr=0 Com_Sfptr=0 Com_Subprogtype=0 Com_Subprogptr=0 Com_Fnlst=0 Com_Sfmk=0 Com_Headings=0 Com_Checklist=0 Datahead=0 Com_Externals=0 Com_Fno=0 Cgolab=0 Notflag=0 Pct=0 Blockifstate=0 Com_Labwarn=0 Com_Vreturn=0;! will be non-zero if any variable return Com_Entries=0;! will be non-zero if any side-entries Com_Assgotos=0;! list of assigned goto labels for optimiser Com_Tmpptr=0;! list of temps defined by GENERATE (for use by optimiser) Com_Destemps=0;! listhead of descriptor temp records created by optimiser Com_Namesfree=2;! free location for next identifier Com_Nextbit=4;! reserving bitstring entries 0 to 3 Com_Nexttemp=1 Com_Ifptr=0;! nest of active IF blocks Com_Nextplab=1;! private label index Com_Tmindex=0;! index of TM specifiers produced by optext Com_Inhibop4=0;! will be set to 1 if any reason to inhibit OP4 Com_Argcnt=0;! no of args - used by Op4 Com_Idcnt=0;! no of identifiers - used by Op4 Com_Labcnt=0;! no of user defined labels - used by Op4 Com_Tmlist=0;! listhead of TM specifiers used by optext Com_Inp = 1 J=Default Size(2) %cycle I = 'A',1,'Z' Imptype(I) = J; ! set implicit type for alphabetics to real %repeat J=DEFAULT SIZE(1) %cycle I = 'I',1,'N' Imptype(I) = J; ! over-ride I - N with implicit integer %repeat Charmask=0;! for implicit bit settings Com_Statordermode=0 Com_Algolref=0;! WILL BE SET TO 1 IF EXTERNAL /ALGOL/ APPEARS %if Com_F77parm&X'800000'#0 %then Com_Algolref=1 %cycle I=0,1,156 Fnspecials(I)=Fnspecials(I)&X'FFFFF';! reset %repeat Com_Equchk=0;! list of equiv chains including a common item !* !******** INITIALISE BLANK COMMON ENTRY IN DICT !* Com_Dptr = Blcmptr S="F#BLCM" Ptr=Locate Name(S) Com_Dptr=Com_Dptr+Cmnrecext PP==record(Com_Adict+Ptr) PP_Class=12; ! COMMON BLOCK NAME PP_Last = Ptr; ! 'LAST ITEM' POINTER TO ITSELF - NO ITEMS YET DEFINED {2900} PP==record(Com_Adict+PSEUDOCMN);! local arrays treated as common sometimes {2900} PP_CMNREFAD=8;! only relevant entry is disp of ref @ {2900} Com_Dptr=200;! WILL ENSURE THAT CONST VALUES ARE >=256 BYTES UP DICT {2900} ! TO AVOID ERROR IN ADD DATA ITEM !* Com_Firststatnum=Com_Linest+1;! FOR STATEMENT MAP !* Savelist=0;! list of items in SAVE statements !* Com_Adblkdtaid=ADDR(BLOCKDATAID) !* %end;! ANALINIT !* !* %externalintegerfn Analstart(%record(Triadf)%arrayname Triads, %integer Adcom,%integername Count) %integer I,J,TLTYP,PTR,SPTR,PATH,LIN,ER !* %record(DORECF)%name DOREC %record(IFRECF)%name IFREC %record(LABRECF)%name LABREC %record(SRECF)%name SS %string(15) S %integerarray Output(0:4000) !* %routine Check Lab Ref %integer Er %if Com_Allowvax=NO %then Er=206 %else Er=331;! error else warning %if LABREC_DOSTART#0 %thenstart;! within a DO loop %unless SS_INF2>=LABREC_DOSTART %then IFAULT(Er,SS_INF2) %finish %if LABREC_IFSTART#0 %thenstart;! within an IF block %unless SS_INF2>=LABREC_IFSTART %or Com_Statement=13 %C %then IFAULT(204,SS_INF2);! avoid test if ENDIF statement %finish %if Com_Curstatclass=1 %then IFAULT(218,SS_INF2) %end;! Check Lab Ref !* Comad=Adcom;! address of common data area Com==record(Adcom) Com_Adident=addr(Identifier) Com_Aderriden=addr(Erriden) Com_Adlhead=addr(Lhead(0)) !* Default Size(1)=X'51' Default Size(2)=X'52' !* %if Com_F77parm&X'08000000'#0 %thenstart;! I2 Default Size(1)=X'41' %finish !* %if Com_F77parm&X'00004000'#0 %thenstart;! undefined Default Size(1)=0 Default Size(2)=0 %finish !* Analinit !* Com_Nexttriad=1 Com_Trblock=0 !* %if Count=0 %thenstart %unless Com_Lineno>0 %thenstart Com_Faulty=0 Readnext %finish First Stat;! check for invalid first statement %finish !* NEXT STATEMENT: I=Readline(Input,Type,Ltype) %if I#0 %then %result=I LTYPE = MAPLTYPE(LTYPE); ! MAPLTYPE(0:7)=0,0,1,2,4,4,5,5 TLTYP = LTYPE %if Com_Subprogtype = 0 %then LTYPE = 6 ANALYSE LINE: LIN=0 Com_Nextch = INPUT(1) Com_Inp = 1 Com_Maxinp=1 CGOLAB=0 Com_Fnlst=0 NOTFLAG=0 PCT=0 Com_Sfmk=0 !* Path=Analyse(Triads,Com_Nexttriad,Ltype,Com_Adict,Lin,Output) !* %if Com_Subprogtype = 0 %and Com_Nextch # NL %thenstart; ! MUST BE A MAIN PROGRAM S="F_MAIN" PTR=LOCATE NAME(S) I=NEW SUBPROGRAM(PTR,0,0,ER);! MAIN PROGRAM I=Generate(Triads,Com_Nexttriad,0,-2,Com_Rescom1,Comad,Output);! register private label LTYPE = TLTYP; ! ORIGINAL CLASSIFICATION (OVER-RIDDEN BECAUSE SUBPROGTYPE WAS 0) -> ANALYSE LINE %finish !* %if PATH#3 %and Com_Curstatclass=0 %and Com_Nextch=10 %C %then Com_Statordermode=4;! executable statement !* %if Com_Lab = 0 %thenstart %if Com_Labwarn#0 %then LFAULT(177) PTR = 0 %finishelsestart Com_Labwarn=0 I=SETLAB(Com_Lab,PTR) LABREC==record(Com_Adict+PTR) %if LABREC_LINE # 0 %thenstart; ! LABEL ADDRESS ALREADY SPECIFIED IFAULT(227,LABREC_LINE); ! LABEL SET TWICE ->AFTER LABEL %finish LABREC_LINE=Com_Linest %if Com_Curstatclass=0 %then Com_Curstatclass=2 LABREC_X0=LABREC_X0!Com_Curstatclass;! 1 non-exec 2 exec %if LABREC_X0&8 # 0 %thenstart IFAULT(228,LABREC_LINK5); ! LAB IS A FORMAT LABEL %finish %if Com_Doptr#0 %thenstart DOREC==record(Com_Adict+Com_Doptr) LABREC_DOSTART=DOREC_LINE;! start of DO enclosure LABREC_DOEND=X'7FFF' I=NEW LIST CELL(DOREC_LABLIST,2) SS==record(Com_Adict+I) SS_INF0=PTR %finish !* %if Com_Ifptr#0 %thenstart IFREC==record(Com_Adict+Com_Ifptr) LABREC_IFSTART=IFREC_LINE;! start of IF block enclosure LABREC_IFEND=X'7FFF' I=NEW LIST CELL(IFREC_LABLIST,2) SS==record(Com_Adict+I) SS_INF0=PTR %finish !* SPTR=LABREC_LINK2;! LIST OF FORWARD REFERENCES %while SPTR#0 %cycle SS==record(Com_Adict+SPTR) CHECK LAB REF FREE LIST CELL(SPTR,3);! abandon these list cells now that triads are used %repeat LABREC_LINK2=0;! new entries will be set in CODEGEN SPTR=LABREC_LINK3;! LIST OF GLA WORDS TO HOLD LABEL @ %while SPTR#0 %cycle SS==record(Com_Adict+SPTR) %if SS_INF2#0 %then CHECK LAB REF;! AVOID CHECK FOR ASSIGNED LABELS SPTR=SS_LINK1 %repeat %finish AFTER LABEL: !* I=Generate(Triads,Com_Nexttriad,Lin,Path,Ptr,Comad,Output) !* %if Com_Subprogtype < 0 %thenstart;! END OF SUBPROGRAM Com_Faulty=Com_Faulty+Com_Fno newlines(2) %if Com_Listl#0 ANALINIT Com_Nexttriad=1 Com_Trblock=0 %finish -> NEXT STATEMENT !* %end;! Analstart !* %endoffile