INCLUDE "ERCC07.TRIMP_HOSTCODES"
CONSTINTEGER HOST=EMAS
INCLUDE "ERCC07.TRIMP_TFORM1S"
OWNINTEGERNAME ASL
OWNRECORD (LISTF)ARRAYNAME ASLIST
EXTRINSICRECORD (WORKAF)WORKA
EXTRINSICRECORD (PARMF)PARM
EXTERNALROUTINE MOVE BYTES(INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF)
!************************************************************************
!* A MOVE BYTES ROUTINE THAT WILL WORK ON WORD&BYTE ADDRESS M-CS *
!***********************************************************************
INTEGER I
RETURN IF LENGTH<=0
IF HOST=EMAS START ; ! EMAS BYTE ADDRESSES
I=X'18000000'+LENGTH
*LDA_TOBASE; *INCA_TOOFF; *LDTB_I
*LSS_FBASE; *IAD_FOFF; *LUH_I
*MV_L =DR
FINISH
IF HOST=PERQ START ; ! WORD ADDRESS+BYTE OFFSET
FBASE=FBASE+FOFF>>1
FOFF=FOFF&1
TOBASE=TOBASE+TOOFF>>1
TOOFF=TOOFF&1
*LDLDB_6; ! TO BASE
*LDL8; ! TOOFF (BTM BITS)
*LDLDB_2; ! FBASE
*LDL4; ! FOFF
*LDL0; ! LENGTH
*STLATE_X'63'
*MVBW
FINISH
IF HOST=ACCENT START ; ! WORD ADDRESS+BYTE OFFSET
FBASE=FBASE+FOFF>>1
FOFF=FOFF&1
TOBASE=TOBASE+TOOFF>>1
TOOFF=TOOFF&1
*LDLDB_2; ! FBASE
*LDL4; ! FOFF
*LDLDB_6; ! TO BASE
*LDL8; ! TOOFF (BTM BITS)
*LDL0; ! LENGTH
*MVBW
FINISH
IF HOST=PNX START
FBASE=2*FBASE+FOFF
TOBASE=2*TOBASE+TOOFF
**FBASE
**TOBASE
**LENGTH
*MVB
FINISH
END
EXTERNALSTRING (255)FN PRINTNAME(INTEGER N)
INTEGER V,K
STRING (255) S
S="???"
IF 0<=N<=WORKA_NNAMES START
V=WORKA_WORD(N)
K=WORKA_LETT(V)
IF K#0 THEN S=STRING(ADDR(WORKA_LETT(V)))
FINISH
RESULT =S
END
STRINGFN MESSAGE(INTEGER N)
!***********************************************************************
!* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT *
!* 1 %REPEAT is not required *
!* 2 Label & has already been set in this block *
!* 4 & is not a Switch name at current textual level *
!* 5 Switch name & in expression or assignment *
!* 6 Switch label &(#) set a second time *
!* 7 Name & has already been declared *
!* 8 Routine or fn & has more parameters than specified *
!* 9 Parameter # of & differs in type from specification *
!* 10 Routine or fn & has fewer parameters than specified *
!* 11 Label & referenced at line # has not been set *
!* 12 %CYCLE at line # has two control clauses *
!* 13 %REPEAT for %CYCLE at line # is missing *
!* 14 %END is not required *
!* 15 # %ENDs are missing *
!* 16 Name & has not been declared *
!* 17 Name & does not require parameters or subscripts *
!* 18 # too few parameters provided for & *
!* 19 # too many parameters provided for & *
!* 20 # too few subscripts provided for array & *
!* 21 # too many subscripts provided for array & *
!* 22 Actual parameter # of & conflicts with specification *
!* 23 Routine name & in an expression *
!* 24 Integer operator has Real operands *
!* 25 Real expression in integer context *
!* 26 # is not a valid %EVENT number *
!* 27 & is not a routine name *
!* 28 Routine or fn & has specification but no body *
!* 29 %FUNCTION name & not in expression *
!* 30 %RETURN outwith routine body *
!* 31 %RESULT outwith fn or map body *
!* 34 Too many textual levels *
!* 37 Array & has too many dimensions *
!* 38 Array & has upper bound # less than lower bound *
!* 39 Size of Array & is more than X'FFFFFF' bytes *
!* 40 Declaration is not at head of block *
!* 41 Constant cannot be evaluated at compile time *
!* 42 # is an invalid repetition factor *
!* 43 %CONSTANT name & not in expression *
!* 44 Invalid constant initialising & after # items *
!* 45 Array initialising items expected ## items given # *
!* 46 Invalid %EXTERNAL %EXTRINSIC or variable %SPEC *
!* 47 %ELSE already given at line # *
!* 48 %ELSE invalid after %ON %EVENT *
!* 49 Attempt to initialise %EXTRINSIC or %FORMAT & *
!* 50 Subscript of # is outwith the bounds of & *
!* 51 %FINISH is not required *
!* 52 %REPEAT instead of %FINISH for %START at line # *
!* 53 %FINISH for %START at line # is missing *
!* 54 %EXIT outwith %CYCLE %REPEAT body *
!* 55 %CONTINUE outwith %CYCLE %REPEAT body *
!* 56 %EXTERNALROUTINE & at wrong textual level *
!* 57 Executable statement found at textual level zero *
!* 58 Program among external routines *
!* 59 %FINISH instead of %REPEAT for %CYCLE at line # *
!* 61 Name & has already been used in this %FORMAT *
!* 62 & is not a %RECORD or %RECORD %FORMAT name *
!* 63 %RECORD length is greater than # bytes *
!* 64 Name & requires a subname in this context *
!* 65 Subname & is not in the %RECORD %FORMAT *
!* 66 Expression assigned to record & *
!* 67 Records && and & have different formats *
!* 69 Subname && is attached to & which is not of type %RECORD *
!* 70 String declaration has invalid max length of # *
!* 71 & is not a String variable *
!* 72 Arithmetic operator in a String expression *
!* 73 Arithmetic constant in a String expression *
!* 74 Resolution is not the correct format *
!* 75 String expression contains a sub expression *
!* 76 String variable & in arithmetic expression *
!* 77 String constant in arithmetic expression *
!* 78 String operator '.' in arithmetic expression *
!* 80 Pointer variable & compared with expression *
!* 81 Pointer variable & equivalenced to expression *
!* 82 & is not a pointer name *
!* 83 && and & are not equivalent in type *
!* 86 Global pointer && equivalenced to local & *
!* 87 %FORMAT name & used in expression *
!* 90 Untyped name & used in expression *
!* 91 %FOR control variable & not integer *
!* 92 %FOR clause has zero step *
!* 93 %FOR clause has noninteger number of traverses *
!* 95 Name & not valid in assembler *
!* 96 Operand # not valid in assembler *
!* 97 Assembler construction not valid *
!* 98 Addressability *
!* 99 Facility not supported by target hardware *
!* 101 Source line has too many continuations *
!* 102 Workfile of # Kbytes is too small *
!* 103 Dictionary completely full *
!* 104 Dictionary completely full *
!* 105 Too many textual levels *
!* 106 String constant too long *
!* 107 Compiler tables are completely full *
!* 108 Condition too complicated *
!* 109 Compiler inconsistent *
!* 110 Input ended *
!* 201 Long integers are inefficient as subscripts *
!* 202 Name & not used *
!* 203 Label & not used *
!* 204 Global %FOR control variable & *
!* 205 Name & not addressable *
!* 206 Semicolon in comment text *
!* 207 %CONSTANT variable & not initialised *
!* 208 Unsupported precision used - nearest available substituted *
!* 209 Target machine is word addressed *
!* 210 Redundant %ALIAS provided *
!* 211 Prefix %SYSTEM not supported. Use %ALIAS *
!* 212 Unproductive logical operation noted *
!* 255 Contact Advisory Service *
!***********************************************************************
CONSTBYTEINTEGERARRAY OUTTT(0:63)='?','A','B','C','D','E','F','G',
'H','I','J','K','L','M','N',
'O','P','Q','R','S','T','U',
'V','W','X','Y','Z','&','-',
'/','''','(',')',
'a','b','c','d','e','f','g',
'h','i','j','k','l','m','n',
'o','p','q','r','s','t','u',
'v','w','x','y','z','.','%',
'#','?'(2)
CONSTINTEGER WORDMAX= 792,DEFAULT= 788
CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,C
1, 32769, 32771, 32772, 32773, 2, 32775, 32776,
32777, 32778, 32780, 32781, 32782, 32783, 32784, 4,
32776, 32771, 32772, 32785, 32786, 32788, 32789, 32790,
32792, 32794, 5, 32786, 32788, 32776, 32782, 32795,
32797, 32798, 6, 32786, 32800, 32801, 32781, 32785,
32802, 32804, 7, 32805, 32776, 32777, 32778, 32780,
32806, 8, 32808, 32797, 32810, 32776, 32777, 32811,
32812, 32814, 32815, 9, 32817, 32819, 32820, 32776,
32821, 32782, 32823, 32824, 32825, 10, 32808, 32797,
32810, 32776, 32777, 32828, 32812, 32814, 32815, 11,
32775, 32776, 32829, 32789, 32831, 32819, 32777, 32772,
32780, 32781, 12, 32832, 32789, 32831, 32819, 32777,
32834, 32835, 32837, 13, 32769, 32839, 32832, 32789,
32831, 32819, 32771, 32840, 14, 32842, 32771, 32772,
32773, 15, 32819, 32843, 32844, 32840, 16, 32805,
32776, 32777, 32772, 32780, 32806, 17, 32805, 32776,
32845, 32772, 32846, 32812, 32797, 32848, 18, 32819,
32850, 32851, 32812, 32852, 32839, 32776, 19, 32819,
32850, 32854, 32812, 32852, 32839, 32776, 20, 32819,
32850, 32851, 32848, 32852, 32839, 32855, 32776, 21,
32819, 32850, 32854, 32848, 32852, 32839, 32855, 32776,
22, 32856, 32858, 32819, 32820, 32776, 32860, 32862,
32825, 23, 32808, 32788, 32776, 32782, 32863, 32795,
24, 32864, 32866, 32777, 32868, 32869, 25, 32868,
32795, 32782, 32871, 32873, 26, 32819, 32771, 32772,
32785, 32875, 32876, 32878, 27, 32776, 32771, 32772,
32785, 32880, 32788, 28, 32808, 32797, 32810, 32776,
32777, 32825, 32882, 32883, 32884, 29, 32885, 32788,
32776, 32772, 32782, 32795, 30, 32887, 32889, 32880,
32884, 31, 32891, 32889, 32810, 32797, 32893, 32884,
34, 32894, 32854, 32792, 32895, 37, 32897, 32776,
32777, 32850, 32854, 32898, 38, 32897, 32776, 32777,
32900, 32901, 32819, 32902, 32814, 32903, 32901, 39,
32904, 32820, 32897, 32776, 32771, 32811, 32814, 32905,
32907, 40, 32908, 32771, 32772, 32789, 32911, 32820,
32784, 41, 32912, 32914, 32916, 32917, 32789, 32919,
32804, 42, 32819, 32771, 32863, 32921, 32923, 32925,
43, 32927, 32788, 32776, 32772, 32782, 32795, 44,
32929, 32931, 32933, 32776, 32936, 32819, 32937, 45,
32897, 32933, 32937, 32938, 32940, 32937, 32941, 32819,
46, 32929, 32942, 32944, 32797, 32946, 32948, 47,
32949, 32778, 32941, 32789, 32831, 32819, 48, 32949,
32921, 32936, 32950, 32876, 49, 32951, 32953, 32954,
32944, 32797, 32956, 32776, 50, 32958, 32820, 32819,
32771, 32889, 32960, 32961, 32820, 32776, 51, 32963,
32771, 32772, 32773, 52, 32769, 32965, 32820, 32963,
32839, 32967, 32789, 32831, 32819, 53, 32963, 32839,
32967, 32789, 32831, 32819, 32771, 32840, 54, 32969,
32889, 32832, 32769, 32884, 55, 32970, 32889, 32832,
32769, 32884, 56, 32972, 32776, 32789, 32976, 32792,
32794, 57, 32977, 32979, 32981, 32789, 32792, 32794,
32982, 58, 32983, 32985, 32986, 32988, 59, 32963,
32965, 32820, 32769, 32839, 32832, 32789, 32831, 32819,
61, 32805, 32776, 32777, 32778, 32780, 32990, 32782,
32783, 32956, 62, 32776, 32771, 32772, 32785, 32991,
32797, 32991, 32956, 32788, 63, 32991, 32993, 32771,
32995, 32814, 32819, 32907, 64, 32805, 32776, 32997,
32785, 32999, 32782, 32783, 32873, 65, 33001, 32776,
32771, 32772, 32782, 32960, 32991, 32956, 66, 33003,
33005, 32953, 33007, 32776, 67, 33009, 33011, 33012,
32776, 33013, 33014, 33016, 69, 33001, 33011, 32771,
33018, 32953, 32776, 33020, 32771, 32772, 32820, 32823,
32991, 70, 33021, 33023, 32777, 32921, 33026, 32993,
32820, 32819, 71, 32776, 32771, 32772, 32785, 33021,
32946, 72, 33027, 32866, 32782, 32785, 33021, 32795,
73, 33027, 32931, 32782, 32785, 33021, 32795, 74,
33029, 32771, 32772, 32960, 33031, 33033, 75, 33021,
32795, 33035, 32785, 33037, 32795, 76, 33021, 32946,
32776, 32782, 33038, 32795, 77, 33021, 32931, 32782,
33038, 32795, 78, 33021, 32866, 33040, 32782, 33038,
32795, 80, 33041, 32946, 32776, 33043, 32862, 32795,
81, 33041, 32946, 32776, 33045, 32953, 32795, 82,
32776, 32771, 32772, 32785, 33048, 32788, 83, 33011,
33012, 32776, 32844, 32772, 33050, 32782, 32823, 86,
33052, 33048, 33011, 33045, 32953, 33054, 32776, 87,
32956, 32788, 32776, 32990, 32782, 32795, 90, 33055,
32788, 32776, 32990, 32782, 32795, 91, 33057, 32835,
32946, 32776, 32772, 32871, 92, 33057, 33058, 32777,
32982, 33060, 93, 33057, 33058, 32777, 33061, 32878,
32820, 33063, 90, 33055, 32788, 32776, 32990, 33065,
32946, 95, 32805, 32776, 32772, 32875, 32782, 33066,
96, 33068, 32819, 32772, 32875, 32782, 33066, 97,
33070, 33072, 32772, 32875, 98, 33075, 99, 33078,
32772, 33080, 33082, 33083, 33085, 101, 33087, 32831,
32777, 32850, 32854, 33089, 102, 33092, 32820, 32819,
33094, 32771, 32850, 33096, 103, 33097, 33099, 33101,
104, 33097, 33099, 33101, 105, 32894, 32854, 32792,
32895, 106, 33021, 32931, 32850, 33102, 107, 33103,
33105, 32844, 33099, 33101, 108, 33107, 32850, 33109,
109, 33103, 33112, 110, 33115, 33116, 201, 33117,
33118, 32844, 33120, 33065, 32848, 202, 32805, 32776,
32772, 32990, 203, 32775, 32776, 32772, 32990, 204,
33052, 33057, 32835, 32946, 32776, 205, 32805, 32776,
32772, 33123, 206, 33126, 32782, 33128, 33130, 207,
32927, 32946, 32776, 32772, 33131, 208, 33134, 33137,
32990, 33139, 33140, 33142, 33144, 209, 33147, 33149,
32771, 33151, 33152, 210, 33154, 33156, 32852, 211,
33158, 33160, 32772, 33162, 33164, 33156, 212, 33165,
33168, 33170, 33172, 255, 33173, 33175, 33177, 0
CONSTINTEGERARRAY LETT(0: 410)=0,C
X'7890A80B',X'02A00000',X'53980000',X'5D7E8000',
X'652E3AD3',X'652C8000',X'190C52D8',X'36000000',
X'510E6000',X'436652C3',X'49C80000',X'452CB700',
X'672E8000',X'53700000',X'69453980',X'4565F1D6',
X'42000000',X'27BD3A47',X'50000000',X'5D0DB280',
X'43A00000',X'47AE594B',X'5DA00000',X'692F1A6B',
X'43600000',X'592ED2D8',X'4BC6194B',X'679D37DC',
X'5F900000',X'439E74CF',X'5D6CB768',X'590C52D8',
X'36FFB000',X'672C77DD',X'48000000',X'694DB280',
X'1D0DB280',X'492C7643',X'652C8000',X'257EBA53',
X'5D280000',X'4D700000',X'5B7E5280',X'610E50DB',
X'4BA4B966',X'69443700',X'6784B1D3',X'4D4CB200',
X'210E50DB',X'4BA4B900',X'7A000000',X'5F300000',
X'494CD34B',X'65980000',X'69CE1280',X'4D95F680',
X'6784B1D3',X'4D4C70E9',X'537DC000',X'4D2EF2E4',
X'652CD2E5',X'4B7472C8',X'594DD280',X'781B2199',
X'0A000000',X'69BDE000',X'477DDA65',X'5F600000',
X'47643AE7',X'4B980000',X'4D7E4000',X'5B4E79D3',
X'5D380000',X'7829C200',X'7829C266',X'4394A000',
X'497CB980',X'652E3AD3',X'65280000',X'67AC59C7',
X'654E1A66',X'697DE000',X'4D2EE000',X'6195FB53',
X'492C8000',X'5B0DDC80',X'439650F2',X'031E9AC3',
X'58000000',X'610E50DB',X'4BA4B900',X'477DD359',
X'531E9980',X'6F4E9400',X'43700000',X'137692CF',
X'4B900000',X'5F84B943',X'697E4000',X'252C3600',
X'5F84B943',X'5D266000',X'537692CF',X'4B900000',
X'477DDA4B',X'71A00000',X'6D0D94C8',X'782AC29D',
X'28000000',X'5DADB14B',X'64000000',X'657EBA53',
X'5D280000',X'45AE8000',X'5D780000',X'457C9C80',
X'7832A707',X'2849E700',X'7890AA2B',X'24700000',
X'5FAE9BD3',X'69400000',X'7890A9AB',X'18A00000',
X'5B0E0000',X'297DE000',X'592ED2D9',X'66000000',
X'039650F2',X'494DB2DD',X'674DF766',X'6B8612E4',
X'457EB748',X'592E7980',X'597EF2E4',X'274F5280',
X'30F0C30D',X'0C30CF00',X'45CE92E6',X'092C7643',
X'650E94DF',X'5C000000',X'512C3200',X'077DD9E9',
X'43768000',X'470DD75F',X'68000000',X'45280000',
X'4BB4366B',X'43A4B200',X'477DB853',X'59280000',
X'5376D0D9',X'53200000',X'652E12E9',X'53A537DC',
X'4D0C7A5F',X'64000000',X'7819E727',X'2809CA00',
X'1376D0D9',X'53200000',X'477DD9E9',X'43768000',
X'53753A53',X'436539D3',X'5D380000',X'433692E4',
X'53A4B6E6',X'4BC612C7',X'692C8000',X'7BE80000',
X'4F4ED2DC',X'782B0A0B',X'24702600',X'782B0A25',
X'12726486',X'6D0E54C3',X'4564A000',X'789A0286',
X'7829898A',X'7879C000',X'03A692DB',X'61A00000',
X'69780000',X'53753A53',X'436539CA',X'7831E91B',
X'02A00000',X'27AC59C7',X'654E1A00',X'6944A000',
X'457EB749',X'66000000',X'78312713',X'26400000',
X'53767A4B',X'43200000',X'789A80A5',X'28000000',
X'782B04A8',X'7819E729',X'1272A280',X'782B0A0B',
X'24702625',X'1EAA849D',X'0A000000',X'6F95F74E',
X'0BC4B1EB',X'690C564A',X'67A43A4B',X'5B2DDA00',
X'4D7EB748',X'752E5780',X'2195F3E5',X'43680000',
X'436DF74E',X'4BC692E5',X'5D0D8000',X'657EBA53',
X'5D2E6000',X'6B9CB200',X'7890A19F',X'24200000',
X'592DD3E9',X'50000000',X'4F94B0E9',X'4B900000',
X'652E3AD3',X'652E6000',X'67AC5743',X'5B280000',
X'27AC5743',X'5B280000',X'0BC6194B',X'679D37DC',
X'439E74CF',X'5D2C8000',X'652C77E5',X'48000000',
X'252C77E5',X'49980000',X'36D80000',X'43748000',
X'510ED280',X'494CD34B',X'652DDA00',X'4D7E56C3',
X'69980000',X'43A690C7',X'512C8000',X'6F4531D0',
X'27A654DD',X'4E000000',X'492C7643',X'650E94DF',
X'5C000000',X'5B0F0000',X'03953A51',X'5B2E94C6',
X'252E77D9',X'6BA537DC',X'477E594B',X'47A00000',
X'4D7E56C3',X'68000000',X'477DDA43',X'53766000',
X'67AC4000',X'43953A51',X'5B2E94C6',X'3DDBC000',
X'217D3769',X'4B900000',X'477DB843',X'652C8000',
X'4B8EB4ED',X'4364B747',X'4B200000',X'617D3769',
X'4B900000',X'4B8EB4ED',X'4364B768',X'0F65F143',
X'58000000',X'597C70D8',X'2B769CE1',X'4B200000',
X'7831E900',X'47643AE7',X'4A000000',X'67A4B800',
X'5D7DD4DD',X'692CF2E4',X'69943B4B',X'659CB980',
X'43980000',X'439E72DB',X'4564B900',X'1F84B943',
X'5D200000',X'039E72DB',X'4564B900',X'477DD9E9',
X'65AC7A53',X'5F700000',X'0324994B',X'679C3153',
X'594E9C80',X'0D0C74D9',X'53A72000',X'67AE185F',
X'65A4B200',X'45C80000',X'690E53CB',X'68000000',
X'510E526F',X'4394A000',X'277EB947',X'4A000000',
X'477DDA53',X'5DAC3A53',X'5F766000',X'2F7E55CD',
X'5364A000',X'17173A4B',X'66000000',X'676C3658',
X'094C7A53',X'5F743972',X'477DB859',X'4BA4B672',
X'4DAD9600',X'597DD380',X'077DB853',X'592E4000',
X'690C564B',X'66000000',X'077DD253',X'694DF700',
X'477DB859',X'531C3A4B',X'48000000',X'537477DD',
X'674E7A4B',X'5DA00000',X'13761AE8',X'4B7492C8',
X'197DD380',X'537692CF',X'4B966000',X'5374B34D',
X'531D32DD',X'68000000',X'4324994B',X'679C3159',
X'4A000000',X'272DB4C7',X'5F65F700',X'477DB6CB',
X'5DA00000',X'692F1A00',X'53753A53',X'436539CB',
X'48000000',X'2B767AE1',X'617E5A4B',X'48000000',
X'6194B1D3',X'674DF700',X'38000000',X'5D2C394B',
X'67A00000',X'43B434D9',X'43159280',X'67AC59E9',
X'53A6BA4B',X'48000000',X'290E53CB',X'68000000',
X'5B0C7453',X'5D280000',X'6F7E5200',X'4324994B',
X'679CB200',X'252C9ADD',X'490DDA00',X'78098483',
X'26000000',X'2194B353',X'70000000',X'789B29A9',
X'0A680000',X'67AE185F',X'65A4B276',X'2B9CA000',
X'2B76195F',X'49AC7A53',X'6D280000',X'597CF4C7',
X'43600000',X'5F84B943',X'694DF700',X'5D7E92C8',
X'077DDA43',X'47A00000',X'0326D4E7',X'5F972000',
X'272E5B53',X'47280000'
INTEGER I,J,K,M,Q,S
STRING (70)OMESS
OMESS=" "
CYCLE I=1,1,WORDMAX-1
->FOUND IF N=WORD(I)
REPEAT
I=DEFAULT
FOUND:
J=1
CYCLE
K=WORD(I+J)
IF K&X'8000'=0 THEN EXIT
K=K&X'7FFF'
OMESS=OMESS." " UNLESS J=1
UNTIL M&1=0 CYCLE
M=LETT(K); S=25
UNTIL S<0 CYCLE
Q=M>>S&63;
IF Q¬=0 THEN OMESS=OMESS.TOSTRING(OUTTT(Q))
S=S-6
REPEAT
K=K+1
REPEAT
J=J+1
REPEAT
RESULT =OMESS
END
EXTERNALSTRING (16)FN SWRITE(INTEGER VALUE, PLACES)
STRING (16) S
STRING (1)SIGN
INTEGER D0, D1, D2
PLACES=PLACES&15
SIGN=" "
S=""
IF VALUE<0 THEN SIGN="-" AND VALUE=-VALUE
D0=VALUE
CYCLE
D1=D0//10
D2=D0-10*D1
S=TOSTRING(D2+'0').S
D0=D1
REPEAT UNTIL D0=0
S=SIGN.S
S=" ".S WHILE LENGTH(S)<=PLACES
RESULT =S
END
EXTERNALROUTINE FAULT(INTEGER N, DATA, IDENT)
!***********************************************************************
!* SETS UP AN ERROR MESSAGE AND SHOVES IT OUT ONTO THE LISTING *
!* AN ALSO OPTIONALLY TO THE TERMINAL *
!***********************************************************************
INTEGER I, J, S, T, Q, QMAX, LENGTH
STRING (255)MESS1,MESS2,WK1,WK2
!*DELSTART
MONITOR IF PARM_FAULTY=0 AND (PARM_Z#0 OR PARM_DCOMP#0)
!*DELEND
MESS1=""; MESS2=""
PARM_FAULTY=PARM_FAULTY+1
IF N=100 THEN START ; ! SYNTAX FAULTS ARE SPECIAL
MESS1="
* Failed to analyse line ".SWRITE(WORKA_LINE,2)."
"
J=0; S=0; T=0; Q=DATA; QMAX=IDENT>>16
LENGTH=IDENT&X'FFFF'
UNTIL (J=';' AND Q>QMAX) OR Q=LENGTH CYCLE
I=J; J=WORKA_CC(Q); ! DATA HAS START OF LINE POSN
IF J>128 AND I<128 THEN MESS2=MESS2." %" AND T=T+2
IF I>128 AND J<128 THEN MESS2=MESS2." " AND T=T+1
IF Q=QMAX THEN START
S=T+1
IF S>=115 THEN MESS2=MESS2."?" AND T=T+1
FINISH
MESS2=MESS2.TOSTRING(J)
T=T+1
Q=Q+1
EXIT IF T>=250
REPEAT
IF Q=QMAX THEN S=T
FINISH ELSE START
MESS1="
*".SWRITE(WORKA_LINE, 4)." "
PARM_OPT=1
PARM_INHCODE=1 IF PARM_LET=0; ! STOP GENERATING CODE
MESS1=MESS1."FAULT".SWRITE(N,2)
MESS2=MESSAGE(N)
IF MESS2->WK1.("##").WK2 THEN C
MESS2=WK1.SWRITE(IDENT,1).WK2
IF MESS2->WK1.("#").WK2 THEN C
MESS2=WK1.SWRITE(DATA,1).WK2
IF MESS2->WK1.("&&").WK2 THEN C
MESS2=WK1.PRINTNAME(DATA).WK2
IF MESS2->WK1.("&").WK2 THEN C
MESS2=WK1.PRINTNAME(IDENT).WK2
IF N>100 THEN MESS2=MESS2." Disaster"
FINISH
CYCLE I=2,-1,1
SELECT OUTPUT(PARM_TTOPUT) IF I=1
PRINTSTRING(MESS1)
PRINTSTRING(MESS2) IF MESS2#""
IF N=100 AND S<115 THEN START
NEWLINE; SPACES(S+4); PRINTSYMBOL('!')
FINISH
NEWLINE
SELECT OUTPUT(82) IF I=1
EXIT IF PARM_TTOPUT<=0
REPEAT
IF N=109 THEN MONITOR
! %IF N=109 %THEN PARM_DCOMP=1 %AND CODEOUT
IF N>100 THEN STOP
END
EXTERNALROUTINE WARN(INTEGER N,V)
STRING (30) T; STRING (120) S
S=MESSAGE(N+200)
IF S->S.("&").T THEN S=S.PRINTNAME(V).T
PRINTSTRING("
? Warning :- ".S." at line No".SWRITE(WORKA_LINE,1))
NEWLINE
END
EXTERNALROUTINE PRHEX(INTEGER VALUE, PLACES)
CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4',
'5','6','7','8','9','A','B','C','D','E','F'
INTEGER I
CYCLE I=PLACES<<2-4, -4, 0
PRINT SYMBOL(HEX(VALUE>>I&15))
REPEAT
END
EXTERNALROUTINE PRINT THIS TRIP(RECORD (TRIPF)ARRAYNAME TRIPS,
INTEGER I)
!***********************************************************************
!* OUTPUTS A TRIPLE IN READABLE FORM *
!***********************************************************************
CONST STRING (5)ARRAY OPERATION(0:192)= C
" ? ","RT HD","RDSPY","RDARE","RDPTR",
"RTBAD","RTXIT","XSTOP"," ? "," ? ",
" ¬ "," -U "," FLT "," ABS ","SHRNK",
"STRCH"," JAM "," ??? ","NO OP","PRELD",
" ? ","SSPTR","RSPTR","ASPTR","DARRY",
"SLINE","STPCK","FRPRE","FPOST","FRPR2",
"PRECL","RCALL","RCRFR","RCRMR"," ? ",
"GETAD"," INT ","INTPT","TOSTR","MNITR",
"PPROF","RTFP ","ONEV1","ONEV2","DVSTT",
"DVEND","FREND"," ? "(3),
"UCNOP","UCB1 ","UCB2 ","UCB3 "," UCW ",
"UCBW ","UCWW ","UCLW ","UCB2W","UCNAM",
" ? "(68),
" + "," - "," !! "," ! "," * ",
" // "," / "," & "," >> "," << ",
" ** "," COMP","DCOMP"," VMY "," COMB",
" = "," <- "," ****"," ADJ "," INDX",
"IFTCH","LASS ","FORCK","PRECC","CNCAT",
"IOCPC","PASS1","PASS2","PASS3",
"PASS4","PASS5","PASS6",
"BJUMP","FJUMP","REMLB","TLAB ","DCLSW",
"SETSW","-> SW"," S=1 "," S=2 "," S<- ",
"AHASS","PTRAS","MAPRS","FNRES","SCOMP",
"SDCMP","PRES1","PRES2","RESLN","RESFN",
"SIGEV","RECAS","AAINC","AHADJ","CTGEN",
"GETPR","SINDX","ZCOMP","CLSFT","CASFT",
"DVBPR","RSTRE","MULTX";
RECORD (TRIPF)NAME CURR
ROUTINESPEC OPOUT(RECORD (RD)NAME OPND)
NEWLINE
CURR==TRIPS(I)
WRITE(I,2)
SPACE
PRINTSTRING(OPERATION(CURR_OPERN))
SPACE
PRHEX(CURR_OPTYPE,2)
WRITE(CURR_CNT,2)
WRITE(CURR_DPTH,2)
SPACES(1)
PRHEX(CURR_FLAGS,4)
WRITE(CURR_PUSE,3)
SPACE
PRHEX(CURR_X1,8)
SPACE
OPOUT(CURR_OPND1)
OPOUT(CURR_OPND2) IF CURR_OPERN>=128
RETURN
ROUTINE OPOUT(RECORD (RD)NAME OPND)
STRING (17)T
STRING (8)S
INTEGER I,J
SWITCH SW(0:10)
PRHEX(OPND_PTYPE,4)
J=OPND _FLAG
->SW(J) UNLESS J>9
PRINTSTRING("?")
PRHEX(OPND_S1&X'FFFF',4)
SPACE
PRHEX(OPND_D,8)
SPACE
PRHEX(OPND_XTRA,8)
RETURN
SW(0):SW(1): ! CONSTANT
PRINTSTRING(" ")
IF OPND_PTYPE&7=5 START ; ! STRING CONSTS
I=WORKA_A(OPND_D)
I=17 IF I>17
LENGTH(T)=I
CYCLE I=1,1,I
J=WORKA_A(OPND_D+I)
J='_' IF J<=31
CHARNO(T,I)=J
REPEAT
T<-T." "
PRINTSTRING(T)
FINISH ELSE START
PRHEX(OPND_D,8)
SPACES(4)
IF OPND_PTYPE>>4>5 THEN PRHEX(OPND_XTRA,8) ELSE SPACES(8)
FINISH
SPACES(2)
RETURN
SW(2): ! NAME
PRINTSTRING(" NAME ")
NAM: S<-PRINTNAME(OPND_D)." "
PRINTSTRING(S)
IF OPND_XTRA#0 THEN PRHEX(OPND_XTRA,8) ELSE SPACES(8)
SPACE
RETURN
SW(4): ! VIA STORED POINTER @TRIPLE
PRINTSTRING("OFFSET-PTR")
->COM
SW(5): ! 32 BIT ADDRESS
PRINTSTRING(" PNTR ")
->NAM
SW(7): ! IN A STACK FRAME
PRINTSTRING(" TEMP ")
PRHEX(OPND_D,8)
SPACE
PRHEX(OPND_XTRA,8)
RETURN
SW(6): ! INDIRECT
PRINTSTRING(" IND-OFFST")
COM: WRITE(OPND_D,2)
SPACE
PRHEX(OPND_XTRA,8)
SPACE
RETURN
SW(8): ! A TRIPLE
PRINTSTRING(" TRIPLE ")
WRITE(OPND_D,2)
SPACES(12)
RETURN
SW(9): ! REGISTER ITEM
PRINTSTRING(" ITEM IN REGSTR ")
SPACES(4)
RETURN
SW(10): ! B-D FORFM
PRINTSTRING("BASE&DIS ")
PRHEX(OPND_XB,2)
SPACE
PRHEX(OPND_D,8)
END
END
EXTERNALROUTINE PRINT TRIPS(RECORD (TRIPF)ARRAYNAME TRIPS)
INTEGER I
RETURN IF PARM_Y=0 AND PARM_Z=0;! TRIPLES ON CODE+PARMY OR Z
PRINTSTRING("
TRIPLES FOR LINE"); WRITE(WORKA_LINE,3)
PRINTSTRING("
NO OPRN PT C D FLGS PUSE X1 OPERAND 1 OPERAND 2")
I=TRIPS(0)_FLINK
WHILE I>0 CYCLE
PRINT THIS TRIP(TRIPS,I)
I=TRIPS(I)_FLINK
REPEAT
END
EXTERNALROUTINE INITASL(RECORD (LISTF)ARRAYNAME SPACE,INTEGERNAME PTR)
!***********************************************************************
!* INITIALISES THE ASL AND REMEMBERS IT LOCATION
!***********************************************************************
INTEGER I
ASLIST==SPACE
ASL==PTR
WORKA_ASL CUR BTM=ASL-240
WORKA_CONST LIMIT=4*WORKA_ASL CUR BTM-8
CYCLE I=WORKA_ASL CUR BTM,1,ASL-1
ASLIST(I+1)_LINK=I
REPEAT
ASLIST(WORKA_ASL CUR BTM)_LINK=0
ASLIST(0)_S1=-1
ASLIST(0)_S2=-1
ASLIST(0)_S3=-1
ASLIST(0)_LINK=0
END
EXTERNALROUTINE PRINT LIST(INTEGER HEAD)
!***********************************************************************
!* A DEBUGGING ONLY ROUTINE.
!***********************************************************************
RECORD (LISTF)NAME LCELL
INTEGER I,J,K
PRINTSTRING("
PRINT OF LIST ")
WRITE(HEAD,2)
NEWLINE
WHILE HEAD#0 CYCLE
LCELL==ASLIST(HEAD)
WRITE(HEAD,3)
SPACES(3)
PRHEX(LCELL_S1,8)
SPACES(3)
PRHEX(LCELL_S2,8)
SPACES(3)
PRHEX(LCELL_S3,8)
SPACES(3)
PRHEX(LCELL_LINK,8)
NEWLINE
HEAD=LCELL_LINK&X'FFFF'; ! EXTRA LINK IN TAGS LIST!!
REPEAT
END
EXTERNALROUTINE CHECK ASL
!***********************************************************************
!* CHECK ASL AND PRINT NO OF FREE CELLS. DEBUGGING SERVICE ONLY *
!***********************************************************************
INTEGER N,Q
Q=ASL; N=0
WHILE Q#0 CYCLE
N=N+1
Q=ASLIST(Q)_LINK
REPEAT
NEWLINE
PRINTSTRING("FREE CELLS AFTER LINE ")
WRITE(WORKA_LINE,3)
PRINTSYMBOL('=')
WRITE(N,3)
END
EXTERNALINTEGERFN MORE SPACE
!***********************************************************************
!* FORMATS UP SOME MORE OF THE ASL *
!***********************************************************************
INTEGER I,N,CL,AMOUNT
N=WORKA_ASL CUR BTM-1
AMOUNT=(WORKA_NNAMES+1)>>3; ! EIGHTTH OF NNAMES
I=WORKA_ASL CUR BTM-((WORKA_CONST PTR+8)>>2);! GAP BETWEEN CONSTS &ASL
IF I>>1<AMOUNT THEN AMOUNT=I>>1;! TAKE ONLY HALF THE REMAINDER
IF AMOUNT<20 THEN AMOUNT=0
WORKA_ASL CUR BTM=WORKA_ASL CUR BTM-AMOUNT
IF WORKA_ASL CUR BTM<=1 THEN WORKA_ASL CUR BTM=1
CL=4*WORKA_ASL CUR BTM-8
IF WORKA_ASL CUR BTM>=N OR WORKA_CONST PTR>CL THEN START
FAULT(102, WORKA_WKFILEK,0)
FINISH ELSE WORKA_CONST LIMIT=CL; ! NEW VALUE WITH BIGGER ASL
CYCLE I=WORKA_ASL CUR BTM,1,N-1
ASLIST(I+1)_LINK=I
REPEAT
ASLIST(WORKA_ASL CUR BTM)_LINK=0
ASL=N; RESULT =N
END
!%EXTERNALINTEGERFN NEW CELL
!***********************************************************************
!* PROVIDE A NEW LIST PROCESSING CELL. CRAPOUT IF NONE AVAILABLE *
!***********************************************************************
!%INTEGER I
! %IF ASL=0 %THEN ASL=MORE SPACE
! I=ASL
! ASL=ASLIST(ASL)_LINK
! ASLIST(I)_LINK=0
! %RESULT =I
!%END
EXTERNALROUTINE PUSH(INTEGERNAME CELL, INTEGER S1, S2, S3)
!***********************************************************************
!* PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN *
!* ONTO THE TOP OF THE LIST POINTED AT BY CELL. *
!***********************************************************************
RECORD (LISTF)NAME LCELL
INTEGER I
I=ASL
IF I=0 THEN I=MORE SPACE
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_LINK=CELL
CELL=I
LCELL_S1=S1
LCELL_S2=S2
LCELL_S3=S3
END
EXTERNALROUTINE POP(INTEGERNAME CELL, S1, S2, S3)
!***********************************************************************
!* COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO *
!* S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S*
!***********************************************************************
INTEGER I
RECORD (LISTF)NAME LCELL
I=CELL
LCELL==ASLIST(I)
S1=LCELL_S1
S2=LCELL_S2
S3=LCELL_S3
IF I# 0 THEN START
CELL=LCELL_LINK
LCELL_LINK=ASL
ASL=I
FINISH
END
EXTERNALROUTINE BINSERT(INTEGERNAME TOP,BOT,INTEGER S1,S2,S3)
!***********************************************************************
!* INSERT A CELL AT THE BOTTOM OF A LIST *
!* UPDATING TOP AND BOTTOM POINTERS APPROPIATELY *
!***********************************************************************
INTEGER I,J
RECORD (LISTF)NAME LCELL
I=ASL
IF I=0 THEN I=MORE SPACE
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_S1=S1; LCELL_S2=S2
LCELL_S3=S3; LCELL_LINK=0
J=BOT
IF J=0 THEN BOT=I AND TOP=BOT ELSE START
ASLIST(J)_LINK=I
BOT=I
FINISH
END
EXTERNALROUTINE INSERT AFTER(INTEGERNAME PLACE,INTEGER S1,S2,S3)
!***********************************************************************
!* ADDS A CELL INT THE MIDDLE OF A LIST AFTER "CELL" WHICH *
!* IS UPDATED *
!***********************************************************************
INTEGER I
RECORD (LISTF)NAME OLDCELL,CELL
FAULT(109,0,0) IF PLACE<=0
I=ASL
IF I=0 THEN I=MORE SPACE
CELL==ASLIST(I)
ASL=CELL_LINK
OLDCELL==ASLIST(PLACE)
CELL_S1=S1; CELL_S2=S2
CELL_S3=S3
CELL_LINK=OLDCELL_LINK
OLDCELL_LINK=I
PLACE=I
END
EXTERNALROUTINE INSERT AT END(INTEGERNAME CELL, INTEGER S1, S2, S3)
!***********************************************************************
!* ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL' *
!***********************************************************************
INTEGER I,J,N
RECORD (LISTF)NAME LCELL
I=CELL; J=I
WHILE I#0 CYCLE
J=I
I=ASLIST(J)_LINK
REPEAT
N=ASL
IF N=0 THEN N=MORE SPACE
LCELL==ASLIST(N)
ASL=LCELL_LINK
IF J=0 THEN CELL=N ELSE ASLIST(J)_LINK=N
LCELL_S1=S1
LCELL_S2=S2
LCELL_S3=S3
LCELL_LINK=0
END
EXTERNALINTEGERFN FIND(INTEGER LAB, LIST)
!***********************************************************************
!* THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND *
!* RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN *
!* SCANNING LABEL LISTS. *
!***********************************************************************
WHILE LIST#0 CYCLE
RESULT =LIST IF LAB=ASLIST(LIST)_S2
LIST=ASLIST(LIST)_LINK
REPEAT
RESULT =-1
END
EXTERNALROUTINE CLEAR LIST(INTEGERNAME OPHEAD)
!***********************************************************************
!* THROW AWAY A COMPLETE LIST (MAY BE NULL!) *
!***********************************************************************
INTEGER I, J
I=OPHEAD; J=I
WHILE I#0 CYCLE
J=I
I=ASLIST(J)_LINK
REPEAT
IF J#0 START
ASLIST(J)_LINK=ASL
ASL=OPHEAD; OPHEAD=0
FINISH
END
!%EXTERNALROUTINE CONCAT(%INTEGERNAME LIST1, LIST2)
!!***********************************************************************
!!* ADDS LIST2 TO BOTTOM OF LIST1 *
!!***********************************************************************
!%INTEGER I,J
! I=LIST1
! J=I
! %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK
! %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2
! LIST2=0
!%END; ! AN ERROR PUTS CELL TWICE ONTO
! FREE LIST - CATASTROPHIC!
ENDOFFILE