! DATED 02 MAY 78 2
ROUTINESPEC SETS(INTEGER STREAM)
ROUTINE DUMP BIN(HALFINTEGERARRAYNAME CODE, C
INTEGER START,FINISH,STRINGNAME T,INTEGERNAME FLAG)
PRINTSTRING("ROUTINE DUMPBIN CALLED ??
")
END; ! DUMPBIN
OWNBYTEINTEGERARRAY BIN(-2:30000)
OWNINTEGERARRAY T(0:300)
OWNINTEGER CA,BLKENT,BRFAULT
OWNINTEGERARRAY BAT(0:6000)
RECORDFORMAT REL ADDRS(INTEGER RADDR,LINK)
OWNRECORDARRAY REL(1:10)(RELADDRS)
OWNINTEGER MAIN=0
OWNINTEGER SYSSTK=0
OWNINTEGER ENDCO1=0
OWNINTEGER ENDCO=0
OWNINTEGER CT0=0
OWNINTEGER LASTRELADDR=0
OWNINTEGER LASTCAREL=0
ROUTINE DBIN(INTEGER OP,M1,NEM1,NUM1,M2,NEM2,NUM2)
!
!
! OP=-2 ADDRESS OF CT0 OR STB NOW AVAILABLE :
! M1=17=STB : M1=18=CT0 : NEM1=ADDR(M1)
!
! OP=-1 BTN NOW SET : ADDRESS AT BAT(M1)
!
! OP= 0 MACHINE CODE
!
! OP= 108-110 OR 120-125 BRANCH OR JUMP
!
! OP= 111-119 OR 126-166 ANY OTHER INSTRUCTION
!
!
ROUTINESPEC POP BT ADDR(INTEGERNAME BTADDRHD,CADDR,TYPE)
ROUTINESPEC REMOVE SAT BTS
OWNBYTEINTEGERARRAY BIN(-2:30000)
HALFINTEGERARRAYNAME BINS
HALFINTEGERARRAYFORMAT BINFORM(0:15000)
BINS==ARRAY(ADDR(BIN(0)),BINFORM)
INTEGERFNSPEC FIND BT ENTRY(INTEGER BTNO)
ROUTINESPEC PUSH UNSAT BTS(INTEGER BTNO,CADDR,TYPE)
ROUTINESPEC PUSH BT ADDR(INTEGERNAME BTADDRHD,INTEGER CADDR,TYPE)
INTEGERFNSPEC OCT TO BIN(INTEGERNAME PTR,INTEGERARRAYNAME T)
ROUTINESPEC OCT(INTEGER I)
BRFAULT=0
RECORDFORMAT UNSATBTS(INTEGER LINK,BTNO,BTADDRHD)
RECORDFORMAT CALSTF(INTEGER LINK,CADDR,TYPE)
OWNRECORDARRAY BTCELLS(0:999)(UNSATBTS)
OWNRECORDARRAY LCELLS(0:999)(CALSTF)
OWNINTEGERARRAY CTSTBHD(17:18)=-1(2)
OWNINTEGER RELPTR=2
OWNINTEGER FIRST=0
OWNINTEGER BTASL=0
OWNINTEGER LASL=0
OWNINTEGER BTC=-1
OWNINTEGER ABS=0
OWNINTEGER STB=0
INTEGER J,K,L,ENTRY,LAST ENTRY,PUSH CT STB ; PUSH CT STB=0
BYTEINTEGER BRDISP
HALFINTEGER JMPDISP
INTEGER CODE,I
OWNINTEGERARRAY INST(108:166)= C
X'100',X'77',X'837',X'BC0',X'1000',X'80',X'A1',X'C00',
X'CC0',0(3),X'200',X'300',X'400',X'500',X'700',X'600',
X'4000',X'5000',X'A40',0,X'1000',X'7400',0(24),X'6000',X'E000',X'5000',
X'6000',X'E000',X'A80',X'AC0',X'A00',X'2000',X'B00',X'C0'
OWNINTEGERARRAY MODE(-1:13)=0(2),1,2,3,4,5,6,7,2,0,1,0,2,0
!
!
!
IF 108<=OP<=110 OR 120<=OP<=125 OR OP=-1 START
IF FIRST=0 START
CYCLE I=0,1,998
BTCELLS(I)_LINK=I+1
LCELLS(I)_LINK=I+1
BTCELLS(I)_BTADDRHD=-1
REPEAT
BTCELLS(999)_LINK=0
LCELLS(999)_LINK=0
BTCELLS(999)_BTADDRHD=-1
FIRST=1
FINISH
!
!
!
IF OP=-1 START; ! LABEL NOW PLANTED BAT(M1)=ADDR(LABEL)
I=FIND BT ENTRY(M1)
IF I<0 THEN ->OUT; ! NO OUTSTANDING REFERENCES TO LABEL
POP:
POP BT ADDR(BTCELLS(I)_BTADDRHD,J,K)
L=(BAT(M1)-J-2)>>(K>>1)
IF K=2 AND L>128 THEN BRFAULT=1
IF ABS=0 OR K=2 THEN C
BINS(J>>1)<-BINS(J>>1)! C
L ELSE BINS(J>>1)<- C
BAT(M1)-LASTCAREL+LASTRELADDR
->POP UNLESS BTCELLS(I)_BTADDRHD=-1
REMOVE SAT BTS
->OUT
FINISH
CODE=INST(OP); ! GET CODE FOR BRANCH
IF NEM1>100 THEN NEM1=NEM1-100
IF OP=110 THEN CODE=CODE!(NEM1<<6); ! RETURN REG. FOR JSR
IF NUM2=-1 START
OCT(CODE!2)
->OUT
FINISH
IF NEM2=129 AND BAT(NUM2)=-1 START; ! LABEL NOT SET
I=FIND BT ENTRY(NUM2)
OCT(CODE)
IF OP=109 OR OP=110 THEN J=0 ELSE J=2
IF I<0 START; ! NO ENTRY FOR THIS BRANCH
PUSH UNSAT BTS(NUM2,CA-J,J)
->OUTC
FINISH
PUSH BT ADDR(BTCELLS(I)_BTADDRHD,CA-J,J)
OUTC:
IF J=0 THEN OCT(0)
->OUT
FINISH
! DEAL HERE WITH LABELS WHICH ARE SET
IF NEM2=136 OR NEM2=166 THEN I=NUM2 ELSE I=BAT(NUM2)
IF OP=109 START; ! JMP
JSR:
OCT(CODE)
IF ABS=0 START
JMPDISP=CA-I
JMPDISP<--JMPDISP-2
IF JMPDISP&1=1 THEN JMPDISP=JMPDISP+1
FINISHELSE JMPDISP<-I-LASTCAREL+LASTRELADDR
IF NEM2=152 THEN JMPDISP=X'130'
IF NEM2=166 THEN JMPDISP=NUM2
OCT(JMPDISP)
->OUT
FINISH
IF OP=110 START; ! JSR
IF NEM2=152 OR NEM2=166 THEN CODE=X'81F'
CODE=CODE!(NEM1<<6)
->JSR
FINISH
BRDISP=(CA-I)>>1
BRDISP<--BRDISP-1
OCT(CODE!BRDISP)
OUT:
RETURN
FINISH
!
!
!
IF OP=-2 START; ! FILL IN CT0+N OR STB+N
L8:
IF CTSTBHD(M1)=-1 THEN RETURN; ! NO OUTSTANDING REFERENCES
POP BT ADDR(CTSTBHD(M1),I,J)
! I NOW CONTAINS THE ADDRESS OF WORD TO BE PLUGGED
! J CONTAINS THE MODE
IF 6<=J<=7 THEN BINS(I>>1)<-CA-(I+2)+ C
BINS(I>>1) ELSE C
BINS(I>>1)<-CA+BINS(I>>1)
->L8
FINISH
!
!
!
IF OP=0 START; ! MACHINE CODE
J=M1-1
L1:
I=OCT TO BIN(J,T)
IF I>=0 START; ! *NUMBER
OCT(I)
L2:
IF T(J)=10 OR T(J)=';' THEN RETURN
IF T(J)=',' START
J=J+1
->L1
FINISH
J=J+1
->L2
FINISH; ! *NUMBER
!
! CHECK FOR .WORD
!
IF T(J)='.' AND T(J+1)='W' AND T(J+2)='O' AND T(J+3)='R' START
J=J+5
->L1
FINISH
!
! MUST BE NAME OR ADDRESS
!
IF T(J)='.' AND T(J+1)='=' START; ! RELOCATION ADDRESS
J=J+2
I=OCT TO BIN(J,T)
RETURN IF I<0
L9:
REL(REL PTR)_RADDR=I
REL(REL PTR)_LINK=CA
REL PTR=REL PTR+1
REL(REL PTR)_LINK=-1
LASTRELADDR=I
LASTCAREL=CA
RETURN
FINISH; ! RELOCATION ADDRESS
!
! CT0
!
IF T(J)='C' AND T(J+1)='T' AND T(J+2)='0' AND T(J+3)='=' START
J=J+4
I=0
K=T(J)
WHILE T(J)#';' AND T(J)#10 CYCLE
IF '0'<=T(J)<='7' START
I=OCT TO BIN(J,T)
->L3
FINISH
J=J+1
REPEAT
L3:
IF K='.' THEN CT0=CA-LASTCAREL+LASTRELADDR+I ELSE CT0=I
I=CT0
->L9 IF I>LASTRELADDR
RETURN
FINISH; ! *CT0
!
! .ABSOLUTE
!
IF T(J)='.' AND T(J+1)='A' AND T(J+2)='B' AND T(J+3)='S' START
ABS=1
INST(109)=X'5F'
INST(110)=X'81F'
RETURN
FINISH
!
! .BYTE
!
IF T(J)='.' AND T(J+1)='B' START; ! ! *.BYTE
J=J+4
L4:
J=J+1
K=0
I=OCT TO BIN(J,T)
->L5 UNLESS T(J)=','
J=J+1
K=OCT TO BIN(J,T)
L5:
OCT(K<<8!I)
IF T(J)=',' THEN ->L4 ELSE RETURN
FINISH; ! *.BYTE
!
! STB:
!
IF T(J)='S' AND T(J+1)='T' AND T(J+2)='B' AND T(J+3)=':' START
STB=CA-LASTCAREL+LASTRELADDR
WHILE T(J)#'+' THEN J=J+1
J=J+1
I=OCT TO BIN(J,T)
I=STB+I
->L9
RETURN
FINISH; ! *STB:.=.
!
! MAIN
!
IF T(J)='M' AND T(J+1)='A' AND T(J+2)='I' AND T(J+3)='N' START
MAIN=CA
IF T(J+4)='+' START
J=J+5
OCT(OCT TO BIN(J,T))
FINISHELSE OCT(0)
->L2
FINISH
!
! ENDCO,ENDCO1
!
IF T(J)='E' AND T(J+1)='N' AND T(J+2)='D' C
AND T(J+3)='C' AND T(J+4)='O' START
IF T(J+5)='1' THEN ENDCO1=CA ELSE ENDCO=CA
OCT(0)
->L2
FINISH
!
! SYSSTK:
!
IF T(J)='S' AND T(J+1)='Y' AND T(J+2)='S' AND T(J+3)='S' START
IF T(J+6)=':' START
I=CA-LASTCAREL+LASTRELADDR
BINS(SYSSTK>>1)<-I
SYSSTK=I
FINISHELSESTART
SYSSTK=CA
OCT(0)
FINISH
->L2
FINISH
!
! .ASCII
!
IF T(J)='.' AND T(J+1)='A' AND T(J+2)='S' AND T(J+3)='C' START
J=J+6
WHILE T(J)='_' THEN J=J+1
I=T(J)
J=J+1
WHILE T(J)#I CYCLE
BIN(CA!!1)<-T(J)
CA=CA+1
J=J+1
REPEAT
IF CA&1#0 START
BIN(CA-1)=' '
CA=CA+1
FINISH
->L2
FINISH
!
! BLKENT
!
IF T(J)='B' AND T(J+1)='L' AND T(J+2)='K' AND T(J+3)='E' START
J=J+7
BLKENT=OCT TO BIN(J,T)
->L2
FINISH; ! BLKENT
SETS(3)
PRINTSTRING(";* FAILED TO ANALYSE STATEMENT
")
RETURN
FINISH; ! MACHINE CODE
!
!
!
IF NEM1>=100 THEN NEM1=NEM1-100
IF NEM2>=100 THEN NEM2=NEM2-100
CODE=INST(OP&255)
IF CODE=0 THEN RETURN
IF OP>255 THEN CODE=CODE!X'8000'
! CODE FOR CT0 & STB ADDRESSES ASUMED SET
IF NEM1=17 OR NEM1=18 START; ! FIRST OPERAND IS CT0 OR STB
IF M1=8 THEN M1=2
IF M1=9 THEN M1=3
IF M1=10 THEN M1=7
IF M1=3 AND ABS=0 THEN M1=6
IF NEM1=17 THEN NUM1=NUM1+20+STB ELSE NUM1=NUM1+CT0
IF (NEM1=17 AND STB=0) OR (NEM1=18 AND CT0=0) START
PUSH CT STB=1
->L6
FINISH
IF 6<=M1<=7 THEN NUM1=NUM1-(CA-LASTCAREL+LASTRELADDR+4)
L6:
NEM1=7
FINISH
IF NEM2=17 OR NEM2=18 START; ! SECOND OPERAND IS CT0 OR STB
IF M2=8 THEN M2=2
IF M2=9 THEN M2=3
IF M2=10 THEN M2=7
IF M2=3 AND ABS=0 THEN M2=6
IF NEM2=17 THEN NUM2=NUM2+20+STB ELSE NUM2=NUM2+CT0
IF (NEM2=17 AND STB=0) OR (NEM2=18 AND CT0=0) START
PUSH CT STB=PUSH CT STB+2
->L7
FINISH
IF NUM1#0 THEN I=6 ELSE I=4
IF 6<=M2<=7 THEN NUM2=NUM2-(CA-LASTCAREL+LASTRELADDR+I)
L7:
NEM2=7
FINISH
CODE=CODE!(NEM1<<6)!NEM2
I=MODE(M1)
IF I=2 AND M1#2 THEN CODE=CODE!X'1C0'
IF I=6 AND NUM1=0 THEN I=1
CODE=CODE!(I<<9)
I=MODE(M2)
IF I=2 AND M2#2 THEN CODE=CODE!7
IF I=6 AND NUM2=0 THEN I=1
CODE=CODE!(I<<3)
OCT(CODE)
IF PUSH CT STB&1#0 START
PUSH BT ADDR(CTSTBHD(NEM1),CA,M1)
OCT(NUM1)
FINISH
IF PUSH CT STB&2#0 START
PUSH BT ADDR(CTSTBHD(NEM2),CA,M2)
OCT(NUM2)
FINISH
IF NUM1#0 THEN OCT(NUM1)
IF NUM2#0 THEN OCT(NUM2)
RETURN
INTEGERFN OCT TO BIN(INTEGERNAME PTR,INTEGERARRAYNAME T)
INTEGER I
I=0
L1:
IF '0'<=T(PTR)<='7' THEN ->L2
IF T(PTR)#'_' THEN RESULT=-1
PTR=PTR+1
->L1
L2:
IF '0'<=T(PTR)<='7' THEN I=I<<3!(T(PTR)-'0') ELSE RESULT=I
PTR=PTR+1
->L2
END
ROUTINE OCT(INTEGER I)
BINS(CA>>1)<-I
CA=CA+2
END
ROUTINE PUSH UNSAT BTS(INTEGER BTNO,CADDR,TYPE)
INTEGER I,K
I=BTASL
BTASL=BTCELLS(BTASL)_LINK
BTCELLS(I)_BTNO=BTNO
PUSH BT ADDR(BTCELLS(I)_BTADDRHD,CADDR,TYPE)
K=BTC
BTC=I
BTCELLS(I)_LINK=K
END
ROUTINE PUSH BT ADDR(INTEGERNAME BTADDRHD,INTEGER CADDR,TYPE)
INTEGER I
I=LASL
LASL=LCELLS(LASL)_LINK
LCELLS(I)_CADDR=CADDR
LCELLS(I)_TYPE=TYPE
LCELLS(I)_LINK=BTADDRHD
BTADDRHD=I
END
ROUTINE POP BT ADDR(INTEGERNAME BTADDRHD,CADDR,TYPE)
INTEGER I
CADDR=LCELLS(BTADDRHD)_CADDR
TYPE=LCELLS(BTADDRHD)_TYPE
I=LCELLS(BTADDRHD)_LINK
LCELLS(BTADDRHD)_LINK=LASL
LASL=BTADDRHD
BTADDRHD=I
END
ROUTINE REMOVE SAT BTS
INTEGER I,J
I=BTASL
J=BTCELLS(ENTRY)_LINK
BTCELLS(ENTRY)_LINK=BTASL
BTASL=ENTRY
IF LAST ENTRY=-1 THEN BTC=J ELSE BTCELLS(LAST ENTRY)_LINK=J
END
INTEGERFN FIND BT ENTRY(INTEGER BTNO)
INTEGER I
LAST ENTRY=-1
ENTRY=BTC
TRY AGAIN:
IF ENTRY=-1 THEN RESULT=-1; ! NOT FOUND
IF BTCELLS(ENTRY)_BTNO=BTNO THEN RESULT=ENTRY; ! FOUND
LAST ENTRY=ENTRY
ENTRY=BTCELLS(ENTRY)_LINK
->TRY AGAIN
END
END
!%EXTRINSICBYTEINTEGERARRAY BIN(-2:30000)
OWNSTRING(7) RV="7.10"
!
! RENUMBERING THE ALTS OF <UI> REQUIRED ALTERATIONS TO
! SS SW(1) AND SW(2) TESTING ALT OF UI
! RT (SCALAR NAME PARAM)
! RT (ARRAYNAME PARAM)
! SCCOND ("THEN UI IS JUMP")
!
! REGISTERS 1024
!
! NOTE DOPE VECTORS HAVE (TYPE<<4) ! ND
!
ROUTINE SKIMP11(INTEGER TARGET)
!%CONTROL148; ! 128 + 16 + 4
!%BEGIN
STRING (10) ST
HALFINTEGERARRAYNAME BINS
HALFINTEGERARRAYFORMAT BINFORM(0:15001)
BINS==ARRAY(ADDR(BIN(-2)),BINFORM)
OWNINTEGER UNDER=20; ! NO OF BYTES UNDER FIRST DISPLAY
OWNINTEGER PDISP=14; !RT PARAMS START PDISP BYTES FROM STP.
OWNINTEGER TEMPS=20; !NO. OF BYTES FOR TEMP STORAGE IN DISPLAY
OWNINTEGER PREVL=12; !DISPL(BYTES) IN DISPLAY OF PREV LEVEL PTR.
OWNINTEGER ARADS
OWNINTEGER CYCS
OWNINTEGER OPNS
OWNINTEGER CALLS
OWNINTEGER ENTS
OWNINTEGER CSIZE
OWNINTEGER SCS=0
OWNINTEGER PJS=0
OWNINTEGER STMTS=0
!%ROUTINESPEC SETS(%INTEGER N)
ROUTINESPEC READ SYM(INTEGERNAME I)
ROUTINESPEC READ STATEMENT
INTEGERFNSPEC COMPARE
ROUTINESPEC PRINT AR(INTEGER N)
ROUTINESPEC SS
ROUTINESPEC FAULT(INTEGER I)
INTEGERFNSPEC NEWCELL
INTEGERFNSPEC RETURN CELL(INTEGER I)
INTEGERFNSPEC TAG OF(INTEGER NAME)
INTEGERFNSPEC TAG OFF(INTEGER NAME)
ROUTINESPEC POP(INTEGERNAME CELL,INF,INF1)
ROUTINESPEC PUSH(INTEGERNAME CELL, INTEGER INF,INF1)
INTEGERFNSPEC BT NEXT
INTEGERFNSPEC CT NEXT
ROUTINESPEC SHOW TAGS
INTEGERFNSPEC PRINT4(INTEGER I)
ROUTINESPEC PRINTNAME(INTEGER I)
RECORDFORMAT RELADDRS(INTEGER RADDR,LINK)
!%EXTRINSICRECORDARRAY REL(1:10)(RELADDRS)
OWNINTEGER LASTRELADDR
OWNINTEGER LASTCAREL
!%EXTRINSICINTEGER CT0
!%EXTERNALINTEGER BRFAULT=0
!%EXTERNALINTEGER BLKENT=0
!%EXTERNALINTEGER CA
!%EXTRINSICINTEGER MAIN,SYSSTK,ENDCO,ENDCO1
OWNINTEGER ASSTK=0
INTEGER AP,TP,PSP,BTN,CTN,FAULTS,RAD,LEVEL,COMP,SCF
INTEGER POLISH; POLISH=0
INTEGER FLACC; FLACC=0
INTEGER REALS; REALS=0
OWNINTEGER STRFLAG=0; ! MAY BE SET IN RT STRING.
OWNINTEGER EXPFFLAG=0; ! MAY BE SET IN RT AD.
OWNINTEGER READFLAG=0; ! MAY BE SET IN RT RT.
INTEGER LINE,TWSP,TWSPLIM
OWNINTEGERARRAY IND(0:7)=100,101,102,103,104,105,106,107
OWNINTEGERARRAY IUSE(0:5)=0(6); ! TO KEEP TRACK OF USES(I0=ACC)
OWNINTEGERARRAY POINT(0:5)=0(6)
OWNINTEGERARRAY POINT1(0:5)=-1(6)
OWNINTEGER PTEXTSHL=0
OWNINTEGER CCSET=-1
OWNINTEGER ALGO=0
OWNINTEGER SP=106
OWNINTEGER PC=107
OWNINTEGER INC=161
OWNINTEGER DEC=162
OWNINTEGER CLR=163
OWNINTEGER CLRB=419; ! CLR+256
OWNINTEGER BR=108
OWNINTEGER JMP=109
OWNINTEGER JSR=110
OWNINTEGER TST=111
OWNINTEGER MOV=112
OWNINTEGER MOVB=368; ! MOV+256
OWNINTEGER RTS=113
OWNINTEGER CLC=114
OWNINTEGER BIC=126
OWNINTEGER ROR=115
OWNINTEGER NEG=165
OWNINTEGER NOT=128
OWNINTEGER TRAP=119
OWNINTEGER CMP=164
OWNINTEGER MASL=116
OWNINTEGER ACC=100
OWNINTEGER R0=100
OWNINTEGER R1=101
OWNINTEGER R2=102
OWNINTEGER R3=103
OWNINTEGER R4=104
OWNINTEGER R5=105
OWNINTEGER STB=117 ; ! ADDRESS OF STACK BASE=GLOBALS
OWNINTEGER CT=118; ! ADDRESS OF CONSTANT TABLE BASE
OWNINTEGER BT=129
OWNINTEGER LLAB=136
OWNINTEGER LOAD=112; ! MNEMONIC FOR LOAD OPERATION
OWNINTEGER SUB=160
OWNINTEGER ADD=159
OWNINTEGER STR=130
OWNINTEGER ASH=131
OWNINTEGER SWAB=166
OWNHALFINTEGERARRAY BINREALS(0:14)=308,312,316,320,352,0(4),
356,324,328,332,336,340
INTEGER SWTCA,CTCA
! ALSO ARRAYS TAG,LINK AND NAME AND OWNINTEGER LAST PERM SPEC
! ARRAY PS(-1000:-...) FOLLOWS
ENDOFLIST
OWNINTEGERARRAY PS(-1000:-196)= -995,
-728, 5, -631, 3, -988, -625, -529, -519,
5, -674, 3, -984, -470, 58,-1000, -976,
-465, -409, -309, 1, -357, -351, 3, -974,
-372, -967, -281, -334, -316, 1, -302, 3,
-956, -270, -529, -519, 212, 200, 197, 206,
5, -728, 3, -946, -270, -529, -519, 195,
217, 195, 204, 197, 3, -939, -728, -270,
5, -529, -519, 3, -925, 195, 217, 195,
204, 197, 1, 61, -581, 44, -581, 44,
-581, 3, -917, 210, 197, 208, 197, 193,
212, 3, -911, 207, 215, 206, -465, -401,
-901, 195, 207, 206, 212, 210, 207, 204,
2, 3, -889, 211, 215, 201, 212, 195,
200, 1, -357, 5, -387, 3, -881, 1,
40, -607, 2, 41, 58,-1000, -872, 198,
201, 206, 201, 211, 200, -649, 3, -859,
211, 200, 207, 210, 212, 210, 207, 213,
212, 201, 206, 197, -848, 202, 213, 205,
208, 211, 211, 200, 207, 210, 212, -836,
202, 213, 205, 208, 211, 206, 207, 210,
205, 193, 204, -827, 204, 207, 206, 199,
202, 213, 205, 208, -822, 197, 206, 196,
3, -815, 194, 197, 199, 201, 206, 3,
-802, 197, 206, 196, 207, 198, 208, 210,
207, 199, 210, 193, 205, -792, 197, 206,
196, 207, 198, 198, 201, 204, 197, -782,
198, 193, 213, 204, 212, 2, 45, 62,
-470, -763, 210, 197, 195, 207, 210, 196,
198, 207, 210, 205, 193, 212, 1, 40,
-257, -219, 41, 3, -746, 210, 197, 195,
207, 210, 196, 206, 193, 205, 197, 1,
-357, 40, 1, 41, 3, -740, 204, 201,
211, 212, 3, -729, 197, 206, 196, 207,
198, 204, 201, 211, 212, 3, 0, -722,
1, 95, 1, -614, -534, -718, 1, -614,
-534, -711, 45, 62, 1, 40, -581, 41,
-707, 45, 62, -470, -700, 210, 197, 212,
213, 210, 206, -691, 210, 197, 211, 213,
204, 212, 61, -581, -686, 211, 212, 207,
208, -675, 208, 210, 201, 206, 212, 212,
197, 216, 212, 4, 0, -664, 212, 200,
197, 206, 211, 212, 193, 210, 212, -658,
211, 212, 193, 210, 212, -650, 212, 200,
197, 206, -728, 7, -649, 0, -639, 197,
204, 211, 197, 211, 212, 193, 210, 212,
-633, 197, 204, 211, 197, -728, -632, 0,
-627, -625, -529, -519, -626, 0, -622, 201,
198, -615, 213, 206, 204, 197, 211, 211,
0, -609, 40, -581, -540, 41, -608, 0,
-605, 43, -603, 45, -601, 92, -600, 0,
-595, 1, 95, 1, -592, 1, -614, -590,
2, -586, 40, -581, 41, -582, 40, 2,
41, 0, -577, -607, -599, -576, 0, -572,
-570, -599, -576, -571, 0, -567, 60, 60,
-564, 62, 62, -561, 47, 47, -559, 38,
-556, 33, 33, -554, 33, -551, 42, 42,
-549, 47, -547, 42, -545, 43, -543, 45,
-541, 46, 0, -536, 44, -581, -540, -535,
0, -531, -213, -581, -530, 0, -525, -581,
-491, -581, -520, 40, -529, -519, 41, 0,
-513, 193, 206, 196, -529, -506, -508, 207,
210, -529, -498, -507, 0, -500, 193, 206,
196, -529, -506, -499, 0, -493, 207, 210,
-529, -498, -492, 0, -489, 61, -486, 92,
61, -483, 60, 61, -481, 60, -478, 62,
61, -476, 62, -474, 35, -471, 45, 62,
0, -468, 1, -466, 2, 0, -453, 194,
217, 212, 197, 201, 206, 212, 197, 199,
197, 210, -445, 201, 206, 212, 197, 199,
197, 210, -440, 210, 197, 193, 204, -427,
211, 200, 207, 210, 212, 201, 206, 212,
197, 199, 197, 210, -418, 204, 207, 206,
199, 210, 197, 193, 204, -410, 211, 212,
210, 201, 206, 199, -201, 0, -403, 193,
210, 210, 193, 217, -402, 0, -397, 1,
-378, 3, -388, 193, 210, 210, 193, 217,
1, -387, 6, 0, -379, 40, -607, 2,
58, -607, 2, 41, 0, -374, 61, -607,
2, -373, 0, -370, 33, -362, 195, 207,
205, 205, 197, 206, 212, -360, 3, -358,
42, 0, -353, 44, 1, -357, -352, 0,
-344, 40, -581, 58, -581, -342, 41, -343,
0, -336, 44, -581, 58, -581, -342, -335,
0, -326, 210, 207, 213, 212, 201, 206,
197, -322, -465, 198, 206, -317, -465, 205,
193, 208, 0, -311, 211, 208, 197, 195,
-310, 0, -304, 206, 193, 205, 197, -303,
0, -293, 40, -465, -409, -309, 1, -357,
-291, 41, -292, 0, -283, 44, -465, -409,
-309, 1, -357, -291, -282, 0, -272, 197,
216, 212, 197, 210, 206, 193, 204, -271,
0, -264, 213, 206, 212, 201, 204, -258,
215, 200, 201, 204, 197, 0, -247, 201,
206, 212, 197, 199, 197, 210, 1, -357,
-234, 210, 197, 195, 207, 210, 196, 206,
193, 205, 197, 1, -357, -220, 194, 217,
212, 197, 201, 206, 212, 197, 199, 197,
210, 1, -357, 0, -215, 44, -257, -219,
-214, 0, -210, 61, 61, -208, 61, -205,
60, 45, -202, 45, 62, 0, -197, 40,
2, 41, -196, 0
OWNINTEGERARRAY TAG(0: 4000)= C
0( 108), 627, 0( 18), 578, 0( 15), 617, 0( 6),
588, 0( 20), 556, 0( 2), 570, 0( 10), 598,
0( 12), 608, 0( 2), 523, 0( 3), 538, 0,
531, 0, 635, 0( 6), 582, 0( 6), 610,
564, 0( 2), 558, 0( 2), 646, 0( 157), 640,
0( 20), 594, 0( 9), 656, 540, 0( 4), 549,
0( 2), 515, 0( 9), 547, 633, 0( 6), 512,
574, 0( 6), 528, 603, 0( 14), 650, 0( 41),
21061, 21337, 20300, 20037, 16400, 446, 0, 21337, 20300,
16896, 428, 21323, 21337, 20300, 16384, 201, 20562, 21587,
16975, 21328, 16400, 454, 0, 17664, 16384, 207, 21328,
17747, 20037, 16400, 205, 0, 18766, 16384, 420, 20037,
18766, 20037, 16400, 438, 0, 16711, 16384, 425, 18766,
21504, 22354, 16912, 171, 0, 17664, 17236, 21317, 16416,
227, 0( 2), 20565, 19791, 16400, 224, 0, 21061,
17168, 174, 0, 16708, 16400, 447, 0, 21317, 16912,
127, 0, 17236, 21584, 17228, 16400, 216, 0, 17747,
17729, 19521, 16400, 150, 0, 20304, 16400, 409, 0,
21329, 21061, 16400, 185, 0, 21329, 18766, 17747, 22354,
16432, 455, 0( 3), 17747, 17228, 16432, 223, 0( 3),
16400, 143, 0, 18245, 16707, 33296, 198, 0, 16896,
108, 21061, 21060, 21332, 33296, 439, 0, 20039, 16985,
34320, 209, 0, 18766, 18245, 21335, 33040, 388, 0,
20562, 16912, 230, 0, 21587, 18766, 19525, 16400, 470,
0, 255, 21576, 21248, 16912, 419, 0( 3336)
OWNINTEGERARRAY TAG1(0: 4000)= C
0( 512), 16708, 19778, 0, 22612, 0( 2), 18,
19778, 0, 1, 0, 18768, 19778, 0, 2, 0,
18766, 22861, 19456, 16707, 3, 0, 2, 0, 4,
0, 16707, 0, 22348, 5, 0, 2, 17664, 6,
0, 22348, 17747, 22352, 7, 0, 2, 17664, 8,
0, 21584, 0, 18772, 9, 0, 3, 0, 18766,
19525, 10, 0, 2( 2), 21504, 17408, 11, 0,
2, 16708, 12, 0, 3, 17490, 13, 0, 18,
19525, 14, 0, 18, 20309, 21844, 20307, 15, 0,
2, 21586, 19712, 17219, 16, 0, 2, 17742, 17,
0, 2, 0, 16708, 18, 0, 2, 0, 21573,
20736, 18772, 19, 0, 2, 18( 2), 20736, 20307,
20, 0, 2, 18( 2), 21, 0, 2, 20992,
17152, 22, 0, 2, 23, 0, 17231, 0, 21065,
24, 0, 2, 0, 21573, 25, 0, 2, 21573,
20992, 16706, 26, 0, 2, 18766, 27, 0, 2,
21586, 18176, 20039, 28, 0, 6, 0( 3), 29,
0, 22, 0( 3335)
OWNINTEGERARRAY LINK(0: 4000)= C
0( 108), 631, 0( 18), 583, 0( 15), 623, 0( 6),
595, 0( 20), 559, 0( 2), 575, 0( 10), 604,
0( 12), 628, 0( 2), 526, 0( 3), 541, 0,
536, 0, 641, 0( 6), 589, 0( 6), 618,
571, 0( 2), 565, 0( 2), 651, 0( 157), 647,
0( 20), 599, 0( 9), 663, 545, 0( 4), 554,
0( 2), 521, 0( 9), 550, 636, 0( 6), 516,
579, 0( 6), 532, 611, 0( 14), 657, 0( 41),
513, 514, 0, 519, 518, 0( 2), 520, 0( 2),
517, 524, 525, 0( 2), 522, 529, 530, 0,
535, 534, 527, 0( 3), 533, 539, 0, 544,
543, 537, 0( 3), 542, 548, 0, 553, 552,
546, 0( 3), 551, 557, 0, 562, 561, 555,
0( 2), 569, 563, 567, 560, 568, 0( 3),
573, 566, 0( 2), 577, 572, 0( 2), 581,
576, 0, 586, 585, 580, 0, 587, 0, 592,
591, 584, 0, 593, 0( 2), 597, 590, 0,
602, 601, 596, 0( 2), 607, 606, 600, 0( 2),
626, 0, 609, 613, 605, 614, 615, 0( 2),
616, 620, 612, 621, 622, 0, 625, 619, 0( 3),
630, 624, 0( 2), 629, 634, 0, 639, 638,
632, 0( 2), 644, 643, 637, 0, 645, 0( 2),
649, 642, 0, 654, 653, 648, 0, 655, 0,
661, 659, 652, 660, 0( 2), 667, 665, 658,
666, 0, 668, 669, 670, 671, 672, 673, 674,
675, 676, 677, 678, 679, 680, 681, 682, 683,
684, 685, 686, 687, 688, 689, 690, 691, 692,
693, 694, 695, 696, 697, 698, 699, 700, 701,
702, 703, 704, 705, 706, 707, 708, 709, 710,
711, 712, 713, 714, 715, 716, 717, 718, 719,
720, 721, 722, 723, 724, 725, 726, 727, 728,
729, 730, 731, 732, 733, 734, 735, 736, 737,
738, 739, 740, 741, 742, 743, 744, 745, 746,
747, 748, 749, 750, 751, 752, 753, 754, 755,
756, 757, 758, 759, 760, 761, 762, 763, 764,
765, 766, 767, 768, 769, 770, 771, 772, 773,
774, 775, 776, 777, 778, 779, 780, 781, 782,
783, 784, 785, 786, 787, 788, 789, 790, 791,
792, 793, 794, 795, 796, 797, 798, 799, 800,
801, 802, 803, 804, 805, 806, 807, 808, 809,
810, 811, 812, 813, 814, 815, 816, 817, 818,
819, 820, 821, 822, 823, 824, 825, 826, 827,
828, 829, 830, 831, 832, 833, 834, 835, 836,
837, 838, 839, 840, 841, 842, 843, 844, 845,
846, 847, 848, 849, 850, 851, 852, 853, 854,
855, 856, 857, 858, 859, 860, 861, 862, 863,
864, 865, 866, 867, 868, 869, 870, 871, 872,
873, 874, 875, 876, 877, 878, 879, 880, 881,
882, 883, 884, 885, 886, 887, 888, 889, 890,
891, 892, 893, 894, 895, 896, 897, 898, 899,
900, 901, 902, 903, 904, 905, 906, 907, 908,
909, 910, 911, 912, 913, 914, 915, 916, 917,
918, 919, 920, 921, 922, 923, 924, 925, 926,
927, 928, 929, 930, 931, 932, 933, 934, 935,
936, 937, 938, 939, 940, 941, 942, 943, 944,
945, 946, 947, 948, 949, 950, 951, 952, 953,
954, 955, 956, 957, 958, 959, 960, 961, 962,
963, 964, 965, 966, 967, 968, 969, 970, 971,
972, 973, 974, 975, 976, 977, 978, 979, 980,
981, 982, 983, 984, 985, 986, 987, 988, 989,
990, 991, 992, 993, 994, 995, 996, 997, 998,
999, 1000, 1001, 1002, 1003, 1004, 1005, 1006, 1007,
1008, 1009, 1010, 1011, 1012, 1013, 1014, 1015, 1016,
1017, 1018, 1019, 1020, 1021, 1022, 1023, 1024, 1025,
1026, 1027, 1028, 1029, 1030, 1031, 1032, 1033, 1034,
1035, 1036, 1037, 1038, 1039, 1040, 1041, 1042, 1043,
1044, 1045, 1046, 1047, 1048, 1049, 1050, 1051, 1052,
1053, 1054, 1055, 1056, 1057, 1058, 1059, 1060, 1061,
1062, 1063, 1064, 1065, 1066, 1067, 1068, 1069, 1070,
1071, 1072, 1073, 1074, 1075, 1076, 1077, 1078, 1079,
1080, 1081, 1082, 1083, 1084, 1085, 1086, 1087, 1088,
1089, 1090, 1091, 1092, 1093, 1094, 1095, 1096, 1097,
1098, 1099, 1100, 1101, 1102, 1103, 1104, 1105, 1106,
1107, 1108, 1109, 1110, 1111, 1112, 1113, 1114, 1115,
1116, 1117, 1118, 1119, 1120, 1121, 1122, 1123, 1124,
1125, 1126, 1127, 1128, 1129, 1130, 1131, 1132, 1133,
1134, 1135, 1136, 1137, 1138, 1139, 1140, 1141, 1142,
1143, 1144, 1145, 1146, 1147, 1148, 1149, 1150, 1151,
1152, 1153, 1154, 1155, 1156, 1157, 1158, 1159, 1160,
1161, 1162, 1163, 1164, 1165, 1166, 1167, 1168, 1169,
1170, 1171, 1172, 1173, 1174, 1175, 1176, 1177, 1178,
1179, 1180, 1181, 1182, 1183, 1184, 1185, 1186, 1187,
1188, 1189, 1190, 1191, 1192, 1193, 1194, 1195, 1196,
1197, 1198, 1199, 1200, 1201, 1202, 1203, 1204, 1205,
1206, 1207, 1208, 1209, 1210, 1211, 1212, 1213, 1214,
1215, 1216, 1217, 1218, 1219, 1220, 1221, 1222, 1223,
1224, 1225, 1226, 1227, 1228, 1229, 1230, 1231, 1232,
1233, 1234, 1235, 1236, 1237, 1238, 1239, 1240, 1241,
1242, 1243, 1244, 1245, 1246, 1247, 1248, 1249, 1250,
1251, 1252, 1253, 1254, 1255, 1256, 1257, 1258, 1259,
1260, 1261, 1262, 1263, 1264, 1265, 1266, 1267, 1268,
1269, 1270, 1271, 1272, 1273, 1274, 1275, 1276, 1277,
1278, 1279, 1280, 1281, 1282, 1283, 1284, 1285, 1286,
1287, 1288, 1289, 1290, 1291, 1292, 1293, 1294, 1295,
1296, 1297, 1298, 1299, 1300, 1301, 1302, 1303, 1304,
1305, 1306, 1307, 1308, 1309, 1310, 1311, 1312, 1313,
1314, 1315, 1316, 1317, 1318, 1319, 1320, 1321, 1322,
1323, 1324, 1325, 1326, 1327, 1328, 1329, 1330, 1331,
1332, 1333, 1334, 1335, 1336, 1337, 1338, 1339, 1340,
1341, 1342, 1343, 1344, 1345, 1346, 1347, 1348, 1349,
1350, 1351, 1352, 1353, 1354, 1355, 1356, 1357, 1358,
1359, 1360, 1361, 1362, 1363, 1364, 1365, 1366, 1367,
1368, 1369, 1370, 1371, 1372, 1373, 1374, 1375, 1376,
1377, 1378, 1379, 1380, 1381, 1382, 1383, 1384, 1385,
1386, 1387, 1388, 1389, 1390, 1391, 1392, 1393, 1394,
1395, 1396, 1397, 1398, 1399, 1400, 1401, 1402, 1403,
1404, 1405, 1406, 1407, 1408, 1409, 1410, 1411, 1412,
1413, 1414, 1415, 1416, 1417, 1418, 1419, 1420, 1421,
1422, 1423, 1424, 1425, 1426, 1427, 1428, 1429, 1430,
1431, 1432, 1433, 1434, 1435, 1436, 1437, 1438, 1439,
1440, 1441, 1442, 1443, 1444, 1445, 1446, 1447, 1448,
1449, 1450, 1451, 1452, 1453, 1454, 1455, 1456, 1457,
1458, 1459, 1460, 1461, 1462, 1463, 1464, 1465, 1466,
1467, 1468, 1469, 1470, 1471, 1472, 1473, 1474, 1475,
1476, 1477, 1478, 1479, 1480, 1481, 1482, 1483, 1484,
1485, 1486, 1487, 1488, 1489, 1490, 1491, 1492, 1493,
1494, 1495, 1496, 1497, 1498, 1499, 1500, 1501, 1502,
1503, 1504, 1505, 1506, 1507, 1508, 1509, 1510, 1511,
1512, 1513, 1514, 1515, 1516, 1517, 1518, 1519, 1520,
1521, 1522, 1523, 1524, 1525, 1526, 1527, 1528, 1529,
1530, 1531, 1532, 1533, 1534, 1535, 1536, 1537, 1538,
1539, 1540, 1541, 1542, 1543, 1544, 1545, 1546, 1547,
1548, 1549, 1550, 1551, 1552, 1553, 1554, 1555, 1556,
1557, 1558, 1559, 1560, 1561, 1562, 1563, 1564, 1565,
1566, 1567, 1568, 1569, 1570, 1571, 1572, 1573, 1574,
1575, 1576, 1577, 1578, 1579, 1580, 1581, 1582, 1583,
1584, 1585, 1586, 1587, 1588, 1589, 1590, 1591, 1592,
1593, 1594, 1595, 1596, 1597, 1598, 1599, 1600, 1601,
1602, 1603, 1604, 1605, 1606, 1607, 1608, 1609, 1610,
1611, 1612, 1613, 1614, 1615, 1616, 1617, 1618, 1619,
1620, 1621, 1622, 1623, 1624, 1625, 1626, 1627, 1628,
1629, 1630, 1631, 1632, 1633, 1634, 1635, 1636, 1637,
1638, 1639, 1640, 1641, 1642, 1643, 1644, 1645, 1646,
1647, 1648, 1649, 1650, 1651, 1652, 1653, 1654, 1655,
1656, 1657, 1658, 1659, 1660, 1661, 1662, 1663, 1664,
1665, 1666, 1667, 1668, 1669, 1670, 1671, 1672, 1673,
1674, 1675, 1676, 1677, 1678, 1679, 1680, 1681, 1682,
1683, 1684, 1685, 1686, 1687, 1688, 1689, 1690, 1691,
1692, 1693, 1694, 1695, 1696, 1697, 1698, 1699, 1700,
1701, 1702, 1703, 1704, 1705, 1706, 1707, 1708, 1709,
1710, 1711, 1712, 1713, 1714, 1715, 1716, 1717, 1718,
1719, 1720, 1721, 1722, 1723, 1724, 1725, 1726, 1727,
1728, 1729, 1730, 1731, 1732, 1733, 1734, 1735, 1736,
1737, 1738, 1739, 1740, 1741, 1742, 1743, 1744, 1745,
1746, 1747, 1748, 1749, 1750, 1751, 1752, 1753, 1754,
1755, 1756, 1757, 1758, 1759, 1760, 1761, 1762, 1763,
1764, 1765, 1766, 1767, 1768, 1769, 1770, 1771, 1772,
1773, 1774, 1775, 1776, 1777, 1778, 1779, 1780, 1781,
1782, 1783, 1784, 1785, 1786, 1787, 1788, 1789, 1790,
1791, 1792, 1793, 1794, 1795, 1796, 1797, 1798, 1799,
1800, 1801, 1802, 1803, 1804, 1805, 1806, 1807, 1808,
1809, 1810, 1811, 1812, 1813, 1814, 1815, 1816, 1817,
1818, 1819, 1820, 1821, 1822, 1823, 1824, 1825, 1826,
1827, 1828, 1829, 1830, 1831, 1832, 1833, 1834, 1835,
1836, 1837, 1838, 1839, 1840, 1841, 1842, 1843, 1844,
1845, 1846, 1847, 1848, 1849, 1850, 1851, 1852, 1853,
1854, 1855, 1856, 1857, 1858, 1859, 1860, 1861, 1862,
1863, 1864, 1865, 1866, 1867, 1868, 1869, 1870, 1871,
1872, 1873, 1874, 1875, 1876, 1877, 1878, 1879, 1880,
1881, 1882, 1883, 1884, 1885, 1886, 1887, 1888, 1889,
1890, 1891, 1892, 1893, 1894, 1895, 1896, 1897, 1898,
1899, 1900, 1901, 1902, 1903, 1904, 1905, 1906, 1907,
1908, 1909, 1910, 1911, 1912, 1913, 1914, 1915, 1916,
1917, 1918, 1919, 1920, 1921, 1922, 1923, 1924, 1925,
1926, 1927, 1928, 1929, 1930, 1931, 1932, 1933, 1934,
1935, 1936, 1937, 1938, 1939, 1940, 1941, 1942, 1943,
1944, 1945, 1946, 1947, 1948, 1949, 1950, 1951, 1952,
1953, 1954, 1955, 1956, 1957, 1958, 1959, 1960, 1961,
1962, 1963, 1964, 1965, 1966, 1967, 1968, 1969, 1970,
1971, 1972, 1973, 1974, 1975, 1976, 1977, 1978, 1979,
1980, 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988,
1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997,
1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015,
2016, 2017, 2018, 2019, 2020, 2021, 2022, 2023, 2024,
2025, 2026, 2027, 2028, 2029, 2030, 2031, 2032, 2033,
2034, 2035, 2036, 2037, 2038, 2039, 2040, 2041, 2042,
2043, 2044, 2045, 2046, 2047, 2048, 2049, 2050, 2051,
2052, 2053, 2054, 2055, 2056, 2057, 2058, 2059, 2060,
2061, 2062, 2063, 2064, 2065, 2066, 2067, 2068, 2069,
2070, 2071, 2072, 2073, 2074, 2075, 2076, 2077, 2078,
2079, 2080, 2081, 2082, 2083, 2084, 2085, 2086, 2087,
2088, 2089, 2090, 2091, 2092, 2093, 2094, 2095, 2096,
2097, 2098, 2099, 2100, 2101, 2102, 2103, 2104, 2105,
2106, 2107, 2108, 2109, 2110, 2111, 2112, 2113, 2114,
2115, 2116, 2117, 2118, 2119, 2120, 2121, 2122, 2123,
2124, 2125, 2126, 2127, 2128, 2129, 2130, 2131, 2132,
2133, 2134, 2135, 2136, 2137, 2138, 2139, 2140, 2141,
2142, 2143, 2144, 2145, 2146, 2147, 2148, 2149, 2150,
2151, 2152, 2153, 2154, 2155, 2156, 2157, 2158, 2159,
2160, 2161, 2162, 2163, 2164, 2165, 2166, 2167, 2168,
2169, 2170, 2171, 2172, 2173, 2174, 2175, 2176, 2177,
2178, 2179, 2180, 2181, 2182, 2183, 2184, 2185, 2186,
2187, 2188, 2189, 2190, 2191, 2192, 2193, 2194, 2195,
2196, 2197, 2198, 2199, 2200, 2201, 2202, 2203, 2204,
2205, 2206, 2207, 2208, 2209, 2210, 2211, 2212, 2213,
2214, 2215, 2216, 2217, 2218, 2219, 2220, 2221, 2222,
2223, 2224, 2225, 2226, 2227, 2228, 2229, 2230, 2231,
2232, 2233, 2234, 2235, 2236, 2237, 2238, 2239, 2240,
2241, 2242, 2243, 2244, 2245, 2246, 2247, 2248, 2249,
2250, 2251, 2252, 2253, 2254, 2255, 2256, 2257, 2258,
2259, 2260, 2261, 2262, 2263, 2264, 2265, 2266, 2267,
2268, 2269, 2270, 2271, 2272, 2273, 2274, 2275, 2276,
2277, 2278, 2279, 2280, 2281, 2282, 2283, 2284, 2285,
2286, 2287, 2288, 2289, 2290, 2291, 2292, 2293, 2294,
2295, 2296, 2297, 2298, 2299, 2300, 2301, 2302, 2303,
2304, 2305, 2306, 2307, 2308, 2309, 2310, 2311, 2312,
2313, 2314, 2315, 2316, 2317, 2318, 2319, 2320, 2321,
2322, 2323, 2324, 2325, 2326, 2327, 2328, 2329, 2330,
2331, 2332, 2333, 2334, 2335, 2336, 2337, 2338, 2339,
2340, 2341, 2342, 2343, 2344, 2345, 2346, 2347, 2348,
2349, 2350, 2351, 2352, 2353, 2354, 2355, 2356, 2357,
2358, 2359, 2360, 2361, 2362, 2363, 2364, 2365, 2366,
2367, 2368, 2369, 2370, 2371, 2372, 2373, 2374, 2375,
2376, 2377, 2378, 2379, 2380, 2381, 2382, 2383, 2384,
2385, 2386, 2387, 2388, 2389, 2390, 2391, 2392, 2393,
2394, 2395, 2396, 2397, 2398, 2399, 2400, 2401, 2402,
2403, 2404, 2405, 2406, 2407, 2408, 2409, 2410, 2411,
2412, 2413, 2414, 2415, 2416, 2417, 2418, 2419, 2420,
2421, 2422, 2423, 2424, 2425, 2426, 2427, 2428, 2429,
2430, 2431, 2432, 2433, 2434, 2435, 2436, 2437, 2438,
2439, 2440, 2441, 2442, 2443, 2444, 2445, 2446, 2447,
2448, 2449, 2450, 2451, 2452, 2453, 2454, 2455, 2456,
2457, 2458, 2459, 2460, 2461, 2462, 2463, 2464, 2465,
2466, 2467, 2468, 2469, 2470, 2471, 2472, 2473, 2474,
2475, 2476, 2477, 2478, 2479, 2480, 2481, 2482, 2483,
2484, 2485, 2486, 2487, 2488, 2489, 2490, 2491, 2492,
2493, 2494, 2495, 2496, 2497, 2498, 2499, 2500, 2501,
2502, 2503, 2504, 2505, 2506, 2507, 2508, 2509, 2510,
2511, 2512, 2513, 2514, 2515, 2516, 2517, 2518, 2519,
2520, 2521, 2522, 2523, 2524, 2525, 2526, 2527, 2528,
2529, 2530, 2531, 2532, 2533, 2534, 2535, 2536, 2537,
2538, 2539, 2540, 2541, 2542, 2543, 2544, 2545, 2546,
2547, 2548, 2549, 2550, 2551, 2552, 2553, 2554, 2555,
2556, 2557, 2558, 2559, 2560, 2561, 2562, 2563, 2564,
2565, 2566, 2567, 2568, 2569, 2570, 2571, 2572, 2573,
2574, 2575, 2576, 2577, 2578, 2579, 2580, 2581, 2582,
2583, 2584, 2585, 2586, 2587, 2588, 2589, 2590, 2591,
2592, 2593, 2594, 2595, 2596, 2597, 2598, 2599, 2600,
2601, 2602, 2603, 2604, 2605, 2606, 2607, 2608, 2609,
2610, 2611, 2612, 2613, 2614, 2615, 2616, 2617, 2618,
2619, 2620, 2621, 2622, 2623, 2624, 2625, 2626, 2627,
2628, 2629, 2630, 2631, 2632, 2633, 2634, 2635, 2636,
2637, 2638, 2639, 2640, 2641, 2642, 2643, 2644, 2645,
2646, 2647, 2648, 2649, 2650, 2651, 2652, 2653, 2654,
2655, 2656, 2657, 2658, 2659, 2660, 2661, 2662, 2663,
2664, 2665, 2666, 2667, 2668, 2669, 2670, 2671, 2672,
2673, 2674, 2675, 2676, 2677, 2678, 2679, 2680, 2681,
2682, 2683, 2684, 2685, 2686, 2687, 2688, 2689, 2690,
2691, 2692, 2693, 2694, 2695, 2696, 2697, 2698, 2699,
2700, 2701, 2702, 2703, 2704, 2705, 2706, 2707, 2708,
2709, 2710, 2711, 2712, 2713, 2714, 2715, 2716, 2717,
2718, 2719, 2720, 2721, 2722, 2723, 2724, 2725, 2726,
2727, 2728, 2729, 2730, 2731, 2732, 2733, 2734, 2735,
2736, 2737, 2738, 2739, 2740, 2741, 2742, 2743, 2744,
2745, 2746, 2747, 2748, 2749, 2750, 2751, 2752, 2753,
2754, 2755, 2756, 2757, 2758, 2759, 2760, 2761, 2762,
2763, 2764, 2765, 2766, 2767, 2768, 2769, 2770, 2771,
2772, 2773, 2774, 2775, 2776, 2777, 2778, 2779, 2780,
2781, 2782, 2783, 2784, 2785, 2786, 2787, 2788, 2789,
2790, 2791, 2792, 2793, 2794, 2795, 2796, 2797, 2798,
2799, 2800, 2801, 2802, 2803, 2804, 2805, 2806, 2807,
2808, 2809, 2810, 2811, 2812, 2813, 2814, 2815, 2816,
2817, 2818, 2819, 2820, 2821, 2822, 2823, 2824, 2825,
2826, 2827, 2828, 2829, 2830, 2831, 2832, 2833, 2834,
2835, 2836, 2837, 2838, 2839, 2840, 2841, 2842, 2843,
2844, 2845, 2846, 2847, 2848, 2849, 2850, 2851, 2852,
2853, 2854, 2855, 2856, 2857, 2858, 2859, 2860, 2861,
2862, 2863, 2864, 2865, 2866, 2867, 2868, 2869, 2870,
2871, 2872, 2873, 2874, 2875, 2876, 2877, 2878, 2879,
2880, 2881, 2882, 2883, 2884, 2885, 2886, 2887, 2888,
2889, 2890, 2891, 2892, 2893, 2894, 2895, 2896, 2897,
2898, 2899, 2900, 2901, 2902, 2903, 2904, 2905, 2906,
2907, 2908, 2909, 2910, 2911, 2912, 2913, 2914, 2915,
2916, 2917, 2918, 2919, 2920, 2921, 2922, 2923, 2924,
2925, 2926, 2927, 2928, 2929, 2930, 2931, 2932, 2933,
2934, 2935, 2936, 2937, 2938, 2939, 2940, 2941, 2942,
2943, 2944, 2945, 2946, 2947, 2948, 2949, 2950, 2951,
2952, 2953, 2954, 2955, 2956, 2957, 2958, 2959, 2960,
2961, 2962, 2963, 2964, 2965, 2966, 2967, 2968, 2969,
2970, 2971, 2972, 2973, 2974, 2975, 2976, 2977, 2978,
2979, 2980, 2981, 2982, 2983, 2984, 2985, 2986, 2987,
2988, 2989, 2990, 2991, 2992, 2993, 2994, 2995, 2996,
2997, 2998, 2999, 3000, 3001, 3002, 3003, 3004, 3005,
3006, 3007, 3008, 3009, 3010, 3011, 3012, 3013, 3014,
3015, 3016, 3017, 3018, 3019, 3020, 3021, 3022, 3023,
3024, 3025, 3026, 3027, 3028, 3029, 3030, 3031, 3032,
3033, 3034, 3035, 3036, 3037, 3038, 3039, 3040, 3041,
3042, 3043, 3044, 3045, 3046, 3047, 3048, 3049, 3050,
3051, 3052, 3053, 3054, 3055, 3056, 3057, 3058, 3059,
3060, 3061, 3062, 3063, 3064, 3065, 3066, 3067, 3068,
3069, 3070, 3071, 3072, 3073, 3074, 3075, 3076, 3077,
3078, 3079, 3080, 3081, 3082, 3083, 3084, 3085, 3086,
3087, 3088, 3089, 3090, 3091, 3092, 3093, 3094, 3095,
3096, 3097, 3098, 3099, 3100, 3101, 3102, 3103, 3104,
3105, 3106, 3107, 3108, 3109, 3110, 3111, 3112, 3113,
3114, 3115, 3116, 3117, 3118, 3119, 3120, 3121, 3122,
3123, 3124, 3125, 3126, 3127, 3128, 3129, 3130, 3131,
3132, 3133, 3134, 3135, 3136, 3137, 3138, 3139, 3140,
3141, 3142, 3143, 3144, 3145, 3146, 3147, 3148, 3149,
3150, 3151, 3152, 3153, 3154, 3155, 3156, 3157, 3158,
3159, 3160, 3161, 3162, 3163, 3164, 3165, 3166, 3167,
3168, 3169, 3170, 3171, 3172, 3173, 3174, 3175, 3176,
3177, 3178, 3179, 3180, 3181, 3182, 3183, 3184, 3185,
3186, 3187, 3188, 3189, 3190, 3191, 3192, 3193, 3194,
3195, 3196, 3197, 3198, 3199, 3200, 3201, 3202, 3203,
3204, 3205, 3206, 3207, 3208, 3209, 3210, 3211, 3212,
3213, 3214, 3215, 3216, 3217, 3218, 3219, 3220, 3221,
3222, 3223, 3224, 3225, 3226, 3227, 3228, 3229, 3230,
3231, 3232, 3233, 3234, 3235, 3236, 3237, 3238, 3239,
3240, 3241, 3242, 3243, 3244, 3245, 3246, 3247, 3248,
3249, 3250, 3251, 3252, 3253, 3254, 3255, 3256, 3257,
3258, 3259, 3260, 3261, 3262, 3263, 3264, 3265, 3266,
3267, 3268, 3269, 3270, 3271, 3272, 3273, 3274, 3275,
3276, 3277, 3278, 3279, 3280, 3281, 3282, 3283, 3284,
3285, 3286, 3287, 3288, 3289, 3290, 3291, 3292, 3293,
3294, 3295, 3296, 3297, 3298, 3299, 3300, 3301, 3302,
3303, 3304, 3305, 3306, 3307, 3308, 3309, 3310, 3311,
3312, 3313, 3314, 3315, 3316, 3317, 3318, 3319, 3320,
3321, 3322, 3323, 3324, 3325, 3326, 3327, 3328, 3329,
3330, 3331, 3332, 3333, 3334, 3335, 3336, 3337, 3338,
3339, 3340, 3341, 3342, 3343, 3344, 3345, 3346, 3347,
3348, 3349, 3350, 3351, 3352, 3353, 3354, 3355, 3356,
3357, 3358, 3359, 3360, 3361, 3362, 3363, 3364, 3365,
3366, 3367, 3368, 3369, 3370, 3371, 3372, 3373, 3374,
3375, 3376, 3377, 3378, 3379, 3380, 3381, 3382, 3383,
3384, 3385, 3386, 3387, 3388, 3389, 3390, 3391, 3392,
3393, 3394, 3395, 3396, 3397, 3398, 3399, 3400, 3401,
3402, 3403, 3404, 3405, 3406, 3407, 3408, 3409, 3410,
3411, 3412, 3413, 3414, 3415, 3416, 3417, 3418, 3419,
3420, 3421, 3422, 3423, 3424, 3425, 3426, 3427, 3428,
3429, 3430, 3431, 3432, 3433, 3434, 3435, 3436, 3437,
3438, 3439, 3440, 3441, 3442, 3443, 3444, 3445, 3446,
3447, 3448, 3449, 3450, 3451, 3452, 3453, 3454, 3455,
3456, 3457, 3458, 3459, 3460, 3461, 3462, 3463, 3464,
3465, 3466, 3467, 3468, 3469, 3470, 3471, 3472, 3473,
3474, 3475, 3476, 3477, 3478, 3479, 3480, 3481, 3482,
3483, 3484, 3485, 3486, 3487, 3488, 3489, 3490, 3491,
3492, 3493, 3494, 3495, 3496, 3497, 3498, 3499, 3500,
3501, 3502, 3503, 3504, 3505, 3506, 3507, 3508, 3509,
3510, 3511, 3512, 3513, 3514, 3515, 3516, 3517, 3518,
3519, 3520, 3521, 3522, 3523, 3524, 3525, 3526, 3527,
3528, 3529, 3530, 3531, 3532, 3533, 3534, 3535, 3536,
3537, 3538, 3539, 3540, 3541, 3542, 3543, 3544, 3545,
3546, 3547, 3548, 3549, 3550, 3551, 3552, 3553, 3554,
3555, 3556, 3557, 3558, 3559, 3560, 3561, 3562, 3563,
3564, 3565, 3566, 3567, 3568, 3569, 3570, 3571, 3572,
3573, 3574, 3575, 3576, 3577, 3578, 3579, 3580, 3581,
3582, 3583, 3584, 3585, 3586, 3587, 3588, 3589, 3590,
3591, 3592, 3593, 3594, 3595, 3596, 3597, 3598, 3599,
3600, 3601, 3602, 3603, 3604, 3605, 3606, 3607, 3608,
3609, 3610, 3611, 3612, 3613, 3614, 3615, 3616, 3617,
3618, 3619, 3620, 3621, 3622, 3623, 3624, 3625, 3626,
3627, 3628, 3629, 3630, 3631, 3632, 3633, 3634, 3635,
3636, 3637, 3638, 3639, 3640, 3641, 3642, 3643, 3644,
3645, 3646, 3647, 3648, 3649, 3650, 3651, 3652, 3653,
3654, 3655, 3656, 3657, 3658, 3659, 3660, 3661, 3662,
3663, 3664, 3665, 3666, 3667, 3668, 3669, 3670, 3671,
3672, 3673, 3674, 3675, 3676, 3677, 3678, 3679, 3680,
3681, 3682, 3683, 3684, 3685, 3686, 3687, 3688, 3689,
3690, 3691, 3692, 3693, 3694, 3695, 3696, 3697, 3698,
3699, 3700, 3701, 3702, 3703, 3704, 3705, 3706, 3707,
3708, 3709, 3710, 3711, 3712, 3713, 3714, 3715, 3716,
3717, 3718, 3719, 3720, 3721, 3722, 3723, 3724, 3725,
3726, 3727, 3728, 3729, 3730, 3731, 3732, 3733, 3734,
3735, 3736, 3737, 3738, 3739, 3740, 3741, 3742, 3743,
3744, 3745, 3746, 3747, 3748, 3749, 3750, 3751, 3752,
3753, 3754, 3755, 3756, 3757, 3758, 3759, 3760, 3761,
3762, 3763, 3764, 3765, 3766, 3767, 3768, 3769, 3770,
3771, 3772, 3773, 3774, 3775, 3776, 3777, 3778, 3779,
3780, 3781, 3782, 3783, 3784, 3785, 3786, 3787, 3788,
3789, 3790, 3791, 3792, 3793, 3794, 3795, 3796, 3797,
3798, 3799, 3800, 3801, 3802, 3803, 3804, 3805, 3806,
3807, 3808, 3809, 3810, 3811, 3812, 3813, 3814, 3815,
3816, 3817, 3818, 3819, 3820, 3821, 3822, 3823, 3824,
3825, 3826, 3827, 3828, 3829, 3830, 3831, 3832, 3833,
3834, 3835, 3836, 3837, 3838, 3839, 3840, 3841, 3842,
3843, 3844, 3845, 3846, 3847, 3848, 3849, 3850, 3851,
3852, 3853, 3854, 3855, 3856, 3857, 3858, 3859, 3860,
3861, 3862, 3863, 3864, 3865, 3866, 3867, 3868, 3869,
3870, 3871, 3872, 3873, 3874, 3875, 3876, 3877, 3878,
3879, 3880, 3881, 3882, 3883, 3884, 3885, 3886, 3887,
3888, 3889, 3890, 3891, 3892, 3893, 3894, 3895, 3896,
3897, 3898, 3899, 3900, 3901, 3902, 3903, 3904, 3905,
3906, 3907, 3908, 3909, 3910, 3911, 3912, 3913, 3914,
3915, 3916, 3917, 3918, 3919, 3920, 3921, 3922, 3923,
3924, 3925, 3926, 3927, 3928, 3929, 3930, 3931, 3932,
3933, 3934, 3935, 3936, 3937, 3938, 3939, 3940, 3941,
3942, 3943, 3944, 3945, 3946, 3947, 3948, 3949, 3950,
3951, 3952, 3953, 3954, 3955, 3956, 3957, 3958, 3959,
3960, 3961, 3962, 3963, 3964, 3965, 3966, 3967, 3968,
3969, 3970, 3971, 3972, 3973, 3974, 3975, 3976, 3977,
3978, 3979, 3980, 3981, 3982, 3983, 3984, 3985, 3986,
3987, 3988, 3989, 3990, 3991, 3992, 3993, 3994, 3995,
3996, 3997, 3998, 3999, 4000, 0
LIST
OWNINTEGERARRAY NAME(0:4)= C
664, 0( 4)
OWNINTEGER ASL= 662
OWNINTEGER NNAMES= 511
OWNINTEGER MINFREE= 3817
OWNINTEGER FREE= 3817
INTEGERARRAY A(1:300); ! ANALYSIS RECORD
!%EXTERNALINTEGERARRAY T(1:300); ! SOURCE TEXT
INTEGER LTSIZE,HV,SWTSIZE
LTSIZE=6000; HV=NNAMES-8
SWTSIZE=300
!%EXTERNALINTEGERARRAY BAT(0:6000)
INTEGERARRAY COT(-1:LTSIZE)
HALFINTEGERARRAYNAME SCONST
HALFINTEGERARRAYFORMAT SFORM(0:LTSIZE+1)
SCONST==ARRAY(ADDR(COT(-1)),SFORM)
INTEGERARRAY SWT(-SWTSIZE:-1)
INTEGER SWTN
INTEGERARRAY JUMP,STAR,BRT,CYC,RTP,SBR,SAVETWSP,RECELTS(0:5)
OWNINTEGERARRAY TRUE(1:8)=121,120,124,123,122,125,120,121
OWNINTEGERARRAY FALSE(1:8)=120,121,125,122,123,124,121,120
OWNINTEGERARRAY PREC(1:40)=3,3,2,2,1,1,3,2,2,1,
1,1,4,0(6),0,
0(10),
0(3),0(2),0(5)
! AN ELT. 34 BELOW CANNOT BE USED - TAKEN FOR NULL UNARY OP.
! %OWNINTEGERARRAY OPR(0:37)=
! 0/ 112,6,7,5,3,
! 5/ 8,127,2,14,4,
! 10/ 159,160,165,128,9,
! 15/ 13,10,11,12,164,
! 20/ 156,157,158,0,0,
! 25/ 0,0,0,0,0,
! 30/ 130,161,162,163,0,
! 35/ 111,0,112
OWNINTEGERARRAY OPR(0:37)= C
112,6,7,5,3,
8,127,2,14,4,
159,160,165,128,9,
13,10,11,12,164,
156,157,158,0,0,
0,0,0,0,0,
130,161,162,163,0,
111,0,112
! ABOVE 2:EXPI 3:AND 4:MULT 5:DIV 6:SHL 7:SHR 8:LXOR
! 9: EXPF 10:ADDF 11:SUBF 12:NEGF 13:MULF
! 14:DIVF 15:SPARE
!
! 112=LOAD 127=LOR=BIS 159=ADD 160=SUB 165=NEG 128=NOT=COM
! 164=CMP 130=STR 161=INC 162=DEC 163=CLR
!
! %OWNINTEGERARRAY UCN(1:37)=
! 1 /3,3,3,2,2,2,3,3,2,2,
! 11/ 3,1,1,3,2,2,3,1,3,3,
! 21/ 3,3,0,0,0,
! 26/ 0,0,0,0,3,
! 31/ 1,1,1,0,1,0,2
OWNINTEGERARRAY UCN(1:37)= C
3,3,3,2,2,2,3,3,2,2,
3,1,1,3,2,2,3,1,3,3,
3,3,0,0,0,
0,0,0,0,3,
1,1,1,0,1,0,2
INTEGER DIAGS,RDIAG,NORELT1,NORELT2
INTEGER I,CONSTPTR,MARK,MARK2,CHECKS
OWNINTEGER SPECS=0
INTEGER PLAB
HALFINTEGER FLIT,FLOT
CONSTPTR=0; CHECKS=5
PLAB=0
DIAGS=0
RDIAG=0
! SETS(0); !SET UP SPECS IP STREAM
SETS(1); SPECS=1
SETS(3); !SET UP LISTING OUTPUT STREAM
PRINTSTRING( ";ERCC IMP-11 COMPILER ".RV."
")
SETS(2); !SET UP OBJ STREAM
PRINTSTRING C
("
ACC=%0
R0=%0
R1=%1
R2=%2
R3=%3
R4=%4
R5=%5
SP=%6
PC=%7
") UNLESS TARGET&8192#0
CA=0; !CURRENT CODE-DUMPING ADDRESS
BTN=0; ! BRANCH TABLE POINTER
SWTN=0; !SWITCH TABLE POINTER
LINE=0
! CONSTANT TABLE POINTER, HOLE 0 IS FOR LINE NO.
! HOLES 1 AND 2 ARE FOR FLOATING ZERO.
COT(0)=-1; COT(1)=0; COT(2)=0
CTN=3; ! NEXT FREE HOLE
FAULTS=0; ! FAULT COUNT
TWSP=PDISP; ! (>5 FOR FLG PT CODING..) (BYTES)
RAD=0; ! NEXT RELATIVE ADDRESS TO BE AL
LEVEL=0; ! TEXTUAL LEVEL
SCF=0; ! CONDITION FLAG
JUMP(0)=0; ! JUMP LIST POINTER
STAR(0)=0; ! STORAGE ALLOCATION POSITION IN
NAME(0)=0; ! NAME LIST POINTER
RTP(0)=-1; ! TYPE = %BEGIN-%END BLOCK
RECELTS(0)=0
L2: READ STATEMENT
TP=1; ! SOURCE TEXT POINTER
L14: PSP=-1000; ! START OF <SS> IN PHRASE TABLE
AP=1; ! ANALYSIS RECORD POINTER
IF COMPARE=1 THEN ->L1; ! STATEMENT RECOGNISED
FAULT(100); ! SYNTAX ERROR
PRINT SYMBOL(';')
L5: PRINT SYMBOL(T(TP)); !CHAR OF OFFENDING LINE
IF T(TP)=10 THEN ->L2; ! NELINE
TP=TP+1
IF T(TP)#';' THEN ->L5; ! CONTINUE PRINTING
TP=TP+1
->L14
L1: PRINT AR(AP); ! PRINT ANALYSIS RECORD
AP=1; ! ANALYSIS RECORD POINTER
STMTS=STMTS+1
COMP=0
NORELT1=0
NORELT2=0
SS; ! COMPILE SOURCE STATEMENT
IF T(TP)=10 OR T(TP+1)=10 THEN ->L2
TP=TP+1
! SKIP TERMINATING SEMICOLON, PROCEED TO NEXT STMT.
->L14
ROUTINE READ SYM(INTEGERNAME I)
READ SYMBOL(I)
PRINT SYMBOL(I) UNLESS SPECS=0
END; ! READ SYM
!
!
!%CONTROL0
ROUTINE FLT11(INTEGER I)
! PARAM IS A SYSTEM 4 INTEGER (32-BIT)
! RESULT IS A PDP-11 REAL (32-BIT) AS 32-BIT (SYSTEM 4) INTEGER.
!
! THIS FUNCTION OBVIOUSLY IS TO RUN ONLY ON SYSTEM 4.
!
HALFINTEGER SIGN,EXP,FRAC1,FRAC2
IF I=0 THENSTART
FLIT=0;FLOT=0;RETURN;FINISH
FRAC1=0; FRAC2=0; EXP=129; SIGN=0
IF I<0 THENSTART; I=-I; SIGN<-X'8000'; FINISH
LOOP:
IF I&(-2)=0 THEN -> L5
FRAC2<-((FRAC2&X'FFFF')>>1)!((FRAC1&1)<<15)
FRAC1<-FRAC1>>1
EXP=EXP+1
IF I&1#0 THEN FRAC1<-FRAC1 ! X'0040'
I=I>>1
-> LOOP
L5:
-> SIZE FAIL UNLESS EXP<=511
FLIT<-SIGN!(EXP<<7)!FRAC1
FLOT<-FRAC2
RETURN
SIZE FAIL:
SETS(2)
PRINTSTRING("SIZE FAIL, FN FLT11
")
STOP
END; ! FLT11
!%CONTROL X'F1111111'
!
!
ROUTINE WRIT(INTEGER J); ! NO LEADING SPACES
INTEGER I,K,L,M
M=0
IF J>=0 THEN ->L1
PRINTSYMBOL('-')
J=-J
L1: I=1000000000
K=1
L2: L=J//I
M=M+L; !M NON ZERO IF ZEROS SIGNIFICANT
IF M#0 OR K=10 THEN PRINT SYMBOL(L+'0')
! PRINT ALL SIGNIFICANT
J=J-I*L
I=I//10
K=K+1
IF K<=10 THEN ->L2
END; ! WRIT
ROUTINE HEX4(INTEGER I)
INTEGER J,CH
CYCLE J=12,-4,0
CH=(I>>J)&15 + '0'
CH=CH+7 IF CH>'9'
PRINTSYMBOL(CH)
REPEAT
END; ! HEX4
ROUTINE OCT5(INTEGER I)
INTEGER L
L=12
L1:
PRINTSYMBOL((I>>L)&7+'0')
L=L-3
->L1 UNLESS L<0
END; ! OCT5
ROUTINE OCTS(INTEGER I)
!OUTPUTS 16 BITS IN 6 OCTAL DIGITS.
IF I&X'8000'#0 THENSTART;I=I&X'7FFF';
PRINTSYMBOL('1'); FINISHELSE PRINTSYMBOL('0')
OCT5(I)
END; !OCTS
ROUTINE OCT(INTEGER I)
HALFINTEGER(ADDR(BIN(CA)))<-I;CA=CA+2;RETURN
END; !OCT
ROUTINE OCTN(INTEGER I,J)
IF TARGET&8192=0 START
SPACE; OCTS(I); CA=CA+2; NEWLINE IF J=0
FINISHELSE OCT(I)
END; !OCTN
ROUTINE OCODE(INTEGER LEV,OFF); ! OFFSET IS SUPPLIED IN BYTES
OCTN((LEV<<13)!OFF>>1,0); ! DUMPED AS WORD DISPL
END; ! OCODE
ROUTINE READ STATEMENT
ROUTINESPEC STORE(INTEGER I)
INTEGER SH,I
SETS(3); !SET UP LISTING OUTPUT STREAM
SH=0; ! SHIFT VALUE
TP=1; ! SOURCE TEXT POINTER
LINE=LINE+1
IF SPECS#0 THENSTART
PRINTSYMBOL(';')
OCTS(CA-LASTCAREL+LASTRELADDR)
WRITE(LINE,5)
SPACES(5+3*LEVEL); ! INDENT LISTINGS
FINISH
L1: I=NEXT SYMBOL; ! SKIP BLANK LINES
IF I#10 THEN ->L3
SKIP SYMBOL
->L1
L3: READ SYM(I)
IF I='''' THEN ->L4; ! LITERAL TEXT START
L8: IF I#'%' THEN ->L5
SH=128; ! SHIFT VALUE FOR KEYWORD
->L3
L5: IF I<'A' OR I>'Z' THEN SH=0; ! END OF KEYWORD
IF I=' ' THEN ->L3; ! IGNORE SPACES
T(TP)=I+SH; TP=TP+1
IF I#10 THEN ->L3; ! NOT END OF LINE YET
IF TP>=300 THEN ->L10
IF T(TP-2)#'C'+128 THENRETURN
!HERE %C NL HAS JUST BEEN READ
->L9 IF SPECS=0
PRINT SYMBOL(';')
SPACES(17+3*LEVEL)
L9:
TP=TP-2
->L1
L10: STORE(I); STOP
L4: SH=0
STORE('''')
L7: READ SYM(I)
IF I=10 THEN PRINT SYMBOL(';')
!TO BE COMMENT IN O/P
STORE(I)
IF I#'''' THEN ->L7; ! MORE LITERAL TEXT YET
READ SYM(I)
IF I#'''' THEN ->L8; ! END OF TEXT
->L4; ! TWO QUOTES STAND FOR ONE
ROUTINE STORE(INTEGER I)
IF TP<=300 THEN ->L1
FAULT(101); ! STATEMENT TOO LONG
TP=1; ! IGNORE FIRST 300 CHARS
L1: T(TP)=I+SH; ! STORE SHIFTED CHAR
TP=TP+1
END; ! STORE
END
INTEGERFN COMPARE
! ANALYSE PHRASE
INTEGERFNSPEC NAME
INTEGERFNSPEC CONSTLIST
INTEGERFNSPEC CONST
INTEGERFNSPEC PTEXT
INTEGER APP,TPP,PSPP,AE,N
SWITCH BIP(1:7)
TPP=TP; ! PRESERVE INITIAL TEXT POINTER
! FOR BACKTRACKING
APP=AP; ! PRESERVE INITIAL ANALYSIS RECO
! POINTER FOR BACKTRACKING
A(AP)=1; ! ALTERNATIVE 1 FIRST
L11: AE=PS(PSP); ! POINTER TO END OF ALTERNATIVE
PSP=PSP+1; ! FIRST ITEM OF ALTERNATIVE DEFN
L12: IF PSP=AE THENRESULT =1; ! END OF ALT REACHED - SUCCESS
N=PS(PSP); ! NEXT ITEM OF ALT DEFN
PSP=PSP+1; ! FOR FOLLOWING ITEM
IF N<0 THEN ->L13; ! SUB-PHRASE TO BE COMPARED
IF N<=7 THEN ->BIP(N)
IF N#T(TP) THEN ->L14; ! TEXT CHAR DOES NOT MATCH SOURC
TP=TP+1; ! NEXT SOURCE TEXT POSITION
->L12; ! GO FOR NEXT ITEM OF DEFN
L13: PSPP=PSP; ! PRESERVE PRESENT 'PS' POSITION
PSP=N; ! 'PS' POSITION OF SUB-PHRASE
AP=AP+1; ! ANALYSIS REC POSITION FOR SUB-
N=COMPARE; ! ANALYSE SUB-PHRASE
PSP=PSPP; ! RESTORE 'PS' POSITION FOR OLD
IF N=1 THEN ->L12; ! SUCCESS - GO FOR NEXT ITEM OF
L14: TP=TPP; ! BACKTRACK SOURCE TEXT
AP=APP; ! AND ANALYSIS RECORD POINTERS
IF PS(AE)=0 THENRESULT =0; ! END OF PHRASE
PSP=AE; ! START OF DEFN OF NEXT ALTERNAT
A(AP)=A(AP)+1; ! COUNT ALTERNATIVE NUMBER ON ON
->L11; ! GO TO ANALYSE NEW ALTERNATIVE
BIP(1):IF NAME=1 THEN ->L12; ! NAME FOUND
->L14; ! NAME NOT FOUND - TRY NEXT ALT
BIP(2):IF CONST=1 THEN ->L12; ! CONST FOUND
->L14; ! CONST NOT FOUND - TRY NEXT ALT
BIP(3):IF T(TP)=10 THEN ->L12; ! NEWLINE FOUND
IF T(TP)=M';' THEN ->L12; ! SEMI COLON
->L14
BIP(4):IF PTEXT=1 THEN ->L12; ! TEXT FOUND
->L14
BIP(5):MARK=AP+1; ->L12; ! THIS PHRASE ALWAYS SUCCEEDS
BIP(6):IF CONSTLIST=1 THEN ->L12; ->L14; ! (NULL CONSTLIST) NOT
! ALLOWED
BIP(7):MARK2=AP+1; ->L12
INTEGERFN NAME
! RECOGNISE AND INSERT NAME IN HASHING AREA OF TAG/LINK ARRAYS
INTEGER I,J,K,L,M,N
INTEGER OE; OE=0; !ODD/EVEN
INTEGER INC
INC=0
I=T(TP); ! FIRST CHAR
IF I<'A' OR I>'Z' OR T(TP+1)='''' THENRESULT =0
! (NOT LETTER) OR M'...' CONSTAN
L=0; ! POINTER TO LIST OF NAME CHARS
J=I<<8; ! PACK FIRST CHAR
K=0; ! SHIFT FOR PACKING NEXT CHAR
L1: TP=TP+1
I=T(TP); ! NEXT CHAR
IF I<'0' OR (I>'9' AND I<'A') OR I>'Z' THEN ->L2; ! NOT
! LETTER
INC=I
J=J!I<<K ; ! PACK CHARACTER
K=K-8; ! NEXT SHIFT
IF K>=0 THEN ->L1; ! WORD NOT FULL YET
IF OE=0 THEN N=NEWCELL
IF OE=0 THEN TAG(N)=J ELSE TAG1(N)=J; ! STORE WORD IN NEW CELL
OE=1-OE
J=0; ! CLEAR WORD FOR PACKING
K=8; ! FIRST SHIFT FOR NEW WORD
-> L1 IF OE=0
! LINK IN NEW CELL IF ONE JUST TAKEN
IF L=0 THEN ->L3; ! NOTHING IN LIST YET
LINK(M)=N; ! LINK IN PREVIOUS LAST TO PT TO NEW CELL
M=N; ! RESET LAST CELL POINTER
->L1
L3: L=N; ! L TO PT TO 1ST CELL OF NAME
M=N; ! M TO PT TO LAST CELL OF NAME
->L1
!
! END OF NAME REACHED - PUT AWAY LAST CHARS & TIDY LIST.
L2: IF J=0 AND OE=0 THEN ->L4; ! NOTHING IN THIS WORD
IF J=0 AND OE#0 THEN -> L25
IF OE=0 THEN N=NEWCELL; ! NEW CELL FOR LAST WORD
IF OE=0 THEN TAG(N)=J ELSE TAG1(N)=J
L25:
IF L=0 THEN ->L5; ! NOTHING IN LIST YET
-> L4 IF OE#0
LINK(M)=N; ! LINK AFTER LAST CELL
->L4
L5: L=N; ! L TO TP TO 1ST CELL OF NAME
!
! ALL CHARS NOW STORED AWAY. NOW SEE IF NAME IS
! ALREADY IN LIST.
L4: I=INC!TAG(L) ; ! FIRST 4 LETTERS& LAST
! LETTER
! LAST 4 LETTERS
IF OE=0 THEN J=TAG(N) ELSE J=TAG1(N)
I=I-I//HV*HV; !HASH FOR STARTING POSN
INC=((J-J//29*29)+1)!1 ; !ODD INCREMENT
J=I; ! SET INDEX FOR SEARCHING
L11: IF TAG(J)=0 THEN ->L6; ! VACANT HOLE (I.E. NAME NOT IN
! IE. THIS SEARCH START PT NOT OCCUPIED, SO NAME NOT
! IN ALREADY.
K=TAG(J); ! POINTER TO NAME LIST (EXISTING
M=L; ! POINTER TO NAME LIST (NEW)
L9: IF TAG(K)#TAG(M) OR C
TAG1(K)#TAG1(M) THEN ->L7; ! COMPARE WORDS OF CHARS
K=LINK(K); ! NEXT CELL (EXISTING)
M=LINK(M); ! NEXT CELL (NEW)
IF K=0 THEN ->L8; ! END OF LIST (EXISTING)
IF M=0 THEN ->L7; ! END OF LIST (NEW) - FAILURE
->L9
L8: IF M=0 THEN ->L10; ! END OF LIST (NEW) - SUCCESS
!
! TRY NEXT HASH AREA ENTRY
L7: J=(J+INC)&NNAMES; !INCREMENT CYCLICALLY
IF J#I THEN ->L11; ! NOT YET DONE FULL CYCLE
FAULT(103); ! DICTIONARY FULL
L10: L=RETURN CELL(L); ! NAME ALREADY IN SO RETURN
IF L#0 THEN ->L10; ! NEW NAME LIST TO ASL
->L12
!
! NAME WAS NOT IN PREVIOUSLY. SET TAG ENTRY TO POINT TO LIST OF
! IDENTIFIER CHARACTERS.
L6: TAG(J)=L; ! FILL IN NEW NAME LIST POINTER
LINK(J)=0
L12: AP=AP+1; ! INCREMENT ANALYSIS RECORD POSI
A(AP)=J; ! STORE INDEX OF NAME IN HASHING
RESULT =1; ! SUCCESS
END; ! NAME
INTEGERFN CONST
ROUTINE CREADF(INTEGERNAME X,Y,INTEGERARRAYNAME T, C
INTEGERNAME TP,F)
INTEGER FLAG,CURSYM; ! FLAG= 0FOR'-',1 FOR '+'
INTEGER IVALUE,FF
INTEGER A,SIGN,EXP11,FRAC
LONGREAL RWORK,SCALE
INTEGER TTP
ROUTINE SKIP SYMBOL
TP=TP+1
END
INTEGERFN NEXT SYMBOL
RESULT=T(TP)
END
F=3; !SET SUCCESS FIRST
TTP=TP
FLAG=1
-> TEST SIGN
IGNORE LEADING SPACES:
SKIP SYMBOL
TEST SIGN:CURSYM=NEXT SYMBOL; ! CARE NOT TO READ TERMINATOR
-> IGNORE LEADING SPACES IF CURSYM=' '
-> PASS SIGN IF CURSYM='+'
-> DIGIT UNLESS CURSYM='-'
FLAG=0; ! RECORD INITIAL MINUS
PASS SIGN: SKIP SYMBOL; ! MOVE OVER SIGN ONCE IT HAS
CURSYM=NEXT SYMBOL; ! BEEN RECORDED IN FLAG
DIGIT: -> DIGIT NOT FIRST UNLESS '0'<=CURSYM AND CURSYM<='9'
RWORK=CURSYM-'0'; ! KEEP TOTAL IN RWORK
LOOP: SKIP SYMBOL
CURSYM=NEXT SYMBOL
-> NOT DIG UNLESS '0'<=CURSYM AND CURSYM<='9'
RWORK=10*RWORK+(CURSYM-'0'); ! CONTINUE EVALUATING
-> LOOP
NOT DIG:
-> FAIL NOT REAL UNLESS CURSYM='.'
SCALE=10
FPART: SKIP SYMBOL
CURSYM=NEXT SYMBOL
-> TRY AT UNLESS '0'<=CURSYM AND CURSYM<='9'
RWORK=RWORK+(CURSYM-'0')/SCALE
SCALE=10*SCALE;
-> FPART
TRY AT:
! THE VALUE HAS NOW BEEN READ INTO RWORK. THERE MIGHT BE AN EXPONENT
! E.G. '1.7@ 10' IS VALID DATA FOR READ
-> FIX UNLESS CURSYM='@'
-> SCALE FAIL ; ! SCALE FACTORS '@' NOT YET IMPLEMENTED
SKIP SYMBOL; ! MOVE PAST THE '@'
IF IVALUE<=-99 THEN RWORK=0 ELSE RWORK=RWORK*10**IVALUE
FIX:
! PICK OUT FLOATING ZERO
IF RWORK=0 THENSTART; X=0; RETURN; FINISH
IF FLAG=0 THEN RWORK=-RWORK
A=ADDR(RWORK)
!
!
!*******************************************************
PRINTSTRING("REALS NOT IMPLEMENTED ON 2900.....
")
-> FAIL
!THIS CODE IS ONLY TO BE RUN ON THE SYSTEM 4.
!
!
SIGN=INTEGER(A)&X'80000000'
EXP11=((BYTEINTEGER(A)&127)-64)<<2 + 128
FRAC=INTEGER(A) & X'00FFFFFF'
IF INTEGER(A+4)<0 AND FRAC#X'FFFFFF' THEN FRAC=FRAC+1
-> L5 IF FRAC=0
CYCLE FF=1,1,24
IF FRAC&X'00800000'#0 THEN -> L5
FRAC=FRAC<<1
EXP11=EXP11-1
REPEAT
L5:
-> SIZE FAIL UNLESS 0<= EXP11 <= 511
INTEGER(A)=SIGN!(EXP11<<23)!(FRAC&X'007FFFFF')
!
!
!******************************************************
!
!
! X=SHORTINTEGER(A)
! Y=SHORTINTEGER(A+2)
RETURN
DIGIT NOT FIRST:
! CAN HAVE .73 AS VALID IMP NO
-> FAIL NOT REAL UNLESS CURSYM='.'
SKIP SYMBOL
CURSYM=NEXT SYMBOL
-> FAIL NOT REAL UNLESS '0'<=CURSYM AND CURSYM<='9'
RWORK=(CURSYM-'0')/10
SCALE=100;
-> FPART
SIZE FAIL:
SELECT OUTPUT(99)
PRINTSTRING(" CPLR READ: EXPNT FAIL
")
-> FAIL
SCALE FAIL:
SELECT OUTPUT(99)
PRINTSTRING(" ""@"" NOT YET IMPLEMENTED
")
FAIL:
FAIL NOT REAL:
X=0
F=0
TP=TTP
END
! RECOGNISE INTEGER AND LITERAL TEXT CONSTANTS
INTEGER I,J,K,L,F,G; F=2; !TO INDICATE INTEGER TYPE
L=0
I=T(TP); ! FIRST CHAR
G=0
IF I='''' THEN ->L1; ! START OF LITERAL TEXT
G=1
IF I='M' THEN ->L7; ! COULD BE M'...' CONSTANT
IF I='X' AND T(TP+1)='''' THEN ->L10; ! COULD BE HEX CONST
IF I='O' START
TP=TP+1
IF T(TP)#'''' THEN RESULT=0
J=0
OLO:
TP=TP+1
I=T(TP)
IF I='''' THEN -> EXINC
UNLESS '0'<=I AND I<='7' AND J&X'E000'=0 THEN RESULT=0
J=(J<<3) ! (I-'0')
-> OLO
FINISH
G=1
!
! TRY FOR A REAL CONST
CREADF(J,L,T,TP,F)
IF F=3 THEN -> L2; ! JUMP IF REAL CONST
F=2; ! INDICATE INTEGER TYPE
!
! DEC INTEGER
IF I<'0' OR I>'9' THENRESULT =0; ! NOT A DIGIT
J=I-'0'; ! FIRST DIGIT VALUE
L3: TP=TP+1
I=T(TP); ! NEXT CHAR
IF I<'0' OR I>'9' THEN ->L2; ! NOT A DIGIT - END OF INTEGER
J=10*J+I-'0'; ! ACCUMMULATE INTEGER VALUE
->L3
!
! HEX CONST
L10: TP=TP+1; J=0; K=0; ! HEX CONSTS
L11: TP=TP+1; I=T(TP)
IF I>='0' AND I<='9' THEN ->L12
IF I<'A' OR I>'F' THEN ->L14
I=I-55;
->L13
L12: I=I-'0'
L13: J=J<<4!I; K=K+1; ->L11
L14: IF I#'''' OR K>4 THENRESULT =0
EXINC:
TP=TP+1
-> L2
!
! M-CONST
L7: IF T(TP+1)#'''' THENRESULT =0; ! NOT M'..' CONSTANT -
! FAILU
TP=TP+1
L1: J=0; ! CLEAR PACKING WORD
K=0; ! NUMBER OF CHARS SO FAR
IF A(1)=12 AND A(2)=6 THENSTART
G=0
A(AP+2)=CTN ;! STARTING POSITION IN CT.
I=PTEXT
AP=AP+1
RESULT=I
FINISH
L6: TP=TP+1
I=T(TP); ! NEXT CHARACTER
IF I#'''' THEN ->L4; ! NOT QUOTE
TP=TP+1
I=T(TP); ! NEXT CHARACTER
IF I#'''' THEN ->L5; ! END OF TEXT - ELSE IGNORE SECO
L4: J=J<<8!I ; ! PACK CHARACTER
K=K+1; ! CHARACTER COUNT
IF K=2 AND G=0 THENSTART
TP=TP-2
RESULT=PTEXT
FINISH
->L6
L5: IF K>2 THENRESULT =0; ! CHAR STRING TOO LONG
!
! EXIT
L2: AP=AP+1
A(AP)=F;! 2 : INTEGER TYPE 3: REAL
AP=AP+1
A(AP)=J; ! CONSTANT VALUE
AP=AP+1
A(AP)=L; ! FOR REAL
RESULT =1; ! SUCCESS
END; ! CONST
INTEGERFN PTEXT
INTEGER I,J,K,M,CH
IF T(TP)#'''' THENRESULT =0
TP=TP+1
M=CTN
IF A(1)=12 AND A(2)=6 THENSTART
IF PTEXTSHL=0 THEN J=8 ELSESTART
CTN=CTN+1
COT(CTN)=0
J=0
FINISH
IF TP>2 AND T(TP-2)#'=' THEN K=COT(CTN) ELSESTART
COT(CTN)=0
K=0
FINISH
FINISHELSESTART
J=8
K=0
COT(M)=0; ! IN CASE NULL TEXT SUPPLIED
FINISH
CH=0
L1: I=T(TP)
TP=TP+1
IF I='''' THEN ->L5
L2: K=K!I<<J
J=J+8
CH=CH+1
IF J<=8 THEN ->L1
COT(CTN)<-K; ! 2 CHARS TO CONST TABLE
K=0
CTN=CTN+1
J=0
->L1
L5: IF T(TP)#'''' THEN ->L6
TP=TP+1; ! TWO QUOTES = ONE QUOTE
->L2
L6: IF K=0 THEN ->L7
COT(CTN)<-K; ! LAST FEW CHARS
CTN=CTN+1
L7: COT(M)<-COT(M)!CH<<PTEXTSHL; !COUNT OF CHARS
IF A(1)=12 AND A(2)=6 THENSTART
CYCLE CTN=CTN,1,CTN+((A(5)-CH)//2)
COT(CTN)=0
REPEAT
FINISH
IF CH=0 AND A(5)&1=1 START; ! NULL STRING OF ODD LENGTH
CTN=CTN+1
COT(CTN)=0
FINISH
AP=AP+1
IF A(1)=12 AND A(2)=6 THEN A(AP)=CH ELSEC
A(AP)=M
RESULT =1
END; ! PTEXT
INTEGERFN CONSTLIST
INTEGER CPOINT
INTEGER RF,I,J,CTR,SIGN,SCP,S,S1,RTP
INTEGER TYPE,CNUM
INTEGER SHL
SHL=0
CNUM=0; ! TO BE NO OF LOGICAL ENTRIES IN CONST TABLE,
! IE. 1 INTEGER=1 ENTRY, 1 REAL=1 ENTRY
IF T(TP)#'=' THENRESULT =0
TP=TP+1; CTR=0; ! OWN ARRAYS REL TO $(0)
SCP=CTN; ! SAVE START POSITION IN CONST TABLE
L6: RTP=TP; I=T(TP); SIGN=1; ! TEST IF CONSTANT SIGNED
IF A(1)=12 AND A(2)=6 START
IF (A(5)//2)*2=A(5) AND (CNUM//2)*2#CNUM THENC
PTEXTSHL=8 ELSE PTEXTSHL=0
IF PTEXT=1 START
CNUM=CNUM+1
->L97
FINISH
->L98
FINISH
IF I='+' THEN ->L8
IF I#'-' THEN ->L9
SIGN=-1
L8: TP=TP+1
L9: IF CONST=0 THEN ->L98; ! USE CONST TO GET NEXT CONSTANT
AP=AP-3; S=A(AP+2); RF=1; ! EXTRACT CONSTANT FROM ANAL RECD
S1=A(AP+3); ! REAL CONST
TYPE=A(AP+1)
IF A(1)=12 AND A(2)=3 AND TYPE=2 START
FLT11(S)
S=FLIT
S1=FLOT
TYPE=3
FINISH
IF A(1)=12 AND A(2)=2 AND TYPE=3 THEN FAULT(44)
IF T(TP)#'(' THEN ->L1; ! IS THERE A REPEAT FACTOR
TP=TP+1
IF CONST=0 OR T(TP)#')' THEN ->L98; ! CONST EXTRACTS RF
AP=AP-3; RF=A(AP+2); TP=TP+1
! REPEAT FACTOR NOW SET UP IN RF
L1: S=S*SIGN IF TYPE<3; ! CONSTANT NOW WITH CORRECT SIGN(INTEGER)
IF TYPE=3 AND SIGN<0 THEN S=S!X'8000'
IF A(1)=12 AND A(2)=1 START
! OWNBYTE ARRAY COMING
! %IF S< -128 %OR S>127 %THEN %RESULT=0
CYCLE J=1,1,RF
IF SHL=0 START
CPOINT=CT NEXT
COT(CPOINT)<-S
COT(CPOINT)<-COT(CPOINT)&255
SHL=1
FINISH ELSE START
COT(CPOINT)<-COT(CPOINT) ! (S<<8)
SHL=0
FINISH
REPEAT
FINISH ELSE START
CYCLE J=1,1,RF
I=CTNEXT
IF TYPE=3 THENSTART; ! REAL CONST
COT(I)<-S
COT(CT NEXT)<-S1
FINISH ELSE COT(I)<-S
REPEAT
FINISH
CNUM=CNUM+RF
L97: IF T(TP)#',' THEN ->L99
TP=TP+1
IF T(TP)#10 THEN ->L6
READ STATEMENT; TP=1; ->L6
L98: TP=RTP
L99: A(AP+1)=CNUM; !NO OF CONSTS TO ANAL REC
A(AP+2)=SCP; !TOGETHER WITH STARTING POSN
AP=AP+2
PTEXTSHL=0
RESULT =1
END; ! CONSTLIST
END; ! COMPARE
ROUTINE PRINT AR(INTEGER N)
! PRINT ANALYSIS RECORD (N LONG)
INTEGER I
IF DIAGS=0 THENRETURN
I=1
L1: WRITE(A(I),3)
IF I//16*16=I THEN NEWLINE
I=I+1
IF I<=N THEN ->L1
NEWLINE
END; ! PRINT AR
INTEGERFN BT NEXT
! ALLOCATE NEXT POSITION IN BRANCH TABLE
IF BTN<=LTSIZE THEN ->L1; !STILL ROOM
FAULT(66); ! TOO MANY LABELS
BTN=0; ! TRY TO CONTINUE
L1: BAT(BTN)=-1; ! MARKER FOR ADDRESS NOT FILLED
BTN=BTN+1; ! NEXT POSITION
RESULT =BTN-1; ! THIS POSITION
END; ! BT NEXT
INTEGERFN CT NEXT
! ALLOCATE NEXT POSITION IN CONSTANT TABLE
IF CTN<=LTSIZE THEN ->L1; !STILL ROOM
FAULT(67); ! TOO MANY CONSTS
CTN=0; ! TRY TO CONTINUE
L1: CTN=CTN+1; ! NEXT POSITION
RESULT =CTN-1; ! THIS POSITION
END; ! CT NEXT
ROUTINE SS
! COMPILE SOURCE STATEMENT
ROUTINESPEC REC DISP(INTEGER I,INTEGERNAME K,KK,TYPENO)
ROUTINESPEC FMT ELT
ROUTINESPEC RFMTD
ROUTINESPEC ENDS
ROUTINESPEC UI
INTEGERFNSPEC FREE REG
ROUTINESPEC BLOCK ENTRY
ROUTINESPEC FLOAT
ROUTINESPEC UP STACK PTR(INTEGER N)
ROUTINESPEC SCCOND(INTEGERNAME I, INTEGER I,I)
ROUTINESPEC SEXPR(INTEGERNAME TYPE)
ROUTINESPEC RTSPEC
INTEGERFNSPEC FIND LABEL
ROUTINESPEC CHECK JUMPS
ROUTINESPEC SET LINE
ROUTINESPEC SET LAB(INTEGER PTP)
ROUTINESPEC STORE TAG(INTEGER NAME,FORM,TYPE,DIM,LEV,AD)
!
!
ROUTINESPEC RESTORE INTER
ROUTINESPEC RELEASE(INTEGER REG)
ROUTINESPEC SET INTER (INTEGER REG)
ROUTINESPEC INTER TO SP
ROUTINESPEC SAVE INTER
INTEGERFNSPEC ADDRDUMP(INTEGER LEVEL,DISP)
ROUTINESPEC DUMP(INTEGER OP,BASE,DISP)
INTEGERFNSPEC SET INDEX(INTEGER BASE)
INTEGERFNSPEC LOAD INDEX(INTEGER OT,INTEGERARRAYNAME LOCN)
ROUTINESPEC LOCK(INTEGER R)
ROUTINESPEC UNLOCK(INTEGER R)
INTEGERFNSPEC P11REG
ROUTINESPEC LD ADDR(INTEGER REG,BASE,DISP)
INTEGERFNSPEC INTER BASE
ROUTINESPEC LOSE(INTEGER REG)
INTEGERFNSPEC INTER REG
INTEGERFNSPEC INTER TO REG(INTEGER ACC)
INTEGERFNSPEC BYTE TO REG(INTEGER BASE,DISP,REG)
ROUTINESPEC PRR
ROUTINESPEC PRI(INTEGER OT)
!
!
ROUTINESPEC PJ(INTEGER A,A,A)
ROUTINESPEC PPJ(INTEGER A)
ROUTINESPEC HOY NAME(INTEGER A)
ROUTINESPEC TYPE CH(INTEGER I,I)
ROUTINESPEC CBPAIR(INTEGERNAME I,I)
ROUTINESPEC DETAG
ROUTINESPEC SKIP SEXPR
ROUTINESPEC SKIP APP
ROUTINESPEC RT
ROUTINESPEC ARRAD(INTEGER MODE, INTEGERNAME REG)
ROUTINESPEC RETURN
ROUTINESPEC PMN(INTEGER I)
ROUTINESPEC COMMA
ROUTINESPEC IUSES0
ROUTINESPEC PRLAB
ROUTINESPEC D11(INTEGER OP,MODE,NEM,NUM)
ROUTINESPEC D11A(INTEGER OP,M1,NEM1,NUM1,M2,NEM2,NUM2)
ROUTINESPEC OPERAND(INTEGER MODE,NEM,NUM)
ROUTINESPEC MAA(INTEGER M1,A1,M2,A2)
ROUTINESPEC EM(INTEGER I)
ROUTINESPEC AD(INTEGER I)
ROUTINESPEC TSAVE(INTEGER TWSP)
ROUTINESPEC TOPOL
ROUTINESPEC FPOL
ROUTINESPEC TO GLOBLS(INTEGER I)
ROUTINESPEC F GLOBLS
SWITCH SW(1:29)
OWNINTEGERARRAY GLOBLS(1:10)=0(10)
OWNINTEGER GP=0
OWNINTEGER IN EXT=0
OWNINTEGER UTAG=0; ! FOR USE IN RTS ARRAD & PJ.
OWNINTEGER SR=-1; ! %SHORT %ROUTINE
OWNINTEGER JS=-1; ! %JUMPS %SHORT
OWNINTEGER LJS=0; ! %LONG %JUMP
OWNINTEGER BDIAGSPTR=0
INTEGER TEMPHEAD; TEMPHEAD=0
INTEGER FMT NAME,RDISP,NRELTS,TORF
INTEGER I,J,K,L,M,N,NN,WS,CELL1,CELL2,TYPE,WK
INTEGER INHIB; INHIB=0; !USED ONLY FOR CASE I=J IN UI & SEXPR
INTEGER DV,UIJ
!
!
OWNINTEGERARRAY PAR1(0:1)
OWNINTEGERARRAY PAR2(0:1)
OWNINTEGERARRAY PAR3(0:1)
OWNINTEGER LOCKED=0
OWNINTEGER IHEAD=0
INTEGERARRAY SOUR,DEST(-1:2)
!!!!!111111111111111111111111111111!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
OWNINTEGERARRAY ENCODE(0:16)= C
X'08B0',
X'0CB0',
X'1350',
X'1B50',
X'2350',
X'0000',
X'3040',
X'38C0',
X'4350',
X'4946',
X'0000',
X'0000',
X'6430',
X'4351',
X'7410',
X'7CB8',
X'8350'
IF LEVEL>0 AND RDIAG#0 START
CYCLE I=1,1,LEVEL
PRINTSTRING("LEVEL")
WRITE(I,1)
PRINTSYMBOL(':')
J=SBR(I)
WHILE J#0 CYCLE
WRITE(TAG(J),3)
J=LINK(J)
REPEAT
NEWLINE
REPEAT
FINISH
!
!
SOUR(-1)='S'
DEST(-1)='D'
I=A(AP); ! ANALYSIS RECORD ENTRY
AP=AP+1; ! FOR FOLLOWING ENTRY
WS=0; ! WORKSPACE POINTER TO ZERO
IF LEVEL#0 THEN ->L1
!
! 5 <CMARK> (COMMENT, M/C CODE, THE LATTER NOT BEING INTENDED!
! 6 <EXT><RT><SPEC>
! 8 %BEGIN
! 12 <OWN><TYPE><OWNDEC>
! 13 %CONTROL
! 18 %JUMPSSHORT
! 21 %ENDOFFILE
!
IF I=5 OR I=6 OR I=22 OR I=12 OR I=13 OR I=18 OR I=24 C
OR I=28 OR I=29 THEN ->L1
FAULT(57); ! BEGIN NOT FIRST
L1: ->SW(I)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! UI
SW(1): SET LINE; ! UPDATE LINE COUNT
IF A(MARK)=1 THEN ->L110; ! CONDITION AFTER UI
UI; !AND COMPILE UNCONDITIONAL INSTRN
RETURN
L110: J=AP; ! SAVE POSN OF UI
AP=MARK+2; !TO P<SC>
SCCOND(I,A(MARK+1),J); !COMPILE CONDITION
AP=J
IF A(AP)#4 THEN UI; ! COMPILE UI UNLESS JUMP
!(NECESSARY JUMP HAS BEEN FIXED IN SCCOND).
IF I>=0 THEN SET LAB(I); ! LABEL FOR BR ROUND UI
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! %IF . . . %THEN . . .
SW(2): SET LINE; ! UPDATE LINE COUNT
J=A(AP); AP=AP+1
IF A(MARK)<=2 THEN ->L220; ! ALT OF <SUI> IS %THEN%START OR %START
! THEN ALT OF <SUI> IS <UI><ELSE''>.
SCCOND(I,J,MARK+1); ! COMPILE CONDITION
AP=MARK+1; ! TO P<UI>
UIJ=A(AP); ! ALT NO OF UI1
IF UIJ#4 THEN UI; ! UI1 UNLESS JUMP
! AP IS NOW PTG TO ALT OF <ELSE''>.
! 1:%ELSESTART 2: %ELSE UI12 3: NULL
IF A(MARK2)=3 THEN ->L230; !JUMP IF ALT OF <ELSE''> IS NULL.
! OTHERWISE PLANT A JUMP ROUND THE ELSE CLAUSE.
! BUT NOT IF 'THEN' CLAUSE IS -> LAB
IF UIJ#4 THEN START; ! UI1 WAS NOT A JUMP
IF A(MARK2)=2 THEN K=0 ELSE K=1
!(MANDATORY SHORT FOR 'ELSE UI', ELSE BEST CAN DO
J=BT NEXT
PJ(BR,K,J); ! AT END OF UI1, PLANT JUMP ROUND UI2
FINISH
IF I>=0 THEN SETLAB(I); ! LABEL FOR START OF UI2
! MARK2 IS PTG TO ALT OF <ELSE''>.
IF A(MARK2)=1 THENSTART ; !WE HAVE %ELSE %START
PUSH(SBR(LEVEL),J,UIJ)
RETURN
FINISH
! HERE WE HAVE %ELSE UI2
AP=MARK2+1; ! TO PT TO <UI>.
UI; ! UI2
SETLAB(J) UNLESS UIJ=4; ! LABEL FOR END OF UI2, NOT NEEDED IF UI1
! WAS JUMP
RETURN
L220:
! ALT OF <SUI> IS %START
SCCOND(I,J,MARK); ! SIMPLE CONDITION
! LEAVES I PTG TO ALT OF <ELSE''> IN ANAL REC.
PUSH(SBR(LEVEL),I,0); ! SAVE I FOR %FINISH
RETURN
L230:
IF I>=0 THEN SETLAB(I); !SET BRANCH ROUND UI.
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! LABEL
SW(3): I=FIND LABEL; ! LOCATE/INSERT LAB IN JUMP LIST
IF I<0 THEN ->L302; ! INVALID LABEL
IF BAT(I)>=0 THEN FAULT(2); !LABEL SET TWICE
SETLAB(I); ! FILL IN LABEL ADDRESS
L302: SS; ! COMPILE STATEMENT AFTER LABEL
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DECLARATIONS (OTHER THAN %OWN)
!
SW(4): ! <TYPE> 1=BYTEINTEGER 2=INTEGER,3=REAL,4=SHORTINT,5=LONGREAL
TYPE=A(AP)
IF TYPE=6 THEN ->L408; ! TYPE=STRING
IF TYPE>3 THEN TYPE=TYPE-2; ! SHORTINT=INT, LONGREAL=REAL
I=TYPE
! SET I=1,2,4 FOR BYTE,INTEGER,REAL
IF I=3 THEN I=I+1
IF A(AP+1)=1 THEN ->L401; ! <ARRAY?> = %ARRAY
AP=AP+1
J=A(AP+1)&1
IF J=1 THEN I=2
L402: AP=AP+2; ! POINTER ON NAME
! ALIGN RAD TO WORD FOR INTEGER AND REAL
IF TYPE>=2 THEN RAD=(RAD+1)&(-2)
STORE TAG(A(AP),J,TYPE,0,LEVEL,RAD); ! TAGS FOR THIS NAME
RAD=RAD+I
IF A(AP+1)=1 THEN ->L402; ! MORE <NAMES>
IF A(AP+2)#2 THEN FAULT(37); ! SURPLUS BND PAIR
RETURN ; ! IGNORE EXTRA BOUND PAIRS
!
! ARRAY DECLARATIONS (OTHER THAN %OWN)
!
L401:
AP=AP+1
IF A(AP+1)=1 THENSTART ; FAULT(100) ; RETURN ; FINISH
RAD=(RAD+1)&(-2)
DV=RAD; K=AP; ! PUT DOPE VECTOR AMONG LOCALS
SET LINE; ! UPDATE LINE COUNT
L403: AP=AP+2; ! SKIP A NAME
IF A(AP+1)=1 THEN ->L403; ! MORE NAMES YET IN NAMELIST
AP=AP+2; ! ON TO P<ABP>
IF A(AP)=1 THEN ->L404; ! BOUND PAIR PRESENT
FAULT(37); ! MISSING BND PAIR
AP=K; ! RESTORE INITIAL ANAL. REC. POI
->L402; ! TREAT AS SCALAR DECLARATIONS
L404:
J=4
L405: ! LOOK FOR THE BOUND-PAIR
J=J+2; ! J POINTS TO ALTS OF <NAMELIST>
IF A(J)=1 THEN -> L405; ! JUMP BACK WHILE ALT OF NAMELIST IS ,<NAME>
! FOLLOWING CONDITIONS ARE J+4,J+11, - ALT OF OPND IS 3 (CONST)
! AND J+5,J+12, - ALT OF CONST IS 2 (TYPE INTEGER)
IF A(J+4)=3 AND A(J+5)=2 AND A(J+11)=3 AND A(J+12)=2 C
AND A(J+15)=2 THENSTART
! CONST BDD ARRAY. PUT DV INTO COT. REL ADDR
! OF ALL ELTS KNOWN AT COMPILE TIME.
DV=CT NEXT
! ONE DV FOR ALL ARRAYS WITH THESE BOUNDS
COT(DV)=1 ! (I<<4) ;! ND
K=A(J+6); ! LB
L=A(J+3); ! PICK UP PLUS-DASHED
IF L=2 THEN K=-K; IF L=3 THEN K=¬K
COT(CT NEXT)=K; ! LB
M=A(J+13); ! UB
L=A(J+9); ! PICK UP PLUS-DASHED
IF L=2 THEN M=-M; IF L=3 THEN M=¬M
COT(CT NEXT)=M; ! UB
COT(CT NEXT)=0 ; ! RANGE. NOT USED
M=(M-K+1)*I; ! NO. OF BYTES FOR EACH ACTUAL ARRAY
K=K*I
! K IS NO OF BYTES FROM ARRAY(0) TO ARRAY(LB)
! M IS NO OF BYTES FOR EACH ACTUAL ARRAY
J=3
L410:
J=J+2; ! POINTS TO <NAME>S
! PUT ARRAYS AND HEADERS IN LOCAL SPACE, ONE HDR FOR EACH ARRAY.
L=RAD; ! RAD FOR 1ST ACTUAL ELEMENT OF ARRAY
RAD=RAD+M; ! AREA FOR ARRAY, RAD IS NOW RAD FOR HDR
RAD=(RAD+1)&(-2)
STORE TAG(A(J),2,TYPE,1,LEVEL,RAD)
! PUT AN EXTRA CELL CONTAINING ADDR(ARRAY(0)) BEHIND ARRAY
! NAME TAGS WITH TOP BIT SET IN LINK FIELD.
CELL1=LINK(A(J))
CELL2=NEWCELL
TAG(CELL2)=L-K
TAG1(CELL2)=0
LINK(CELL2)=LINK(CELL1)
LINK(CELL1)=CELL2!X'8000'
! NEXT PLANT CODE TO LOAD THE HEADER
D11A(MOV,8,0,L-K,6,R1,RAD); ! ADDR(ARRAY(0))
D11A(ADD,0,R1,0,6,R1,RAD)
LD ADDR(-1,15,DV*2); ! ADDR(DV)
DUMP(STR,13,RAD+2)
RAD=RAD+4
IF A(J+1)=1 THEN -> L410
! JUMP BACK WHILE ALT OF NAMELIST IS ,<NAME>
RETURN
FINISH
J=2; ! LEAVE HOLE FOR NUMBER OF DIMEN
L406: AP=AP+1
SEXPR(L); ! LOWER BOUND EXPR, L=TYPE FOUND
DUMP(STR,13,DV+J); ! STORE LOWER BOUND
SEXPR(M); ! UPPER BOUND EXPR, M=TYPE FOUND
DUMP(STR,13,DV+J+2); ! STORE UPPER BOUND
J=J+6; ! INCREMENT FOR NEXT BOUND PAIR
IF L>2 OR M>2 THEN FAULT(24); ! BND REAL EXPRN
IF A(AP)=1 THEN ->L406; ! ON <BPS> - MORE BOUND PAIRS
J=(J-2)//6; ! NUMBER OF DIMENSIONS
! SET TOPQUARTET OF ND IN DV TO BE 1,2,4 FOR BYTE,INT,REAL
DUMP(LOAD,14,J!(I<<4)); ! LOAD NO OF DIMENSIONS
DUMP(STR,13,DV); ! INTO WORD 1 OF DOPEVECTOR
! ADDR OF DOPEVECTOR TO I3
! MOV #DV,R3
D11A(MOV,8,0,DV,0,IND(3),0)
! ADD R1,R3
D11A(ADD,0,R1,0,0,IND(3),0)
AP=K; !RESTORE ANAL REC PTR
RAD=RAD+2+6*J; ! RAD ON PAST DOPE VECTOR
L407: AP=AP+2; ! ON <NAME>
STORE TAG(A(AP),2,TYPE,J,LEVEL,RAD); ! TAGS FOR EACH ARRAY NAME
PPJ(0); ! DECLARE ARRAY LEAVING @DV IN I3 &
! ADDR(A(0)) IN ACC
SET INTER(0)
DUMP(STR,13,RAD); ! ADDR(A(0)) TO WORD1 OF ARRAYHEAD
SET INTER(3)
DUMP(STR,13,RAD+2); ! AND @DV INTO WORD2
RAD=RAD+4; ! RELATIVE ADDRESS FOR NEXT ARRAYHEAD
IF A(AP+1)=1 THEN ->L407; ! MORE <NAMES>
RETURN
!
! STRING DECLARATIONS (OTHER THAN %OWN)
!
L408:
SET LINE
IF A(AP+1)=1 THEN ->L409
AP=AP+2
->L419 IF A(AP+1)=1 ; !STRINGNAME
FAULT(32) ;!STRING LENGTH MISSING
J=255 ;!GIVE STRING MAX. LENGTH
AP=AP+2
->L411 ;!TRY TO CONTINUE
L409:
AP=AP+3
IF A(AP-1)=2 THEN ->L412
FAULT(33) ;!LENGTH NOT INTEGER
J=255 ;!GIVE STRING MAX. LENGTH
->L411 ;!TRY TO CONTINUE
L412:
J=A(AP) ;!STRING LENGTH
L411:
AP=AP+2
IF A(AP)=1 THEN ->L413 ; !STRING ARRAY
->L419 IF A(AP+1)=1 ; !STRINGNAME
AP=AP+2 ;!POINT TO FIRST NAME
IF A(AP+1)=1 THENSTART; ! MORE THAN 1 NAME
D11A(MOV,8,0,J,0,R0,0); ! MOVE MAX. LENGTH TO R0
I=0
K=R0
L=0
FINISHELSESTART
I=8
K=0
L=J
FINISH
->L415
L414:
AP=AP+2 ;!SKIP NAME
RETURNUNLESS A(AP-1)=1 ; !NO MORE NAMES
L415:
STORE TAG(A(AP),0,6,1,LEVEL,RAD)
D11A(MOV,I,K,L,6,R1,RAD+2);!MAX. LENGTH
D11A(MOV,8,0,RAD+4,6,R1,RAD);!ADDRESS OF
D11A(ADD,0,R1,0,6,R1,RAD);!STRING
RAD=RAD+4+J+1
IF RAD&1=1 THEN RAD=RAD+1 ; !MAKE RAD WORD ALIGNED
->L414
!
! STRING ARRAY DECLARATIONS (OTHER THAN %OWN)
!
L413:
AP=AP+1
K=AP ;! SAVE ANAL PTR.
L418:
AP=AP+2; ! SKIP A NAME
IF A(AP)=1 THEN ->L418; ! MORE NAMES IN NAMELIST
AP=AP+1; ! ON TO P<BP>
IF A(AP)=1 THEN ->L416; ! BOUND PAIR PRESENT
FAULT(37); !MISSING BOUND PAIR
AP=K+1; ! RESTORE INITIAL ANAL. REC. PTR.
->L415; ! TREAT AS ORDINARY STRING
L416:
IF A(AP+3)=3 AND A(AP+4)=2 AND A(AP+10)=3 ANDC
A(AP+11)=2 AND A(AP+14)=2 THENSTART
! BOUND PAIR AT A(AP+5) AND A(AP+12)
DV=CT NEXT
! ONE FOR ALL STRING ARRAYS WITH THESE BOUNDS
K=A(AP+5) ;! LB
L=A(AP+2) ;! PLUS-DASHED
IF L=2 THEN K=-K ; IF L=3 THEN K=¬K
COT(CT NEXT)=K ;! LB
M=A(AP+12) ;! UB
L=A(AP+9) ;! PLUS-DASHED
IF L=2 THEN M=-M ; IF L=3 THEN M=¬M
COT(CT NEXT)=M ;! UB
COT(CT NEXT)=J ;! MAX. LENGTH OF EACH STRING
L=M-K
IF L<0 THEN L=L*(-1) ; L=L+1
COT(DV)=L ! 128 ; ! ND
L=L*J+L ; ! NO. OF BYTES FOR ARRAY
IF L&1=1 THEN L=L+1; ! MAKE WORD ALIGNED
AP=7
L417:
AP=AP+2
M=RAD
RAD=RAD+L
STORE TAG(A(AP),2,TYPE,1,LEVEL,RAD)
CELL1=LINK(A(AP))
CELL2=NEWCELL
TAG(CELL2)=J; ! MAX. STRING LENGTH
LINK(CELL2)=LINK(CELL1)
LINK(CELL1)=CELL2
D11A(MOV,8,0,M-K*J+K,6,R1,RAD); ! ADDR(STRING(0))
D11A(ADD,0,R1,0,6,R1,RAD)
LD ADDR(-1,15,DV*2); ! ADDR(DV)
DUMP(STR,13,RAD+2)
RAD=RAD+4
IF A(AP+1)=1 THEN ->L417; ! MORE NAMES
RETURN
FINISH
RETURN
!
! STRING NAME
!
L419:
AP=AP+2
IF A(AP-1)#1 THENSTART ; FAULT(100) ; RETURN ; FINISH
L420:
STORE TAG(A(AP),1,6,0,LEVEL,RAD)
D11A(MOV,8,0,225,6,R1,RAD+2)
RAD=RAD+4
RETURNIF A(AP+1)#1 ; ! NO MORE NAMES
AP=AP+2
->L420
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! COMMENT, M/C CODE
!
SW(5):
!AP IS POINTING TO ALT OF <CMARK>
!TP IS POINTING TO CHAR AFTER ! OR %COMMENT OR *
I=A(AP)
IF I=4 THENSTART; PRLAB; IUSES0
IF TARGET&8192#0 START
DBIN(0,TP,0,0,0,0,0)
WHILE T(TP)#10 AND T(TP)#';' THEN TP=TP+1
RETURN
FINISH
CA=CA+2; FINISH
! PRINTS LABEL IF NECESSARY AND SELECTS OBJECT STREAM.
L500:
J=T(TP)
J=10 IF J=';'
J=' ' IF J='_'
PRINT SYMBOL(J) IF I=4; !M/C CODE
RETURNIF J=10
TP=TP+1
->L500
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
SW(6): ! RT AND RT SPEC
RTSPEC; ! COMPILE RT/FN SPEC/HEADING
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SW(7): ! %UNTIL/%WHILE ... %THEN ...
BEGIN;INTEGER I,J,K,L,M
L=A(AP); ! 1=UNTIL 2=WHILE
! INITIAL JUMP FOR %UNTIL
IF L=1 START; J=BTNEXT; PJ(BR,0,J); FINISH
K=BTNEXT
SETLAB(K); ! LABEL FOR TOP OF LOOP
I=BTNEXT; ! FOR EXIT LABEL
AP=AP+1; ! START OF <SC>
SCCOND(M,L,-I)
IF M>=0 THEN SETLAB(M)
IF L=1 THEN SETLAB(J); ! LABEL FOR JUMP ROUND TEST FOR UNTIL
! NOW COMPILE THE UI
AP=MARK
UI
PJ(BR,0,K); ! BACK TO TEST AT TOP OF LOOP
SETLAB(I); ! LABEL FOR LOOP EXIT
END; ! BEGIN-BLOCK
RETURN
!
!-------------------------------------------------------------------
SW(8): ! %UNTIL/%WHILE ... %CYCLE
BEGIN;INTEGER I,J,K,L,M
L=A(AP); ! 1=UNTIL 2=WHILE
IF L=1 START; J=BTNEXT; PJ(BR,0,J); FINISH
K=BTNEXT
SETLAB(K); ! TOP OF LOOP
I=BTNEXT; ! FOR EXIT LABEL
AP=AP+1; ! START OF <SC>
SCCOND(M,L,-I); ! M TO BE CONDITION EXIT LABEL, I IS 'UI' JUMP LAB
IF M>=0 THEN SETLAB(M)
IF L=1 THEN SETLAB(J)
PUSH(CYC(LEVEL),I,K); ! EXIT LAB, TOP LAB
PUSH(CYC(LEVEL),1,0); ! INDICATOR, DUMMY
END; ! BEGIN-BLOCK
RETURN
!-----------------------------------------------------------------------
SW(9): ! UI %UNTIL/%WHILE ...
BEGIN;INTEGER I,J,K,L,M,APUI
APUI=AP
L=A(MARK-1); ! 1=UNTIL 2=WHILE
IF L=1 START; J=BTNEXT; PJ(BR,0,J); FINISH
K=BTNEXT
SETLAB(K); ! TOP OF LOOP
I=BTNEXT; ! FOR EXIT LABEL
AP=MARK; ! START OF <SC>
SCCOND(M,L,-I)
IF M>=0 THEN SETLAB(M)
IF L=1 THEN SETLAB(J)
AP=APUI
UI
PJ(BR,0,K)
SETLAB(I); ! EXIT FROM LOOP
END; ! BEGIN-BLOCK
RETURN
!-----------------------------------------------------------------------
SW(10):! %CYCLE NAME#EXP,EXP,EXP
CYCS=CYCS+1
SET LINE; ! UPDATE LINE COUNT
J=AP; ! SAVE POINTER
AP=AP+1
SKIP SEXPR
SEXPR(K)
DUMP(STR,13,RAD); ! INCREMENT
SEXPR(L)
DUMP(STR,13,RAD+2); ! FINAL VALUE
AP=J+1
SEXPR(M); ! INITIAL
IF K!L!M#2 THEN FAULT(24); ! REAL CYC EXPRN
I=TAG OF(A(J))
IF (I>>8)&7#2 THEN FAULT(25); ! CYC CTRL NOT INT
L=I&15+(I>>7)&32
M=TAG OFF(A(J))
NN=INTER TO REG(0)
SET LAB(BTN); ! REPEAT JUMPS IN HERE
DUMP(STR,L,M); ! STORE INCREMENTED CONTROL
PUSH(CYC(LEVEL),RAD,BTN); ! INDICATE ORD TYPE
PUSH(CYC(LEVEL),0,A(J)); ! INDICATOR, NAME
BTN=BTN+1
RAD=RAD+4
RETURN
!-------------------------------------------------------------------
SW(11):! %REPEAT
SET LINE; ! UPDATE LINE COUNT
POP(CYC(LEVEL),M,K); ! INDICATOR, NAME
IF M=-1 START
FAULT(1); ! REPEAT EXTRA
RETURN
FINISH
POP(CYC(LEVEL),L,J); ! RAD,BTN OR EXIT LAB,TOP LAB
IF M=1 START
! UNTIL/WHILE TYPE
PJ(BR,0,J); ! TOP LABEL
SETLAB(L); ! EXIT LABEL
RETURN
FINISH
I=TAG OF(K)
DUMP(LOAD,I&15+(I>>7)&32,TAG OFF(K))
NN=INTER TO REG(0)
MAA(0,R0,0,R3)
DUMP(ADD,13,L); !ADD INCREMENT INTO R0
D11A(SUB,6,R1,L+2,0,R3,0); ! SUBTRACT FINAL FROM R3
PJ(FALSE(1),1,J)
UNLOCK(0)
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SW(12):! %OWN TYPE OWNDEC
!
!
! NOTE A MINOR ERROR TO SORT FOR UNINITIALISED %OWNREAL DCLARATION
!
!
I=A(AP)
IF I=6 THEN ->L1270; ! OWN STRING DECLARATION
IF I>3 THEN I=I-2; ! SHORTINT=INT, LONGREAL=REAL
! I SET 1=BYTEINTEGER, 2=INTEGER, 3=REAL
J=A(AP+2); ! J=NAME
AP=AP+3
IF A(AP-2)=2 THEN ->L1240; ! GO IF ARRAY
K=0; ! ZERO IS DEFAULT INITIALISATION
IF A(AP)=2 THEN ->L1202
K=A(AP+3); ! INITIAL VALUE
FLOT<-A(AP+4)
! JULY 72: DOES THIS NEXT STMT WORK FOR REALS?
IF A(AP+1)=2 THEN K=-K; ! PLU WAS '-'
L1202: L=CT NEXT
FLIT<-K
IF I=3 THENSTART; ! REAL CONST
IF A(AP+2)=2 THEN FLT11(K)
COT(L)=FLIT
COT(CT NEXT)=FLOT
FINISH C
ELSE COT(L)=K; ! INTEGER CONST
IF I=2 AND A(AP+2)=3 THEN FAULT(44)
STORE TAG(J,0,I,0,15,2*L); ! STORE TAG, BASE=15
RETURN
! %OWN ARRAYS ------------------
L1240: CBPAIR(K,L); ! LB TO K----UB TO L
SET LINE
IF A(AP)#L-K+1 START
FAULT(45); ! WRONG NO OF CONSTS
WRITE(A(AP),2); NEWLINE
FINISH
! SET UP DOPE VECTOR IN CONST TABLE
M=CT NEXT
! 1ST WORD OF DV IS BOTTOM 4 BITS ND=1
! NEXT 4 BITS 1=BYTE 2=INT 3=REAL
COT(M)= 1 ! (1<<(I+3))
M=CT NEXT
COT(M)=K; !LB
M=CT NEXT
COT(M)=L; ! UB
COT(CT NEXT)=0; ! 'RANGE' (NOT USED)
! SET UP ARRAY HEADR ON STACK.
! IF (POSSIBLY HYPOTHETICAL) A(0) LIES WITHIN CONST TABLE,
! USE LDA TO PUT ITS ADDRESS IN HDR. OTHERWISE JUMP TO 1280
! TO EVALUATE ADDRESS.
! SET K TO BE THE NO OF BYTES FROM A(0) TO ACTUAL FIRST ELT
! K IS AT PRESENT 'LB'. (TO TREAT I=1,2,3 BYTE,INT,REAL ONLY).
WK=1
WHILE WK<I CYCLE
K=2*K
WK=WK+1
REPEAT
! SET NN=BYTE DISPL OF ACTUAL 1ST ELT IN CT
NN=2*A(AP+1)
LD ADDR(-1,15,NN-K); ! ADDR A(0)
DUMP(STR,13,RAD); ! TO WORD 1 OF ARRAYHEAD
LD ADDR(-1,15,2*(M-2)); ! ADDR(DOPEVECTOR)
DUMP(STR,13,RAD+2); ! TO WORD 2 OF ARRAYHEAD
STORE TAG(J,2,I,1,LEVEL,RAD)
IF K>NN THENSTART
CELL1=LINK(J)
CELL2=NEWCELL
TAG(CELL2)=NN-K
TAG1(CELL2)=1
LINK(CELL2)=LINK(CELL1)
LINK(CELL1)=CELL2!X'8000'
FINISH
RAD=RAD+4
RETURN
L1270:! %OWN STRING ------------------------
SET LINE
IF A(AP+1)=1 THEN ->L1271
FAULT(32);! STRING LENGTH MISSING
RETURN
L1271:
IF A(AP+2)=2 THEN ->L1272
FAULT(33);! STRING LENGTH NOT INTEGER
RETURN
L1272:
J=A(AP+3) ;! STRING LENGTH
AP=AP+6 ;! ON NAME
IF A(AP-1)=2 THEN ->L1280; ! STRING ARRAY
CTN=J+1
IF CTN&1#0 THEN CTN=CTN+1; ! MAKE WORD ALIGNED
CTN=CTN//2+A(12)
STORE TAG(A(AP),0,6,1,LEVEL,RAD)
D11A(MOV,8,0,J,6,R1,RAD+2);! MAX. LENGTH
LD ADDR(-1,15,A(12)*2);! ADDRESS OF STRING
DUMP(STR,13,RAD)
IF A(11)>J START
FAULT(45)
WRITE(A(11),2)
NEWLINE
FINISH
RAD=RAD+4
RETURN
L1280:! %OWN STRING ARRAY
N=A(AP);! NAME
AP=AP+1
CB PAIR(K,L);! LB TO K____UB TO L
CYCLE I=K,1,L
IF A(AP)>J START
FAULT(45);! CHECK INDIVIDUAL STRINGS
WRITE(A(AP),2)
NEWLINE
FINISH
AP=AP+1
REPEAT
I=L-K+1
IF A(AP)#I START
FAULT(45);! CHECK NUMBER OF STRINGS
WRITE(A(AP),2)
NEWLINE
FINISH
AP=AP+1;! TO STARTING POSITION IN CT.
M=J*I+I
IF M//2*2#M THEN CTN=CTN+1; ! MAKE WORD ALIGNED
M=CT NEXT
COT(M)=129 ;! (1 ! 8<<4) NO. OF DIMS.
M=CT NEXT
COT(M)=K ;! LB
M=CT NEXT
COT(M)=L ;! UB
M=CT NEXT
COT(M)=J ;! MAX. LENGTH OF EACH STRING
STORE TAG(N,2,6,1,LEVEL,RAD)
CELL1=LINK(N)
CELL2=NEWCELL
TAG(CELL2)=J ;! MAX. LENGTH OF STRING
LINK(CELL2)=LINK(CELL1)
LINK(CELL1)=CELL2
LD ADDR(-1,15,2*A(AP)-K*(J+1)) ;! ADDR(STRING(0))
DUMP(STR,13,RAD) ;! TO WORD 1 OF ARRAYHEAD
LD ADDR(-1,15,2*(M-3)) ;! ADDR(DV)
DUMP(STR,13,RAD+2) ;! TO WORD 2 OF ARRAYHEAD
RAD=RAD+4
RETURN
!
!
!
!
SW(13):! %CONTROL <CONST>
CHECKS=A(AP+1)
DIAGS=CHECKS>>1&1
RDIAG=CHECKS&1024
IF CHECKS&256#0 THEN TEMPS=0; ! NO LOCAL TEMPS FOR REALEXPRESSNS
RETURN
SW(14):! %SWITCH <SWITCHLIST>
I=AP; AP=MARK
CBPAIR(J,K); ! LB TO J, UB TO K
AP=I; ! TO FIRST NAME
IF J<=K THEN ->L1401; J=K
FAULT(27); !SWITCH INSIDE OUT
L1401: I=A(AP); ! <NAME>
STORE TAG(I,8,0,1,LEVEL,CTN); !FORM=8,DIM=1,DISP=PTR TO COT
COT(CTN)=J; COT(CTN+1)=K; ! LB,UB TO CONST TABLE
COT(CTN+2)=SWTN; CTN=CTN+3; !POSN OF ADDRESSES
CYCLE L=J,1,K
IF SWTN>SWTSIZE START
FAULT(66); SWTN=0
FINISH
SWT(SWTN-SWTSIZE)=-1
SWTN=SWTN+1
REPEAT
AP=AP+2
IF A(AP-1)=1 THEN ->L1401; ! FURTHER SWITCH NAME
RETURN
SW(15):! <SWITCH LABEL>:<SS>
I=TAG OF(A(AP))
IF I=0 THEN ->L1565
IF I>>12#8 OR I&255#16+LEVEL THEN ->L1565; !MUST BE SW
I=TAG OFF(A(AP))
J=A(AP+3); ! LABEL NO
IF A(AP+1)=2 THEN J=-J; ! NEGATE IF PRECEDED BY -
IF J<COT(I) OR J>COT(I+1) THEN ->L1565; ! BOUND CHECK
J=J-COT(I)+COT(I+2)
IF SWT(J-SWTSIZE)>=0 THEN ->L1565
SET LAB(J-SWTSIZE); ! SET THE ADDRESS IN BRANCH TABLE
L1510: AP=AP+5
SS; RETURN ; !COMPILE FOLLOWING STATEMENT
L1565: FAULT(5); !SWITCH LABEL ERROR
->L1510
SW(16):! %FINISH
! AP IS PTG TO ALT OF <ELSE''>.
! 1: %ELSESTART 2: %ELSE UI 3: NULL
K=A(AP)
POP(SBR(LEVEL),J,UIJ)
IF J>=0 THEN ->L1601
FAULT(51); !FINISH EXTRA
RETURN
L1601:
IF K<=2 THENSTART ; !WE HAVE %ELSE %START OR %ELSE UI
I=BT NEXT
IF K=2 THEN L=0 ELSE L=1
!(PLANT SHORT JUMP MANDATORILY FOR '%ELSE UI').
PJ(BR,L,I)
FINISH
SETLAB(J) UNLESS UIJ=3
RETURNIF K=3; ! IE. FOR <ELSE''> NULL
IF K=1 THENSTART ; !WE HAVE %ELSE %START
PUSH(SBR(LEVEL),I,0)
RETURN
FINISH
!THEN WE HAVE %ELSE UI
AP=AP+1; ! TO PT TO <UI>.
UI
SETLAB(I)
RETURN
SW(17): !%SHORTROUTINE
SR=LEVEL
RETURN
SW(18): ! %JUMPS %SHORT
JS=1
RETURN
SW(19): ! %JUMPS %NORMAL
SR=-1; JS=-1
RETURN
SW(20): ! %LONG %JUMP
LJS=LJS+1
RETURN
SW(21): ! %END
SHOW TAGS; ! PRINT OUT TAGS OF NAMES IN SCOP
SET LINE; ! UPDATE LINE COUNT
CHECK JUMPS; ! CHECK LABELS NOT SET & RETURN
NEWLINE
J=RTP(LEVEL); !TYPE OF BLOCK 'END'ING
J=J&15 UNLESS J=-1
F GLOBLS
IUSES0
DETAG; ! UNDECLARE NAMES, FAULT MISSING ONES
I=J&7
! PLANT STOP FOR FNS, EXCEPT FOR TRUSTED PROGS.
IF J>0 AND I>0 AND CHECKS&128=0 THEN PPJ(8)
IF I=0 THEN RETURN; ! PLANT RETURN CODE FOR RTS
IF J>=0 THEN ->L701; ! GO UNLESS BEGIN-END BLOCK
! THEN IT WAS A BEGIN-END BLOCK
DUMP(LOAD,13,PREVL); ! RESET TO OLD DISPLAY
UNLOCK(INTER TO REG(1))
L701:
! CANCEL %SHORT %ROUTINE IF LEVEL CORRESPONDS TO
!WHERE IT LAST APPEARED.
SR=JS IF LEVEL<=SR
LEVEL=LEVEL-1; ! DECREMENT TEXTUAL LEVEL COUNT
IF LEVEL>=1 THEN ->L703; ! NOT BACK AT OUTER LEVEL YET
FAULT(14); ! EXCESS END
->L708; ! TREAT AS %ENDOFPROGRAM
L703:
IF J>=8 THENSTART
LEVEL=LEVEL-1; ! BACK TO 0 FOR %EXT
IF LEVEL#0 THENSTART; FAULT(14); LEVEL=0; FINISH
RETURN
FINISH
RAD=COT(STAR(LEVEL)); ! RESTORE OLD RAD FOR MORE DECLA
TWSP=SAVETWSP(LEVEL)
! SET LABEL FOR JUMP ROUND RT, IF NECESSARY
IF J>=0 AND CHECKS&128=0 THEN SETLAB(BRT(LEVEL))
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! %BEGIN
!
SW(22): ! %BEGIN
IF LEVEL=0 THENSTART; BTN=0; ! RESET BR TABLE AFTER PERM SPECS
SETS(2); ! OBJECT STREAM
IF TARGET&8192=0 START
PRINTSTRING(" .GLOBL PERM,STB,SYSSTK
MAIN:
MOV ASSTK,SP
MOV ASTB,R1
MOV R1,@R1
TRAP 9.
")
OCTN(UNDER,0)
PRINTSTRING(" SWT-.
CT0-.
")
CA=CA+16
FINISHELSESTART
HALFINTEGER(ADDR(BIN(MAIN)))<-CA-LASTCAREL+LASTRELADDR C
+HALFINTEGER(ADDR(BIN(MAIN)))
ASSTK=CA+2
DBIN(112,2,7,1,0,SP,0)
DBIN(112,2,17,-20,0,R1,0)
DBIN(112,0,R1,0,1,R1,0)
EM(9)
OCTN(UNDER,0)
SWTCA=CA
OCT(CA-LASTCAREL+LASTRELADDR)
CTCA=CA
IF CT0>0 THEN OCT(CT0-(CA-LASTCAREL+LASTRELADDR)) ELSE C
OCT(CA-LASTCAREL+LASTRELADDR)
FINISH
FINISH
IF LEVEL#0 THEN COT(STAR(LEVEL))=RAD; !SAVE OLD STATIC STGE
LEVEL=LEVEL+1; !UP TEXTUAL LEVEL
SET LINE; ! UPDATE LINE CT
PUSH(BDIAGSPTR,CA,-1)
BLOCK ENTRY; ! OUTPUT CODE FOR BLOCK ENTRY
TWSP=PDISP
RAD=TWSP+TEMPS; ! ALLOW TEMPORIES AFTER DISPLAY
TWSPLIM=TWSP + TEMPS
SAVETWSP(LEVEL)=TWSP
RTP(LEVEL)=-1; !FOR BEGIN..END BLOCKS
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! %ENDOFPROGRAM, %ENDOFFILE
!
SW(24): ! %ENDOFFILE
! LEVEL MUST BE 0 WHEN %ENDOFFILE IS ENCOUNTERED
IN EXT=-1; ! INDICATOR FOR TERMINATION OUTPUT
IF LEVEL#0 THENSTART; FAULT(15); LEVEL=0; FINISH
F GLOBLS
-> L709
SW(23):
! LEVEL MUST BE 1 WHEN %EOP IS ENCOUNTERED
IF LEVEL#1 THENSTART; FAULT(15); LEVEL=1; FINISH
SHOW TAGS; ! PRINT OUT TAGS FOR NAMES IN SCO
SET LINE; ! UPDATE LINE COUNT
CHECK JUMPS; ! CHECK AND RETURN JUMP LIST
! CHECK JUMPS ALSO FILLS STATIC STORAGE INTO CONST TAB.
F GLOBLS
DETAG; !UNDECLARE NAMES
IF LEVEL#1 THEN FAULT(15); ! TOO FEW ENDS
L708: PPJ(5); ! %STOP IN PERM
L709:
CSIZE=CA//2
! BT0 -------------------------------- BT0
! I=(BTN+4)//5; ! NO OF ROWS WITH FIVE COLUMNS
! %CYCLE J=0,1,I-1
! PRINTSTRING(";! ")
! %CYCLE K=0,1,4
! L=J+I*K
! %IF L<BTN %THEN %START
! PRINTSTRING("BT")
! WRIT(L)
! PRINTSTRING("=L")
! %IF I<0 %THEN PRINTSTRING("UNDEF") %ELSE OCT5(BAT(L))
! SPACE
! %FINISH
! %REPEAT
! NEWLINE
! %REPEAT
! NEWLINE
!-------------------------------------- SWT
IF TARGET&8192=0 START
IF BTN>0 THEN START
CYCLE J=0,1,BTN-1
PRINTSTRING("; BT")
WRIT(J)
PRINTSTRING("=L")
I=BAT(J)
IF I<0 THEN PRINTSTRING("UNDEF") ELSE OCT5(I)
NEWLINE
REPEAT
FINISH
PRINTSTRING("SWT:
")
IF SWTN=0 THEN -> L910
CYCLE I=-SWTSIZE,1,SWTN-SWTSIZE-1
IF SWT(I)<0 THENSTART;PRINTSTRING(" -1
")
-> L911
FINISH
PRINTSTRING(" L")
OCT5(SWT(I))
PRINTSTRING("-.
")
L911:
REPEAT
L910:
I=0
!-------------------------------- CT0
PRINTSTRING("CT0:
")
L901:
SPACE
OCTS(COT(I))
PRINTSTRING(" ; ")
WRIT(I); SPACE
WRIT(COT(I))
PRINTSYMBOL('.')
NEWLINE
I=I+1
IF I#CTN THEN ->L901
PRINTSYMBOL(';')
WRITE(FAULTS,1); ! NUMBER OF PROGRAM FAULTS
PRINTSTRING(" FAULTS IN PROGRAM
")
IF REALS#0 START
IF CHECKS&8=0 THEN PRINTSTRING(" .GLOBL PLSH,LDF,FLT,STST
.GLOBL STRF,ADDF,SUBF,NEGF,MULF,DIVF,EXIT,EXPF
") ELSE PRINTSTRING("PLSH=460
LDF=464
FLT=470
STST=474
STRF=500
ADDF=504
SUBF=510
NEGF=514
MULF=520
DIVF=524
EXIT=540
EXPF=544
")
IF EXPFFLAG=0 THEN PRINTSTRING(".GLOBL $PWRR
$PWRR: 777
")
FINISH
IF IN EXT=0 THEN START
IF STRFLAG=0 THEN PRINTSTRING(" .GLOBL RESCON
RESCON: 777
")
IF READFLAG=0 THEN PRINTSTRING(" .GLOBL READ
READ: 777
")
IF REALS=0 THEN PRINTSTRING(" .GLOBL INTPT1
INTPT1: 777
")
PRINTSTRING("ASTB: STB
ASSTK: SYSSTK
")
FINISH
PRINTSTRING("ENDCO:
.END"); PRINTSTRING(" MAIN") IF FAULTS=0 AND IN EXT=0
NEWLINE
FINISHELSESTART
SETS(6)
HALFINTEGER(ADDR(BIN(SWTCA)))<-CA-LASTCAREL+LASTRELADDR C
-HALFINTEGER(ADDR(BIN(SWTCA)))
IF SWTN#0 START
CYCLE I=-SWTSIZE,1,SWTN-SWTSIZE-1
IF SWT(I)<0 START
OCT(-1)
->L915
FINISH
OCT(SWT(I)-CA)
L915:
REPEAT
FINISH
IF ENDCO1#0 THEN HALFINTEGER(ADDR(BIN(ENDCO1)))<-CA-LASTCAREL C
+LASTRELADDR
IF CT0=0 START
K=CA-LASTCAREL+LASTRELADDR
DBIN(-2,18,K,0,0,0,0)
HALFINTEGER(ADDR(BIN(CTCA)))<-K-HALFINTEGER(ADDR(BIN(CTCA)))
FINISHELSE K=CT0
K=K+(CTN+2)*2
HALFINTEGER(ADDR(BIN(ASSTK)))<-SYSSTK
HALFINTEGER(ADDR(BIN(ENDCO)))<-K
K=0
L=0
J=1
M=0
CYCLE I=0,2,CA-2
IF M=8 THEN M=0
L912:
IF REL(J)_LINK=I START ; ! RELOCATION ADDRESS ENCOUNTERED
K=I
L=REL(J)_RADDR
J=J+1
M=0
->L912 UNLESS I-K+L=CT0
FINISH
IF I-K+L=CT0 AND CT0>0 START
L913:
NN=0
CYCLE N=0,1,CTN-1
IF NN=8 THEN NN=0
IF NN=0 START
NEWLINES(2)
OCTS(I-K+L+N*2)
PRINTSYMBOL(':')
FINISH
SPACES(5)
OCTS(COT(N))
NN=NN+1
REPEAT
M=0
NEWLINES(2)
OCTS(I-K+L+N*2+2)
PRINTSTRING(": ")
OCTS(SYSSTK)
COT(CTN)=SYSSTK
IF CT0=-1 THEN ->L914
IF I=REL(J)_LINK THEN ->L912 ELSE ->L917
FINISH
IF M=0 START
NEWLINES(2)
OCTS(I-K+L)
PRINTSYMBOL(':')
FINISH
SPACES(5)
OCTS(HALFINTEGER(ADDR(BIN(I))))
M=M+1
WK=I-K+L
L917:
REPEAT
IF CT0=0 START
CT0=-1
L=L+2
->L913
FINISH
L914:
IF CT0<=0 START
CT0=CA
REL(J)_LINK=CA
REL(J)_RADDR=CA
J=J+1
FINISH
ST=''
REL(J)_LINK=CA
REL(J)_RADDR=CA
REL(J+1)_LINK=-1
J=1
WHILE REL(J+1)_LINK#-1 CYCLE
IF REL(J)_RADDR=CT0 START
SCONST(0)=CT0
DUMP BIN(SCONST,0,CTN+1,ST,K)
->L916
FINISH
BINS(REL(J)_LINK>>1)<-REL(J)_RADDR
DUMP BIN(BINS,REL(J)_LINK>>1,REL(J+1)_LINK>>1,ST,K)
L916:
J=J+1
REPEAT
BINS(0)=BINS(MAIN>>1+1)
ST='END'
DUMP BIN(BINS,0,0,ST,K)
DUMP BIN(BINS,-1,200,ST,K)
FINISH
SETS(3)
ENDS
IF TARGET&4096#0 START
SETS(0)
PRINTSYMBOL('*')
FINISH
SETS(4); ! CLOSE FILES, SELECTS OP 99.
ENDS
SETS(5); ! QUIT
STOP; ! NOT CALLED, IN EMAS
!==============
ROUTINE ENDS
INTEGER JJ
SPACES(3); NEWLINE; !TO START TTY MOTOR
PRINTSTRING(";STMTS FAULTS
;")
WRITE(STMTS,4); WRITE(FAULTS,6); NEWLINE
PRINTSTRING("; CODE CONSTS TOTAL (WORDS)
;")
JJ=I+SWTN; !ADD SW TAB SIZE TO CONST TAB SIZE
WRITE(CSIZE,4); WRITE(JJ,6); WRITE(JJ+CSIZE,5); C
PRINTSTRING C
(" (DEC)
;")
OCT5(CSIZE); SPACES(2); OCT5(JJ); SPACE; OCT5(JJ+CSIZE)
PRINTSTRING(" (OCT)")
NEWLINE
RETURNUNLESS CHECKS&16#0
PRINTSTRING("; CYC OPNS CALLS ENTS SCS PJS ARADS")
PRINTSTRING(" CTN")
NEWLINE; PRINTSYMBOL(';')
WRITE(CYCS,4); WRITE(OPNS,5); WRITE(CALLS,5); WRITE(ENTS,5)
WRITE(SCS,5)
WRITE(PJS,5)
WRITE(ARADS,5)
WRITE(CTN,5)
NEWLINE
END; ! ENDS
!
SW(25): ! %FAULT
! AR IS <CONST> <LABEL>
UNLESS A(AP)=2 AND A(AP+1)=9 THEN FAULT(36); ! DAFT FAULTNO.
UNLESS LEVEL<=2 THEN FAULT(26); ! ALLOW IN EXT RT.
PPJ(34)
AP=AP+3; ! TO <LABEL>
PJ(BR,1,FINDLABEL); ! UNCONDITIONAL LONG JUMP
RETURN
SW(26): ! FORMAT DECLARATION
! %RECORD %FORMAT <NAME> ( <FMT ELT> <RESTOFFMTD> ) <SEP>
FMT NAME=A(2); ! PTR TO FMT IDEN
NRELTS=0
RDISP=0; ! REL DIPL OF ELT FROM START OF REC
AP=3; ! TO ALT OF <FMT ELT>
FMT ELT
! LEAVES AP PTG TO ENTRY FOLLOWING NULL ALT OF <NLIST>
! IE. TO ALT OF <RESTOFFORMATD>
RFMTD
STORE TAG(FMT NAME,7,7,NRELTS,LEVEL,0)
RETURN
!----------------------------------------------------------------------
SW(27): ! RECORDNAME DECLARATION
! %RECORD %NAME <NAME><NLIST> ( <NAME> ) <SEP>
AP=2; ! TO <NAME>
RAD=(RAD+1) & (-2)
! GO ALONG TO THE FORMAT NAME
UNTIL A(AP-1)=2 THEN AP=AP+2
FMT NAME=A(AP); ! PTR TO FORMAT NAME
K=TAG OF(FMT NAME)
IF K=0 OR K>>8#X'77' START
PRINTNAME(FMT NAME)
FAULT(62); ! NOT FORMAT NAME
RETURN
FINISH
AP=2; ! TO <NAME>
UNTIL A(AP-1)=2 CYCLE
STORE TAG(A(AP),1,7,0,LEVEL,(LINK(FMT NAME)<<16) ! RAD)
RAD=RAD+2
AP=AP+2
REPEAT
RETURN
!
SW(28): ! %LIST
SPECS=1
RETURN
!
SW(29): ! %ENDOFLIST
SPECS=0
RETURN
ROUTINE FMT ELT
! ENTER WITH AP PTG TO ALT OF <FMT ELT>
! EXIT WITH AP POINTING TO ENTRY FOLLOWING NULL ALT OF <NLIST>
INTEGER IRN,I,M,N,M2
IRN=A(AP); ! 1=INTEGER, 2=RECORDNAME, 3=BYTEINTEGER
AP=AP+1; ! TO 1ST NAME
IF IRN#3 AND RDISP&1#0 THEN RDISP=RDISP+1
UNTIL A(AP-1)=2 CYCLE
M=A(AP); ! REC ELT IDEN PTR
M2=TAG(M)
I=LINK(FMT NAME)
N=NEW CELL
TAG(N)=TAG(M2)<<16 ! TAG1(M2); ! 1ST 4 CHARS OF NAME
TAG1(N)=RDISP ! (IRN<<16)
PUSH(RECELTS(LEVEL),0,M)
LINK(FMT NAME)=N
LINK(N)=I
! STORE TAG(A(AP),15,15,15,15,15); ! DUMMY ENTRY FOR REC ELT
IF IRN=3 THEN RDISP=RDISP+1 ELSE RDISP=RDISP+2
AP=AP+2
REPEAT
! AP POINTS TO ENTRY FOLLOWING NULL ALT OF <NLIST>
END; ! FMT ELT
ROUTINE RFMTD
! ENTER WITH AP PTG TO ALT OF <RESTOFFORMATD>
! EXIT WITH AP PTG TO NULL ALT OF <RESTOFFORMATD>
IF A(AP)=2 THEN RETURN
AP=AP+1; ! TO ALT OF <FMT ELT>
FMT ELT
! AP POINTS TO ALT OF <RESTOFFORMATD>
RFMTD
! AP POINTS TO NULL ALT OF <RESOTOFFORMATD>
END; ! RFMTD
!---------------------------------------------------------------------
ROUTINE UI; ! UI UI UI UI UI UI UI UI UI UI UI UI UI UI
! COMPILE UNCONDITIONAL INSTRUCTION
INTEGER I,J,K,L
INTEGER LTYPE
SWITCH SW(1:8)
NORELT1=0; NORELT2=0
I=A(AP); ! NEXT ANALYSIS RECORD ENTRY
AP=AP+1
->SW(I)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! NAME APP ASS
SW(1): ! NAME_NAME<ASSOP><RESTOFUI>
SCF=3
SEXPR(K)
RETURN
SW(2): !
I=TAG OF(A(AP)); ! GET NAME TAG
IF I=0 THEN FAULT(16); !NAME NOT SET
J=AP; ! PRESERVE AP (PTG TO <NAME>.
AP=AP+1
SKIP APP; ! SKIP TO <ASS>
IF A(AP)=1 THEN ->L101; ! ASSIGNMENT STATEMENT
! DO NOT CHECK %EXT BIT IN TYPE FIELD
IF (I>>8)&X'F7'=64 THEN ->L102; ! ROUTINE CALL
IF I#0 THEN FAULT(17); !NOT RT NAME
RETURN
L102: AP=J; ! RESTORE INITIAL ANALYSIS RECOR
RT; ! COMPILE ROUTINE CALL
RETURN
!
! ASSIGNMENT
L101: K=I>>12; ! 'FORM' OF NAME ON LHS
IF K=4 START
FAULT(29); !NAME NOT DESTN (LH=RT TYPE)
I=0; ! CLEAR TAGS TO AVOID FURTHER DI
FINISH
!AP IS PTG TO ALT OF REST-OF-UI
IF A(AP+1)<=2 THEN A(AP+1)=A(AP+1)!!3 ; ! SWOP '==' AND '='
AP=J; ! BACK TO PT TO <NAME>.
SCF=2; ! INDICATE ASST. STMT.
SEXPR(LTYPE)
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SW(3): ! -> SWITCH
I=AP; AP=AP+1
SEXPR(L)
J=INTER TO REG(0)
UNLOCK(0)
TYPE CH(2,L); ! MUST BE INT
J=TAG OF(A(I))
IF J=0 THEN ->L250
IF J>>12#8 OR J&255#16+LEVEL THEN ->L250
LD ADDR(3,15,2*TAG OFF(A(I))); ! TAG HAS NO OF WORDS FROM CT0
UNLOCK(3)
PPJ(7)
RETURN
L250: FAULT(4); !NOT SW NAME
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SW(4): ! -><LABEL>
PJ(BR,1,FINDLABEL); ! SCAN LABELS & PLANT JUMP
!VIA BRANCH TABLE
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! %RETURN
! RTP(LEVEL)= <0 BEGIN-END BLOCK
! 0 RT BLOCK
! >0 FN, 1,2,3=BYTE, INT,REAL
! AND PLUS 8 FOR %EXTERNAL
SW(5): ! %RETURN
IF RTP(LEVEL)&7#0 THEN FAULT(30); !%RETURN CONTEXT
RETURN; ! %RETURN CODE - INCORREC
RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SW(6): ! %RESULT=
I=RTP(LEVEL)
K=I&7; ! TYPE
IF I<=0 OR K=0 THEN FAULT(31); ! RESULT CONTEXT
SEXPR(J); ! COMPILE RESULT EXPRESSION
IF J=6 START
UNLOCK(INTER REG)
D11A(MOV,1,R1,0,0,R0,0)
->L501
FINISH
IF FLACC=0 THEN UNLOCK(INTER TO REG(0)) ELSE FLACC=0
L501:
IF I&X'80'#0 THEN K=2; ! MAP RESULT MUST BE INTEGER
TYPE CH(K,J); !CHECK & FAULT OR FLOAT AS REQD
RETURN; ! LEAVE RESULT IN ACC & RET
RETURN
SW(7): ! %STOP
PPJ(5)
RETURN
!-----------------------------------------------------
SW(8): ! %PRINTTEXT
PPJ(39)
J=A(AP); ! PTR IN ARRAY COT
K=0
CYCLE I=J,1,J+(COT(J)&255)//2
IF TARGET&8192=0 START
PRINTSYMBOL(',') UNLESS K=0
OCTN(COT(I),1)
K=K+1; IF K>9 THENSTART; NEWLINE; K=0; FINISH
FINISHELSE OCT(COT(I))
REPEAT
IF TARGET&8192=0 THEN NEWLINE
CTN=J; ! RESET TO REMOVE CHARS FROM COT
AP=AP+1
!----------------------------------------------------------------------
END; ! UI
ROUTINE SEXPR(INTEGERNAME TYPE)
! COMPILE ARITHMETIC EXPRESSION & RETURN TYPE FOUND
! NORMALLY AP PTS TO ALT OF <PLUS''>, BUT IF SCF=2 IT PTS TO
! <NAME> IN <NAME><APP><RESTOFUI> (AS CALLED FROM UI(1), ASSIGNMENT
! STATEMENT.
! ENTERED WITH AP POINTING TO ALT OF <PLUS''>
! EXIT WITH AP POINTING TO ALT OF THE PHRASE WHICH FOLLOWS <EXP>.
ROUTINESPEC STRING(INTEGER DEST,L,N)
INTEGERFNSPEC REAL TO CT(INTEGER X,Y)
ROUTINESPEC TRY FLT(INTEGERNAME TYPE, INTEGER TPVALUE, C
INTEGERARRAYNAME TST,PST)
ROUTINESPEC PPRINT
ROUTINESPEC OPT
ROUTINESPEC TORP(INTEGER I)
ROUTINESPEC SOAP(INTEGER I,J)
ROUTINESPEC OPN(INTEGER OP,L)
INTEGERFNSPEC PSEVAL
ROUTINESPEC EVAL(INTEGER P)
ROUTINESPEC DESC(INTEGER RPP)
INTEGERFNSPEC TYP(INTEGER RPP)
INTEGER SSCF; SSCF=SCF
INTEGER E2Z
INTEGER RPP,APP,STPTR
INTEGERARRAY AP POS(1:64)
INTEGERARRAY RP0,RP,PT,NP,F,OP,STMARK(1:64); !REVERSE POLISH POINTER/TYPE
!-------------------- BODY OF RT SEXPR ---------------
!AP PTS TO ALT OF <PLUS''> IN PHRASE EXP
! FLOAT & OPERATOR STACK ARRAYS
STPTR=0
E2Z=0
RPP=1; ! RP POINTER
TORP(0); ! EXPR TO REV POL, 0=OP STACK BA
!IF SCF WAS 2 OR 3, TORP HAS CHANGED IT TO 0
PPRINT
IF SCF=0 THEN ->L1; ! NOT PART OF A SIMPLE CONDITION
SCF=0; ! RESET FLAG
COMP=A(AP); ! COMPARATOR NUMBER
IF A(AP+5)=0 AND A(AP+7)=2 THEN ->L2; ! 2ND EXPRESSION 0
AP=AP+1
TORP(0); ! 2ND EXPRESSION TO REVERSE POLI
RP(RPP)=19; ! CODE FOR CMP I.E. (1ST-2ND)
PT(RPP)=1; ! FLAG=OPERATOR
NP(RPP)=0
RPP=RPP+1; ! INCREMENT RP POINTER
->L1
L2:
E2Z=E2Z+1
AP=AP+6; ! SKIP 0 EXPR IN ANALYSIS RECORD
RP(RPP)=35; ! OPERATOR = TST
PT(RPP)=1; ! FLAG=OPERATOR
RPP=RPP+1
L1: APP=AP; ! SAVE FINAL ANAL REC POINTER
IF NORELT1=0 AND RPP>2 START
NORELT1=RP(1); ! POINTER TO ALT OF <UI> FOR RECORDS
NORELT2=RP(2)
FINISH
TYPE=PSEVAL; ! PSEUDO-EVALUATE EXPRESSION
IF TYPE=6 THENSTART
PPRINT
STPTR=1
STRING(0,1,RPP-1)
RETURN
FINISH
OPT
EVAL(RPP-1); ! DUMP CODE FOR EXPR EVALUATION
IF E2Z#0 THEN UNLOCK(INTER REG)
IF TYPE=3 AND SSCF=1 AND FLACC=1 THEN FLACC=0
AP=APP; ! RESTORE FINAL ANAL REC POINTER
RETURN
!------------ END OF BODY OF ROUTINE SEXPR ----------------
ROUTINE STRING(INTEGER DEST,L,N)
INTEGER FINOP,I,J,K,M,MAX1,MAX2,P,JMP,BRANCH
STRFLAG=1
IF DEST=0 AND (RP(N)<30 OR PT(N)<0) AND (RP(N)#19 C
OR PT(N)<0) THEN DEST=1
BRANCH=0
P=2
JMP=0
MAX1=0
MAX2=0
K=L
FINOP=RP(N)
IF DEST=1 THENSTART
! PUT STRING ON TEMP
L=L-1
M=0
->FIRST
FINISH
CYCLE I=1,1,N-1
IF PT(I)>0 AND RP(I)=18 THEN RP(I)=12; !CHANGE '-' TO '.'
REPEAT
FIRST:
I=PT(K); ! TYPE OF OPERAND
IF I=-9 THENSTART; ! STRING ARRAY
AP=RP(K)
MAX1=LINK(LINK(A(AP)))
MAX1=TAG(MAX1)
ARRAD(1,J)
->SECOND
FINISH
IF I=-8 THENSTART; ! STRING
J=RP0(K)<<13!RP(K)
->SECOND
FINISH
IF I=-10 THENSTART; ! STRING CONST.
J=X'E000'!(RP(K)*2)
->SECOND
FINISH
IF I=-5 THENSTART; ! CONST.
J=RP(K)
IF J<0 THEN J=J*(-1)
->SECOND
FINISH
IF I=-1 OR I=-2 THENSTART; ! MAP/FN
OPN(0,K)
! STORE RESULT IN R3 UNLESS OP IS ==
D11A(MOV,0,R0,0,0,R3,0) UNLESS FINOP=37
UNLOCK(0)
J=3
->SECOND
FINISH
IF I=1 AND RP(K)=35 THENSTART; ! %IF A='' %THEN _______
FINOP=40
J=0
->SECOND
FINISH
WRITE(K,1);WRITE(I,1);NEWLINE
FAULT(58)
RETURN
SECOND:
K=K+1
IF K>L+1 THEN ->TRAP1
IF J=3 THENSTART; ! ARRAY
D11A(MOV,0,R3,0,0,R2,0); !MOVE ELEMENT ADDRESS TO R2 INCASE SECOND
!STRING IS ARRAY
M=2
FINISHELSE M=J
MAX2=MAX1
! M HAS TAGS FOR FIRST OPERAND , J FOR SECOND OR ONLY
! TEST %IF A->(B).C
IF FINOP=39 OR (FINOP=19 AND COMP=8) THENSTART
IF STMARK(1)=2 THENSTART
J=0
L=L-1
->TRAP1
FINISH
FINISH
->FIRST
TRAP1:
! CHECK TYPE OF STRING OPERATION & DUMP CODE OR TRAPS &
! MAXIMUM LENGTHS AS REQUIRED. (INIT.)
IF K>L+2 THEN ->TRAP2
IF FINOP=19 THEN FINOP=40; ! <IU>
IF PT(N)<0 THEN FINOP=30
IF WS#0 THEN UP STACK PTR(WS)
IF FINOP<=30 OR FINOP=38 THEN PPJ(40)
IF FINOP=39 THEN PPJ(44)
IF FINOP=37 THENSTART
IF J#3 THENSTART; ! S==S1
DUMP(LOAD,RP0(2)&7,RP(2))
DUMP(STR,RP0(1)&7,RP(1))
DUMP(LOAD,RP0(2)&7,RP(2)+2)
DUMP(STR,RP0(1)&7,RP(1)+2)
FINISHELSESTART; ! S==STRING(ADDR(A(0)))
PAR1(0)=X'3040'
DUMP(STR,RP0(1)&7,RP(1))
FINISH
RETURN
FINISH
IF FINOP=40 THENSTART
IF COMP=8 THEN PPJ(47) ELSE PPJ(49)
FINISH
OCTN(M,1); ! FIRST OPERAND
IF TARGET&8192=0 THEN PRINTSYMBOL(',')
IF M<6 AND M>0 THENSTART
IF MAX2=0 THEN MAX2=255;OCTN(MAX2,1)
IF TARGET&8192=0 THEN PRINTSYMBOL(',');FINISH
OCTN(J,1); ! SECOND OPERAND
IF J<6 AND J>0 THENSTART;PRINTSYMBOL(',') IF TARGET&8192=0
IF MAX1=0 THEN MAX1=255;OCTN(MAX1,1);FINISH
NEWLINE IF TARGET&8192=0
TRAP3:
! CHECK FOR SUB-EXPESSION
->L3 IF K>N
IF K<N THENSTART
M=0
IF FINOP=39 OR (FINOP=40 AND COMP=8) THENSTART
IF STMARK(STPTR)=K THENSTART
STPTR=STPTR+1
CYCLE I=K,1,N
IF PT(I)<0 THEN M=M+1
IF PT(I)>0 AND RP(I)=30 THENSTART
IF M>1 THEN ->L1
RP(I)=12
->L4
L1:
! FIND FIRST OPERAND OF SUB-EXPRESSION
IF PT(K)=1 THEN K=K+1 ELSE ->L2
->L1
L2:
! COMPILE SUB-EXPRESSION
STRING(1,K,I)
K=I+1
J=0
->TRAP2
FINISH
REPEAT
FINISH
FINISH
FINISH
L4:
IF PT(K)>0 THENSTART
IF RP(K)=12 THENSTART; ! IGNORE '.'
K=K+1
->TRAP3
FINISH
L3:
! PLANT TERMINATING TRAPS & LABEL FOR CONDITIONS
IF FINOP<=30 THEN PPJ(42)
IF FINOP=38 THEN PPJ(43)
IF FINOP=39 THEN PPJ(46)
IF FINOP=40 THENSTART
IF COMP=8 THENSTART
PPJ(48)
IF JMP#0 THEN SETLAB(JMP)
FINISHELSE PPJ(50)
FINISH
IF WS#0 THEN UP STACK PTR(-WS)
RETURN
FINISH
->FIRST
TRAP2:
! DUMP INTERMEDIATE TRAPS & JUMPS FOR CONDITIONS
IF FINOP=39 OR (FINOP=40 AND COMP=8) THENSTART
P=P+1
IF P=3 AND COMP=8 THENSTART
P=P-2
IF JMP=0 THEN JMP=BT NEXT
BRANCH=1
FINISH
PPJ(45)
FINISHELSE PPJ(41)
OCTN(J,1)
IF J<6 AND J>0 THENSTART;PRINTSYMBOL(',') IF TARGET&8192=0
IF MAX1=0 THEN MAX1=255;OCTN(MAX1,1);FINISH
NEWLINE IF TARGET&8192=0
IF BRANCH=1 THENSTART
PJ(120,0,JMP)
BRANCH=0
FINISH
IF K=N THEN ->L3
->TRAP3
END
ROUTINE PPRINT
INTEGER I,J,NAME,LH,RH
RETURN UNLESS DIAGS#0
SETS(2)
PRINTSTRING(" RP PT
")
-> L5 IF RPP=1
CYCLE I=1,1,RPP-1
WRITE(I,2)
J=PT(I)
UNLESS -4<=J AND J<=-1 THEN WRITE(RP(I),4) ELSESTART
SPACE; HEX4(RP0(I)); SPACE
LH=RP(I)>>16
RH=RP(I)&X'FFFF'
HEX4(LH)
HEX4(RH)
FINISH
WRITE(J,4)
IF J=-4 OR J=-7 THEN START
NAME=NP(I)
PRINTSTRING(" SCALAR ")
PRINTNAME(NAME) IF 0<=NAME AND NAME<=NNAMES
FINISH
NEWLINE
REPEAT
L5:
END; ! PPRINT
ROUTINE OPT
! TO BE CALLED ONLY AFTER PSEVAL HAS FIXED TAGS IN RP.
! PICKS OUT N=N+1, N=N-1, N=0
! RPP PTS TO ONE BEYOND LAST USED HOLE IN RP/PT.
INTEGER K; K=0
INTEGER I
PPRINT
IF CHECKS&4=0 AND RPP>2 THENSTART
IF PT(1)=-3 AND PT(2)=-3 THENSTART
CYCLE I=RP(1),1,RP(2)-4
->DIFF UNLESS A(I)=A(I+RP(2)-3)
REPEAT
! ARRAY ELEMENTS AGREE
CYCLE I=1,1,RPP-1
IF RP(I)=30 THEN RP(I)=34
REPEAT
DIFF:
FINISH
FINISH
CYCLE I=1,1,RPP-1
RETURNIF PT(I)=-7 AND (TAG OF(POINT1(RP(I)))>>8)&7=7
REPEAT
RETURN IF (RP0(1)>>8)&15#2; ! NOT INTEGER TYPE
IF RPP#6 THEN->L4
IF RP(5)=30 AND PT(5)=1 ANDC
RP(1)=RP(2) AND PT(1)=PT(2) ANDC
PT(4)=2 THENSTART
! PICKING OUT A=A + <SOMETHING>
! A=A - <SOMETHING>
IF RP(3)=1 AND PT(3)=-5 THENSTART
! A=A+1, A=A-1
IF RP(4)=10 THEN K=31; !INC
IF RP(4)=11 THEN K=32 ; !DEC
-> L6
FINISH
IF RP(4)=10 OR RP(4)=11 OR RP(4)=6 THENSTART
! ADD, SUB OR BIS
! A=A+B, A=A-B, A=A!B
RP0(2)=RP0(3)
RP(2)=RP(3)
PT(2)=PT(3)
NP(2)=NP(3)
I=RP(4)
I=12 IF I=6
RP(3)=I + 10; ! OPERATOR IS 20,21 OR 22
PT(3)=1
RPP=4
-> L85
FINISH
FINISH
L4:
IF RPP#4 THEN -> L6
IF RP(3)=30 AND PT(3)=1 ANDC
RP(2)=0 AND PT(2)=-5 THEN K=33; !CLR
L6:
-> L9 IF K=0
RPP=3
RP(2)=K
PT(2)=1
L85:
PPRINT
L9:
END; ! OPT
ROUTINE TORP(INTEGER I)
! TRANSFORM EXPRESSION TO REVERSE POLISH
! ENTERED WITH AP PTG. TO ALT. OF <PLUS''> IN <PLUS''><OPND><EXP>.
SWITCH TORS(1:4)
INTEGER J,K,AP OPND
K=I; !SAVE INITIAL OP STACK PTR.
IF (K>0 AND (OP(1)=39 OR COMP=8)) ORC
(STPTR>0 AND RPP>1) START
IF A(RP(1))=2 START
IF TAG OF(A(RP(1)+1))>>8&7=6 START
K=K+1
OP(K)=30
FINISH
FINISH
FINISH
IF SCF>=2 THENSTART
!FRIG ASSIGNMENT OPERATOR INTO STACK
OP(1)=30
K=1;
!HORRIBLE FRIG HERE. AP PTS TO <NAME> BUT EVAL NEEDS TO
!HAVE PTR TO <OPND>. BUT AP-1 PTS TO ALT OF UI.
!EVAL WILL THINK IT''S ALT OF <OPND>.
AP OPND=AP-1
SOAP(AP OPND,0)
AP=AP+1
AP=AP+1 IF SCF=3
SKIP APP
IF SCF=2 START
! SKIP APP
A(AP OPND)=2; ! MAKE ALT OF '<OPND>' 2=NAME
FINISH ELSE A(AP OPND)=1; ! MAKE ALT OF '<OPND>' 1=NAME_NAME
! AP NOW POINTS TO ALT OF <ASSOP>
IF SCF=3 AND A(AP+1)<=2 THEN A(AP+1)=A(AP+1)!!3
IF A(AP+1)>1 THEN OP(1)=OP(1)+A(AP+1)+5
AP=AP+2; ! PAST ASSOP AND RESTOFUI TO ALT OF <PLUS''>
SCF=0
FINISH
AP=AP+1
J=A(AP); ! <+-?>
AP=AP+1; ! TO PT TO ALT OF <OPND>
IF J=1 OR J=4 THEN ->L1; ! '+' OR 'NULL' ALTERNATIVES
J=J+10; ! CODES FOR UNARY '-' & '¬' OPER
L6:
!
! PICK OUT '-INTEGER CONST' HERE, NEGATNG CONST.
! OTHERWISE INCREMENT OPERATOR STACK PTR & STACK OPERATOR.
!
IF J=12 AND A(AP)=3 AND A(AP+1)=2 THEN C
A(AP+2)=-A(AP+2) ELSE START
K=K+1
OP(K)=J
FINISH
L1:
J=A(AP); ! ALT OF <OPND>
! 1:RECNAME_RECELT 2:NAME-APP 3:CONST 4:SUB-EXPR
IF J#4 THEN SOAP(AP,0); ! STORE ANAL REC POSITION OF OPE
-> TORS(J)
TORS(1): ! RECNAME_REC ELT
AP=AP+3; ! PAST RENAME IDEN AND RECELT IDEN
-> L4
TORS(2): ! NAME-APP
AP=AP+2; ! POINTER TO <APP>
SKIP APP; ! POINTER TO <EXPR>
->L4
!
TORS(4): ! SUB-EXPRESSION
STPTR=STPTR+1
STMARK(STPTR)=RPP
STMARK(STPTR+1)=0
AP=AP+1; ! TO PT TO ALT OF <PLUS''> IN SUB-EXPR
TORP(K); ! SUB-EXPR TO REV POL, K=OP STAC
->L4
!
TORS(3): ! CONST.
AP=AP+4; ! SKIP <CONST>, LEFT ON <EXPR>
IF A(AP-3)>3 THEN AP=AP-2; ! STRING CONST.
L4: IF A(AP)=2 THEN ->L5; ! END OF EXPR OR SUB-EXPR (NULL ALT OF <EXP>)
J=A(AP+1); ! <OP>
AP=AP+2; ! ON <OPERAND>
L7: IF K=I OR PREC(J)>PREC(OP(K)) THEN ->L6; ! OPERATOR STACK
! EMPTY
! OR NEW OPERATOR HAS HIGHER PRECEDENCE.
SOAP(OP(K),1); ! UNSTACK TOP OPERATOR
K=K-1; !USED TO BE DONE IN SOAP...
->L7
!
! END OF SUB-EXPRESSION.
L5: AP=AP+1; ! POINTER AFTER EXPRESSION
L8: IF K=I THENRETURN ; ! ALL OPERATORS UNSTACKED
SOAP(OP(K),1); ! UNSTACK OPERATOR
K=K-1; !USED TO BE DONE IN SOAP...
->L8
END; ! TORP
ROUTINE SOAP(INTEGER I,J)
! STORE IN RP & PT ARRAYS, I=ANAL REC PTR , J= OP/OPD FLAG
IF RPP<=31 THEN ->L1; ! STILL ROOM
FAULT(68); ! EXPR TOO LONG
RPP=1; ! TRY AND CONTINUE
L1:
RP0(RPP)=0
RP(RPP)=I; ! STORE OP/OPD
PT(RPP)=J; ! STORE FLAG
NP(RPP)=0
RPP=RPP+1; ! NEXT POSITION
!FOLLOWING IS NOW DONE IN TORP, AFTER BRINGING SOAP OUTSIDE TORP.
!%IF J#0 %THEN K=K-1; ! DECREMENT OP STACK POINTER FOR
END; ! SOAP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
INTEGERFN PSEVAL
! PSEUDO-EVALUATION, CHECKING, FINDING FLOAT POSITIONS
INTEGER TP,PRP,I,J,K,KK,II,JJ,CONSTTYPE
INTEGERARRAY TST,PST(1:64); !TYPE AND POINTER FOR PSEUDOEVAL
CONSTTYPE=0
TP=0; ! TST & PST STACK POINTER
PRP=1; ! RP POINTER
!
! DEAL WITH OPERAND
L10:
I=RP(PRP); ! ANAL REC POSITION OF NEXT OPERAND
! 1=RECNAME_RECELT 2=NAME 3=CONST
IF A(I)=2 THEN ->L1; ! OPERAND = <NAME>
IF A(I)=1 THEN -> REC ELT
!
! CONST
J=A(I+2); ! CONST VALUE
L=A(I+3); ! REAL CONST
I=A(I+1); ! CONST TYPE
IF I>3 THENSTART; ! STRING CONST
RP(PRP)=I ; ! POINTER TO POSITION IN CT
PT(PRP)=-10
I=6
IF CONSTTYPE=1 THEN TST(1)=6
->L2
FINISH
IF I=3 THENSTART; ! REAL CONST
PT(PRP)=-6
! PUT VALUE IN CONST TABLE, DISPLACEMENT (BYTES) IN BOTTOM
! 16 BITS OF RP, WITH 'LEVEL'=7
K=REAL TO CT(J,L)
RP0(PRP)=7
RP(PRP)=K<<1
FINISH ELSE START
!INTEGER CONST
IF J=0 AND PRP=1 AND RP(RPP-1)=19 C
AND PT(RPP-1)>0 START; ! 1ST EXPRESSION 0
RP(RPP-1)=35
PRP=2
TORF=1
->L10
FINISH
RP(PRP)=J
PT(PRP)=-5
CONSTTYPE=PRP
FINISH
-> L2
!
REC ELT:
AP POS(PRP)=I
NP(PRP)=A(I+1); ! RECORD NAME POINTER
K=TAG OF(A(I+1)); ! RECORD NAME TAG WORD (X'1701')
KK=TAG OFF(A(I+1)); ! LH16=PTR TO FMT TAGS RH16=RECNAME DISP
IF KK>5 THEN REC DISP(I,K,KK,II) ELSESTART
K=TAG OF(LINK(A(I+1)))
KK=TAG OFF(LINK(A(I+1)))
REC DISP(I,K,KK,II)
KK=TAG OFF(A(I+1))
FINISH
-> L4
!
! NAME
L1:
AP POS(PRP)=I
NP(PRP)=A(I+1); ! NAME POINTER
K=TAG OF(A(I+1)); ! POINTER TO NAME TAG WORD
KK=TAG OFF(A(I+1))
IF K#0 THEN ->L3
PRINTNAME(A(I+1))
FAULT(16); !NAME NOT SET
K=X'0200'; ! SET TYPE AS INTEGER TO AVOID D
KK=14; ! JUST TO BE > 6
-> L4
L3:
! TURN RECORDNAME TO INTEGER TO ALLOW ASSIGMENT TO IT
IF K>>8=X'17' START
K=(K&X'FF') ! X'1200'; ! FORM,TYPE ETC
KK=KK&X'FFFF'; ! 'AND' OFF DISP FOR RECORDNAME
FINISH
J=K>>12; ! 'FORM' OF NAME
IF J>1 THEN ->L5; ! NOT SCALAR
!
! SCALAR
IF A(I+2)=1 THEN FAULT(19); ! SCALAR HAS PARAMS
L4:
RP0(PRP)=K; ! STORE NAME TAGS
RP(PRP)=KK
! REGISTER TYPE IF 'DISP' FIELD IS LESS THAN 6
IF KK<6 THEN PT(PRP)=-7 ELSE PT(PRP)=-4
IF K>>8&7=6 START
PT(PRP)=-8
IF CONSTTYPE=1 THEN TST(1)=6
FINISH
-> L6
L5:
RP(PRP)=I+1; ! STORE POINTER TO <NAME>
IF J>=4 THEN ->L7; ! ROUTINE/FN/MAP 'FORM'
!
! ARRAY ELT
! SPECIAL ASSIGNMENT TO UNSUBSCRIPTED ARRAY NAME.
IF K>>8&7=6 START; ! STRING ARRAY ELEMENT
PT(PRP)=-9
IF CONSTTYPE=1 THEN TST(1)=6
->L6
FINISH
IF CHECKS&64#0 AND A(I+2)=2 THENSTART
K=K&X'FFF'; ! SET FORM TO SCALAR
-> L4
FINISH
II=LINK(LINK(A(I+1)))
IF CHECKS&4=0 THENSTART ; ! ARRAY BOUND CHECKING OFF
IF II&X'8000'#0 THENSTART ; ! CONSTANT BOUNDED ARRAY
IF A(I+8)=0 AND A(I+9)=2 THENSTART ; ! CONSTANT
! ARRAY ELEMENT
K=K&X'FFF' ;! SET FORM TO SCALAR
JJ=(K&X'0F00')>>8
IF TAG1(II&X'7FFF')#0 THEN K=K!15
II=TAG(II&X'7FFF')
KK=II+(A(I+7)<<(JJ-1))
->L4
FINISH
FINISH
FINISH
PT(PRP)=-3; ! FLAG AS 'ARRAY' ELEMENT
->L6
L7:
! TYPE FLD IS 0 FOR ROUTINE FORM:
IF K>>8&15#0 THEN ->L8; ! NOT A ROUTINE NAME
FAULT(23); !RT NAME IN EXPR
K=X'0200'; ! SET AS INTEGER TO AVOID DIAGNO
->L4
!
! FUNCTION/MAP
L8:
IF K>>12=4 THEN I=-2 ELSE I=-1
! I IS -2 FOR FN, -1 FOR MAP
PT(PRP)=I; ! FLAG AS 'FUNCTION' OR 'MAP'
L6:
I=K>>8&7; ! 'TYPE' OF NAME
! FOR %EXTERNAL, 8-BIT IS SET IN TYPE FIELD.
!
! HERE OPERAND HAS BEEN DEALT WITH
L2:
TP=TP+1; ! INCREMENT STACK POINTER
TST(TP)=I; ! STACK 'TYPE' OF OPERAND
L12:
PST(TP)=PRP; ! STACK POINTER TO REV POL ARRAY
F(PRP)=0; ! SET TO 'NO FLOAT' (MAY BE OVER
!
! PROCEED TO NEXT RP/PT ENTRY
PRP=PRP+1
IF PRP=RPP THENRESULT =TST(1); ! END OF RP ARRAY,
! RESULT=TYPE
IF PT(PRP)=0 THEN ->L10; ! OPERAND NEXT
!
! OPERATOR NEXT
I=RP(PRP); ! TYPE OF OPERATOR
IF I<12 OR I=19 OR I=30 OR I>=36 THEN ->L11; ! BINARY OPERATORS
IF TST(TP)<=2 OR TST(TP)=6 THEN ->L12; ! INTEGER OPERAND ON 'TYPE' STAC
!
! THEN OPERAND IS REAL
IF I=12 THEN ->L13; ! UNARY '-'
! IF OPERATOR IS TST, ITS THE FINAL OPERATOR AND WE DONT WANT IT
! FOR REAL OPERAND, SO GET OUT
IF I=35 THEN START
RPP=RPP - 1
RESULT=TST(1)
FINISH
FAULT(24); !REAL VARIABLE
TST(TP)=2; ! TYPE TO INTEGER TO AVOID DIAGS
->L12
L13:
RP(PRP)=18; ! CHANGE OPERATOR TO '-' FLOATIN
->L12
!
! BINARY OPERATOR I=OPERATOR NO.
L11:
TP=TP-1; ! DECREMENT 'TYPE' STACK POINTER
PT(PRP)=PST(TP); ! FILL IN POINTER TO POSITION OF OPERAND IN RP STACK
J=TST(TP); ! 'TYPE' OF 1ST OPERAND
K=TST(TP+1); ! 'TYPE' OF 2ND OPERAND
!
! PST(TP) PTS TO OPERAND 1 AND J=TYPE
! PST(TP+1) PTS TO OPERAND 2 AND K=TYPE
! IF AT LEAST ONE OF THE OPERANDS IS REAL, CHECK IF EITHER
! IS AN INTEGER CONST, AND IF SO, FLOAT IT AND PUT IT IN
! THE CONST TABLE.
!
!
IF K=6 OR J=6 THEN ->L12
IF J>2 OR K>2 OR I=8 THENSTART
TRY FLT(J,TP,TST,PST)
TRY FLT(K,TP+1,TST,PST)
FINISH
IF I=8 THEN ->L15; ! '/' - BOTH OPERANDS FLOATING
IF J<=2 AND K<=2 THEN ->L12; ! BOTH OPERANDS INTEGER TYPE
! THEN AT LEAST ONE OPERAND IS REAL
IF I=19 THEN RP(PRP)=11; ! CHANGE CMP->SUB (LATER TO BECOME SUBF)
IF I=30 THENSTART; ! MOVE
IF J=3 AND K<=2 THEN F(PST(TP+1))=1; !FLT FOR 1ST OPND
IF J<=2 AND K=3 THEN FAULT(24)
-> L12
FINISH
IF I>6 THEN ->L16; ! OPERATORS CAN HAVE FLOATING OP
FAULT(24); !REAL OPERAND
TST(TP)=2; ! SET TYPE TO INTEGER TO AVOID DIAGS
->L12
L16:
IF I=7 THEN ->L17; !'**'
RP(PRP)=RP(PRP)+6; ! CHANGE OPERATOR TO 'FLOATING' FORM
!
! REAL DIVIDE
L15:
IF J<=2 THEN F(PST(TP))=1; ! SET 'FLOAT' FLAG FOR 1ST
! OPERA
IF K<=2 THEN F(PST(TP+1))=1; ! SET 'FLOAT' FLAG FOR 2ND
! OPERA
TST(TP)=3; ! 'TYPE' OF RESULT = FLOATING
->L12
!
! EXPONENTIATE
L17:
IF J=3 THEN RP(PRP)=14; ! FLOATING EXP OPERATOR
->L12
END; ! PSEVAL
INTEGERFN REAL TO CT(INTEGER X,Y)
! TO BE PROGRAMMED DIFFERENTLY ON SYSTEM 4.
! PARAM IS PDP-11 REAL IN TWO 16-BIT INTEGERS.
INTEGER I
I=CT NEXT
COT(I)=X
COT(CTNEXT)=Y
RESULT=I
END; ! REAL TO CT
!
!
ROUTINE TRY FLT(INTEGERNAME TYPE, INTEGER TPVALUE, C
INTEGERARRAYNAME TST,PST)
INTEGER W
W=PST(TPVALUE)
IF TYPE=2 AND PT(W)=-5 THENSTART
FLT11(RP(W))
RP0(W)=7
RP(W)=REAL TO CT(FLIT,FLOT)<<1
PT(W)=-6
TYPE=3
TST(TPVALUE)=3
FINISH
END; ! TRY FLT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE EVAL(INTEGER P)
! P IS A POINTER IN THE RP/PT/NP ARRAYS
! DUMP CODE FOR EVALUATION OF EXPRESSION
INTEGER I,J,K,L
INTEGER LTWSP; LTWSP=0
I=PT(P); ! POINTER/TYPE OF LAST REV POL E
IF I<0 THEN ->L1; ! OPERAND
! OPERATOR I PTS TO OPERAND1
! OPERAND2 IS THE ONE PTD TO BY P-1
J=RP(P); ! OPERATOR
K=P-1; ! START OF 2ND OPERAND
IF UCN(J)>1 THEN ->L2; ! BINARY OPERATOR
!
! UNARY OPERATOR
IF J=34 THENSTART
EVAL(K)
IF FLACC=0 THEN MAA(0,ACC,6,R3) ELSESTART
AD(3); OCODE(0,6); FINISH
->L4
FINISH
IF 33>=J AND J>=31 THENSTART ; !UNARY OP ON CORE
OPN(J,K)
->L4
FINISH
EVAL(K); ! DUMP CODE TO EVALUATE OPERAND
J=OPR(J)
!(NEGF %ELSE NEG OR NOT OR TST).
IF J=12 THEN AD(12) ELSESTART
IF TYPE=1 THEN J=J!256
DUMP(J,0,0)
FINISH
->L4
!
! BINARY OPERATOR J HAS OPERATOR NO.
L2:
IF RP(K)=12 AND PT(K)=1 AND PT(K-1)=-5 THENSTART
K=K-1
RP(K)=-RP(K)
FINISH
!
! IS OPERATOR A 'STORE'?
IF 20<=J AND J<=30 THENSTART
EVAL(K); ! EVALUATE 2ND
OPN(J,I); ! STORE IN FIRST/ADDS, SUBS, BISS TO FIRST
->L99
FINISH
!
! IS OPERATOR '==' ?
IF J=37 START
IF P#3 START; FAULT(81); RETURN; FINISH
IF PT(1)#-7 START
IF RP0(1)&X'1000'=0 START; FAULT(82); RETURN; FINISH
FINISHELSESTART
IF (TAG OF(LINK(A(NORELT1+1)))>>8)&7=7 ANDC
A(NORELT1)#1 START
LOSE(RP(1))
RP(1)=TAG OFF(A(NORELT1+1))&X'FFFF'
PT(1)=-4
FINISH
FINISH
IF PT(2)=-7 AND (TAG OF(LINK(A(NORELT2+1)))>>8)&7=7 ANDC
A(NORELT2)#1 START
LOSE(RP(2))
RP0(2)=RP0(2)!X'1000'
RP(2)=TAG OFF(A(NORELT2+1))&X'FFFF'
PT(2)=-4
FINISH
IF RP0(2)=0 THEN L=TAG OF(A(RP(2))) ELSE L=RP0(2)
IF (L>>8)&7#(RP0(1)>>8)&7 START; FAULT(83); RETURN; FINISH
RP0(1)=RP0(1)&X'0FFF' UNLESS NORELT1>0 AND A(NORELT1)=1
IF L&X'1000'#0 AND A(NORELT2)#1 AND PT(2)#-3 C
THEN DUMP(LOAD,RP0(2)&15,RP(2)) ELSESTART
IF PT(2)<(-3) AND L&X'1000'=0 THENC
LD ADDR(-1,RP0(2)&15,RP(2)) ELSESTART
EVAL(K)
IF PT(2)>=-3 THEN PAR1(0)=PAR1(0)&7!ENCODE(6) ELSESTART
UNLESS RP(2)>X'FFFF' START
! CHANGE INDIRECT TO DIRECT FOR RECORDS UNLESS %RN_%RN
IF (NORELT2>0 AND A(NORELT2)=2) C
OR TAG OFF(TAG OFF(A(NORELT2+1))>>16)>>16#2 START
IF (PAR1(0)>>7)&15=7 THEN PAR1(0)=PAR1(0)-X'80'
IF (PAR1(0)>>7)&15=10 THEN PAR1(0)=PAR1(0)-X'80'
FINISHELSESTART
IF (PAR1(0)>>7)&15=6 THEN PAR1(0)=PAR1(0)+X'80'
IF (PAR1(0)>>7)&15=9 THEN PAR1(0)=PAR1(0)+X'80'
FINISH
FINISH
FINISH
FINISH
FINISH
PAR3(0)=0
OPN(J,I)
->L99
FINISH
!
IF J=19 THEN ->L9; ! CMP
IF PT(I)>=-3 OR F(I)#0 THEN ->L6; ! 1ST OPERAND A NODE
IF PT(K)>=-3 OR F(K)#0 THEN ->L7; ! 2ND OPERAND A NODE
OPN(0,I); ! LOAD 1ST OPERAND
OPN(J,K); ! OPN BETWEEN INTER & 2ND OPERAND
->L4
!
! 2ND OPERAND A NODE
L7:
EVAL(K); ! EVALUATE 2ND OPERAND
IF UCN(J)=2 THEN ->L8; ! OPERATOR COMMUTATIVE
PUSH(TEMPHEAD,TYP(K),FLACC)
IF FLACC#0 THEN TSAVE(TWSP) ELSE SAVE INTER
!(ABOVE, IF OPERAND1 IS REAL AND FLACC IS
! IN USE...)
OPN(0,I); ! LOAD 1ST OPERAND
->L10
!
! OPERATOR COMMUTATIVE
L8:
OPN(J,I); ! OPERATION BETWEEN ACC & 1ST OP
->L4
!
! 1ST OPERAND A NODE
L6:
IF PT(K)>=-3 OR F(K)#0 THEN ->L9; ! 2ND OPERAND A NODE
EVAL(I); ! EVALUATE 1ST OPERAND
OPN(J,K); ! OPERATION BETWEEN ACC & 2ND OP
->L4
!
! 1ST & 2ND OPERANDS ARE NODES J HAS OPERATOR NO.
L9:
EVAL(K); ! EVALUATE 2ND OPERAND
PUSH(TEMPHEAD,TYP(K),FLACC)
IF FLACC#0 THENSTART
TSAVE(TWSP); ! PARAM IS DISPLACEMENT IN BYTES
LTWSP=TWSP
TWSP=TWSP+4; ! INC BY 4 BYTES
FAULT(41) IF TWSP>TWSPLIM
FINISH ELSE SAVE INTER
EVAL(I); ! EVALUATE 1ST OPERAND
TWSP=LTWSP IF LTWSP#0
!
!
! 2ND OPERAND WAS A NODE AND ITS VALUE IS
! IN REAL OR INT TEMP.
L10:
!
!
K=OPR(J); ! OPERATION CODE/MNEMONIC
POP(TEMPHEAD,I,J)
IF 2<=K AND K<=8 THENSTART
! OPERAND1 IS TEMP, OPERAND2 INTER
! IN THE IMP EXPRESSION, THE RH OPERAND GOES TO (SP), THE LH TO R0
I=INTER TO REG(0)
RESTORE INTER
INTER TO SP
EM(100+K)
UNLOCK(0)
SET INTER(0)
->L4
FINISH
! OPERATE ON INTERMEDIATE WITH TEMPORARY.
! INDEX = -1 BELOW MEANS OPERAND IS AT (SP)
IF J#0 THENSTART; ! J IS FORMER 'FLACC'
AD(K)
OCODE(LEVEL,TWSP); ! PARAM AS BYTE DISPL
!(TWSP IS AN OFFSET FROM CURRENT LEVEL)
FINISH ELSE START
K=K!256 IF TYPE=1 OR I=1; ! UP OPTYPE FOR BYTE
DUMP(K,-1,0); ! OPERATE ON INTER WITH TEMP
FINISH
->L4
L1:
OPN(0,P); ! DUMP LOAD OPERATION FOR OPERAND
L4:
IF F(P)#0 THEN FLOAT; ! 'FLOAT' CALL
L99:
END; ! EVAL
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE OPN(INTEGER OP,RP POSN)
! DUMP SIMPLE OPERATION, OP=OPERATOR, RP POSN=RP POSITION OF OPERAND
INTEGER I,II,J,K,L,M,KK,AP0
INTEGER OPND TYPE,NN,EQEQ
SWITCH TYPE(-10:-1)
EQEQ=OP
IF OP=37 THEN OP=30
OPNS=OPNS+1
L1:
PPRINT
AP0=RP0(RP POSN)
AP=RP(RP POSN); ! ANAL REC POINTER OR NAME TAGS
I=PT(RP POSN); ! KIND OF OPERAND
J=OPR(OP); ! GET CODE FOR OPERATOR
K=AP0&15; ! LEVEL
L=AP
OPND TYPE=TYP(RP POSN)
-> TYPE(I)
!
TYPE(-1): ! MAP TYPE
RELEASE(0)
IF OP>=30 THEN SAVE INTER
RT
! RT PLANTS CODE LEAVING ADDRESS OF ENTITY REFERENCED IN R0.
! IF ITS STR INC DEC OR CLR, THIS IS THE LAST OPERATION. RESTORE
! WILL LOCK A REG IF IT LOADS ONE. IF ITS ANYHOTHER OP
! ITS AN OP ON INTER WITH WHAT K,L DESCRIBE.
LOCK(0)
IF OP>=30 THEN RESTORE INTER
UNLOCK(0)
K=R0
L=0
-> L9
TYPE(-2): ! FUNCTION TYPE
! ONLY 'LOAD TO INTERMEDIATE' IS REQD, SINCE A FN CALL IS A NODE.
RELEASE(0)
RT; ! DUMP CALL ON FUNCTION
IF OPND TYPE=3 THEN FLACC=1 ELSE SET INTER(0)
RETURN
!
TYPE(-3): ! ARRAY ACCESS
IF OP>=30 AND FLACC=0 THEN KK=3 ELSE KK=1
! AP POINTS TO <NAME>, AP+1 TO <APP>.
! ALLOW REF TO UNSUBSCRIPTED ARRAYNAME FOR COMMUNICATIONS PACKAGE.
IF CHECKS&64#0 AND A(AP+1)=2 THEN -> L40; ! NULL <APP>
ARRAD(KK,K)
K=K+100; L=0;
-> L9
TYPE(-4): ! SCALAR
L40:
I=TAG OF(NP(RP POSN))
IF AP0>>12=0 THEN START; ! VALUE TYPE
IF OPND TYPE#3 AND I>>12#2 THENC
START; ! NOT REAL OR ARRAY
!
! FOR INC,DEC,CLR,ADDS,SUBS,BISS,STR ITS NECESSARY TO FORGET
! ANY ASSOCIATED REGISTER.
IF 20<=OP AND OP<=33 AND AP<6 THEN LOSE(AP)
!
! FOR STR INTER, WHERE INTER IS IN A REGISTER, WE LOSE THE REGISTER
! REFERENCE AND GIVE IT THE NEW ONE.
IF J=STR AND INTER BASE=6 THEN START
KK=INTER REG
LOSE(KK)
IUSE(KK)=32; ! REGISTER VARIABLE
NN=NP(RP POSN); ! GET PTR TO NAME
POINT1(KK)=NN
POINT(KK)=0
! PUSH NEW DESCRIPTOR CELL IN FRONT OF CURRENT TAGS
PUSH(LINK(NN),I,KK); ! RH TAGS WORD = REG NO
FINISH
FINISH; ! NOT REAL
-> L9
FINISH; ! VALUE TYPE
!
! SCALAR NAME TYPE
!
! FOR A REC ELT REFERENCE, RP(=L) HAS
! LH16=REL DISP OF REC ELT RH16=DISP OF RECORDNAME
IF OPND TYPE=3 OR L>X'FFFF' START; ! REALNAME/REC ELT
IF TAG OFF(NP(RP POSN))<=5 START
K=TAG OFF(NP(RP POSN))
->L41
FINISH
K=ADDRDUMP(K,L&X'FFFF'); ! ADDRESS WORD TO REG K
UNLESS OPND TYPE=3 START
LOSE(K)
IUSE(K)=32
NN=NP(RP POSN)
POINT1(K)=NN
POINT(K)=0
PUSH(LINK(NN),I,K)
FINISH
L41:
K=K+100; ! REG MNEMONIC
L=L>>16; ! 0 FOR REALNAME, BUT RELDISP FOR REC ELT
-> L9
FINISH; ! REALNAME/REC ELT
K=K+32; ! LEVEL, INDIRECT
-> L9
!
TYPE(-7): ! REGISTER TYPE
! THE REGISTER MIGHT HAVE GOT LOST DURING THE EXPRESSION
! EVALUATION. CHECK THIS, AND TREAT AS SCALAR IF NECESSARY.
! THIS SITUATION ARISES FROM
! RE-ASSIGNMENT TO A VARIABLE CURRENTLY HELD IN A
! REGISTER.
! ANOTHER HANG-UP IS IF FOR THE TRAP OPERATORS, R0 IS TAKEN BELOW
! SO IF R0 IS THE REGISTER ITS ABOUT TO GET LOST BELOW. THEN TREAT
! AS SCALAR (8 IS THE TOP NUMBER FOR TRAP OPERATORS).
! L IS THE REGISTER.
IF 20<=OP AND OP<=33 AND (POINT1(L)<=0 C
OR (TAG OF(POINT1(L))>>8)&7#7) THEN LOSE(L)
IF J<=8 AND L=0 START
IF (TAG OF(POINT1(0))>>8)&7=7 START
I=FREE REG
MAA(0,100,0,100+I)
POINT1(I)=NP(RP POSN)
IUSE(I)=32
TAG1(LINK(POINT1(0)))=I
PUSH(LINK(POINT1(0)),I,K)
FINISH
LOSE(L)
FINISH
NN=NP(RP POSN)
IF TAG OF(NN)>>12=1 AND TAG OF(NN)>>8&15#7 THEN LOSE(L)
IF TAG OFF(NN)>5 START
RP0(RP POSN)=TAG OF(NN)
RP(RP POSN)=TAG OFF(NN)
IF (RP0(RP POSN)>>8)&7=7 START
REC DISP(AP POS(RP POSN),RP0(RP POSN),RP(RP POSN),II)
OPND TYPE=(RP0(RP POSN)>>8)&7
FINISH
PT(RP POSN)=-4
IF EQEQ=37 AND II=1 THEN RP0(RP POSN)=RP0(RP POSN)&X'0FFF'
PPRINT
-> L1
FINISH
K=L+100; ! L=RP(RP POSN) IS THE REG NO
M=TAG OF(LINK(NN))
IF (M>>8)&7=7 START
L=TAG OFF(LINK(NN))
K=TAG OFF(NN)+100
REC DISP(AP POS(RP POSN),M,L,I)
OPND TYPE=(M>>8)&7
RP0(RP POSN)=M
L=L>>16
->L9
FINISH
L=-1; ! INDICATE REG TYPE
-> L9
!
TYPE(-5): ! CONST VALUE, INTEGER
K=14; ! INDICATE IMMEDIATE CONST.
!
TYPE(-6): ! REAL CONST. TAGS ARE ALREADY SET UP IN RP
! ALL END UP HERE
L9:
! ALL OPNS VIA HERE
IF J<=8 THENSTART
!3: AND 4: MULT 5: DIV
!6: SHL 7: SHR 8: LXOR
!9:EXPF 10:ADDF 11:SUBF 12:NEGF
!13:MULF 14:DIVF 15:SPARE
!(9,12,15 WILL NOT HAPPEN HERE).
!
! FOR THESE FUNCTIONS, WE WANT FIRST THE INTERMEDIATE RESULT
! PUSHED, THEN THE SECOND OPERAND. (THE RESULTING INTERMEDIATE RESULT
! IS LEFT IN R0)
!
I=INTER TO REG(0)
I=3
IF OPND TYPE=1 AND EQEQ#37 THEN I=259; ! ADD 256 TO OPERATOR FOR BYTE
! SOME OPTIMISING FOR AND, SHL AND SHR
IF K=14 START; ! CONST OPERAND
IF CHECKS&2048#0 AND (J=6 OR J=7) START; ! ASH AVAILABLE
IF J=7 THEN L=-L; ! RIGHT SHIFT
D11A(ASH,0,R0,0,8,0,L)
LOSE(0)
RETURN
FINISH; ! ASH AVAILABLE
IF J=3 START; ! AND
D11A(BIC,8,0,¬L,0,R0,0)
LOSE(0)
RETURN
FINISH; ! AND
IF L=1 START; ! CONSTANT=ONE
IF J=7 START; ! SHR
D11A(CLC,0,0,0,0,0,0)
D11A(ROR,0,0,0,0,R0,0)
LOSE(0)
FINISH; ! SHR
IF J=6 THEN D11A(MASL,0,0,0,0,R0,0)
LOSE(0)
RETURN
FINISH; ! CONSTANT=ONE
FINISH; ! CONST OPERAND
DUMP(I,K,L); ! MOV L(K),-(SP)
EM(100+J)
RETURN
FINISH
!
!
IF (9<=J AND J<=15) OR OPND TYPE=3 THEN START; ! REAL OPN
IF J=LOAD THEN J=0; ! SET CODE FOR LDF
IF J=STR THEN J=3; ! SET CODE FOR STRF
AD(J)
!DEAL SPECIALLY WITH X**CONST. PLANT AN EXTRA PARAM OF
! '6' TO INDICATE TO INTERPRETER THAT INTEGER EXPONENT
!FOLLOWS
IF K=14 THENSTART; ! REAL EXPONENTIATE
OCTN(6,0)
OCTN(L,0)
RETURN
FINISH
!DEAL WITH FN OR ARRAY ELT ELSE SCALAR.
IF L=0 THEN OCTN(K-100,0) ELSE DESC(RP POSN)
RETURN
FINISH; ! REAL OPN
!
! DUMP OPERATION ON INTERMEDIATE
IF OPND TYPE=1 AND EQEQ#37 THEN J=J ! 256; ! BYTE OPERATION
DUMP(J,K,L)
RETURN
TYPE(-8):
TYPE(-9):
TYPE(-10):
FAULT(59); ! STRING VARIABLE IN ARITHMETIC EXP.
END; ! OPN
INTEGERFN TYP(INTEGER RPP)
! PARAM IS POSN OF OPERAND IN RP STACK
! IF THE OPERAND IS A FN OR ARRAY ELT, RP ENTRY POINTS TO
! <NAME> IN AR
INTEGER I,W
! IF OPERAND IS AN OPERATOR, USE TYPE OF OPERATOR TO GIV
! RESULT.
I=PT(RPP)
IF I>0 THENSTART
W=RP(RPP)
IF F(RPP)#0 OR W=8 OR (14<=W AND W<=18) THENRESULT=3
RESULT=2
FINISH
IF -3<=I AND I<=-1 THEN C
RESULT=(TAG OF(A(RP(RPP)))>>8)&7
IF I=-6 THEN RESULT=3; !REAL CONST IN CT
RESULT=(RP0(RPP)>>8)&7
END; ! TYP
ROUTINE DESC(INTEGER RPP)
! PLANTS DESCRIPTOR WORD FOR REAL OPERAND.
! DESCRIPTOR FORMAT IS (FROM LEFT)
! BITS 0-2 LEVEL
! 3-15 DISPLACEMENT (FROM LEVEL PTR OR FROM CT IF LEV=7)
! OR REG PTG TO OPERAND IF LEV=0
! DISPLACEMENT IS IN BYTES.
SETS(2)
INTEGER K0,K,LEV,OFF
K0=RP0(RPP)
K=RP(RPP)
LEV=K0&7
OFF=K&X'1FFF'; ! AS BYTE DISPL.
FAULT(42) UNLESS LEV=7 OR LEV<=5
OCODE(LEV,OFF); ! OFFSET AS BYTE DISPL
END; ! DESC
END; ! SEXPR
!---------------------------------------------------------
ROUTINE FLOAT
! CONVERTS ACC FROM FIXED TO FLOATING FORM
AD(1); !FLT
END; ! FLOAT
ROUTINE TOPOL
PRR
RETURN IF POLISH#0
RELEASE(4)
D11A(JSR,0,R4,0,9,152,0)
POLISH=1
END; ! TOPOL
ROUTINE FPOL
RETURN IF POLISH=0
AD(4); ! .+2
POLISH=0
END; ! FPOL
ROUTINE AD(INTEGER I)
INTEGER J
! 0 LDF 138 1 FLT 141 2 STST 142 3 STRF 143
! 4 EXIT 143 5 6 7 8
! 9 EXPF 144 10 ADDF 145 11 SUBF 146 12 NEGF 147
! 13 MULF 148 14 DIVF 149
OWNINTEGERARRAY FNS(0:14)= C
139,141,142,140,151,0,0,0,0,
144,145,146,147,148,
149
SETS(2); !SET UP OBJ STREAM
IF I=9 THEN EXPFFLAG=1
IF I=1 THEN START
J=INTER TO REG(0)
UNLOCK(0)
FINISH
TOPOL UNLESS I=4
IF TARGET&8192=0 START
PRINTSTRING(" .WORD ")
PMN(FNS(I)); NEWLINE
CA=CA+2
FINISHELSE OCT(BINREALS(I))
RETURN IF I=4; ! EXIT NOT TO CHANGE FLACC VALUE.
!FORGET/REMEMBER FLACC USE:
IF 2<=I AND I<=3 THEN FLACC=0 ELSESTART
FLACC=1
REALS=1
FINISH
END; ! AD
ROUTINE TSAVE(INTEGER TWSP)
AD(3); !STRF
OCODE(LEVEL,TWSP); ! OFFSET IN BYTES
END; ! TSAVE
ROUTINE SKIP SEXPR
! SKIP PAST <+-?><OPERAND><EXPR> IN ANALYSIS RECORD, AP INITIALLY
! ON <+-''>.
SWITCH SEX(1:5)
AP=AP+1
L5: AP=AP+2; ! SET AP TO <OPERAND>+1
-> SEX(A(AP-1)); ! SWITCH ON ALT OF <OPND>
SEX(5): AP=AP-1; ! STRING CONST
SEX(4): ! SUB-EXPRESSION
SKIP SEXPR; ! SKIP SUB-EXPRESSION
->L3; ! POINTER IS ON <EXPR>
SEX(1): ! <NAME>_<NAME>
AP=AP+2; ! PAST <NAME> AND <NAME>
-> L3
SEX(2): ! <NAME><APP>
AP=AP+1; ! SET AP TO <APP>
SKIP APP
->L3; ! POINTER TO <EXPR>
SEX(3): ! <CONST>
IF A(AP)>3 THEN AP=AP-2
AP=AP+3; ! SKIP <CONST>
L3: AP=AP+1; ! SET AP TO <EXPR>+1
IF A(AP-1)=1 THEN ->L5; ! MORE OPERANDS TO SKIP
! OTHERWISE NULL OF <EXPR>
END; ! SKIP EXPR
ROUTINE SKIP APP
! SKIP PAST <APP> IN ANALYSIS RECORD, AP INITIALLY ON <APP>.
L1: AP=AP+1; ! POINTER TO <APP>+1 OR <EXPRS>+1
IF A(AP-1)=2 THENRETURN ; ! NO MORE EXPRESSIONS TO SKIP
SKIP SEXPR; ! POINTER TO <EXPRS>
->L1
END; ! SKIP APP
ROUTINE SCCOND(INTEGERNAME LABEL, INTEGER IU,P)
! COMPILE CONDITION I.E. <SC><COND>
! LABEL SET TO BT POSITION FOR LABEL TO FOLLOW UI
! IU IS THE ALT OF <IU>.
! P PTS TO THE <UI> IN ANAL REC.
! IF LABEL IS SET 0 AT ENTRY, PLANT SHORT JUMP, ELSE LONG.
ROUTINESPEC SC
ROUTINESPEC COND
ROUTINESPEC STORE(INTEGER FT)
INTEGER I,J,K,L,APP,M
INTEGER SL; SL=0; !SHORT/LONG INDICATOR
INTEGERARRAY CAP,LVL,TF,JMP,LBL(1:16); ! ANAL REC POINTERS,
! NESTING LEV, TRUE/FALSE, JUMP & LABEL ARRAYS
I=1; ! INDEX TO ARRAYS
L=0; ! NESTING LEVEL
SC; ! PROCESS <SC>
COND; ! PROCESS <COND>
APP=AP; ! PRESERVE FINAL ANAL REC POINTE
L=-1
STORE(IU); !PSEUDO FALSE AT LEVEL -1
L=-2
STORE(3-IU); !PSEUDO TRUE AT LEVEL -2
K=I-1; ! LAST POSITION FILLED IN IN ARR
I=1
L2: J=I; ! FIND POSITIONS TO JUMP TO
L1: J=J+1; ! AFTER COMPARISONS
IF LVL(J)>=LVL(I) OR TF(J)=TF(I) THEN ->L1; ! SKIP HIGHER
! LE
JMP(I)=J; ! JUMP TO COMPARISON POSITION J
I=I+1
IF I<K THEN ->L2; ! MORE JUMPS TO FILL IN YET
! P PTS TO ALT OF <UI>.
IF P<=0 OR A(P)=4 START
! THEN UI IS A JUMP INSTRUCTION.
J=K-1; ! LAST POSITION FILLED IN
TF(J)=3-IU; ! REVERSE FT AT LEVEL 1
JMP(J)=J; ! SET JUMP AS THE UI JUMP
IF P>0 START
AP=P+1
LBL(J)=FIND LABEL; ! FILL IN BRANCH TABLE POSITION
SL=1
FINISH ELSE LBL(J)=-P
FINISH
I=1; ! FILL IN PSEUDO-LABELS FOR INNE
L4:
IF LBL(JMP(I))<0 THEN LBL(JMP(I))=BT NEXT; ! NEXT BAT POSITIO
I=I+1
IF I<K THEN ->L4; ! MORE TO FILL IN
I=1
L7: AP=CAP(I); ! ANAL REC POINTER FOR 1ST EXPR
SCF=1; ! SET FLAG FOR SEXPR
TORF=0
SEXPR(L); ! TO EVALUATE (1ST - 2ND)
M=TF(I)
IF TORF=1 THEN M=M!!3 ; ! 0 EXPR. FIRST
IF M=1 THEN L=FALSE(COMP); ! APPROPRIATE BRANCH
! MNEMONIC
IF M=2 THEN L=TRUE(COMP)
PJ(L,SL,LBL(JMP(I))); ! BRANCH TO REQUIRED POSITION
IF LBL(I)>=0 AND (I#K-1 OR TF(I)=IU) THEN SETLAB(LBL(I))
I=I+1; ! FILL IN LABEL ADDRESS
IF I<K THEN ->L7; ! MORE COMPARISONS YET
LABEL=LBL(K); ! FINAL LABEL
AP=APP; !FINAL ANAL REC PTR
RETURN
ROUTINE STORE(INTEGER FT)
! STORE LEVEL & TRUE/FALSE FLAG
IF I<=16 THEN ->L1; ! ARRAYS NOT FULL YET
FAULT(69); !COND TOO LONG
I=1
L1: LVL(I)=L; ! SAVE NESTING LEVEL
TF(I)=FT; ! SAVE TRUE/FALSE FLAG
LBL(I)=-1; ! SET 'LABEL NOT FILLED IN YET'
I=I+1; ! NEXT ARRAY POSITION
END; ! STORE
ROUTINE SC
SCS=SCS+1
AP=AP+1
IF A(AP-1)=1 THEN ->L1; ! SIMPLE COMPARISON
L=L+1; ! NESTING LEVEL UP 1 FOR SUB-CON
SC; ! PROCESS SUB-<SC>
COND; ! PROCESS SUB-<COND>
L=L-1; ! NESTING LEVEL DOWN AFTER SUB-C
RETURN
L1: CAP(I)=AP; ! ANAL REC POINTER FOR SIMPLE CO
SKIP SEXPR; ! SKIP 1ST EXPR OF COMPARISON
AP=AP+1; ! SKIP COMPARATOR
SKIP SEXPR; ! SKIP 2ND EXPR
END; ! SC
ROUTINE COND
! PROCESS <COND> FOR SIMPLE COMPARISONS
INTEGER I
I=A(AP); ! <COND>
AP=AP+1
IF I=3 THENRETURN ; ! NULL ALTERNATIVE OF <COND>
L1: STORE(I); ! SAVE %AND OR %OR TYPE OF CONDI
SC; ! PROCESS <SC>
AP=AP+1; ! POINTER ON <ANDC>+1 OR <ORC>+1
IF A(AP-1)=1 THEN ->L1; ! MORE %ANDS OR %ORS
END; ! COND
END; ! SCCOND
ROUTINE TO GLOBLS(INTEGER I)
INTEGER J
IF GP>0 THENSTART
CYCLE J=1,1,GP
RETURN IF GLOBLS(GP)=I
REPEAT
FINISH
GP=GP+1
GLOBLS(GP)=I
IF GP=10 THEN F GLOBLS
END; ! TO GLOBLS
ROUTINE F GLOBLS
INTEGER J
SETS(2)
RETURN IF GP<=0
IF TARGET&8192=0 START
PRINTSTRING(" .GLOBL ")
CYCLE J=1,1,GP
PRINTNAME(GLOBLS(J))
PRINTSYMBOL(',') UNLESS J=GP
REPEAT
NEWLINE
FINISH
GP=0
END; ! F GLOBLS
ROUTINE RTSPEC
! COMPILE ROUTINE/FN HEADING OR SPEC
INTEGER I,J,K,L,M,N,T,TT,EXT,JJ,NN,LEN,BGN
! 16 BITS IS PLENTY IN THESE ARRAYS..
INTEGERARRAY PT,PN,LENGTH(1:15); ! PARAMETER TYPES AND NAMES
I=0
EXT=2-A(AP); ! PICK UP 1 FOR %EXT, 0 FOR NULL
AP=AP+1; ! TO ALT OF <RT>
N=A(AP); ! ALT OF <RT> 1 : RT 2 : FN 3 : MAP
IF N=1 THEN ->L1; ! <RT>= %ROUTINE
!
! THEN %FN OR %MAP
AP=AP+1
! SET TYPE, 1=BYTEINTEGER, 2=INTEGER, 3=REAL, 6=STRING
! PLUS 8 FOR %EXTERNAL
I=A(AP)
IF I=6 START
AP=AP+1
IF A(AP)=1 THEN AP=AP+3
FINISH
IF I>3 AND I<6 THEN I=I-2; ! SHORTINT=INT, LONGREAL=REAL
L1: J=A(AP+1); ! <SPEC?> 1=SPEC 2=HDG
K=A(AP+2); ! <NAME> OF %ROUTINE/%FN/%MAP
AP=AP+3; ! TO <FPP>
IF EXT=1 THENSTART
! %EXTERNAL<RT><SPEC>
TO GLOBLS(K)
I=I+8; ! ADD 8 TO TYPE FOR %EXTERNAL
IF J=2 THENSTART
! HEADING
IF LEVEL#0 THEN FAULT(55)
IN EXT=IN EXT+1
FINISH; ! HEADING
FINISH; ! EXT=1
L=0; ! PARAMETER COUNT
!
! TREAT FORMAL PARAMETERS, STORE IN PT/PN.
L6:
! AP PTS TO ALT OF <FPP>
IF A(AP)=2 THEN ->L2; ! NO FORMAL PARAMETERS
LEN=0
IF A(AP+1)=6 THENSTART ; ! STRING PARAM.
IF A(AP+2)=1 THENSTART ; ! STRING HAS LENGTH
IF A(AP+3)=2 AND A(AP+5)=0 THEN LEN=A(AP+4) ELSE FAULT(32)
AP=AP+3
FINISH
AP=AP+5
M=2*A(AP-2)&2!A(AP-1)&1 ;! PARAM. 'FORM'
IF M=2 THEN FAULT(9)
! %IF M=1 %AND LEN>0 %THEN FAULT(72); ! STRINGNAME HAS A LENGTH
M=(M<<4)+6
->L5
FINISH
M=2*A(AP+2)&2!A(AP+3)&1 ; ! PARAMETER 'FORM'
! (%ARRAY/%NAME
IF M=2 THEN FAULT(9); !VALUE TYPE ARRAY
NN=A(AP+1); ! A(AP+1) IS ALT OF <TYPE>
IF NN>3 THEN NN=NN-2; ! SHORTINT=INT, LONGREAL=REAL
M=(M<<4)!NN
AP=AP+4; ! ON <NAME>
L5: IF L=15 THEN ->L4; ! 15 PARAMETERS FOUND
L=L+1; ! INCREMENT PARAMETER COUNT
PT(L)=M; ! STORE PARAMETER FORM/TYPE
PN(L)=A(AP); ! STORE PARAMETER NAME IDENT NO.
LENGTH(L)=LEN
AP=AP+2; ! TO <NAMES>+1
IF A(AP-1)=1 THEN ->L5; ! MORE NAMES
->L6
L4: FAULT(8); !TOO MANY PARAMS
!
! PARAM TAGS NOW STORED AWAY.
! CHECK WHETHER RT/FN NAME DECLARED.
L2: T=TAG OF(K); ! GET NAME TAG
IF T=0 THEN ->L7; ! NAME NOT YET SET AT ALL
IF T&15#LEVEL THEN ->L7; ! NAME NOT SET AT THIS LEVEL
! HERE N CONTAINS ALT OF <RT> 1 RT 2 FN 3 MAP
! I CONTAINS TYPE 1 BYTE 2 INT 3 REAL PLUS 8 FOR %EXT
IF N<=2 THEN JJ=64 ELSE JJ=128
IF T>>8=JJ!(I&7) AND J=2 THEN ->L8; ! TAGS AGREE & NOT A SPEC
FAULT(7); !NAME SET TWICE
->L9
L8: IF T>>4&15#L THEN ->L10; ! NUMBER OF PARAMS DIFFER
IF L=0 THEN ->L11; ! NO PARAMS
N=1
M=LINK(LINK(K)); ! POINTER TO 1ST PARAM TAGS CELL
L12:
IF TAG1(M)#PT(N) THEN ->L10; ! PARAM HAS DIFFERENT TAGS
M=LINK(M); ! POINTER TO NEXT PARAM TAGS CEL
! CHECK LENGTH FOR STRING PARAM.
IF PT(N)&6=6 THENSTART
IF TAG(M)#LENGTH(N) THEN ->L10
M=LINK(M)
FINISH
IF N=L THEN ->L11; ! ALL PARAMETERS CHECK OUT
N=N+1
->L12
L10: FAULT(9); !PARS NOT AS SPEC
->L11
L7:
! SET TAGS FOR RT/FN/MAP NAME.
! FORM=4 FOR RT/FN, 8 FOR MAP
! N CONTAINS ALT OF <RT> 1 RT 2 FN 3 MAP
IF N<=2 THEN N=4 ELSE N=8
! TAGS- OFFSET IS OFFSET IN BRANCH TABLE FOR INTERNAL,
! BUT IS PTR TO NAME FOR %EXTERNAL.
IF EXT=1 THEN TT=K ELSE TT=BT NEXT
IF EXT=1 AND J=1 AND CHECKS&8192#0 START
TT=BTNEXT
IF TARGET&8192=0 START
! NEXT INSTRUCTION TO BE CHANGED WITH %ROUTINE PJ
SETS(2)
PRINTSTRING(" BR .+10.
")
CA=CA+2
SET LAB(TT)
PRLAB
PRINTNAME(K)
PRINTSYMBOL(':')
EM(24)
PRINTSTRING(" .ASCII /")
BGN=PRINT4(K)
WHILE BGN<6 CYCLE
PRINTSYMBOL('Y')
BGN=BGN+1
REPEAT
PRINTSYMBOL('/')
NEWLINE
CA=CA+8
FINISHELSESTART
OCT(X'104')
SET LAB(TT)
PRLAB
EM(24)
BGN=PRINT4(K)
WHILE BGN<6 CYCLE
BIN(CA!!1)='Y'
CA=CA+1
BGN=BGN+1
REPEAT
FINISH
FINISH
STORE TAG(K,N,I,L,LEVEL,TT)
IF L=0 THEN ->L9; ! NO PARAMETERS
!
! PUT PARAM TYPES IN TAG/LINK LIST.
I=1
M=LINK(K); ! LINK OF NAME TAGS CELL
L13: N=NEWCELL; ! NEW CELL FOR NEXT PARAMETER TA
TAG1(N)=PT(I)
LINK(N)=LINK(M); ! COPY LINK TO FOLLOWING CELL
LINK(M)=N; ! LINK FOR PRECEDING CELL
M=N; ! POINTER TO NEW LAST PARAMETER
IF PT(I)&7=6 THENSTART
N=NEWCELL
TAG(N)=LENGTH(I)
LINK(N)=LINK(M)
LINK(M)=N
M=N
FINISH
I=I+1
IF I<=L THEN ->L13; ! MORE PARAMETERS YET
L9: IF J#1 THEN ->L11; ! JUMP IF NOT A SPEC.
!
! THEN A SPEC
IF L=0 THENRETURN
CYCLE L=1,1,L
HOY NAME(PN(L))
REPEAT
RETURN
!
! HERE WE START ON THE ROUTINE HEADING
L11:
IF EXT=0 THENSTART
COT(STAR(LEVEL))=RAD; ! PRESERVE STORE ALLOC FOR OLD LEVEL
-> L115 IF CHECKS&128#0
BRT(LEVEL)=BT NEXT; ! ALLOCATE BRANCH TABLE HOLE FOR
PJ(BR,1,BRT(LEVEL)); ! JUMP ROUND RT BODY
FINISH ELSE START
PRLAB
PRINTNAME(K)
PRINTSTRING(":
")
FINISH
L115:
T=TAG OF(K); ! TAG MAY HAVE CHANGED
J=TAG OFF(K); ! RT/FN NO.=BAT POSITION OR PTR TO NAME FOR %EXT
IF EXT=0 THENSTART
IF BAT(J)>=0 THEN FAULT(7); ! ROUTINE NAME SET TWICE
SET LAB(J); ! FILL IN RT/FN START ADDRESS
FINISH
IF CHECKS&4096#0 START
PPJ(37)
OCT(LINE)
FINISH
SET LINE; ! UPDATE LINE COUNT
IF LEVEL<4 THEN ->L15
FAULT(34); !TOO MANY LEVELS
->L16
L15: LEVEL=LEVEL+1; ! INCREMENT LEVEL COUNT
L16:
PUSH(BDIAGSPTR,CA,K)
BLOCK ENTRY; ! PLANT CODE FOR BLOCK ENTRY
RAD=PDISP
RTP(LEVEL)=T>>8; ! ROUTINE / FN TYPE
IF L=0 THEN ->L99; ! NO PARAMETERS
I=1
L17:
!SET TAGS FOR PARAM VARIABLE
IF LENGTH(I)>0 THEN LENGTH(I)=(LENGTH(I)+2)&X'FFFE'
STORE TAG(PN(I),PT(I)>>4,PT(I)&15,0,LEVEL,RAD+LENGTH(I));
RAD=RAD+2+LENGTH(I); ! BYTES
!ARRAYS , STRINGS AND SCALAR REALS TAKE 4 BYTES:
! IF FORM=ARRAY OR (FORM=SCALAR AND TYPE=REAL)
IF PT(I)&32#0 OR (PT(I)&X'F0'=0 AND PT(I)&15=3) C
OR PT(I)&15=6 C
THEN RAD=RAD+2
I=I+1
IF I<=L THEN ->L17; ! MORE PARAMETERS TO SET
L99: TWSP=RAD; RAD=RAD+TEMPS; ! ALLOCATE TEMPORARIES
TWSPLIM=RAD
SAVETWSP(LEVEL)=TWSP
END; ! RTSPEC
ROUTINE TYPE CH(INTEGER LH,RH)
! COMPARES TYPES OF LHS &RHS, ARRANGES FLOAT OR ERROR MESSAGE
! CALLED FROM SW(2) OF UI, -> SW( )
! SW(5) OF UI, %RESULT=
! SCALAR VALUE PAR IN RT
IF LH=RH THEN ->L9; !TYPES AGREE
IF LH=3 THEN FLOAT; ! FLOAT RHS
IF LH<=2 AND RH=3 THEN FAULT(24); !REAL EXP ASSIGNED TO INTEGER
L9:
END; ! TYPE CH
ROUTINE CHECK JUMPS
! CHECK LABELS ALL SET & RETURN JUMP LIST TO ASL
INTEGER I,J
L1: POP(JUMP(LEVEL),I,J); ! EXTRACT A JUMP
IF I<=0 THEN ->L3; ! NO(MORE) JUMPS/LABELS AT THIS L
IF BAT(J)>=0 THEN ->L1; ! LABEL SET CORRECTLY
! PRINT OUT LABEL NO OR NAME
SETS(3)
IF I<8192 THEN WRITE(I,1) ELSE PRINTNAME(I-8192)
FAULT(11); !LABEL NOT SET
->L1; ! MORE JUMPS TO PROCESS
L3: COT(STAR(LEVEL))=(RAD+1)&(-2); ! FILL IN STATIC STORAGE ALLOCAT
! STATIC STORAGE IN BYTES, ABOVE..
IF CYC(LEVEL)#0 THEN FAULT(13); !REPEATS MISSING
IF SBR(LEVEL)#0 THEN FAULT(53); !FINISH MISSING
END; ! CHECK JUMPS
ROUTINE RETURN
! DUMP CODE FOR %RETURN
INTEGER J,K,TYPE
J=RTP(LEVEL)
TYPE=J&15
! NEEDNT UNLOCK IT SINCE LABEL HAS TO COME NEXT
IF TYPE>=8 THEN PPJ(33) ELSE START
DUMP(LOAD,13,PREVL); ! RESET OLD DISPLAY POINTER
K=INTER TO REG(1)
! SET CC FOR INTEGER FUNCTION
D11A(TST,0,0,0,0,ACC,0) IF J&64#0 AND 0<TYPE AND TYPE<=2
D11A(RTS,0,0,0,0,PC,0); ! (MODE = REG)
FINISH
END; ! RETURN
ROUTINE RT; ! RTRTRT
! DUMP CODE FOR A ROUTINE OR FUNCTION CALL
ROUTINESPEC STK PARAM
ROUTINESPEC STACK REGS
ROUTINESPEC UNSTACK REGS
INTEGER RFTAGS,P2,ELT4
INTEGER APP,I,J,K,L,M,N,P,NN,TYPE,FORM,DUMMY
INTEGER INDIRECT
INTEGER LEV,OFFSET,ARNAM; ARNAM=0
INTEGER STP,REG BEHIND
INTEGERARRAY PAP(1:16); ! ANAL REC POINTERS FOR EACH PAR
INTEGERARRAY STKD REGS(2:5)
DUMMY=0; ! SET 1 WHEN RT/FN/MAP IS ADDR() OR INTEGER()
CALLS=CALLS+1
J=LINK(A(AP)); ! POINTER TO ROUTINE/FN NAME TAG
AP=AP+2; ! TO <APP>+1
K=0; ! ACTUAL PARAMETER COUNT
L2: IF A(AP-1)=2 THEN ->L1; ! NO MORE ACTUAL PARAMETERS
IF K<16 THEN K=K+1; ! INCREMENT PARAM COUNT IF NOT T
PAP(K)=AP; ! SAVE ANAL REC POINTER FOR EACH
SKIP SEXPR; ! SKIP TO <EXPRS>
AP=AP+1; ! <EXPRS>+1
->L2
L1: APP=AP; ! PRESERVE FINAL ANAL REC POINTE
L=TAG(J); ! NAME TAGS
M=L>>4&15; ! NUMBER OF FORMAL PARAMETERS
FORM=L>>12
TYPE=(L>>8)&15
LEV=L&15
! OFFSET IS OFFSET IN BT FOR INTERNAL RT/FN/MAP,
! BUT IS PTR TO NAME FOR %EXTERNAL.
OFFSET=TAG1(J)
IF LEV=0 AND TYPE<8 THENSTART
IF OFFSET=14 THEN DUMMY=1; ! ADDR()
IF OFFSET=22 THEN DUMMY=2; ! INTEGER()
IF OFFSET=17 THEN DUMMY=3; ! LACC()
IF OFFSET=23 THEN DUMMY=4; ! ACC
IF OFFSET=24 THEN DUMMY=2; ! RECORD()
IF OFFSET=25 THEN DUMMY=2; ! STRING()
IF OFFSET=26 THEN DUMMY=2; ! BYTEINTEGER()
IF OFFSET=27 THEN DUMMY=5; ! SWAB()
IF OFFSET=28 THEN DUMMY=6; ! PRINTSTRING()
IF OFFSET=29 THEN DUMMY=7; ! LENGTH()
FINISH
IF K#M START
FAULT(19); ! WRONG NUMBER OF PARAMS
IF K>M THEN K=M; ! TAKE 1ST M PARAMS
FINISH
I=WS; ! PRESERVE WORKSPACE POINTER
IF I#0 AND DUMMY=0 THEN UP STACK PTR(I)
WS=PDISP; ! POSITION OF FIRST PARAMETER
IF K=0 THEN ->L5; ! NO ACTUAL PARAMETERS
!> STP=SET INDEX(16)
REG BEHIND=0
!
! EVALUATE PARAMETERS.
!
M=0; ! COUNT OF PARAMS.
!---------------------------------------------------------
L6: M=M+1; ! PROCESS EACH PARAMETER
P=0
AP=PAP(M); ! ANAL REC POSITION OF NEXT ACTU
J=LINK(J); ! POINTER TO NEXT FORMAL PARAM T
IF TAG1(J)>>4=0 THEN ->L7; ! SCALAR VALUE PARAMETER
AP=AP+1
IF TAG1(J)>>4=1 THEN ->L8; ! SCALAR %NAME PARAMETER
! NEED <PLUS''> NULL, <OPND>=NAME, AND NULL <EXP> AND <APP>
IF A(AP)#4 OR A(AP+1)#2 OR A(AP+3)#2 OR A(AP+4)#2 C
THEN ->L9
! CHECK THAT PARAM EXPR IS SINGL
N=TAG OF(A(AP+2))
NN=TAG OFF(A(AP+2))
IF N=0 THEN ->L10; ! ACTUAL NAME NOT SET
IF N>>12&2#0 THEN ->L11; ! 'FORM' OF NAME IS ARRAY
L9: FAULT(22); !PAR NOT ARRAY NAME
->L12
!
! ARRAY %NAME PARAMETER.
L11: P=N&15; ! BASE TO P
DUMP(LOAD,P,NN); ! ARRAY HEAD WORD 1
STK PARAM; ! TO STACK
WS=WS+2
DUMP(LOAD,P,NN+2); ! ARRAY HEAD WORD 2
STK PARAM; ! TO STACK
->L13
!
!-----------------------------------------------------------------------
! SCALAR %NAME FORMAL PARAMETER.
! ACTUAL PARAMETER MUST HAVE
! (1) <PLUS''> NULL
! (2) <EXP> NULL
! OR <EXP> 1 FOR RECORD ELEMENT
L8: IF A(AP)#4 OR A(AP+1)>2 THEN ->L14
N=TAG OF(A(AP+2)); NN=TAG OFF(A(AP+2))&X'FFFF'
IF N#0 THEN ->L15
L10: FAULT(16); !NAME NOT SET
->L18
L15:
IF N>>12<=1 THEN ->L16; ! SCALAR
IF N>>12=4 THEN ->L14; ! ROUTINE/FN
IF N>>12=8 THEN -> MAP; ! MAP TYPE PARAMETER
! THEN ACTUAL PARAM IS ARRAY ELEMENT
AP=AP+2; ! ON <NAME>
IF WS=PDISP THEN WS=0; ! NO NEED TO PROTECT PARAMS
ARRAD(0,P); ! ADDRESS OF ELEMENT
IF WS=0 THEN WS=PDISP; ! RESTORE WS
! P IS LOCKED
SET INTER(P)
! PTD TO BY P, BUT WE WANT THE ADDRESS MOVING, SO 'CONTAINED IN'
! STORE ADDRESS ON STACK, EXCEPT FOR 'PERM' CALL TO ADDR()
! OR MAP INTEGER().
IF DUMMY=0 THENSTART
STK PARAM
IF N>>8&7=6 THENSTART; ! STRING ARRAY PARAM.
WS=WS+2
DUMP(LOAD,N&15,NN+2)
DUMP(STR,6,0)
DUMP(LOAD,8,6)
STK PARAM
FINISH
FINISH
ARNAM=1; !INDICATE FOR 'ADDR()' THAT PARAM IS
! SUBSCRIPTED ARRNAM.
IUSE(P)=0; ! FREE REG
IF A(AP)=2 THEN ->L13; ! END OF EXPRESSION
L14: FAULT(22); !PAR NOT A NAME
->L18
MAP:
! SCALAR %NAME FORMAL PARAM, MAP TYPE ACTUAL
IF DUMMY=2 THEN -> L7; ! TREAT INTEGER() SPECIALLY
AP=AP+2; ! ONTO <NAME>
IF WS=PDISP THEN WS=0
RELEASE(0)
RT; ! CODE PLANTED LEAVES ADDR OF ITEM REFERENCED IN R0
IF WS=0 THEN WS=PDISP
SET INTER(0)
STK PARAM
-> L18; ! FOR NEXT PARAM
!
! SCALAR %NAME FORMAL PARAM, NAME/VALUE TYPE ACTUAL
L16:
IF NN<6 THEN START
! VARIABLE VALUE IS IN A REGISTER
LOSE(NN)
N=TAG OF(A(AP+2))
NN=TAG OFF(A(AP+2))&X'FFFF'
FINISH
! VALUE TYPE ACTUAL ELSE NAME TYPE ACTUAL
INDIRECT=0
IF N>>8&7=6 AND TAG1(J)>>4#0 THENSTART; ! STRING PARAM
IF DUMMY=7 START ; ! LENGTH
DUMP(LOAD,N&15,NN)
J=INTER TO REG(0)
D11A(MOVB,10,R0,0,0,R0,0)
->L52
FINISH
IF DUMMY=1 THEN DUMP(LOAD,N&15,NN) ELSESTART
DUMP(LOAD,N&15,NN)
STK PARAM
WS=WS+2
DUMP(LOAD,N&15,NN+2)
FINISH
->L19
FINISH
IF N>>8&7=7 AND A(AP+1)=1 START; ! RECORD ELEMENT
->L14 UNLESS DUMMY=1
AP=AP+1
P2=N
RFTAGS=TAG OFF(A(AP+1))
REC DISP(AP,P2,RFTAGS,ELT4)
IF ELT4=2 THEN ELT4=1 ELSE ELT4=0
P2=ADDR DUMP(N&15,NN)+100
RFTAGS=RFTAGS>>16
D11A(ADD,8,0,RFTAGS,0,P2,0) UNLESS RFTAGS=0
IF P2#100 OR ELT4=1 THEN MAA(ELT4,P2,0,ACC)
PAR1(0)=ENCODE(6)
->L19
FINISH
IF N>>12=0 THEN LD ADDR(-1,N&15,NN) ELSE C
DUMP(LOAD,N&15,NN)
L19:
IF DUMMY=0 THEN STK PARAM ELSE UNLOCK(INTER TO REG(0))
! TO STACK, BUT NOT FOR 'ADDR()'.
IF A(AP+3)=2 THEN ->L17; ! NO <APP>
FAULT(19); !SCALAR HAS PARAMS
->L18
L17: IF A(AP+4)=1 THEN ->L14; ! NOT END OF EXPRESSION
L13:
! DO ACTUAL AND FORMAL TYPES AGREE?
IF N>>8&15=TAG1(J)&15 THEN ->L18;
! PARAM WRONG TYPE (BUT NOT FOR READSYMBOL AND ADDR())
! OR FOR READ/WRITE SQ
FAULT(22) UNLESS OFFSET=0 OR OFFSET=14 C
OR OFFSET=19 OR OFFSET=20
->L18
!-----------------------------------------------------------------------
! SCALAR VALUE FORMAL PARAM.
!
L7: IF WS=PDISP THEN WS=0; ! NO NEED TO PROTECT PARAMS
SEXPR(P); !EVALUATE PARAMETER.
IF DUMMY=6 START ; ! PRINTSTRING
D11A(MOV,10,R1,0,0,R3,0)
EM(6)
->L52
FINISH
IF WS=0 THEN WS=PDISP; ! RESTORE WS
TYPE CH(TAG1(J)&15,P); !CHECK & FAULT OR FLOAT
!
! PARAM TO STACK (SCALAR VALUE FORMAL PARAM).
! TREAT SPECIAL CASES %MAP INTEGER AND %RT LACC
! FOR MAP TYPE, RT LEAVES THE ADDRESS OF THE ENTITY
! REFERENCED IN R0.
IF DUMMY>=2 THEN START; ! INTENDED TO TAKE CASES 2,3 ONLY
UNLOCK(INTER TO REG(0))
-> L52
FINISH
IF TAG1(J)&15#3 THEN STK PARAM ELSESTART
AD(2); !STST
OCTN((WS-PDISP)>>1,0); ! PARAM IS NO. OF WORDS
WS=WS+2; ! 4 BYTES ALTOGETHER FOR REAL PARAM
REG BEHIND=REG BEHIND+2
FINISH
L18: WS=WS+2; ! INCREMENT WORKSPACE PAST PARAM
IF TAG1(J)&7=6 AND TAG1(J)>>4=0 THENSTART; ! STRING VALUE PARAM.
J=LINK(J)
WS=WS+2+TAG(J)
IF WS&1#0 THEN WS=WS+1
MAA(6,R1,0,R5)
D11A(MOV,10,R1,0,6,R5,WS-2-PDISP)
D11A(MOV,8,0,TAG(J),6,R5,WS-PDISP)
WS=WS+2
FINISH
L12: IF M#K THEN ->L6; ! MORE PARAMETERS YET
!--------------------------------------------------------------------
!
!
! NOW PLANT THE CALL TO THE RT/FN/MAP.
L5:
!
IF LEV#0 OR TYPE>=8 THEN START
! RELEASE REG 0 FOR FN/MAP (TYPE=0 FOR RT FORM)
IF TYPE#0 THEN RELEASE(0)
STACK REGS
IF TYPE>=8 AND CHECKS&8192=0 THENSTART
! %EXTERNAL TYPE
PRLAB
PRINTSTRING(" JSR PC,")
PRINTNAME(OFFSET)
NEWLINE
CA=CA+4
FINISH ELSE D11A(JSR,0,PC,0,13,BT,OFFSET); ! JSR BT<N>
IUSES0
UNSTACK REGS
->L52
FINISH
! TO PERM FOR IMPLICITS
! TREAT SPECIAL CASE OF ADDR() WHERE THE ARGUMENT IS A SUBSCRIPTED
! ARRAY NAME.
IF OFFSET=14 AND ARNAM#0 THENSTART
RELEASE(0)
MAA(0,R3,0,ACC); ! MOV R3,ACC
->L52
FINISH
READFLAG=1 IF OFFSET=13; ! (DUMPING .GLOBL READ AT EOP).
! PLANT PERM JUMP, BUT NOT FOR FNS ADDR() OR ACC
! RELEASE REG 0 FOR PERM CALLS WHICH ARE FUNCTIONS,
! IN PARTICULAR 1 NEXT SYMBOL, 9, INT PT
RELEASE(0) IF OFFSET=1 OR OFFSET=9
PPJ(OFFSET+10) UNLESS DUMMY=1 OR DUMMY=4
!
! RT/FN/MAP/PERM CALL HAS BEEN PLANTED (IF ONE WAS NECESSARY)
L52: AP=APP; ! RESTORE FINAL ANAL REC POINTER
WS=I; ! RESTORE ORIGINAL WORKSPACE VAL
IF I#0 AND DUMMY=0 THEN UP STACK PTR(-I)
IF DUMMY=5 START
IF TARGET&8192#0 THEN D11A(SWAB,0,0,0,0,0,0) ELSESTART
CA=CA+2
PRINTSTRING(" SWAB R0
")
FINISH
FINISH
RETURN
ROUTINE STK PARAM
! %IF REG BEHIND>0 %THEN %START
! D11A(ADD,8,REG BEHIND,0,0,100+STP,0)
! REG BEHIND=0
! %FINISH
RETURNIF P=6; ! STRING VALUE PARAM.
DUMP(STR,16,WS-PDISP); ! BECAUSE (R1) PTS TO STP+PDISP
END; ! STK PARAM
ROUTINE STACK REGS
INTEGER J
CYCLE J=2,1,5
STKD REGS(J)=0
IF IUSE(J)&64#0 THEN START
D11A(MOV,0,100+J,0,4,SP,0)
UNLOCK(J)
STKD REGS(J)=1
FINISH
REPEAT
END; ! STACK REGS
ROUTINE UNSTACK REGS
INTEGER J
CYCLE J=2,1,5
IF STKD REGS(J)#0 THEN START
D11A(MOV,2,SP,0,0,100+J,0)
LOCK(J)
FINISH
REPEAT
END; ! UNSTACK REGS
END; ! RTRTRT
ROUTINE REC DISP(INTEGER I,INTEGERNAME K,KK,TYPENO)
INTEGER RFTAGS,ELT PTR,ELT4,LIST PTR,CT,TRDISP,FLT,RDISP,RECTYPE
INTEGER NAME DISP,FMT PTR,P2,ID
! K HAS TAGS OF RECORDNAME, KK HAS PTR TO RECORDFORMAT TAGS
TYPENO=0
FLT=61
ID=A(I+1)
ELT PTR=A(I+2)
IF K>>8#X'17' THEN -> RERR; ! 1ST IDEN NOT RECORDNAME
FMT PTR=KK>>16
NAME DISP=KK&X'FFFF'
RFTAGS=TAG(FMT PTR); ! FORM/TYPE ETC OF REC FORMAT
FLT=60
IF RFTAGS>>8#X'77' THEN -> RERR; ! NOT POINTING TO FORMATNAME
! NOW GO DOWN LIST OF ELEMENTS IN FORMAT LOOKING FOR THE ELT IDEN
! A(I+2) IS PTR TO ELT IDEN
P2=TAG(ELT PTR)
ELT4=TAG(P2)<<16 ! TAG1(P2); ! 1ST 4 CHARS OF ELT IDEN
ID=ELT PTR
LIST PTR=LINK(FMT PTR); ! TO PT TO 1ST CELL OF FMT LIST
WHILE LIST PTR>0 CYCLE
IF TAG(LIST PTR)=ELT4 THEN -> FOUND
LIST PTR=LINK(LIST PTR)
REPEAT
FLT=65; ! SUBNAME NOT FOUND
RERR:
PRINTNAME(ID)
FAULT(FLT)
K=X'0101'; ! TYPE=INTEGER LEVEL=1
KK=14; ! ANYTHING > 6
-> OUT
!
FOUND:
TRDISP=TAG1(LIST PTR)
FLT=59
RECTYPE=TRDISP>>16
TYPENO=RECTYPE
IF RECTYPE=2 THEN RECTYPE=1; ! MAKE INTEGER-TYPE ELT
IF RECTYPE=1 THEN RECTYPE=X'1200' ELSE RECTYPE=X'1100'
RDISP=TRDISP&X'FFFF'; ! REL DISP OF REC ELT
K=(K&X'FF') ! RECTYPE; ! SET TYPE/FORM=%INTEGERNAME 0R BYTEINTEGER
KK=(RDISP<<16) ! NAME DISP; ! PUT REL DISP IN TOP 16 BITS
! FOR A RECORD ELEMENT, RP HAS
! LH16=REL DISP OF ELT RH16=DISP OF RECORDNAME
OUT:
END; ! REC DISP
ROUTINE BLOCK ENTRY
! PLANT THE CODE FOR BLOCK ENTRY TO COPY GLOBAL PART OF OLD
! DISPLAY AND NEW ELEMENTS TO MAKE CURRENT DISPLAY
! R1 POINTS TO OLD DISPLAY,I2 HAS RETURN ADDRESS
INTEGER I
ENTS=ENTS+1
I=CT NEXT; ! HOLE FOR STATIC STORAGE
IF IN EXT#0 THENSTART
LEVEL=LEVEL+1; ! TO MAKE IT 2
D11A(CLR,0,0,0,4,SP,0); ! WORD TO HOLD OLD CT PTR.
EM(32)
IF TARGET&8192=0 START
PRINTSTRING(" SWT-.
CT0-.
")
CA=CA+4
FINISHELSESTART
SWTCA=CA
OCT(CA)
CTCA=CA
OCT(CA)
FINISH
IN EXT=0
FINISH ELSE START
IF CHECKS&16384=0 THEN EM(4) ELSE C
D11A(JSR,0,R4,0,9,166,BLKENT)
FINISH
OCTN((LEVEL<<13)!I,0); ! OFFSET IN WORDS
IF LEVEL>4 THEN FAULT(34)
! FOR NEW LEVEL...
STAR(LEVEL)=I; ! REMEMBER HOLE FOR FILLING LATER
JUMP(LEVEL)=0; !CLEAR ASSORTED LISTHEADS
NAME(LEVEL)=0
CYC(LEVEL)=0
SBR(LEVEL)=0
RECELTS(LEVEL)=0
IUSES0
END; ! BLOCK ENTRY
ROUTINE UP STACK PTR(INTEGER N)
! DUMPS CODE TO INCREASE (INCL. DECREASE) STACK TOP PTR BY N(BYTES)
INTEGER I,J
J=ADD
IF N<0 THEN START
J=SUB
N=-N
FINISH
CYCLE I=0,1,5
IF IUSE(I)=16 THEN IUSE(I)=0
REPEAT
D11A(J,8,0,N,1,R1,0); ! ADD #N,@R1
END; ! UP STACK PTR
ROUTINE ARRAD(INTEGER MODE, INTEGERNAME REG)
! DUMP CODE TO CALCULATE ARRAY ELEMENT ADDRESS, LEAVING IT IN REG.
! BOTTOM BIT OF MODE INDICATES RESULT IN ACC OR INDEX
! SECOND BOTTOM BIT INDICATES IF ACC FREE OR MUST BE SAVED
! ENTERED WITH AP POINTING TO <NAME> OF <NAME><APP>
! EXIT WITH AP ON ALT OF PHRASE WHICH FOLLOWS <APP>.
INTEGER I,J,K,RI,JJ,ABC
ABC=CHECKS&4; ! 0 CHECKS OFF #0 CHECKS ON
ARADS=ARADS+1
I=WS; ! PRESERVE WORKSPACE VALUE
WS=0; ! NEW WORKSPACE VALUE
IF I#0 THEN UP STACK PTR(I)
J=TAG OF(A(AP))
JJ=TAG OFF(A(AP))
IF J>>8&15=6 THEN ABC=4
! NOT USED RI=J>>8&15 - 1; ! SET RI 0 FOR INT, 1 FOR REAL.
SAVE INTER UNLESS MODE<2
IF ABC#0 THENSTART
IUSE(3)=IUSE(3) ! 128
IUSE(0)=IUSE(0) ! 128
RELEASE(3); ! NEEDED FOR PERM CALL
RELEASE(0)
IUSE(3)=IUSE(3) & X'FF7F'
IUSE(0)=IUSE(0) & X'FF7F'
FINISH
AP=AP+1; ! ON <APP>
IF A(AP)=1 THEN ->L4; ! SHOULD BE PARAMETER EXPRESSION
FAULT(22); !NO ARRAY INDEXES
->L2
!
! EVALUATE SUFFIX EXPRESSIONS.
L4: AP=AP+1; ! ON <+-?>
IF WS#0 THEN WS=WS+4; ! INCREMENT WORKSPACE EXCEPT FOR
SEXPR(K); ! EVALUATE INDEX, SHOULD BE INTEGER
! SUFFIX IS NOW IN INTERMEDIATE.
IF WS=0 THEN WS=4; ! RESET WORKSPACE VALUE
IF K>2 THEN FAULT(24); !REAL EXPRN
IF A(AP)=1 THEN ->L4; ! MORE INDEX EXPRESSIONS
L2: AP=AP+1; ! SET POINTER TO AFTER ARRAY ELEMENT
IF ABC#0 THEN -> CHECKS ON
! CHECKS OFF
! SUFFIX IS IN INTERMEDIATE (FROM SEXPR)
! ADD FIRST WORD OF HDR = ADDR(A(0))
REG=INTER TO REG(3)
WS=(J>>8)&15-1
WHILE WS#0 CYCLE
WS=WS-1
D11A(MASL,0,0,0,0,REG+100,0)
REPEAT
DUMP(ADD,J&15,JJ)
-> JOINAR
CHECKS ON:
LOSE(0)
K=INTER TO REG(0); ! GET SUFFIX TO R0
UNLOCK(0); ! DOESN''T WANT TO BE
! PLACE DETAILS OF ARRAY HD IN WORD FOLLOWING TRAP.
! FROM LEFT, 1ST 3 BITS = LEVEL
! NEXT = 0, INT 1, REAL
! REMAINING 12 = DISPLACEMENT (IN WORDS) FROM LEVEL.
JJ=JJ>>1
FAULT(40) IF JJ>4095; ! JJ TOO BIG FOR 12 BITS
J=((J&15)<<13) ! JJ ;!TAGS FOR HD
IF J=UTAG AND CHECKS&512=0 THEN PPJ(2) ELSESTART
UTAG=J
PPJ(1)
OCTN(J,0)
FINISH
! PERM LEAVES ADDR IN I3
REG=3
JOINAR:
WS=I; ! RESTORE OLD WORKSPACE VALUE
LOCK(REG)
IF I#0 THEN UP STACK PTR(-I)
UNLOCK(REG)
IF MODE<2 THEN RETURN
RESTORE INTER
END; ! ARRAD
ROUTINE SET LINE
OWNINTEGER LAST LINE=0
IF LINE=LAST LINE OR CHECKS&1=0 THENRETURN
PPJ(37)
IF TARGET&8192=0 START
WRIT(LINE); PRINTSTRING(".
")
CA=CA+2
FINISHELSE OCT(LINE)
LAST LINE=LINE
END; ! SET LINE
ROUTINE SET LAB(INTEGER BTP)
PLAB=PLAB+1; ! INDICATOR ONLY
IUSES0
FPOL
SETS(2)
IF BTP>=0 AND TARGET&8192=0 THEN START
PRINTSTRING("BT"); WRIT(BTP); PRINTSTRING("=.
")
FINISH
! FLACC MUST BECOME 'OUT OF USE' AT LABEL
FLACC=0
! SWITCH TABLE ELSE BRANCH TABLE
IF BTP<0 THEN SWT(BTP)=CA ELSE BAT(BTP)=CA
DBIN(-1,BTP,0,0,0,0,0) UNLESS TARGET&8192=0
IF BRFAULT=1 THEN FAULT(99)
END; ! SET LAB
ROUTINE CBPAIR(INTEGERNAME LB,UB)
!P ON ALT OF P<CBPAIR> ON ENTRY
LB=A(AP+3)
IF A(AP+1)=2 THEN LB=-LB
UB=A(AP+7)
IF A(AP+5)=2 THEN UB=-UB
AP=AP+9
END; ! CBPAIR
INTEGERFN FIND LABEL
! CHECK & LOCATE OR INSERT LABEL IN JUMP LIST FOR THIS LEVEL
INTEGER I,J,LABEL
IF A(AP)=1 THEN ->L6; ! ALPHANUMERIC LABEL
AP=AP+1
I=A(AP); ! TYPE OF CONST
LABEL=A(AP+1); ! VALUE OF CONST
AP=AP+3; ! AFTER <CONST>
IF I=2 AND LABEL<8192 THEN ->L3; ! VALID LABEL NUMBER
FAULT(38); !INVALID LABEL
RESULT =-1; ! 'FAULTY' RESULT
! NUMERIC LABEL
L3: I=JUMP(LEVEL); ! JUMP LIST POINTER
IF I=0 THEN ->L1; ! NOTHING IN LIST YET
L2: IF LABEL=TAG(I) THEN RESULT =TAG1(I); ! LABEL ALRE
I=LINK(I); ! NEXT CELL IN LIST
IF I#0 THEN ->L2; ! MORE CELLS YET
L1: J=BT NEXT; ! NEXT BRANCH TABLE POSITION
PUSH(JUMP(LEVEL),LABEL,J)
RESULT =J; ! NEW BRANCH TABLE POSITION
! ALPHANUMERIC LABEL
L6: I=A(AP+1); AP=AP+2; ! NO. OF NAME FOR NAME LABEL
LABEL=I+8192; !UNIQUE NO. FOR NAME LABEL
J=TAG OF(I)
IF J>>12=8 AND J&15=LEVEL THEN ->L3; !CURRENTLY LAB
STORE TAG(I,8,0,0,LEVEL,0)
-> L3
END; ! FIND LABEL
ROUTINE STORE TAG(INTEGER NAM,FORM,TYPE,DIM,LEV,AD)
! STORE TAGS I.E. SET NAME & CHECK NOT SET ALREADY
INTEGER M
M=LINK(NAM); ! POINTER TO EXISTING TAGS WORD
IF M=0 OR LEV#TAG(M)&15 OR FORM&12#0 THEN ->L1; ! NOT
! SET,
! AT THIS LEVEL OR NEW NAME A ROUTINE/FN/MAP
FAULT(7); !NAME SET TWICE
RETURN
L1: PUSH(LINK(NAM),FORM<<12!TYPE<<8!DIM<<4!LEV,AD)
PUSH(NAME(LEVEL),NAM,0); ! PUSH ONTO LIST OF NAMES AT
! THIS LEVEL. NAME(LEVEL) LIST HOLDS PTRS INTO HASHING AREA.
END; ! STORE TAG
ROUTINE HOY NAME(INTEGER I)
! PARAM IS PTR INTO HASHING AREA FOR THE NAME.
IF CHECKS&1024#0 START
PRINTSTRING("
HOY NAME I LINK(I) OLD TAG(I) NEW TAG(I)
")
WRITE(I,7)
WRITE(LINK(I),12)
WRITE(TAG(I),18)
FINISH
IF LINK(I)#0 THEN ->L9; ! STILL DECLARED
L1: IF TAG(I)=0 THEN ->L9; ! LIST EMPTY
TAG(I)=RETURN CELL(TAG(I))
IF CHECKS&1024#0 THEN WRITE(TAG(I),10)
->L1; ! RETURN 4 CHARS
L9:
IF CHECKS&1024#0 THEN NEWLINE
END; ! HOY NAME
ROUTINE DETAG
! DESTROYS TAG LIST AND FAULTS ROUTINE BODIES MISSING
INTEGER I,J,K,L,FORM,TYPE,KK
POP(BDIAGSPTR,K,L)
IF TARGET&4096#0 START
SETS(0)
IF L=-1 THEN PRINTSTRING("%BEGIN") ELSESTART
PRINTSYMBOL('%'); PRINTNAME(L); FINISH
WRITE(LEVEL,5)
WRITE(K,7)
NEWLINE
SETS(2)
FINISH
L1: POP(NAME(LEVEL),J,I)
IF J<0 THEN ->L9
POP(LINK(J),K,KK); ! DESTROY CELL HAVING CURRENT USE
FORM=K>>12
TYPE=(K>>8)&15
IF TARGET&4096#0 AND FORM#4 AND FORM<7 START
! LIST OF NAMES & DISPLACEMENTS FOR BRIANS SYSTEM.
SETS(0)
PRINTNAME(J)
WRITE(FORM,5)
WRITE(TYPE,5)
WRITE(K&15,5)
IF KK>5 OR FORM>=4 THEN WRITE(KK&X'FFFF',5) ELSEC
WRITE(TAG OFF(J)&X'FFFF',5)
NEWLINE
SETS(2)
FINISH
! THROW AWAY CELL HAVING ADDR(ARRAY(0)) FOR CONT BDD ARRAY
IF LINK(J)&X'8000'#0 THENSTART
K=1
LINK(J)=LINK(J)&X'7FFF'
->L3
FINISH
! SKIP THINGS WHICH ARE (COND1) NOT RT OR FN NAMES AND (COND2) SW NAMES.
IF FORM<4 OR (FORM=8 AND TYPE=0) THEN -> L4
IF TYPE>=7 THEN -> L2; ! %EXT RT/FN/MAP OR REC FMT
! FOR INTERNAL RT/FN/MAP, CHECK THAT IT''S BEEN DECLARED
IF BAT(KK)>=0 THEN ->L2; !RT ADDR KNOWN SO BODY GIVEN
SETS(3)
PRINTSYMBOL(';')
PRINT NAME(J); SPACE; ! FAULTY NAME TO LISTING
FAULT(28); !ROUTINE MISSING
L2: K=K>>4&15; ! NO. OF PARAMS
L3: IF K=0 AND TYPE#7 THEN ->L4; ! NO (MORE) PARAMS
POP(LINK(J),L,I); ! DESTROY PARAM CELL
K=K-1; ->L3 UNLESS L<0
L4: HOY NAME(J); ! TEXT OF NAME CELLS BACK TO ASL
->L1
L9:
WHILE RECELTS(LEVEL)#0 CYCLE
POP(RECELTS(LEVEL),J,I)
HOY NAME(I)
REPEAT
END; ! DETAG
ROUTINE PPJ(INTEGER N)
! PLANTS JUMP TO PERM ROUTINE
PJS=PJS+1
EM(N)
END; ! PPJ
ROUTINE PJ(INTEGER BRANCH,SL,N)
! PLANTS CONDITIONAL JUMP TO ENTRY N OF BRANCH TABLE
! BRANCH CAN BE BUNC,BRZ,BRNZ,BRL,BRG,BRNL,BRNG ON REG
!SL=0: PLANT A SHORT JUMP UNLESS THE LABEL HAS BEEN DECLARED AND IT''S
! MORE THAN 127 WORDS AWAY.
!SL=1: PLANT A LONG JUMP UNLESS LABEL HAS BEEN DECLARED AND IT''S
! <127 WORDS BEHIND, OTHERWISE LONG.
!
! BUT IF SR OR JS NON-NEGATIVE, PLANT SHORT JUMPS ANYWAY.
! (UNLESS A LONG JUMP CAN BE SEEN TO BE NEEDED).
!
INTEGER J,MODE,NEM
!
!
-> SHORT IF (SL=0 OR JS>=0 OR SR>=0) AND LJS<=0
!
! PLANT SHORT IF LABEL DECLARED & <127 WORDS BACK, ELSE LONG.
IF BAT(N)>0 AND CA-BAT(N)<=252 AND LJS=0 THEN -> SHORT
IF LJS>0 THEN LJS=LJS-1
LONG:
IF BRANCH=BR THEN -> L3
CYCLE J=1,1,7
-> L2 IF BRANCH=TRUE(J)
REPEAT
L2:
D11A(FALSE(J),0,0,0,11,150,-1); ! CBR .+6; !-1 IS TO HELP
!RT OPERAND.
L3:
MODE=13; NEM=BT; ! LONG, BT-N
IF BAT(N)>0 THEN START
MODE=14; NEM=LLAB; ! LONG, L-N
N=BAT(N)
FINISH
D11A(JMP,0,0,0,MODE,NEM,N)
-> L9
SHORT:
! HOWEVER, IF THE LABEL HAS BEEN DECLARED AND WE KNOW IT NEEDS
! A LONG JUMP, PLANT IT LONG.
IF BAT(N)>0 AND CA-BAT(N)>252 THEN -> LONG
MODE=11; NEM=BT; ! SHORT, BT-N
IF BAT(N)>0 THEN START
MODE=12; NEM=LLAB; ! SHORT, L-N
N=BAT(N)
FINISH
D11A(BRANCH,0,0,0,MODE,NEM,N)
L9:
END; ! PJ
ROUTINE DUMP(INTEGER OPB,BASE,DISP)
SWITCH S(0:8)
INTEGER J,K,L,M,P1
INTEGER SMODE,SNEM,SNUM,DMODE,DNEM,DNUM
INTEGER TYPE,REG,OP
OP=OPB & 255
REG=0
PRR
PRI(0)
TYPE=OP
IF OP=LOAD THEN TYPE=0
IF OP=STR OR (156<=OP AND OP<=158) THEN TYPE=2
IF OP=INC OR OP=DEC OR OP=CLR THEN TYPE=4
IF OP=NEG OR OP=NOT THEN TYPE=5
IF 32<BASE AND BASE<=37 THEN START
BASE=BASE-32
REG=7; ! TO MEAN INDIRECT
FINISH
IF BASE=-1 THENSTART
! OPERATE ON INTERMEDIATE WITH TEMP
TYPE=6
IF OP=CMP THEN TYPE=7
FINISH
! THIS BELOW IS INTENDED TO COPE WITH BIC,BIS,COM,ADD,SUB
IF TYPE>126 THEN TYPE=1
! IF BASE>=100, ITS A REGISTER MNEMONIC
! THEN IF INDEX=0 ITS A 'PTD TO BY REG' MODE 7
! #0 ITS A 'DISP(REG)' MODE 8
IF BASE>=100 THENSTART
REG=BASE-100
BASE=7; ! PTD TO BY REG
IF DISP>0 THEN START; ! DISP(REG)
BASE=8
FINISH
IF DISP<0 THEN BASE=6; ! IN A REG (REGISTER TYPE)
FINISH
IF OP=TST THEN TYPE=8; ! TST INTERMEDIATE
-> S(TYPE)
S(0): ! LOAD
PAR1(0)=ENCODE(BASE) ! REG
PAR2(0)=DISP
PAR3(0)=0
IF OPB>255 THEN PAR3(0)=1
IF 6<=BASE AND BASE<=8 THEN LOCK(REG)
RETURN
S(1): ! ADD/SUB/BIS
! GET INTERMEDIATE TO REGISTER
J=INTER TO REG(-1); ! ANY REG
LOSE(INTER REG)
IF OPB>255 THEN START
REG=BYTE TO REG(BASE,DISP,REG)
BASE=6
OPB=OP; ! USE THE NON-BYTE OPERATOR
FINISH
PAR1(1)=ENCODE(BASE) ! REG
PAR2(1)=DISP
K=LOAD INDEX(1,SOUR)
DMODE=0
DNEM=100+J
DNUM=0
-> PLANTS
S(2): ! INTERMEDIATE TO STORE ('STR')
! ALSO ADDS, SUBS, BISS
! FOR MOV INTER TO STORE, WHERE INTER IS BYTE AND PROVIDED ITS NOT
! 'STRB', GET INTER TO REG FIRST
IF PAR3(0)=1 AND OPB<255 THEN J=INTER TO REG(-1)
J=LOAD INDEX(0,SOUR)
IF OPB>255 AND SOUR(1)=SP START
J=FREE REG
D11A(OP,SOUR(0),SOUR(1),SOUR(2),0,J+100,0)
SOUR(0)=0
SOUR(1)=J+100
SOUR(2)=0
FINISH
IF BASE=17 THEN START
! STORE TO (REG)+, REG=DISP IN CALL OF DUMP
DMODE=2
DNEM=DISP
DNUM=0
IUSE(DISP)=0
UNLOCK(INTER REG)
-> PLANTS
FINISH
PAR1(1)=ENCODE(BASE) ! REG
PAR2(1)=DISP
! IMPORTANT NOT TO RELOAD THE LEVEL PTR FOR DEST, SO LOCK IT
LOCK(J) IF J>=0
K=LOAD INDEX(1,DEST)
UNLOCK(J) IF J>=0
! FOR INTERMEDIATE 'IN REG' OR 'PTD TO BY REG', THE REG IS NOW FREE.
UNLOCK(INTER REG); ! (IF IT WAS LOCKED)
PLANTDS:
DMODE=DEST(0)
DNEM=DEST(1)
DNUM=DEST(2)
-> PLANTS
S(3): ! MOV STORE TO -(SP)
LOSE(INTER REG)
PAR1(1)=ENCODE(BASE) ! REG
PAR2(1)=DISP
J=LOAD INDEX(1,SOUR)
IF OPB>255 START
J=FREE REG+100
D11A(MOVB,SOUR(0),SOUR(1),SOUR(2),0,J,0)
SOUR(0)=0
SOUR(1)=J
SOUR(2)=0
FINISH
DMODE=4; ! -(SP)
DNEM=SP
DNUM=0
OPB=MOV
-> PLANTS
S(4): ! INC, DEC, CLR ON STORE
PAR1(0)=ENCODE(BASE) ! REG
PAR2(0)=DISP
-> L80
S(8): ! TST INTERMEDIATE
RETURN IF INTER BASE=6 AND INTER REG=CCSET
L80:
J=LOAD INDEX(0,DEST)
D11A(OPB,0,0,0,DEST(0),DEST(1),DEST(2))
RETURN
S(5): ! NEG/NOT ON INTERMEDIATE
J=INTER TO REG(-1); ! ANY REG
LOSE(INTER REG)
D11A(OP,0,0,0,0,100+J,0)
RETURN
S(6): ! OPERATE WITH TEMP SAVED ON INTERMEDIATE
LOSE(INTER REG)
! GET INTERMEDIATE TO REG.
J=INTER TO REG(-1); ! ANY REG
! GET DETAILS OF TEMP SAVED
POP(IHEAD,PAR1(1),L)
PAR2(1)=L&X'FFFF'
PAR3(1)=L>>16
! IF TEMP SAVED HAD A LOCKED REGISTER, UNLOCK IT.
UNLOCK(P11REG)
K=LOAD INDEX(1,SOUR)
! UNLOCK(J)
IF PAR3(1)#0 AND PAR1(1)>>7&15=1 START
L=FREE REG+100
D11A(MOVB,SOUR(0),SOUR(1),SOUR(2),0,L,0)
SOUR(0)=0
SOUR(1)=L
SOUR(2)=0
FINISH
DMODE=0
DNEM=100+J
DNUM=0
OPB=OP
PLANTS:
SMODE=SOUR(0)
SNEM=SOUR(1)
SNUM=SOUR(2)
D11A(OPB,SMODE,SNEM,SNUM,DMODE,DNEM,DNUM)
RETURN
S(7): ! CMP
! SET UP RH OPERAND OF CMP
POP(IHEAD,PAR1(1),K)
PAR2(1)=K&X'FFFF'
PAR3(1)=K>>16
IF PAR3(1)=1 START; ! BYTE OPERAND
K=LOAD INDEX(1,SOUR)
LOCK(K) IF K>=0
L=FREE REG
UNLOCK(K) IF K>=0
D11A(MOVB,SOUR(0),SOUR(1),SOUR(2),0,100+L,0)
K=L
DEST(0)=0
DEST(1)=100+K
DEST(2)=0
FINISH ELSE K=LOAD INDEX(1,DEST)
LOCK(K) IF K>=0; ! LOCK REG CONTAINING OPND, OR LEV PTR
!
! SET UP LH OPERAND OF CMP
M=-1
IF OPB>255 THEN M=INTER TO REG(-1)
OPB=OP
L=LOAD INDEX(0,SOUR)
UNLOCK(K) IF K>=0
UNLOCK(M) IF M>=0
UNLOCK(INTER REG); ! (IF IT WAS LOCKED)
UNLOCK(P11REG)
-> PLANTDS
END; ! DUMP
INTEGERFN INTER BASE
RESULT=PAR1(0)>>11
END; ! INTER BASE
INTEGERFN INTER REG
! RESULT=1 IF INTER IS NOT 'IN' OR 'PTD TO BY' REG
! OR DISP(REG)
! (1 IS AN IRRELEVANT
! REG NO , SINCE R1 IS RESERVED).
INTEGER BASE,P1
P1=PAR1(0)
BASE=P1>>11
RESULT=1 UNLESS 6<=BASE AND BASE<=8
RESULT=P1&7
END; ! INTER REG
INTEGERFN P11REG
INTEGER BASE,P1
P1=PAR1(1)
BASE=P1>>11
RESULT=1 UNLESS 6<=BASE AND BASE<=8
RESULT=P1&7
END; ! P11REG
ROUTINE LOSE(INTEGER REG)
INTEGER I,J,K
RETURN IF REG=1 OR IUSE(REG)&32=0
I=POINT1(REG)
POP(LINK(I),J,K)
IF J=-1 OR K>5 THEN PRINTSTRING("LOSE ERROR *****
")
POINT1(REG)=-1
IUSE(REG)=IUSE(REG) & X'FFDF'; ! CLR BIT 2**5=32
END; ! LOSE
ROUTINE RELEASE(INTEGER REG)
INTEGER J,IPT,BASE,P1
LOSE(REG)
IF IUSE(REG) & 64=0 THEN RETURN; ! REG NOT LOCKED
!
! THEN REG IS LOCKED, MOVE ITS CONTENTS
J=FREE REG
MAA(0,100+REG,0,100+J)
LOCK(J)
! THE REG WHOSE CONTENTS HAVE BEEN MOVED HAD EITHER A TEMP STORED
! RESULT OR THE CURRENT INTERMEDIATE RESULT.
IPT=POINT(REG)
IF IPT#0 THEN START
TAG(IPT)=(TAG(IPT)&X'FFF8') ! J
POINT(J)=POINT(REG)
POINT(REG)=0
FINISH ELSE START
P1=PAR1(0)
BASE=P1>>11
IF 6<=BASE AND BASE<=8 THEN PAR1(0)=(P1&X'FFF8') ! J
PRINTSTRING(";RELEASE
") IF RDIAG#0
FINISH
UNLOCK(REG)
END; ! RELEASE
ROUTINE SET INTER(INTEGER REG)
! PARAM IS REG (0-7), TO SET INTER AS BEING IN REG,
! OR DITTO PLUS 8 TO SET INTER AS POINTD TO BY REG.
INTEGER B
B=6; ! CONTAINED IN REG
IF REG>7 THEN B=7; ! PTD TO BY REG
REG=REG & 7
PAR1(0)=ENCODE(B) ! REG
LOCK(REG)
END; ! SET INTER
ROUTINE RESTORE INTER
INTEGER BASE,J
POP(IHEAD,PAR1(0),J)
PAR2(0)=J&X'FFFF'
PAR3(0)=J>>16
BASE=PAR1(0)>>11
IF 6<=BASE AND BASE<=8 THEN POINT(INTER REG)=0
END; ! RESTORE INTER
ROUTINE SAVE INTER
INTEGER BASE,P1
P1=PAR1(0)
BASE=P1>>11
! FOR 1 - 4 6 14, 15, NO NEED TO DO ANYTHING
! FOR 6 - 8 JUST THE REGISTER LOCKED
! FOR 9, IT''S THERE ALREADY
IF 6<=BASE AND BASE<=8 THENSTART
LOSE(INTER REG)
IF LOCKED>3 THEN INTER TO SP; ! SETS PAR1(0)
FINISH
PUSH(IHEAD,PAR1(0),(PAR3(0)<<16) ! PAR2(0))
IF 6<=BASE AND BASE<=8 THEN POINT(INTER REG)=IHEAD
END; ! SAVE INTER
ROUTINE INTER TO SP
INTEGER BASE,J
BASE=PAR1(0)>>11
! PERHAPS ITS ALREADY @SP...
IF BASE=9 THEN RETURN
! UNLOCK ANY REG WHICH CONTAINED OR WAS BEING USED TO REFERENCE INTER
IF PAR3(0)#0 THEN J=INTER TO REG(-1)
UNLOCK(INTER REG)
J=LOAD INDEX(0,SOUR)
D11A(MOV,SOUR(0),SOUR(1),SOUR(2),4,SP,0)
PAR1(0)=ENCODE(9)
END; ! INTER TO SP
INTEGERFN INTER TO REG(INTEGER DREG)
! DREG>=0 TO R<N>
! DREG <0 TO ANY REG
! THE REGISTER IS LOCKED.
INTEGER BASE,P1,J,SREG
P1=PAR1(0)
BASE=P1>>11
SREG=P1&7
! PERHAPS ITS IN A REG ALREADY...
IF BASE=6 AND (DREG=SREG OR DREG<0) THEN RESULT=SREG
IF BASE=7 THENSTART
! POINTED AT BY REG
IF DREG<0 THEN START
DREG=FREE REG; !INCASE SREG CONTAINS RECORD NAME POINTER
! DREG=SREG
! %IF SREG=0 %OR SREG=3 %THEN DREG=FREE REG
FINISH ELSE START
IF DREG#SREG THEN RELEASE(DREG)
FINISH
J=MOV
IF PAR3(0)#0 THEN J=MOVB
D11A(J,1,SREG+100,0,0,DREG+100,0)
UNLOCK(SREG)
-> L9
FINISH
IF DREG<0 THEN DREG=FREE REG ELSE RELEASE(DREG)
IF BASE=9 THEN STOP; ! ERROR
IF BASE=6 OR BASE=8 THEN UNLOCK(SREG)
J=LOAD INDEX(0,SOUR)
J=MOV
IF PAR3(0)#0 THEN J=MOVB
D11A(J,SOUR(0),SOUR(1),SOUR(2),0,100+DREG,0)
L9:
PAR1(0)=ENCODE(6) ! DREG
PAR3(0)=0
LOCK(DREG)
PRR
RESULT=DREG
END; ! INTER TO REG
INTEGERFN FREE REG
! FIND A FREE INDEX REGISTER
! CHOOSES IUSE SUFFIX CONTAINING LOWEST VALUE<30
! WILL NOT GIVE A REG IF ITS IUSE IS >32
OWNINTEGERARRAY ORDER(0:14)= C
0,2,3,4,5,
5,4,2,3,0,
4,2,5,3,0
INTEGER I,J,MINR,P,X,START
START=ALGO*5
ALGO=0
PRR
MINR=1000; X=-1
CYCLE I=0,1,4
J=ORDER(START+I)
P=IUSE(J)
IF P>32 THEN ->L1
IF P<MINR THENSTART ; MINR=P; X=J; FINISH
L1:
REPEAT
IF X<0 THEN FAULT(110)
IF RDIAG#0 THENSTART
PRINTSTRING(";FREE REG"); WRITE(X,1); NEWLINE
FINISH
IUSE(X)=0
RESULT=X
END; ! FREE REG
ROUTINE LOCK(INTEGER REG)
RETURN IF REG=1
IF IUSE(REG)&64#0 START
RETURNUNLESS CHECKS&2#0
PRINTSYMBOL(';')
WRITE(REG,1)
PRINTSTRING(" ALREADY LOCKED *****
")
RETURN
FINISH
IUSE(REG)=IUSE(REG) ! 64
LOCKED=LOCKED + 1
END; ! LOCK
ROUTINE UNLOCK(INTEGER REG)
RETURN IF REG=1
IF IUSE(REG)&64=0 THEN RETURN
IUSE(REG)=IUSE(REG) & 63
LOCKED=LOCKED - 1
END; ! UNLOCK
INTEGERFN SET INDEX(INTEGER BASE)
INTEGER RES,K
RES=1
IF BASE=LEVEL THEN -> SET UP
CYCLE RES=0,1,5
IF RES#1 AND IUSE(RES)=BASE THEN -> SET UP
REPEAT
ALGO=1
RES=FREE REG
K=BASE&15
K=5 IF K=15
D11A(MOV,6,R1,2*K,0,100+RES,0)
IUSE(RES)=BASE
SET UP:
RESULT=RES
END; ! SET INDEX
INTEGERFN ADDRDUMP(INTEGER LEVEL,DISP)
INTEGER J,LDD
PAR1(1)=ENCODE(LEVEL)
PAR2(1)=DISP
PAR3(1)=0
J=LOAD INDEX(1,SOUR)
ALGO=0
LDD=FREE REG
D11A(MOV,SOUR(0),SOUR(1),SOUR(2),0,LDD+100,0)
RESULT=LDD
END; ! ADDRDUMP
INTEGERFN LOAD INDEX(INTEGER OT,INTEGERARRAYNAME LOCN)
! RESULT IS REG NO OF LEVEL POINTER IF ONE HAS BEEN LOADED
! OTHERWISE RESULT=-1
INTEGER P1,P2,NEM,NUM,BASE,RES,PIC
INTEGER INDIRECT
INDIRECT=0
RES=-1
P1=PAR1(OT)
P2=PAR2(OT)
BASE=P1>>11
PIC=CHECKS&8
IF 1<=BASE AND BASE<=4 AND P1&7=7 THEN INDIRECT=INDIRECT+1
IF (2<=BASE AND BASE<=4) OR BASE=16 C
OR (PIC#0 AND (BASE=1 OR BASE=15)) THENSTART
RES=SET INDEX(BASE)
! SET UP NEW STATUS
PAR1(OT)=ENCODE(8) ! RES; ! PDISP(REG)
FINISH
P1=PAR1(OT)
NEM=0
NUM=0
IF P1&16#0 THEN NUM=PAR2(OT)
IF P1&32#0 THEN START
IF P1&8=0 THEN NEM=STB ELSE NEM=CT
FINISH
IF P1&64#0 THEN NEM=100 + (P1&7); ! REG
LOCN(0)=(P1>>7)&15+INDIRECT; ! MODE
LOCN(1)=NEM
LOCN(2)=NUM
-> L999 IF RDIAG=0
PRINTSTRING("LD INDX
")
PRINTSTRING("OT=")
PRINTSYMBOL(OT+'0')
PRINTSTRING("; ")
PRINTSYMBOL(LOCN(-1))
WRITE(LOCN(0),3)
SPACES(2)
IF NEM=0 THEN PRINTSTRING(" 0") ELSE PMN(LOCN(1))
WRITE(LOCN(2),1)
NEWLINE
L999:
RESULT=RES
END; ! LOAD INDEX
ROUTINE LD ADDR(INTEGER REG,BASE,DISP)
! IN PARAMS - REG = -1 JUST SET UP INTERMEDIATE
! > 0 LOAD ADDRESS TO THAT REG
! BASE TO DEFINE INTER MODE
INTEGER PIC,J,K
UNLESS 1<=BASE<=4 OR BASE=15 THEN C
PRINTSTRING("RINTTEXT'RT. LD ADDR?
")
PIC=CHECKS&8
IF (BASE=1 OR BASE=15) AND PIC=0 THEN START
! #STB+ #CT0+
IF REG<0 THEN START
IF BASE=1 THEN J=0 ELSE J=8; ! STB ELSE CT0
PAR1(0)=ENCODE(12) ! J
PAR2(0)=DISP
FINISH ELSE START
IF BASE=1 THEN J=STB ELSE J=CT
D11A(MOV,8,J,DISP,0,100+REG,0)
FINISH
RETURN
FINISH
! OTHERWISE WE KNOW WE HAVE TO LOAD A REG (OR USE ONE THATS
! ALREADY LOADED)
IF REG<0 THEN REG=FREE REG ELSE RELEASE(REG)
D11A(MOV,8,0,DISP,0,100+REG,0)
J=1; ! FOR R1 IF BASE=LEVEL
IF BASE=LEVEL THEN -> FOUND
CYCLE J=0,1,5
IF J#1 AND IUSE(J)=BASE THEN -> FOUND
REPEAT
! THEN THERES NOT A REG SET UP
K=BASE&15
K=5 IF K=15
D11A(ADD,6,R1,2*K,0,100+REG,0)
-> SETPAR
FOUND:
D11A(ADD,0,J+100,0,0,REG+100,0)
SETPAR:
PAR1(0)=ENCODE(6) ! REG
LOCK(REG)
END; ! LD ADDR
INTEGERFN BYTE TO REG(INTEGER BASE,DISP,REG)
INTEGER J,K
PAR1(1)=ENCODE(BASE) ! REG
PAR2(1)=DISP
J=LOAD INDEX(1,SOUR)
K=FREE REG
D11A(MOVB,SOUR(0),SOUR(1),SOUR(2),0,K+100,0)
RESULT=K
END; ! BYTE TO REG
ROUTINE PRR
INTEGER J,USE
RETURN UNLESS RDIAG#0
PRINTSYMBOL(';')
CYCLE J=0,1,5
USE=IUSE(J)
IF USE=0 OR J=1 THEN -> L9
PRINTSTRING("R".TOSTRING(J+'0')." ")
IF USE&32#0 THEN START
PRINTSTRING(" SCALAR ")
PRINTNAME(POINT1(J))
FINISH
IF USE&64#0 THEN PRINTSTRING(" LOCKED")
PRINTSTRING(", ")
L9:
REPEAT
NEWLINE
PRINTSTRING(" LOCKED ="); WRITE(LOCKED,1)
NEWLINE
END; ! PRR
ROUTINE PRI(INTEGER OT)
INTEGER BASE,MODE,REG,P1
RETURN UNLESS RDIAG#0
PRINTSTRING("PAR"); PRINTSYMBOL(OT+'0'); PRINTSTRING(": ")
P1=PAR1(0)
BASE=P1>>11
REG=P1&7
MODE=(P1>>7)&15
WRITE(MODE,1)
SPACE
IF P1&64#0 THENSTART
PRINTSYMBOL('R')
PRINTSYMBOL(REG+'0')
SPACE
FINISH
IF P1&32#0 THENSTART
IF P1&8=0 THEN PRINTSTRING("STB") ELSE PRINTSTRING("CT0")
FINISH
IF P1&16#0 THEN WRITE(PAR2(OT),1)
NEWLINE
END; ! PRI
ROUTINE D11(INTEGER OP,MODE,NEM,NUM)
INTEGER NL IND,BYT
NL IND=MODE
FPOL
MODE=MODE-100 IF MODE>90
BYT=0
IF OP>255 THEN START
OP=OP & 255
BYT=BYT + 1
FINISH
PRLAB; !SETS UP OBJ STREAM
CA=CA+2
SPACE
PMN(OP)
IF BYT#0 THEN PRINTSYMBOL('B')
SPACE
OPERAND(MODE,NEM,NUM)
NEWLINE UNLESS NL IND>90
END; ! D11
ROUTINE D11A(INTEGER OP,M1,NEM1,NUM1,M2,NEM2,NUM2)
FPOL
PRLAB; !SETS UP OBJ STREAM
IF M1=12 THEN PRINTSTRING("*****MODE 12**********
")
IF M1=8 THENSTART ; !AA
IF NUM1=1 THENSTART ; !BB
IF OP=ADD THENSTART ; OP=INC; ->L3; FINISH
IF OP=SUB THENSTART ; OP=DEC; ->L3; FINISH
FINISH ; !BB
IF (OP&255=MOV OR OP&255=STR) AND NUM1=0 AND NEM1#CT C
THENSTART
OP=OP&256+CLR
L3:
IF TARGET&8192#0 START
DBIN(OP,0,0,0,M2,NEM2,NUM2)
RETURN
FINISH
D11(OP,M2+100,NEM2,NUM2); !+100 TO SUPPRESS NL IN D11
->L9
FINISH
FINISH ; !AA
IF TARGET&8192#0 START
DBIN(OP,M1,NEM1,NUM1,M2,NEM2,NUM2)
CCSET=-1
IF M2=0 THEN CCSET=NEM2-100
RETURN
FINISH
D11(OP,M1+100,NEM1,NUM1); !+100 TO SUPPRESS NL IN D11.
IF M1#0 OR NEM1#0 OR NUM1#0 THEN COMMA
OPERAND(M2,NEM2,NUM2)
CCSET=-1
IF M2=0 THEN CCSET=NEM2-100
L9:
NEWLINE
END; ! D11A
ROUTINE OPERAND(INTEGER MODE,NEM,NUM)
SWITCH K(-1:14)
IF MODE>=8 AND MODE#11 AND MODE#12 THEN CA=CA+2; !ALSO FOR 6 & 7, SEE
! BELOW
->K(MODE)
K(1): !DREG
K(10): !DREL
PRINT SYMBOL('@')
K(-1): !NON-CORE, NON-REG EG. TRAP
K(0): !REG
K(9): !REL
PMN(NEM) UNLESS NEM=0
IF NUM=0 THEN ->L9
->PLUSNUM
K(3): !DAINC
PRINTSYMBOL('@')
K(2): !AINC
INPAREN:
PRINT SYMBOL('(')
PMN(NEM)
PRINT SYMBOL(')')
IF MODE=2 OR MODE=3 THEN PRINT SYMBOL('+')
->L9
K(5): !DADEC
PRINT SYMBOL('@')
K(4): !ADEC
PRINT SYMBOL('-')
->INPAREN
K(7): !DINDX
PRINT SYMBOL('@')
K(6): !INDX
IF NUM#0 THENSTART
CA=CA+2
WRIT(NUM)
PRINTSYMBOL('.')
FINISH
->IN PAREN
K(11): ! REL (SHORT BRANCHES)
K(13): ! REL (MNEMONIC WITH NUM CONCATENATED)
PMN(NEM)
WRIT(NUM) UNLESS NUM<0
->L9
K(12): ! REL (SHORT BRANCHES
K(14): ! REL
PMN(NEM)
OCT5(NUM)
-> L9
K(8): !IMMEDIATE
PRINT SYMBOL('#')
UNLESS NEM=0 THEN PMN(NEM)
PLUSNUM:
PRINT SYMBOL('+') UNLESS NUM<0
!
! THERE ARE 'UNDER' WORDS UNDER LEVEL 1 DISPLAY.
!
IF NEM=STB THEN NUM=NUM+UNDER
WRIT(NUM)
PRINT SYMBOL('.')
L9:
END; ! OPERAND
ROUTINE MAA(INTEGER M1,A1,M2,A2)
!MOV ACC TO ACC
D11A(MOV,M1,A1,0,M2,A2,0)
END; ! MAA
ROUTINE EM(INTEGER I)
OWNINTEGER INST=X'8900'
PRLAB
IF TARGET&8192=0 START
D11(TRAP,-1,0,I)
CA=CA+2
FINISHELSE OCT(INST!I)
CCSET=-1
END; ! EM
ROUTINE IUSES0
INTEGER J,K,L
CYCLE J=0,1,5
LOSE(J)
IUSE(J)=0
REPEAT
LOCKED=0
UTAG=0
CCSET=-1
END; ! IUSES0
ROUTINE PRLAB
SETS(2); !SET UP OBJ STREAM
!GET OUT OF POLISH MODE IF IN. FPOL HAS NO EFFECT IF NOT IN,
!OTHERWISE POLISH IS 1ST SET 0, THEN D11 CALLED FOR 'BR .+2'.
FPOL
RETURN IF PLAB=0
IF TARGET&8192=0 START
PRINT SYMBOL('L')
OCT5(CA)
PRINTSTRING(":
")
FINISH
PLAB=0
END; ! PRLAB
ROUTINE PMN(INTEGER I)
!
!----------------------------------------------------------------------
! %OWNINTEGERARRAY MNIND(100:166)= %C
! 100/ 0,4,7,10,13,16,20,23,26,29,33,
! 111/ 38,42,46,50,54,58,62,66,70,
! 120/ 76,80,84,88,
! 124/ 92,96,100,104,
! 128/ 108,112,42,236,121,
! 133/ 124,127,130,133,
! 137/ 136,139,
! 139/ 175,231,179,183,188,192,197,
! 146/ 202,207,212,217,222,226,170,0,0,0,142,146,104,
! 159/ 142,146,150,154,158,162,166,240
!-----------------------------------------------------------------------
! %OWNINTEGERARRAY MNS(0:1123)= %C
! 0 M'R0',M' ',M'R1',M' R',M'2 ',M'R3',M' R',M'4 ',M'R5',M' ',
! 20 M'SP',M' P',M'C ',M'BR',M' J',M'MP',M' J',M'SR',M' ',
! 38 M'TS',M'T ',M'MO',M'V ',M'RT',M'S ',M'CL',M'C ',M'RO',M'R ',
! 58 M'AS',M'L ',M'ST',M'B ',M'CT',M'0 ',M'TR',M'AP',M' ',
! 76 M'BN',M'E ',M'BE',M'Q ',M'BG',M'E ',M'BL',M'T ',
! 92 M'BL',M'E ',M'BG',M'T ',M'BI',M'C ',M'BI',M'S ',
! 108 M'CO',M'M ',M'BT',M' *',M'2 ',M'*3',M' *',M'4 ',
! 124 M'*5',M' *',M'6 ',M'*7',M' L',M' ',
! 136 M'*9',M' *',M'0 ',M'AD',M'D ',M'SU',M'B ',
! 150 M'IN',M'C ',M'DE',M'C ',M'CL',M'R ',M'CM',M'P ',M'NE',M'G ',
! 170 M'PL',M'SH',M' L',M'DF',M' F',M'LT',M' S',M'TS',M'T ',
! 188 M'.+',M'2 ',M'EX',M'PF',M' A',M'DD',M'F ',
! 202 M'SU',M'BF',M' N',M'EG',M'F ',M'MU',M'LF',
! 216 M' D',M'IV',M'F ',M'.+',M'6 ',M'EX',M'IT',M' S',M'TR',M'F ',
! 236 M'AS',M'H ',M'BL',M'KE',M'NT',M' '
!-----------------------------------------------------------------------
!
OWNINTEGERARRAY MNIND(100:166)= C
0,4,7,10,13,16,20,23,26,29,33,
38,42,46,50,54,58,62,66,70,
76,80,84,88,
92,96,100,104,
108,112,42,236,121,
124,127,130,133,
136,139,
175,231,179,183,188,192,197,
202,207,212,217,222,226,170,0,0,0,142,146,104,
142,146,150,154,158,162,166,240
OWNINTEGERARRAY MNS(0:123)= C
M'R0',M' ',M'R1',M' R',M'2 ',M'R3',M' R',M'4 ',M'R5',M' ',
M'SP',M' P',M'C ',M'BR',M' J',M'MP',M' J',M'SR',M' ',
M'TS',M'T ',M'MO',M'V ',M'RT',M'S ',M'CL',M'C ',M'RO',M'R ',
M'AS',M'L ',M'ST',M'B ',M'CT',M'0 ',M'TR',M'AP',M' ',
M'BN',M'E ',M'BE',M'Q ',M'BG',M'E ',M'BL',M'T ',
M'BL',M'E ',M'BG',M'T ',M'BI',M'C ',M'BI',M'S ',
M'CO',M'M ',M'BT',M' *',M'2 ',M'*3',M' *',M'4 ',
M'*5',M' *',M'6 ',M'*7',M' L',M' ',
M'*9',M' *',M'0 ',M'AD',M'D ',M'SU',M'B ',
M'IN',M'C ',M'DE',M'C ',M'CL',M'R ',M'CM',M'P ',M'NE',M'G ',
M'PL',M'SH',M' L',M'DF',M' F',M'LT',M' S',M'TS',M'T ',
M'.+',M'2 ',M'EX',M'PF',M' A',M'DD',M'F ',
M'SU',M'BF',M' N',M'EG',M'F ',M'MU',M'LF',
M' D',M'IV',M'F ',M'.+',M'6 ',M'EX',M'IT',M' S',M'TR',M'F ',
M'AS',M'H ',M'BL',M'KE',M'NT',M' '
INTEGER K,LR,CH,L
L=I&256
I=I-L
UNLESS 100<=I AND I<=166 THEN START
PRINTSTRING("*PMN*
")
WRITE(I,1)
RETURN
FINISH
K=MNIND(I)
IF (K=170 AND CHECKS&8192#0) OR (K=240 AND CHECKS&16384#0) C
THEN PRINTSTRING("@#")
L1:
LR=K&1
CH=(MNS(K//2)>>(8*(1-LR))) & 255
IF CH=' ' THEN START
IF L#0 THEN PRINTSYMBOL('B')
RETURN
FINISH
PRINTSYMBOL(CH)
K=K+1
-> L1
END; ! PMN
ROUTINE COMMA
PRINT SYMBOL(',')
END; ! COMMA
END; ! SS
ROUTINE FAULT(INTEGER I)
SETS(3); !SELECT LISTING FILE
NEWLINE
PRINTSTRING(";*")
WRITE(LINE,4)
SPACE
IF I=100 THEN ->L1
PRINTSTRING("FAULT")
WRITE(I,3)
L2: NEWLINE UNLESS I=45
FAULTS=FAULTS+1
IF I>100 THENSTOP
RETURN
L1: PRINTSTRING(" SYNTAX?")
->L2
END; ! FAULT
INTEGERFN NEWCELL
! ALLOCATE NEW CELL FOR LIST PROCESSING
! RETURNS INDEX IN ARRAY LINK - DOUBLE THIS FOR ARRAY TAG.
INTEGER I
IF ASL=0 THEN ->L1; ! END OF AVAILABLE SPACE LIST
I=ASL; ! POINTER TO TOP CELL OF ASL
ASL=LINK(ASL); ! ASL POINTER TO NEXT CELL DOWN
TAG(I)=0; ! CLEAR NEW CELL OUT
TAG1(I)=0
LINK(I)=0
RESULT =I; ! INDEX TO NEW CELL
L1: FAULT(107); !ASL EMPTY
END; ! NEWCELL
INTEGERFN RETURN CELL(INTEGER I)
! DEALLOCATE CELL AND RETURN IT TO ASL
INTEGER J
J=LINK(I); ! PRESENT LINK VALUE OF CELL
LINK(I)=ASL; ! LINK TO TOP OF ASL
ASL=I; ! ASL POINTER TO RETURNED CELL
RESULT =J; ! RETURN VALUE OF LINK
END; ! RETURN CELL
ROUTINE PUSH(INTEGERNAME CELL, INTEGER INF,INF1)
INTEGER M
M=NEWCELL
TAG(M)=INF
TAG1(M)=INF1
LINK(M)=CELL
IF CHECKS&1024#0 START
PRINTSTRING("PUSH ")
WRITE(CELL,1)
WRITE(M,1)
SPACE; HEX4(INF)
SPACE; HEX4(INF1)
NEWLINE
FINISH
CELL=M
END; ! PUSH
ROUTINE POP(INTEGERNAME CELL,INF,INF1)
INTEGER I
IF CELL=0 THEN ->L1
INF=TAG(CELL)
INF1=TAG1(CELL)
I=CELL
CELL=RETURN CELL(CELL)
IF CHECKS&1024#0 START
PRINTSTRING("POP ")
WRITE(I,1)
WRITE(CELL,1)
SPACE; HEX4(INF)
SPACE; HEX4(INF1)
NEWLINE
FINISH
RETURN
L1: INF=-1
IF CHECKS&1024#0 THEN PRINTSTRING("POP -1
")
END; ! POP
INTEGERFN TAG OF(INTEGER NAME)
INTEGER P
P=LINK(NAME)
IF P#0 THEN P=TAG(P)
RESULT =P
END; ! TAG OF
INTEGERFN TAG OFF(INTEGER N)
RESULT=TAG1(LINK(N))
END; ! TAG OFF
INTEGERFN PRINT4(INTEGER I)
INTEGER J,K,L,M,OE; OE=0
J=TAG(I); ! POINTER TO NAME CELL
L5:
! FIRST OR NEXT TWO CHARS.
IF OE=0 THEN K=TAG(J) ELSE K=TAG1(J)
L=8; ! FIRST CHAR. SHIFT
L4:
M=K>>L&255; ! CHAR.
IF M=0 THEN ->RES
IF TARGET&8192=0 THEN PRINTSYMBOL(M) ELSESTART; ! PRINT CHAR.
BIN(CA!!1)=M
CA=CA+1
FINISH
L=L-8; ! NEXT SHIFT
IF L>=0 THEN ->L4; ! MORE CHARS. YET
OE=1-OE
IF OE#0 THEN ->L5; ! GET NEXT TWO CHARS.
RES:
! RETURN NUMBER OF CHARS. PRINTED
IF L<0 THEN RESULT=4
IF L=8 THEN RESULT=2
IF OE=1 THEN RESULT=3 ELSE RESULT=1
END
ROUTINE PRINTNAME(INTEGER I)
INTEGER J,K,L,M,OE; OE=0
J=TAG(I); !POINTER TO NAME LIST
L5:
! FIRST OR NEXT FOUR CHARS
IF OE=0 THEN K=TAG(J) ELSE K=TAG1(J)
L=8; ! FIRST CHAR SHIFT VALUE
L4: M=K>>L&255; ! CHAR
IF M=0 THENRETURN
PRINTSYMBOL(M); ! PRINT CHAR
L=L-8; ! NEXT SHIFT
IF L>=0 THEN ->L4; ! MORE CHARS YET
OE=1-OE
IF OE#0 THEN -> L5
J=LINK(J); ! POINTER TO NEXT 4 CHARS
IF J#0 THEN ->L5; !GO UNLESS NO MORE CHARS
END; ! PRINTNAME
ROUTINE SHOW TAGS
! DISPLAY TAGS OF NAMES IN SCOPE
INTEGER I,J,K,L,M,OE; OE=0
IF CHECKS&32=0 THENRETURN
I=0; ! EXAMINE TAGS FROM 0 UP
L1: IF TAG(I)=0 THEN ->L2; ! NO NAME WITH IDENTIFICATION NU
NEWLINE
WRITE(I,3); ! IDENT. NO.
SPACES(4)
PRINT NAME(I)
L3: NEWLINE
SPACES(4)
J=LINK(I); ! POINTER TO NAME TAGS
L7: SPACES(4)
J=J&X'7FFF'
! FIRST TAGS WORD
IF OE=0 THEN K=TAG(J) ELSE K=TAG1(J)
L=28; ! FIRST SHIFT VALUE
L6: M=K>>L&15; ! NEXT HEX DIGIT
IF M<10 THEN PRINT SYMBOL(M+'0'); ! PRINT HEX DIGIT
IF M>=10 THEN PRINT SYMBOL(M+'A'-10)
L=L-4; ! NEXT SHIFT
IF L>=0 THEN ->L6; ! MORE DIGITS IN THIS WORD
OE=1-OE
IF OE#0 THEN -> L7
J=LINK(J); ! POINTER TO NEXT CELL
IF J#0 THEN ->L7; ! MORE CELLS
L2: I=I+1
IF I<=NNAMES THEN ->L1; ! MORE NAMES TO CONSIDER
NEWLINES(2)
END; ! SHOW TAGS
END; ! SKIMP11
EXTERNALSTRINGFNSPEC DATE
EXTERNALSTRINGFNSPEC TIME
EXTERNALROUTINESPEC CLOSE STREAM(INTEGER I)
EXTERNALROUTINESPEC DEFINE(STRING (63) S)
EXTERNALROUTINESPEC CLEAR(STRING(19) S)
!%EXTERNALROUTINESPEC SKIMP11(%INTEGER TARGET)
OWNINTEGER OST,SOU=1,OBJ=2,LST=2
OWNINTEGER OBJINIT=0,LSTINIT=0
OWNSTRING(63) SOUF="",OBJF="",LSTF="",LSTB=""
OWNINTEGER TARGET=0; !0=RELOCATABLE 1=ABSOLUTE
OWNINTEGERARRAY ENV(0:11)
OWNINTEGER BPP=0
!
!
!
EXTERNALROUTINE IMP11(STRING(63) S)
INTEGER J,K
ROUTINESPEC CHECK(INTEGER N STRING(63) S)
S=".IN" IF S=""
SOUF=S UNLESS S->SOUF.(",").OBJF
CHECK(1,SOUF)
IF OBJF="" THEN OBJF=".OUT"
IF BYTEINTEGER(ADDR(SOUF)+1)='.' AND SOUF#".IN" THENC
-> BAD
IF OBJF->OBJF.(",").LSTF START
IF LSTF->LSTF.(",").LSTB START
CHECK(4,LSTB)
TARGET=TARGET+4096
DEFINE("STREAM04,".LSTB)
FINISH
CHECK(3,LSTF)
FINISH
CHECK(2,OBJF)
IF LSTF="" THEN LSTF=OBJF
IF OBJF#LSTF THEN LST=5
IF SOUF#".IN" THENSTART
-> BAD IF SOUF=OBJF OR SOUF=LSTF
FINISH
! CLEAR("STREAMS")
DEFINE("STREAM01,".SOUF)
IF TARGET&8192#0 START
DEFINE("SQ3,".OBJF.",,F80")
DEFINE("STREAM06,SS#IMPLP")
SELECT OUTPUT(6)
FINISHELSESTART
DEFINE("STREAM02,".OBJF)
SELECT OUTPUT(2)
FINISH
! DEFINE("STREAM04,ERCC10.SPECS")
DEFINE("STREAM10,.NULL"); ! ONLY FOR TARGET NON-ZERO, TO THROW AWAY
! EARLY OUTPUT FOR SHORTNESS INTESTING
UNLESS LST=OBJ THENSTART
DEFINE("STREAM05,".LSTF)
SELECT OUTPUT(5)
FINISH
SELECT OUTPUT(0)
!
J=ADDR(ENV(0))
! *LA_15,<OUT>
! *L_1,J
! *STM_4,15,0(1)
IF LST=OBJ THEN TARGET=TARGET+4
SKIMP11(TARGET)
OUT:
CLEAR("STREAM01")
CLEAR("STREAM02")
CLEAR("STREAM05")
!
RETURN
INTEGERFN FN OK(STRING(63) S)
! FILENAME OK. (RESULT = 1 IF OK, 0 IF NOT).
INTEGER J,L,CH,AS
AS=ADDR(S)
L=LENGTH(S)
RESULT=1 UNLESS 0<L<=8
CYCLE J=1,1,L
CH=BYTEINTEGER(AS+J)
IF J=1 THENSTART
RESULT=1 UNLESS 'A'<=CH<='Z'
FINISH
RESULT=0 UNLESS '0'<=CH<='9' OR 'A'<=CH<='Z' OR CH='#'
REPEAT
RESULT=1; ! OK
END; ! FN OK
ROUTINE CHECK(INTEGER N STRING(63) S)
INTEGER J,AS,L,CH
STRING(63) USER,W,MEM
OWNSTRING(5) ARRAY PERI(1:6)= C
".IN",".OUT",".LP",".PP",".CP",".NULL"
AS=ADDR(S)
IF BYTEINTEGER(AS+1)='.' THENSTART
CYCLE J=1,1,6
-> OUT IF S->(PERI(J)).W AND LENGTH(W)<=2
REPEAT
-> BAD
FINISH
IF N=1 START
! LET SRC IP FILE HAVE USER.FILENAME
IF S->USER.(".").S AND LENGTH(USER)#6 THEN->BAD
IF S->S.("_").MEM START
-> BAD IF FN OK(MEM)=0
FINISH
-> BAD IF FN OK(S)=0
FINISH
OUT:
RETURN
BAD:
PRINTSTRING("BAD PARAM"); WRITE(N,1)
NEWLINE
STOP
END; !CHECK
BAD: PRINTSTRING("FOOLISH PARAMS
")
END; !IMP11
EXTERNALROUTINE SK11(STRING(63) S)
PRINTSTRING("IN FUTURE PLEASE USE ""IMP11"" INSTEAD OF ""SK11""
")
IMP11(S)
END; !SK11
EXTERNALROUTINE SKT(STRING(63) S)
TARGET=2
IMP11(S)
END; ! SKT
EXTERNALROUTINE IMP11A(STRING(63) S)
TARGET=1
IMP11(S)
END; !IMP11A
EXTERNALROUTINE SK11A(STRING(63) S)
PRINTSTRING("IN FUTURE PLEASE USE ""IMP11A"" INSTEAD OF ""SK11A""
")
IMP11A(S)
END; !SK11A
EXTERNALROUTINE SK114K
PRINTSTRING("PLEASE TYPE ""IMP11A"" HEREAFTER..
")
END
EXTERNALROUTINE IMP11S(STRING(63) S)
TARGET=TARGET+8192
IMP11(S)
END
EXTERNALROUTINE SETS(INTEGER N)
ROUTINESPEC TITLE
ROUTINESPEC IDENS
ROUTINESPEC SELOUT(INTEGER I)
INTEGER J
SWITCH A(0:6)
->A(N)
A(0): !SELECT SPECS OUTPUT
SELOUT(4)
-> L9
A(1): !SELECT SOURCE INPUT
SELECT INPUT(1)
-> L9
A(2): !SELECT OBJ OUTPUT
IF TARGET&8192=0 THEN SELOUT(2) ELSE SELOUT(6)
IF OBJINIT=0 THEN START
OBJINIT=1
IF OBJF=".OUT" THEN SELOUT(10) ELSE TITLE
FINISH
-> L9
A(3): !SELECT LISTING OUTPUT
SELOUT(LST)
IF LSTINIT=0 START
LSTINIT=1
IDENS
FINISH
-> L9
A(4): !CLOSE FILES
SELECT INPUT (0)
SELECT OUTPUT(0)
CLOSE STREAM(1)
CLOSE STREAM(LST) UNLESS LST=OBJ
CLOSESTREAM(4) UNLESS LSTB=""
IF TARGET&8192#0 THEN CLOSESTREAM(6) ELSE CLOSE STREAM(2)
-> L9
A(6): ! SELECT BINARY LP LISTING OUTPUT
SELOUT(6)
-> L9
A(5): ! QUIT
J=ADDR(ENV(0))
! *L_1,J
! *LM_4,15,0(1)
! *BCR_15,15
L9:
RETURN
ROUTINE TITLE
IDENS UNLESS OBJF=LSTF
PRINT STRING(" .TITLE ".SOUF."
")
END; ! TITLE
ROUTINE IDENS
RETURN IF OBJF=".OUT"
PRINTSTRING(";SOURCE=".SOUF." COMPILED: ".DATE." ".TIME."
;ASSEMBLER FILE=".OBJF."
")
END; ! IDENS
ROUTINE SELOUT(INTEGER I)
RETURN IF OST=I
SELECT OUTPUT(I)
OST=I
END; ! SELOUT
END; !SETS
ENDOFFILE
LL
IF J#0 THEN ->L7; ! MORE CELLS
L2: I=I+1
IF I<=NNAMES THEN -> L1; ! MORE NAMES TO CONSIDER
NEWLINES(2)
END