constinteger malmon=0
EXTERNAL ROUTINE SPEC Phex {*~np1 %alias "s_phex"}(INTEGER n)
EXTERNAL INTEGER FN SPEC MALLOC(INTEGER bytesize)
INCLUDE "hostcodes.inc"
CONSTINTEGER HOST=M88K
!%INCLUDE "tform2s"
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
RECORDFORMAT PARMF(INTEGER BITS1,BITS2,TTOPUT,
BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
INTEGER LPOPUT,SP0)
RECORDFORMAT LEVELF(INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE,
NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
INTEGERARRAY AVL WSP(0:4))
IF 1<<host&unsignedshorts=0 START
RECORDFORMAT RD((INTEGER S1 OR SHORT PTYPE,BYTE XB,FLAG),
((INTEGER D OR REAL R),
INTEGER XTRA OR SHORT H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
RECORDFORMAT TAGF((SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
INTEGER S1,S2,S3),INTEGER LINK)
RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
RECORD(RD) OPND1,OPND2)
RECORDFORMAT LISTF((SHORTINTEGER PTYPE,(SHORT UIOJ OR BYTE XB,FLAG),
SHORT SNDISP,ACC,SLINK,KFORM OR INTEGER S1,S2,S3),INTEGER LINK)
FINISH ELSE START
RECORDFORMAT RD((INTEGER S1 OR HALF PTYPE,BYTE XB,FLAG),
((INTEGER D OR REAL R),
INTEGER XTRA OR HALF H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
RECORDFORMAT TAGF((HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
INTEGER S1,S2,S3),INTEGER LINK)
RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
HALFINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
RECORD(RD) OPND1,OPND2)
RECORDFORMAT LISTF((HALFINTEGER PTYPE,(HALF UIOJ OR BYTE XB,FLAG),
HALF SNDISP,ACC,SLINK,KFORM OR INTEGER S1,S2,S3),INTEGER LINK)
FINISH
RECORDFORMAT WORKAF(INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
INTEGERNAME LINE,N,S5,STRING(9)LADATE,
BYTEINTEGERARRAYNAME CC,A,LETT,
INTEGERARRAYNAME WORD,TAGS,CTABLE,
RECORD(LEVELF)ARRAYNAME LEVELINF,
INTEGERARRAY PLABS,PLINK(0:31),
RECORD(LISTF)ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
CONSTINTEGER LEAVE STACKED=2****0; ! SET LEAVE RESULT IN ESTACK
CONSTINTEGER LOADOP1=2****1; ! OPERAND 1 NEEDS LOADING
CONSTINTEGER LOADOP2=2****2; ! OPERAND 2 NEEDS LOADING
CONSTINTEGER NOTINREG=2****3; ! PREVENT REG OPTIMISNG
! OF TEMPS OVER LOOPS&JUMPS
CONSTINTEGER USE ESTACK=2****4; ! KEEP DUPLICATE IN ESTACK
CONSTINTEGER USE MSTACK=2****5; ! PUT DUPLICAT ON MSTACK
CONSTINTEGER CONSTANTOP=2****6; ! ONE OPERAND IS CONSTANT(FOR FOLDING)
CONSTINTEGER COMMUTABLE=2****7; ! OPERATION IS COMMUTABLE
CONSTINTEGER USED LATE=2****13; ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
CONSTINTEGER ASS LEVEL=2****14; ! ASSEMBLER LEVEL OPERATION
CONSTINTEGER DONT OPT=2****15; ! DONT DUPLICATE THIS RESULT
! USED FOR BYTE PTR & OTHER SODS!
!
RECORDFORMAT EMASFHDRF(INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
! FORMAT FOR ARRAY HEADS
! %END %OF %FILE "TFORM2S"
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
AGN:
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 else IF HOST=PERQ START; ! WORD ADDRESS+BYTE OFFSET
FBASE=FBASE+FOFF>>1
FOFF=FOFF&1
TOBASE=TOBASE+TOOFF>>1
TOOFF=TOOFF&1
IF (TOBASE+LENGTH>>1)>>16#TOBASE>>16 OR C
(FBASE+LENGTH>>1)>>16#FBASE>>16 START
! TLATE FAILS IF SEG BNDRY CROSSED
MOVEBYTES(1,FBASE,FOFF,TOBASE,TOOFF)
TOOFF=TOOFF+1
FOFF=FOFF+1
LENGTH=LENGTH-1
->AGN
FINISH
*LDLDB_6; ! TO BASE
*LDL8; ! TOOFF (BTM BITS)
*LDLDB_2; ! FBASE
*LDL4; ! FOFF
*LDL0; ! LENGTH
*STLATE_X'63'
*MVBW
FINISH else IF HOST=ACCENT 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
*MVBW
FINISH else IF HOST=PNX start
FBASE=2*FBASE+FOFF
TOBASE=2*TOBASE+TOOFF
**FBASE
**TOBASE
**LENGTH
*MVB
FINISH else IF 1<<host&emachine#0 START
FBASE=FBASE+FOFF
TOBASE=TOBASE+TOOFF
**FBASE
**TOBASE
**LENGTH
*MVB
FINISH else IF HOST=IBM OR HOST=IBMXA OR HOST=AMDAHL START
*L_0,TOBASE; *A_0,TOOFF
*L_2,FBASE; *A_2,FOFF
*L_1,LENGTH; *LR_3,1
*MVCL_0,2
else
FBASE=FBASE+FOFF
TOBASE=TOBASE+TOOFF
BYTEINTEGER(TOBASE+I)=BYTEINTEGER(FBASE+I) FOR I=0,1,LENGTH-1
FINISH
END
EXTERNALSTRING(255)FN PRINTNAME(INTEGER N)
CONSTSTRING(1)ARRAY HEX(0:15)="0","1","2","3","4","5","6","7","8","9",
"A","B","C","D","E","F";
INTEGER V,K,TOP
STRING(255) S
S="?"
TOP=N>>16
N=N&X'FFFF'
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
IF S="?" START; ! UNPRINTABLE
S=S.HEX(N>>K&15) FOR K=28,-4,0
FINISH ELSE START
IF TOP>0 THEN S=PRINTNAME(TOP)."_".S
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 *
!* 3 Jump into %CYCLE at Label & from line # *
!* 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= 802,DEFAULT= 798
CONSTshortINTEGERARRAY WORD(0:WORDMAX)=0,C
1, 32769, 32771, 32772, 32773, 2, 32775, 32776,
32777, 32778, 32780, 32781, 32782, 32783, 32784, 3,
32785, 32786, 32787, 32789, 32775, 32776, 32790, 32791,
32792, 4, 32776, 32771, 32772, 32793, 32794, 32796,
32789, 32797, 32799, 32801, 5, 32794, 32796, 32776,
32782, 32802, 32804, 32805, 6, 32794, 32807, 32808,
32781, 32793, 32809, 32811, 7, 32812, 32776, 32777,
32778, 32780, 32813, 8, 32815, 32804, 32817, 32776,
32777, 32818, 32819, 32821, 32822, 9, 32824, 32792,
32826, 32776, 32827, 32782, 32829, 32790, 32830, 10,
32815, 32804, 32817, 32776, 32777, 32833, 32819, 32821,
32822, 11, 32775, 32776, 32834, 32789, 32791, 32792,
32777, 32772, 32780, 32781, 12, 32787, 32789, 32791,
32792, 32777, 32836, 32837, 32839, 13, 32769, 32841,
32787, 32789, 32791, 32792, 32771, 32842, 14, 32844,
32771, 32772, 32773, 15, 32792, 32845, 32846, 32842,
16, 32812, 32776, 32777, 32772, 32780, 32813, 17,
32812, 32776, 32847, 32772, 32848, 32819, 32804, 32850,
18, 32792, 32852, 32853, 32819, 32854, 32841, 32776,
19, 32792, 32852, 32856, 32819, 32854, 32841, 32776,
20, 32792, 32852, 32853, 32850, 32854, 32841, 32857,
32776, 21, 32792, 32852, 32856, 32850, 32854, 32841,
32857, 32776, 22, 32858, 32860, 32792, 32826, 32776,
32862, 32864, 32830, 23, 32815, 32796, 32776, 32782,
32865, 32802, 24, 32866, 32868, 32777, 32870, 32871,
25, 32870, 32802, 32782, 32873, 32875, 26, 32792,
32771, 32772, 32793, 32877, 32878, 32880, 27, 32776,
32771, 32772, 32793, 32882, 32796, 28, 32815, 32804,
32817, 32776, 32777, 32830, 32884, 32885, 32886, 29,
32887, 32796, 32776, 32772, 32782, 32802, 30, 32889,
32891, 32882, 32886, 31, 32893, 32891, 32817, 32804,
32895, 32886, 34, 32896, 32856, 32799, 32897, 37,
32899, 32776, 32777, 32852, 32856, 32900, 38, 32899,
32776, 32777, 32902, 32903, 32792, 32904, 32821, 32905,
32903, 39, 32906, 32826, 32899, 32776, 32771, 32818,
32821, 32907, 32909, 40, 32910, 32771, 32772, 32789,
32913, 32826, 32784, 41, 32914, 32916, 32918, 32919,
32789, 32921, 32811, 42, 32792, 32771, 32865, 32923,
32925, 32927, 43, 32929, 32796, 32776, 32772, 32782,
32802, 44, 32931, 32933, 32935, 32776, 32938, 32792,
32939, 45, 32899, 32935, 32939, 32940, 32942, 32939,
32943, 32792, 46, 32931, 32944, 32946, 32804, 32948,
32950, 47, 32951, 32778, 32943, 32789, 32791, 32792,
48, 32951, 32923, 32938, 32952, 32878, 49, 32953,
32955, 32956, 32946, 32804, 32958, 32776, 50, 32960,
32826, 32792, 32771, 32891, 32962, 32963, 32826, 32776,
51, 32965, 32771, 32772, 32773, 52, 32769, 32967,
32826, 32965, 32841, 32969, 32789, 32791, 32792, 53,
32965, 32841, 32969, 32789, 32791, 32792, 32771, 32842,
54, 32971, 32891, 32787, 32769, 32886, 55, 32972,
32891, 32787, 32769, 32886, 56, 32974, 32776, 32789,
32978, 32799, 32801, 57, 32979, 32981, 32983, 32789,
32799, 32801, 32984, 58, 32985, 32987, 32988, 32990,
59, 32965, 32967, 32826, 32769, 32841, 32787, 32789,
32791, 32792, 61, 32812, 32776, 32777, 32778, 32780,
32992, 32782, 32783, 32958, 62, 32776, 32771, 32772,
32793, 32993, 32804, 32993, 32958, 32796, 63, 32993,
32995, 32771, 32997, 32821, 32792, 32909, 64, 32812,
32776, 32999, 32793, 33001, 32782, 32783, 32875, 65,
33003, 32776, 32771, 32772, 32782, 32962, 32993, 32958,
66, 33005, 33007, 32955, 33009, 32776, 67, 33011,
33013, 33014, 32776, 33015, 33016, 33018, 69, 33003,
33013, 32771, 33020, 32955, 32776, 33022, 32771, 32772,
32826, 32829, 32993, 70, 33023, 33025, 32777, 32923,
33028, 32995, 32826, 32792, 71, 32776, 32771, 32772,
32793, 33023, 32948, 72, 33029, 32868, 32782, 32793,
33023, 32802, 73, 33029, 32933, 32782, 32793, 33023,
32802, 74, 33031, 32771, 32772, 32962, 33033, 33035,
75, 33023, 32802, 33037, 32793, 33039, 32802, 76,
33023, 32948, 32776, 32782, 33040, 32802, 77, 33023,
32933, 32782, 33040, 32802, 78, 33023, 32868, 33042,
32782, 33040, 32802, 80, 33043, 32948, 32776, 33045,
32864, 32802, 81, 33043, 32948, 32776, 33047, 32955,
32802, 82, 32776, 32771, 32772, 32793, 33050, 32796,
83, 33013, 33014, 32776, 32846, 32772, 33052, 32782,
32829, 86, 33054, 33050, 33013, 33047, 32955, 33056,
32776, 87, 32958, 32796, 32776, 32992, 32782, 32802,
90, 33057, 32796, 32776, 32992, 32782, 32802, 91,
33059, 32837, 32948, 32776, 32772, 32873, 92, 33059,
33060, 32777, 32984, 33062, 93, 33059, 33060, 32777,
33063, 32880, 32826, 33065, 90, 33057, 32796, 32776,
32992, 33067, 32948, 95, 32812, 32776, 32772, 32877,
32782, 33068, 96, 33070, 32792, 32772, 32877, 32782,
33068, 97, 33072, 33074, 32772, 32877, 98, 33077,
99, 33080, 32772, 33082, 33084, 33085, 33087, 101,
33089, 32791, 32777, 32852, 32856, 33091, 102, 33094,
32826, 32792, 33096, 32771, 32852, 33098, 103, 33099,
33101, 33103, 104, 33099, 33101, 33103, 105, 32896,
32856, 32799, 32897, 106, 33023, 32933, 32852, 33104,
107, 33105, 33107, 32846, 33101, 33103, 108, 33109,
32852, 33111, 109, 33105, 33114, 110, 33117, 33118,
201, 33119, 33120, 32846, 33122, 33067, 32850, 202,
32812, 32776, 32772, 32992, 203, 32775, 32776, 32772,
32992, 204, 33054, 33059, 32837, 32948, 32776, 205,
32812, 32776, 32772, 33125, 206, 33128, 32782, 33130,
33132, 207, 32929, 32948, 32776, 32772, 33133, 208,
33136, 33139, 32992, 33141, 33142, 33144, 33146, 209,
33149, 33151, 32771, 33153, 33154, 210, 33156, 33158,
32854, 211, 33160, 33162, 32772, 33164, 33166, 33158,
212, 33167, 33170, 33172, 33174, 255, 33175, 33177,
33179, 0
CONSTINTEGERARRAY LETT(0: 412)=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'15ADB800',X'53769780',X'781B2199',X'0A000000',
X'43A00000',X'4D95F680',X'594DD280',X'7A000000',
X'42000000',X'27BD3A47',X'50000000',X'5D0DB280',
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'5F300000',X'494CD34B',X'65980000',
X'69CE1280',X'6784B1D3',X'4D4C70E9',X'537DC000',
X'4D2EF2E4',X'652CD2E5',X'4B7472C8',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 or n>100) AND (PARM_Z#0 OR PARM_DCOMP#0)
!*DELEND
MESS1=""; MESS2=""
if parm_faulty < 255 then 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>=11 THEN MESS2=MESS2."?" AND T=T+1
FINISH
MESS2=MESS2.TOSTRING(J&127)
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
SELECT OUTPUT(PARM_TTOPUT) unless PARM_TTOPUT=-1
PRINTSTRING(MESS1)
PRINTSTRING(MESS2) IF MESS2#""
IF N=100 AND S<115 THEN START
NEWLINE; SPACES(S+4); PRINTSYMBOL('!')
FINISH
NEWLINE
SELECT OUTPUT(parm_lpoput) unless PARM_TTOPUT=-1
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 (255) mess
return if worka_line>=20000 { In an included file }
if n=10 start
mess="
? Warning: Inspect the C produced for input line ".SWRITE(WORKA_LINE,2)."
"
select output( PARM_TTOPUT) unless PARM_TTOPUT=-1
printstring(mess)
select output(parm_lpoput) unless PARM_TTOPUT=-1
finish
if n=11 start
mess="
? Warning: Structure member name the same as defined name line ".SWRITE(WORKA_LINE,2)."
"
select output( PARM_TTOPUT) unless PARM_TTOPUT=-1
printstring(mess)
select output(parm_lpoput) unless PARM_TTOPUT=-1
finish
if n=12 start
mess="
? Warning: Possible Missed comment at line ".SWRITE(WORKA_LINE,2)."
"
select output( PARM_TTOPUT) unless PARM_TTOPUT=-1
printstring(mess)
select output(parm_lpoput) unless PARM_TTOPUT=-1
finish
if n=13 start
mess="
? Warning: No dope vector found for array access at line ".SWRITE(WORKA_LINE,2)."
Lower bound(s) of zero perforce assumed
"
select output( PARM_TTOPUT) unless PARM_TTOPUT=-1
printstring(mess)
select output(parm_lpoput) unless PARM_TTOPUT=-1
finish
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 *
!***********************************************************************
CONSTSTRING(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","DMASS"," ? "(2),
"UCNOP","UCB1 ","UCB2 ","UCB3 "," UCW ",
"UCBW ","UCWW ","UCLW ","UCB2W","UCNAM",
" ? "(68),
" + "," - "," !! "," ! "," * ",
" // "," / "," & "," >> "," << ",
" REXP"," COMP","DCOMP"," VMY "," COMB",
" = "," <- "," IEXP"," ADJ ","AINDX",
"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:11)
PRHEX(OPND_PTYPE,4)
J=OPND _FLAG
->SW(J) UNLESS J>11
PRINTSTRING("?")
PRHEX(OPND_S1&X'FFFF',4)
SPACE
PRHEX(OPND_D,8)
SPACE
PRHEX(OPND_XTRA,8)
RETURN
SW(0):SW(1): ! CONSTANT
if j=0 then printstring("s") else 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(3):
printstring(" AR ptr "); write(opnd_d,2); spaces(10)
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)
RETURN
SW(11): ! VIA LA ON B&D
PRINTSTRING("ADDR(B&D)")
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)=0
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!
ROUTINE PutError(STRING (255) s)
!***********************************************************************
!* Compilation ends in disarray. Message and stop tidily *
!***********************************************************************
INTEGER bad
printstring("** PUT error **"); newline
bad=addr(s)+1
monitor; STOP
END {PutError}
externalroutine free space(integer ad)
!***********************************************************************
!* This is EPCs interface to FREE *
!* Enables monitoring or checking to take place *
!************************************************************************
printstring(" FREE "); write(ad,1)
newline
end; ! Free space
!*
EXTERNAL INTEGER FN Get Space(INTEGER size{bytes})
!************************************************************************
!* This is EPC's interface to MALLOC *
!* Enables monitoring or checking to take place *
!************************************************************************
INTEGER flag
size=(size+7)&(-8) { keep everything d-w aligned }
IF malmon#0 START
printstring(" MALLOC "); write(size,1)
flag=MALLOC(size)
printstring(" flag = "); phex(flag)
newline
IF flag+size>maxdata THEN maxdata=flag+size
FINISH ELSE flag=MALLOC(size)
IF flag=0 THEN PutError(" MALLOC out of space ")
RESULT=flag
END
externalroutine changesex
end
externalroutine pownarrayhead
end
externalroutine emonon
end
externalroutine prdata
end
externalroutine generate
end
externalroutine pinitown
end
externalroutine esetoptions
end
externalroutine psetfiles
end
externalroutine epilogue
end
externalroutine impabort
end
externalroutine mcodeon
end
externalroutine reformatc
end
externalroutine pfaulty
end
externalroutine prologue
end
externalroutine filldtabrefs
end
externalroutine cxref
end
externalroutine esetgisoptions
end
externalroutine pdata
end
externalroutine pgenerateobject
end
externalroutine pmonon
end
END OF FILE