BEGIN; !HAL-70
! INPUT/OUTPUT STREAMS
OWNINTEGER MAIN=1, PRE=2; !INPUT
OWNINTEGER BIN=1, LIS=2; !OUTPUT
! OPERAND TYPES
OWNINTEGER OPMASK=16_F000; !MACHINE INSTRUCTION OR MACRO
OWNINTEGER MACRO=16_A000
OWNINTEGER SINGLE=16_5000
OWNINTEGER FMASK=16_0800; !FORWARD REF
OWNINTEGER OPFMASK=16_F800; !=OPMASK+FMASK
OWNINTEGER UMASK=16_0200; !UNDEF (FORWARD REF)
OWNINTEGER BMASK=16_0100; !BYTE
OWNINTEGER REG=16_0080; !REGISTER
OWNINTEGER MEMMASK=16_0040; !MEM REF
OWNINTEGER RELMASK=16_0020; !RELOCATABLE
OWNINTEGER XMASK=16_0010; !INDEXED
OWNINTEGER REGXMASK=16_0090; !=REG+XMASK
OWNINTEGER RELUXMASK=16_0230; !=RELMASK+UMASK+XMASK
! TEXT POINTERS (BYTE ADDRESSES)
OWNINTEGER CODEPOS; !(NOT ACTUALLY BYTE)
OWNINTEGER STARTPOS; !START OF CURRENT LINE
OWNINTEGER GETPOS; !INPUT POINTER (NEXT)
OWNINTEGER PUTPOS
OWNINTEGER PSEUDOLIM
OWNINTEGER PRINTPOS; !START OF PRINT LINE
OWNINTEGER FAULTPOS
OWNINTEGER MACLIM; !MACRO DEF LIMIT
! OTHER POINTERS (WORD ADDRESSES)
OWNINTEGER MP; !MACRO-CALL PARAMETERS
OWNINTEGER QBASE,QSTART,QLIM,TRANSF; !OPERAND QUEUE
OWNINTEGER DEFMIN; !TAG MIN (DOWN - RESET)
OWNINTEGER DEFLIM; !TAG LIM (FIXED)
OWNINTEGER ALMAX; !ASSEMBLER LAB MAX (UP - RESET)
OWNINTEGER LABMIN; !USER LAB MIN (DOWN - RESET)
OWNINTEGER LABLIM; !USER LAB LIM (FIXED)
OWNINTEGER BP; !BLOCK POINTER (UP - DOWN)
OWNINTEGER NP; !NEST POINTER (DOWN - UP)
OWNINTEGER STORELIM; !(FIXED)
INTEGER SYM; !CURRENT SYMBOL
INTEGER TERM; !TAG TERMINATOR
INTEGER FSYM; !FAULT FLAG SYMBOL
OWNINTEGER CHARS=0; !PRINT CHAR COUNT
OWNINTEGER LINES=0; !PRINT LINE COUNT
OWNINTEGER BINCOUNT=0; !OUTPUT RECORD ITEM COUNT
OWNINTEGER CHECK=0; !OUTPUT RECORD CHECKSUM
OWNINTEGER PASS=-1; !CURRENT PASS (-1,0,1)
OWNINTEGER LIST=-1; !LISTING CONTROL
INTEGER ASSCOND,SKIP; !ASSEMBLY CONDITIONS (BIT NEST)
OWNINTEGER SAVE=1; !REG SAVE DISPLACEMENT
OWNINTEGER TEMPS=12; !TEMPORARY REGISTER SET (2,3)
INTEGER LOCTYPE,LOC; !LOCATION COUNTER
INTEGER ACC,ATYPE,AVAL; !MAIN TEMP REGISTER
INTEGER CREG,CTYPE,CVAL; !CONDITION CODE
INTEGER COND; !CONDITION CODE MASK
INTEGER DREG,DUSE; !DESTINATION REGISTER
INTEGER TYPE,VAL; !CURRENT TYPE,VALUE
INTEGER TAG1,TAG2; !TAG (CHARS 1:3, 4:6)
INTEGER MODE; !ASSEMBLY MODE
INTEGER PEND; !TAG ALREADY RECOGNISED
INTEGER FLAG; !JUMPS / AHM
OWNINTEGER QQ='?'
OWNINTEGERARRAY BREC(1:52); !BINARY OUTPUT RECORD
!!%INTEGER SBOUND
constINTEGER SBOUND = 16_7F00
!! SBOUND = FREESTORE-260; !ALLOW FOR INPUT BUFFER
!! SBOUND = SBOUND-256 %IF OUTDEV = 2
SELECT OUTPUT(LIS)
!! SBOUND = SBOUND-256 %IF OUTDEV = 2
!! Simulate 18-bit word-addressed PDP9/15 memory:
ownINTEGERARRAY STORE(1:SBOUND)
integerfn integer(integer p)
if p&1 # 0 start
printstring("Integer fetch was not aligned at "); write(p, -1); newline
stop
finish
result = store(P>>1)
end
INTEGERFN CHAR(INTEGER P)
!BYTE FETCH
integer val = store(p>>1)
if p&1 = 0 start
result = val&255
else
result = (val>>8)&255
finish
!! %OPR 2064;!RCR; %DAC P
!! %LAC* P; %OPR 768;!SZL; %JMP L1
!! %OPR 1040;!RTR; %OPR 1040
!! %OPR 1040; %OPR 1040
!!L1: %AND #255; %JMP* CHAR
!! %STOP
END
routine set integer(integer p, k)
store(p>>1) = k
end
ROUTINE PUT CHAR(INTEGER K)
!AT PUTPOS WITH POST-INCREMENT
INTEGER P
!! %MONITOR 21 %IF PUTPOS>>1-DEFMIN >= 0
!{} %signal 2,1 %IF PUTPOS>>1-DEFMIN >= 0
p = store(putpos>>1)
if putpos&1 = 0 start
p = (p&16_FF00) ! (K&255)
else
p = (p&16_00FF) ! ((K&255)<<8)
finish
store(putpos>>1) = p
!! %LAC PUTPOS; %OPR 2064;!RCR; %DAC P
!! %OPR 768;!SZL; %JMP L1
!! %LAC K; %OPR 1032;!RTL; %OPR 1032
!! %OPR 1032; %OPR 1032; %DAC K
!! %LAC #-256; %OPR 513;!SKP!CMA
!!L1: %LAC #-256; %AND* P; %TAD K; %DAC* P
!! %ISZ PUTPOS
putpos = putpos+1
END
ROUTINE FAULT(INTEGER K)
!RECORD (FIRST) FAULT
!NOT NECESSARILY CULPABLE IN PASS 0
FSYM = K IF FSYM = ' '
END
ROUTINE PRINT(INTEGER K)
!! INTEGER(CODEPOS+CHARS) = K
set INTEGER(CODEPOS+CHARS, K)
CHARS = CHARS+1
END
ROUTINE PRINT WORD(INTEGER V)
ROUTINE PRINT HIT(INTEGER V)
V = V&15+'0'; V = V+7 IF V > '9'
PRINT(V)
END
ROUTINE PRINT1(INTEGER V)
PRINT HIT(V>>4); PRINT HIT(V)
END
PRINT1(V>>8); PRINT1(V)
END
ROUTINE PRINT LOC
PRINT WORD(LOC)
IF LOCTYPE&RELMASK # 0 THEN PRINT('''') ELSE PRINT(' ')
PRINT(' ')
END
ROUTINE DO NEWLINE
NEWLINE; LINES = LINES+1
NEWLINES(2) AND LINES = 0 IF LINES = 61
END
ROUTINE PRINT LINE
ROUTINE PRINTIT(INTEGER SUB)
OWNINTEGER MARKER=124; !VERTICAL BAR
INTEGER P,Q,K
RETURN IF CHARS = 0 AND CHAR(PRINTPOS) = NL
PRINT SYMBOL(FSYM); SPACE
P = CODEPOS; Q = P+CHARS
PRINT SYMBOL(INTEGER(P)) AND P=P+1 WHILE P # Q
RETURN IF PRINTPOS = 0
SPACES(17-CHARS)
P = PRINTPOS; Q = 0
CYCLE
PRINT SYMBOL(MARKER) IF P = FAULTPOS
K = CHAR(P); K = SUB IF P = PSEUDOLIM
PRINT SYMBOL('''') IF (K!!Q)&128 # 0
RETURN IF K = NL
PRINT SYMBOL(K&127)
P = P+1; Q = K
REPEAT
END
RETURN IF PASS = 0
UNLESS LIST < 0 OR (PRINTPOS=0 AND FSYM=' ' AND LIST&1=0) START
NEWLINES(3) IF LINES = 0
PRINTIT(' ')
DO NEWLINE
FINISH
IF FSYM # ' ' AND OUTDEV # 1 START
SELECT OUTPUT(0)
PRINTPOS = STARTPOS IF PRINTPOS = 0
PRINT LOC IF CHARS = 0
PRINTIT(NL)
NEWLINE
SELECT OUTPUT(LIS)
FINISH
FSYM = ' '; PRINTPOS = 0; CHARS = 0
END
ROUTINE PUT(INTEGER V)
!STORE 4-BIT ITEM IN BINARY RECORD
OWNINTEGER HOLD=0
V = V&15
HOLD = HOLD<<4+V
BINCOUNT = BINCOUNT+1
IF BINCOUNT&3 = 0 START
BREC(BINCOUNT>>2) = HOLD
CHECK = CHECK!!HOLD
HOLD = 0
FINISH
END
ROUTINE PUT WORD(INTEGER V)
ROUTINE PUT1(INTEGER V)
PUT(V>>4); PUT(V)
END
PUT1(V>>8); PUT1(V)
END
ROUTINE OUTPUT RECORD
OWNINTEGER SEQ=0
INTEGER I
ROUTINE OUTPUT WORD(INTEGER W)
PRINT CH(W>>8&255); PRINT CH(W&255)
END
PUT(0) WHILE BINCOUNT # 208
SELECT OUTPUT(BIN)
CYCLE I = 1,1,10
PRINT CH(0); !RUNOUT
REPEAT
PRINT CH(16_F0); !HEADER CODE
SEQ = SEQ-1
OUTPUT WORD(SEQ); !SEQUENCE NUMBER
OUTPUT WORD(¬(CHECK!!SEQ)); !CHECKSUM
CYCLE I = 1,1,52
OUTPUT WORD(BREC(I))
REPEAT
BINCOUNT = 0; CHECK = 0
SELECT OUTPUT(LIS)
END
ROUTINE PLANT VAL
INTEGER I,J
TYPE = 0 IF TYPE = SINGLE
I = 2; I = 4 IF TYPE&OPMASK # 0
IF PASS > 0 START
OUTPUT RECORD IF BINCOUNT+I+I >= 208
IF I = 4 START
IF TYPE&16_4000 = 0 START
PUT(11); J = TYPE!!OPMASK
TYPE = RELMASK
finish ELSE START
PUT(10); J = TYPE; TYPE = 0
FINISH
PUT WORD(J)
PRINT LINE IF CHARS # 0
PRINT LOC
PRINT WORD(J); PRINT(' ')
finish ELSE START
IF TYPE&RELMASK # 0 THEN PUT(9) ELSE PUT(8)
IF CHARS # 0 THEN PRINT(' ') ELSE PRINT LOC
FINISH
PUT WORD(VAL); PRINT WORD(VAL)
PRINT('''') IF TYPE&RELMASK # 0
PRINT LINE IF TYPE&RELMASK#0 OR CHARS=15
FINISH
LOC = LOC+I
END
ROUTINE NEST(INTEGER K)
!! NP = NP-1; %MONITOR 23 %IF NP = BP
NP = NP-1; !{}%signal 2,3 %IF NP = BP
!! INTEGER(NP) = K
set INTEGER(NP, K)
END
ROUTINE SET LAB(INTEGER DEST)
INTEGER D
D = DEST
CYCLE
TYPE = INTEGER(NP)&16_FFF+DEFLIM; !DEST SLOT
NP = NP+1
VAL = INTEGER(NP); !LOC OF JUMP
NP = NP+1
ATYPE = -1; CREG = -1
FLAG = 0; FLAG = 2 IF (D-VAL)>>1+PASS <= 16
VAL = VAL-FLAG
IF PASS = 0 START
!! D = D-FLAG; INTEGER(TYPE) = D
D = D-FLAG; set INTEGER(TYPE, D)
IF FLAG # 0 START
LOC = LOC-2; DEST = DEST-2
WHILE TYPE # ALMAX CYCLE
!! TYPE = TYPE+1; INTEGER(TYPE) = INTEGER(TYPE)-2
TYPE = TYPE+1; set INTEGER(TYPE, INTEGER(TYPE)-2)
REPEAT
FINISH
finish ELSE START
FAULT('P') IF INTEGER(TYPE) # D
FINISH
RETURN UNLESS INTEGER(NP)&16_1000 # 0
IF INTEGER(NP)&16_2000 # 0 START; !OR
D = VAL+4 IF D = DEST
finish ELSE START
D = DEST
FINISH
REPEAT
END
ROUTINE ASSEMBLE
! INTERDATA OP-CODES (+FORMATS)
OWNINTEGER LOAD=16_080F, LB=16_9303
OWNINTEGER ADD=16_0A0F, SUB=16_0B0F, AND=16_0407
OWNINTEGER OR=16_0607, XOR=16_0707
OWNINTEGER SLLS=16_7508, SRLS=16_7408, SLHL=16_0D04, SRHL=16_0C04
OWNINTEGER COMP=16_0907, CLB=16_9402
OWNINTEGER STORE=16_0002, STB=16_9202, AHM=16_2102
OWNINTEGER BT=16_0203, BF=16_0303
! FORMAT CODES
OWNINTEGER REGISTER=1, MEM=2, LIT=4, SHORT=8
OWNINTEGER ZQUERY=0
INTEGER OP,K,Q,LITVAL,NQ,TYPE1,VAL1,FREE
SWITCH ASS(-30:-1)
ROUTINE FORM INST(INTEGER CODE)
! LS 4 BITS OF CODE DEFINE VALID FORMATS
! INTERDATA OP-CODES FOR DIFFERENT FORMATS
! ARE SYSTEMATICALLY RELATED
! SHORT=REGISTER+SINC, LIT=REGISTER+LINC, MEM=REGISTER+MINC
OWNINTEGER SINC=16_1C00, LINC=16_C000, MINC=16_4000
INTEGER OP
OP = CODE&16_FFF0
IF TYPE = REG START
IF CODE®ISTER # 0 START
TYPE = SINGLE; VAL = OP+VAL
RETURN
FINISH
TYPE = XMASK+VAL; VAL = 0; !COERCE TO INDEXED IMMEDIATE
FINISH
!! %IF TYPE=0 %AND !VAL!<=15 %AND CODE&SHORT#0 %START; !SHORT
IF TYPE=0 AND |VAL|<=15 AND CODE&SHORT#0 START; !SHORT
VAL = -VAL AND OP = OP!!16_100 IF VAL < 0
TYPE = SINGLE; VAL = OP+SINC+VAL
finish ELSE START
FAULT('R') IF TYPE&31 = XMASK; !R0 AS INDEX
IF TYPE&MEMMASK = 0 START; !IMMEDIATE
FAULT('I') IF CODE&LIT = 0
OP = OP+LINC
finish ELSE START; !MEMORY
FAULT('I') IF CODE&MEM = 0
OP = OP+MINC
FINISH
OP = OP!!OPMASK IF TYPE&RELMASK # 0
TYPE = TYPE&15+OP
FINISH
END
ROUTINE PLANT JUMP
INTEGER I,OP
OP = BF; COND=¬COND AND OP=BT IF COND < 0
IF TYPE&(¬UMASK) = LOCTYPE START
I = LOC>>1-VAL>>1
!! FAULT('J') %AND I=0 %IF FLAG # 0 %AND !I! > 15
FAULT('J') AND I=0 IF FLAG # 0 AND |I| > 15
!! %IF !I! <= 15 %START
IF |I| <= 15 START
IF TYPE&UMASK = 0 OR FLAG # 0 START
OP = OP<<1+2; !0408, 0608
TYPE = 0; VAL = I
finish ELSE START
FAULT('S') IF LIST >= 0 AND LIST&8 # 0
FINISH
FINISH
FINISH
FORM INST(COND<<4+OP)
PLANT VAL
COND = 0
END
ROUTINE SET JUMP(INTEGER CASE)
INTEGER THOLD,VHOLD,FHOLD
!! ALMAX = ALMAX+1; %MONITOR 22 %IF ALMAX = LABMIN
ALMAX = ALMAX+1; !{}%signal 2,2 %IF ALMAX = LABMIN
NEST(LOC); NEST(ALMAX-DEFLIM+CASE)
THOLD = TYPE; VHOLD = VAL; FHOLD = FLAG
TYPE = LOCTYPE; VAL = INTEGER(ALMAX); FLAG = 0
TYPE = TYPE+UMASK IF PASS = 0
COND = ¬COND
PLANT JUMP
TYPE = THOLD; VAL = VHOLD; FLAG = FHOLD
END
ROUTINE PLANT INST(INTEGER CODE)
FORM INST(CODE)
SET JUMP(16_1000) IF COND # 0
PLANT VAL
END
ROUTINE LOAD REG(INTEGER R)
INTEGER OP
IF ATYPE = TYPE AND AVAL = VAL START
TYPE = REG; VAL = ACC
RETURN IF R = ACC
FINISH
ATYPE = TYPE AND AVAL = VAL IF R = ACC
ATYPE = -1 IF (ATYPE=REG AND AVAL=R) OR ATYPE&15=R#0
IF TYPE&BMASK = 0 START
OP = LOAD
OP = ADD AND TYPE = 0 IF TYPE!!XMASK = R # 0
CREG = R; CTYPE = 0; CVAL = 0
finish ELSE START
OP = LB
CREG = -1 IF CREG = R
FINISH
PLANT INST(R<<4+OP)
TYPE = REG; VAL = R
END
ROUTINE RELEASE
INTEGER I
RETURN IF TYPE®XMASK = 0
I = TYPE&15; I = VAL IF I = 0
IF I = DREG START
DUSE = DUSE-1
finish ELSE START
I = 1<<I
FREE = FREE!I IF TEMPS&I # 0
FINISH
END
ROUTINE LOAD TEMP
INTEGER I,J
RELEASE
IF DREG >= ZQUERY AND DUSE = 0 START
I = DREG; DUSE = 1
finish ELSE START
J = 1+ZQUERY
CYCLE I = ZQUERY,1,15
->OK IF FREE&J # 0 AND I # DREG
J = J<<1
REPEAT
FAULT('R')
OK: FREE = FREE-J
FINISH
LOAD REG(I)
END
ROUTINE SWOP
INTEGER K
K = TYPE1; TYPE1 = TYPE; TYPE = K
K = VAL1; VAL1 = VAL; VAL = K
END
ROUTINE PROGREF
IF TYPE&RELUXMASK = XMASK AND VAL = 0 START
VAL = TYPE&15; TYPE = REG
FINISH
TYPE = TYPE!MEMMASK IF TYPE # REG
END
Q = QSTART
NEW:NQ = QSTART; FREE = TEMPS
TYPE = INTEGER(Q); Q = Q+1
VAL = INTEGER(Q); Q = Q+1
GET:CYCLE
RETURN IF Q = QLIM
K = INTEGER(Q); Q = Q+1
->ASS(K) IF K < 0
!! INTEGER(NQ) = TYPE1; INTEGER(NQ+1) = VAL1
set INTEGER(NQ, TYPE1); set INTEGER(NQ+1, VAL1)
NQ = NQ+2
TYPE1 = TYPE; VAL1 = VAL
TYPE = K; VAL = INTEGER(Q); Q = Q+1
REPEAT
PREDICATE TEMP
FALSE IF TYPE1 # REG
IF VAL1 = DREG START
FALSE IF DUSE # 1
finish ELSE START
FALSE IF 1<<VAL1&TEMPS = 0
FINISH
TRUE
END
NOP: K = 0; !NOT SYMMETRIC
BOP:IF MODE <= 0 OR (TYPE = 0 AND TYPE1 = 0) START
FAULT('A') IF TYPE # 0
TYPE = TYPE1; VAL = LITVAL
finish ELSE START
IF NOT TEMP OR (TYPE=REG AND VAL=DREG AND DUSE=1 AND K#0) START
SWOP
IF K = 0 OR NOT TEMP START
LOAD TEMP; SWOP
FINISH
FINISH
LOAD TEMP IF TYPE&BMASK # 0 OR (OP&MEM=0 AND TYPE&MEMMASK#0)
RELEASE
PLANT INST(VAL1<<4+OP)
TYPE = REG; VAL = VAL1
CREG = VAL; CTYPE = 0; CVAL = 0
ATYPE = -1 IF ACC = VAL OR ATYPE&15 = VAL # 0
ATYPE = -1 IF ATYPE = REG AND AVAL = VAL
FINISH
POP:NQ = NQ-2
TYPE1 = INTEGER(NQ); VAL1 = INTEGER(NQ+1)
->GET
ASS(-2):
OP = SUB
->NOP IF MODE > 0 AND TYPE # 0
TYPE1 = 0 AND TYPE = 0 IF MODE <= 0 AND TYPE1 = TYPE
VAL = -VAL
ASS(-1):
OP = ADD; LITVAL = VAL1+VAL
->BOP UNLESS TYPE = 0
IF TYPE1&MEMMASK # 0 AND MODE > 0 START
SWOP; LOAD TEMP; SWOP
FINISH
IF TYPE1 = REG START
->BOP IF VAL1 = 0
TYPE1 = XMASK+VAL1; LITVAL = VAL
FINISH
TYPE = TYPE1; VAL = LITVAL
->POP
ASS(-3):
OP = AND; LITVAL = VAL1&VAL
->BOP
ASS(-4):
OP = OR; LITVAL = VAL1!VAL
->BOP
ASS(-5):
OP = XOR; LITVAL = VAL1!!VAL
->BOP
ASS(-6):
OP = SLLS; LITVAL = VAL1<<VAL
OP = SLHL IF TYPE # 0
->NOP
ASS(-7):
OP = SRLS; LITVAL = VAL1>>VAL
OP = SRHL IF TYPE # 0
->NOP
ASS(-8): !TYPE_VAL
TYPE = VAL1
TYPE = 0 IF TYPE&OPMASK = MACRO; !SAFETY
TYPE = 0 IF TYPE&(OPMASK+FMASK) = FMASK
->POP
ASS(-11): !COMPARE
K = INTEGER(Q); Q = Q+1
IF MODE <= 0 START
VAL1 = TYPE1 AND VAL = TYPE IF TYPE1 # TYPE
LITVAL = ¬3
LITVAL = 1 IF VAL1 < VAL
LITVAL = 2 IF VAL1 > VAL
K = K&LITVAL; K = ¬0 IF K # 0
finish ELSE UNLESS CREG=16 AND TYPE1=CTYPE AND VAL1=CVAL AND TYPE=VAL=0 START
IF TYPE1 # REG START
SWOP
IF TYPE1 # REG START
LOAD TEMP; SWOP
finish ELSE START
K = K!!3 UNLESS K = 3 OR K = ¬3
FINISH
FINISH
UNLESS CREG = VAL1 AND CTYPE = TYPE AND CVAL = VAL START
CREG = VAL1; CTYPE = TYPE; CVAL = VAL
UNLESS TYPE = VAL = 0 START
OP = COMP
IF TYPE = ATYPE AND VAL = AVAL START
TYPE = REG; VAL = ACC
FINISH
IF TYPE&BMASK # 0 START
OP = CLB
FAULT('I') UNLESS K = 3 OR K = ¬3
FINISH
finish ELSE START
OP = LOAD
TYPE = REG; VAL = VAL1
FINISH
PLANT INST(VAL1<<4+OP)
FINISH
FINISH
COND = K
->GET
ASS(-12): !TEST CC
COND = ¬VAL
->GET
ASS(-13): !AND,WHILE
IF MODE > 0 START
SET JUMP(16_1000)
finish ELSE START
RETURN IF COND # 0; !CONDITION FALSE
FINISH
RETURN IF Q = QLIM
->NEW
ASS(-14): !OR
IF MODE > 0 START
COND = ¬COND
SET JUMP(16_3000)
finish ELSE START
RETURN IF COND = 0; !CONDITION TRUE
FINISH
->NEW
ASS(-15): !IF
SET JUMP(16_2000)
RETURN
ASS(-16): !ELSE
COND = ¬0
SET JUMP(16_4000)
RETURN
ASS(-17): !IF AFTER ELSE
SET JUMP(16_6000)
RETURN
ASS(-18): !MACCALL IF
SET JUMP(16_8000)
RETURN
ASS(-20): !HASH
TYPE = TYPE&(UMASK+63)
->GET
ASS(-21): !INDEX
FAULT('I') IF TYPE1®XMASK # 0
IF TYPE&MEMMASK # 0 START
IF MODE > 0 START
ZQUERY = 1
LOAD TEMP
ZQUERY = 0
finish ELSE FAULT('A')
FINISH
IF TYPE = REG START
TYPE = XMASK+VAL; VAL = 0
FINISH
ZQUERY = 0
FAULT('I') IF TYPE1&TYPE&RELMASK # 0
TYPE = TYPE1!TYPE!MEMMASK; VAL = VAL1+VAL
->POP
ASS(-22): !MINST SEPARATOR
IF TYPE1&OPMASK = 16_7000 START
IF TYPE1&16_10 = 0 START; !REG-TYPE INST
FAULT('I') IF TYPE # REG
finish ELSE START
VAL = ¬VAL AND VAL1 = VAL1!!16_0100 IF VAL < 0
FAULT('I') IF TYPE # 0 OR VAL > 15
FINISH
TYPE = TYPE1+16_8000; VAL = VAL1&16_FF0F+VAL<<4
finish ELSE IF TYPE1&OPMASK = 16_F000 START
PROGREF IF VAL1&16_FC0F = 16_0003; !BAL,BTC,BFC
FORM INST(VAL1)
finish ELSE FAULT('I')
->POP
ASS(-23): !MACHINE INST
SET JUMP(16_1000) IF COND # 0
PLANT VAL
CREG = -1; ATYPE = -1
RETURN
ASS(-24): !LOAD
LOAD TEMP IF TYPE # REG
Q = QBASE
->GET
ASS(-25): !STORE (TYPE1,VAL1 -> TYPE,VAL)
IF TYPE = REG START
SWOP AND LOAD REG(VAL1) IF VAL1 # VAL
finish ELSE START
ATYPE = -1 IF ATYPE&MEMMASK # 0
IF FLAG = 0 START
IF VAL1 = ACC AND ATYPE < 0 START
K = TYPE&15
ATYPE = TYPE AND AVAL = VAL IF K = 0 OR 1<<K&TEMPS = 0
FINISH
OP = STORE; OP = STB IF TYPE&BMASK # 0
finish ELSE START
CREG = 16; CTYPE = TYPE; CVAL = VAL
OP = AHM
FINISH
PLANT INST(VAL1<<4+OP)
FINISH
RETURN
ASS(-26): !JUMP
SET JUMP(16_1000) IF INTEGER(NP)&16_F000 = 16_3000; !OR
IF FLAG < 0 START; !REPEAT
FLAG = 0
IF PASS = 0 START
K = NP; LITVAL = LOC
WHILE INTEGER(K)&16_1000 # 0 CYCLE
K = K+2; LITVAL = LITVAL-2
REPEAT
FLAG = 1 IF LITVAL-VAL < 32
FINISH
FINISH
PROGREF
PLANT JUMP
RETURN
END; !ASSEMBLE
ROUTINE LOOKUP(INTEGER CONTROL)
!ALL DICT OPERATIONS LOCALISED HERE
!CONTROL = 0 (LOOKUP ONLY), 1 (FORWARD OK),
! 2 (REDEF), 3 (DEF),
! 4 (MACPARM), 7 (LABEL)
INTEGER DP
DP = DEFMIN; DP = MP+5 IF CONTROL = 4
{} WHILE INTEGER(DP) # 0 CYCLE
{} ->YES IF INTEGER(DP) = TAG1 AND INTEGER(DP+1) = TAG2
{} DP = DP+4
{} REPEAT
!!%OWNINTEGER P
!! DP = DP-4
!!REP:DP = DP+4
!! %LAC* DP; %OPR 640;!SNA; %JMP NO
!! %SAD TAG1; %OPR 512; %JMP REP
!! %LAC DP; %TAD #1; %DAC P
!! %LAC* P; %SAD TAG2; %JMP YES
!! ->REP
!!NO:
RETURN IF CONTROL&1 = 0; !NO CREATION
NEW:DEFMIN = DEFMIN-4; DP = DEFMIN
!! %MONITOR 21 %IF DP-QLIM <= 0
!{}%signal 2,1 %IF DP-QLIM <= 0
!! INTEGER(DP) = TAG1; INTEGER(DP+1) = TAG2
set INTEGER(DP, TAG1); set INTEGER(DP+1, TAG2)
!!SET:INTEGER(DP+2) = TYPE; INTEGER(DP+3) = VAL
SET:set INTEGER(DP+2, TYPE); set INTEGER(DP+3, VAL)
RETURN
YES:IF CONTROL&2 = 0 START; !NOT DEF CLASS
TYPE = INTEGER(DP+2); VAL = INTEGER(DP+3)
RETURN
FINISH
IF CONTROL = 3 START
->NEW IF DP-INTEGER(BP) >= 0; !GLOBAL
FAULT('D')
FINISH
->SET IF CONTROL # 7
IF INTEGER(DP+2)&OPFMASK = FMASK START
VAL = INTEGER(DP+3)
IF PASS = 0 START
!! INTEGER(VAL) = LOC
set INTEGER(VAL, LOC)
finish ELSE START
FAULT('P') AND LOC=INTEGER(VAL) IF INTEGER(VAL) # LOC
FINISH
VAL = LOC
finish ELSE START
->NEW IF DP-INTEGER(BP) >= 0
FAULT('D')
FINISH
->SET
END
ROUTINE TAGREF
OWNINTEGER B=2184, W=24717
IF TERM = '(' START
TYPE = 0; VAL = 0
RETURN IF TAG1 = W
TYPE = BMASK
RETURN IF TAG1 = B
FINISH
TYPE = LOCTYPE+FMASK+UMASK; VAL = LABMIN-1
LOOKUP(1)
IF TYPE&OPFMASK = FMASK START
IF VAL = LABMIN-1 START
!! LABMIN = VAL; %MONITOR 22 %IF LABMIN = ALMAX
LABMIN = VAL; !{}%signal 2,2 %IF LABMIN = ALMAX
FINISH
IF PASS > 0 START
VAL = INTEGER(VAL)
FAULT('U') IF VAL = 0
FINISH
TYPE = TYPE-FMASK
FINISH
END
ROUTINE GET SYM
CYCLE
SYM = CHAR(GETPOS); GETPOS = GETPOS+1
RETURN IF SYM # ' '
REPEAT
END
PREDICATE S(INTEGER K)
FALSE UNLESS K = SYM
GET SYM
TRUE
END
PREDICATE SS(INTEGER K)
FALSE UNLESS K = SYM = CHAR(GETPOS)
GETPOS = GETPOS+1
GET SYM
TRUE
END
PREDICATE TAG
INTEGER J,K
ROUTINE CODE SYM
SYM = CHAR(GETPOS); GETPOS = GETPOS+1
K = SYM-'0'
IF K >= 0 START
TERM = -1 AND RETURN IF K < 10
K = SYM-'A'
RETURN IF K >= 0 AND K < 26 AND TERM = 0
FINISH
TERM = SYM
END
ROUTINE PACK TRIPLE
->T1 IF TERM < 0
J = ((K<<5+K)<<1+K)<<4+K+1111; !K*1073+1111
CODE SYM
->T2 IF TERM # 0
J = (K<<3+K)<<2+K+111+J; !J+K*37+111
CODE SYM
->T3 IF TERM # 0
J = J+K+11
CODE SYM
RETURN
T1: J = ((K<<1+K)<<1+K)<<4-K+1; !K*111+1
CODE SYM
T2: RETURN IF TERM > 0
J = (K<<2+K)<<1+K+1+J; !J+K*11+1
CODE SYM
T3: RETURN IF TERM > 0
J = J+K+1
CODE SYM
END
K = SYM-'A'
FALSE UNLESS K >= 0 AND K < 26
FALSE IF SYM = 'X' AND CHAR(GETPOS)&128 # 0
TERM = 0
PACK TRIPLE
TAG1 = J
CYCLE
J = 0
PACK TRIPLE IF TERM <= 0
TAG2 = J
CODE SYM WHILE TERM <= 0
EXIT UNLESS TERM = QQ
TYPE = 1; LOOKUP(0)
FAULT('U') IF TYPE # 0
TAG1 = VAL
TERM = 0; CODE SYM
REPEAT
GET SYM IF TERM = ' '
TRUE
END
PREDICATE TAGIF
FALSE UNLESS SYM='I' AND CHAR(GETPOS)='F' AND CHAR(GETPOS+1)=' '
GETPOS = GETPOS+2
GET SYM
TRUE
END
ROUTINE QUEUE(INTEGER K)
!! INTEGER(QLIM) = K
set INTEGER(QLIM, K)
!! QLIM = QLIM+1; %MONITOR 21 %IF QLIM = DEFMIN
QLIM = QLIM+1; !{}%signal 2,1 %IF QLIM = DEFMIN
END
ROUTINE GET EXP
INTEGER I,NBASE
NBASE = NP
->E3 IF PEND # 0
E1: NEST(0) WHILE S('(')
NEST(-20) IF S('#')
IF TAG START
E3: TAGREF IF PEND >= 0
PEND = 0
IF TYPE = REG AND TERM = '(' START
TYPE = 0 IF SAVE&1 = 0; VAL = VAL+VAL+SAVE
FINISH
FAULT('I') AND TYPE=0 IF TYPE&OPMASK # 0
IF MODE # 0 START
IF TYPE®XMASK # 0 START
I = TYPE&15; I = VAL IF I = 0
DUSE = DUSE+1 IF I = DREG
FINISH
FINISH
IF TERM = '(' START
GET SYM
I = TYPE&31
QUEUE(TYPE-I); QUEUE(VAL)
NEST(-21); NEST(0)
IF I # 0 START
QUEUE(REG); QUEUE(I&15)
NEST(-1)
FINISH
->E1
FINISH
finish ELSE IF '0' <= SYM <= '9' START
TYPE = 0; VAL = SYM-'0'
CYCLE
SYM = CHAR(GETPOS)-'0'
EXIT UNLESS 0 <= SYM <= 9
VAL = (VAL<<2+VAL)<<1+SYM
GETPOS = GETPOS+1
REPEAT
GET SYM
finish ELSE IF SYM = 'X' START
TYPE = 0; VAL = 0
CYCLE
SYM = CHAR(GETPOS)-128
EXIT IF SYM < 0
SYM = SYM-32 IF SYM >= 96; !ENSURE UPPER-CASE
IF '0' <= SYM <= '9' OR 'A' <= SYM <= 'F' START
VAL = VAL<<4+SYM-'0'
VAL = VAL-7 IF SYM >= 'A'
finish ELSE FAULT('H')
GETPOS = GETPOS+1
REPEAT
GET SYM
finish ELSE IF SYM&128 # 0 START
TYPE = 0; VAL = SYM-128
GET SYM
IF MODE >= 0 AND SYM&128 # 0 START
VAL = VAL<<8+SYM-128; GET SYM
FINISH
finish ELSE IF S('.') START
->ERR IF NOT TAG
TYPE = 0; VAL = TAG1
finish ELSE IF S('*') START
TYPE = LOCTYPE&63; VAL = LOC
IF SYM = 'L' START; !FOR NOW
TYPE = 0; VAL = LIST IF TAG
FINISH
finish ELSE IF SYM = '-' START
TYPE = 0; VAL = 0
finish ELSE IF SYM = '¬' START
TYPE = 0; VAL = ¬0
finish ELSE ->ERR
QUEUE(TYPE); QUEUE(VAL)
WHILE NP # NBASE CYCLE
IF INTEGER(NP) < 0 START
QUEUE(INTEGER(NP))
finish ELSE START
EXIT IF NOT S(')')
FINISH
NP = NP+1
REPEAT
I = 1
NEST(-1) AND ->E8 IF S('+')
NEST(-2) AND ->E8 IF S('-')
NEST(-3) AND ->E9 IF S('&')
NEST(-4) AND ->E9 IF S('!')
NEST(-5) AND ->E9 IF S('¬')
NEST(-6) AND ->E9 IF SS('<')
NEST(-7) AND ->E9 IF SS('>')
NEST(-8) AND ->E9 IF S('_')
RETURN IF NP = NBASE
ERR:NP = NBASE
!! %MONITOR 19
E8: I = 0
E9: ->E1 UNLESS MODE = 2 AND NP+1 = NBASE
IF FLAG = I THEN FLAG = QLIM ELSE FLAG = -1
->E1
END
ROUTINE CONDIT(INTEGER QVAL)
OWNINTEGER AND=1717, OR=16873
INTEGER J,K
TRANSF = QSTART; QSTART = QLIM
J = 0
CYCLE
GET EXP
IF S('=') START
K = 3
finish ELSE IF S('#') START
K = ¬3
finish ELSE IF S('<') START
K = ¬1; K = 2 IF S('=')
finish ELSE IF S('>') START
K = ¬2; K = 1 IF S('=')
finish ELSE START
QUEUE(-12)
->ANDOR
FINISH
GET EXP
QUEUE(-11); QUEUE(K)
ANDOR:
EXIT IF NOT TAG
IF TAG1 = AND AND TAG2 = 0 START
!! %MONITOR 19 %IF J < 0
J = 1; QUEUE(-13)
finish ELSE START
!! %MONITOR 19 %IF TAG1 # OR %OR J > 0
J = -1; QUEUE(-14)
FINISH
REPEAT
QUEUE(QVAL) IF QVAL # 0
ASSEMBLE
ATYPE=-1 AND CREG=-1 IF J < 0
END
ROUTINE GET INST
INTEGER I
!OPMASK VALUES
! 0100,0110,1100,1101,1110: DOUBLE WORD INSTRUCTIONS
! 1011,1001,0011,0010,0001: AS ABOVE BUT RELOCATABLE
! 0101: SINGLE WORD INSTRUCTION
! 0111: 2 OPERANDS TO COME
! 1111: 1 OPERAND TO COME
! 1010: MACRO
QUEUE(TYPE); QUEUE(VAL)
RETURN IF TYPE&16_7000 # 16_7000
RETURN IF TERM # ' '; !NO OPERAND FOLLOWING =>
CYCLE
GET EXP
QUEUE(-22)
RETURN IF NOT S(',')
REPEAT
END
ROUTINE READ LINE
INTEGER Q
PUTPOS = STARTPOS
IF MP = 0 START
Q = 0; PSEUDOLIM = 0
CYCLE
READ SYMBOL(SYM)
READ SYMBOL(SYM) AND Q=Q!!128 IF SYM = ''''
EXIT IF SYM = NL
SYM = SYM-32 IF SYM-Q >= 96; !LOWER-CASE -> UPPER-CASE
SYM = SYM+Q
EXIT IF SYM = '/' AND PSEUDOLIM # 0
IF SYM = ' ' START
PSEUDOLIM = PUTPOS IF PSEUDOLIM = 0
finish ELSE PSEUDOLIM = 0
PUT CHAR(SYM)
REPEAT
IF PSEUDOLIM # 0 START
Q = PUTPOS; PUTPOS = PSEUDOLIM
PUT CHAR(NL)
PUTPOS = Q
FINISH
CYCLE
PUT CHAR(SYM)
EXIT IF SYM = NL
READ SYMBOL(SYM)
REPEAT
PRINTPOS = STARTPOS
finish ELSE START
GETPOS = INTEGER(MP)
IF CHAR(GETPOS) = 0 START
QBASE = MP
GETPOS = INTEGER(MP+2)
STARTPOS = INTEGER(MP+3)
MP = INTEGER(MP+4)
IF MP < 0 START
MP = MP-8_700000
WHILE INTEGER(NP)&16_8000 = 0 CYCLE
FAULT('C'); NP = NP+2
REPEAT
SET LAB(LOC)
FINISH
PRINTPOS = 0 IF LIST&2 # 0
GET SYM; !TERMINATOR
GET SYM IF SYM = ';'
RETURN
FINISH
PRINTPOS = STARTPOS IF LIST&2 # 0
QQ = 0
CYCLE
SYM = CHAR(GETPOS); GETPOS = GETPOS+1
IF TAG START
SYM=TERM AND GETPOS=GETPOS-1 IF TERM = ' '
TYPE = INTEGER(MP); VAL = GETPOS-1
LOOKUP(4)
WHILE TYPE # VAL CYCLE
PUT CHAR(CHAR(TYPE))
TYPE = TYPE+1
REPEAT
FINISH
PUT CHAR(SYM)
!! INTEGER(MP) = GETPOS
set INTEGER(MP, GETPOS)
EXIT IF SYM = NL
REPEAT
QQ = '?'
FINISH
QBASE = (PUTPOS+1)>>1
GETPOS = STARTPOS; GET SYM
END
ROUTINE SCAN ARG
! SET TYPE,VAL TO START,LIM OF ARG IF NOT NULL
INTEGER I,J
RETURN IF SYM='I' AND CHAR(GETPOS)='F' AND CHAR(GETPOS+1)=' '
I = GETPOS-1; I = GETPOS IF SYM = '['
J = 0
CYCLE
EXIT IF SYM = NL
EXIT IF (SYM=' ' OR SYM=',' OR SYM=';') AND J<=0
J = J+1 IF SYM = '['
IF SYM = ']' START
J = J-1; EXIT IF J = 0
FINISH
SYM = CHAR(GETPOS); GETPOS = GETPOS+1
REPEAT
IF GETPOS-1 # I START
TYPE = I; VAL = GETPOS-1
FINISH
GET SYM IF SYM = ']'
END
ROUTINE SET ACC
INTEGER I
ACC = -1; ATYPE = -1; CREG = -1
I = TEMPS
RETURN IF I = 0
CYCLE
ACC = ACC+1
RETURN IF I&1 # 0
I = I>>1
REPEAT
END
!MAIN PROGRAM
!RADIX 36 CONSTANTS
OWNINTEGER B=2184, IF=9991, ELS=5950, E=5403, FIN=6907, ISH=10490
OWNINTEGER JUM=11642, P=17206, PS=17983, DEF=4605, END=6009
INTEGER I,J,K
!!%FAULT 19 ->ERR; !RECOGNITION ERROR
!!%FAULT 9 ->BEND; !INPUT ENDED
on event 9,1 start
->err if event_event = 9
->bend if event_event = 1 and event_sub = 9
stop
finish
open input(MAIN, "interdata/test.hal")
open input(PRE, "interdata/hal70.def")
open output(BIN, "interdata/test.bin")
open output(LIS, "interdata/test.lis")
select output(0)
CYCLE I = 1,1,SBOUND
STORE(I) = 0
REPEAT
!! CODEPOS = ADDR(STORE(1))
{} CODEPOS = 1
MACLIM = (CODEPOS+20)<<1
!! STORELIM = ADDR(STORE(SBOUND))
{} STORELIM = sbound
NP = STORELIM
LABLIM = NP-60
BP = LABLIM
DEFLIM = BP-(SBOUND>>2)
DEFMIN = DEFLIM
!! INTEGER(BP) = DEFLIM
set INTEGER(BP, DEFLIM)
SELECT INPUT(PRE)
DO PASS:
STARTPOS = MACLIM
MP = 0
ALMAX = DEFLIM
LABMIN = LABLIM
ASSCOND = 1; SKIP = 0
LOCTYPE = MEMMASK+RELMASK; LOC = 0
SET ACC
READ: FSYM = ' '; FAULTPOS = 0
READ LINE
NEXT:
DREG = -1
MODE = 0
PEND = 0; COND = 0
QSTART = QBASE; QLIM = QSTART
FLAG = 0
IF S('$') START
->NEWPAGE IF SYM = '/'
->ERR IF NOT TAG
->ASSIF IF TAG1 = IF
->ASSELSE IF TAG1 = ELS
->ASSFIN IF TAG1 = FIN
->LEND IF SKIP # 0
->DEFINE IF TAG1 = DEF
->DEFINE IF TAG1 = 19625; !RED
->LISTC IF TAG1 = 13350; !LIS
->TEMP IF TAG1 = 21780; !TEM
->LOCC IF TAG1 = 13556; !LOC
->LOCC IF TAG1 = 1917; !ASS
->SAVC IF TAG1 = 20568; !SAV
->MACDEF IF TAG1 = 14111; !MAC
->BEGIN IF TAG1 = 2460; !BEG
->BEND IF TAG1 = END
FAULT('U')
->LEND
FINISH
->LEND IF SKIP # 0 OR SYM = '/'
->LEND IF SYM = NL
IF TAG START
->LABDEF IF TERM = ':'
MODE = 1
->ASSIGN IF TERM = '(' OR SYM = '='
->JUMP IF TAG1 = JUM AND (TAG2=P OR TAG2=PS)
->IFC IF TAG1 = IF
->ELSE IF TAG1 = ELS AND TAG2 = E
->FINISH IF TAG1 = FIN AND TAG2 = ISH
->WHILE IF TAG1 = 25106 AND TAG2 = 13173
->CYCLE IF TAG1 = 4269 AND TAG2 = 13173
->REPEAT IF TAG1 = 19637 AND TAG2 = 5544
MODE=-2 AND ->DATA IF TAG1 = B
TYPE = UMASK; LOOKUP(0)
->MACCALL IF TYPE&OPMASK = MACRO
->MINST IF TYPE&OPMASK # 0
FAULT('U') AND ->LEND IF TYPE&UMASK # 0
PEND = -1
FINISH
MODE = -1
DATA:
CYCLE
GET EXP; ASSEMBLE
FAULT('I') IF TYPE®XMASK # 0
I = 1
IF S('$') START
I = VAL IF VAL < 1000
QLIM = QSTART
GET EXP; ASSEMBLE
FINISH
WHILE I > 0 CYCLE
IF MODE # -1 START
FAULT('T') IF VAL&16_FF00 # 0
IF MODE = -2 START
J = VAL<<8; MODE = -3
finish ELSE START
VAL = VAL+J; MODE = -2
PLANT VAL; VAL = VAL&255
FINISH
finish ELSE START
PLANT VAL
FINISH
I = I-1
REPEAT
EXIT UNLESS S(',') OR SYM&128 # 0
IF SYM = NL START
PRINT LINE IF PRINTPOS # 0; READ LINE
QSTART = QBASE
FINISH
QLIM = QSTART
REPEAT
VAL=J AND PLANT VAL IF MODE = -3
->SEND
LABDEF:
CREG = -1; ATYPE = -1
GET SYM
FAULT('C') AND NP=STORELIM IF NP # STORELIM
TYPE = LOCTYPE; VAL = LOC
LOOKUP(7)
->NEXT
ASSIGN:
PEND = 1
GET EXP
->ERR IF NOT S('=')
QUEUE(-25); !'STORE'
IF INTEGER(QBASE) = REG START
DREG = INTEGER(QBASE+1)
DUSE = 0
FINISH
QSTART = QLIM; MODE = 2
GET EXP
IF FLAG # 0 START
IF DREG<0 AND FLAG-QSTART=QSTART-QBASE-1 C
AND INTEGER(QBASE)&BMASK=0 START
I = QBASE; J = QSTART
I = I+1 AND J=J+1 WHILE INTEGER(I) = INTEGER(J)
IF J = FLAG START
IF INTEGER(QLIM-1) = -2 START; !MINUS
QSTART = J-2
!! INTEGER(QSTART) = 0; INTEGER(QSTART+1) = 0
set INTEGER(QSTART, 0); set INTEGER(QSTART+1, 0)
ELSE
QSTART = J; QLIM = QLIM-1
FINISH
finish ELSE FLAG = 0
finish ELSE FLAG = 0
FINISH
QUEUE(-24); !'LOAD'
CONDQ:
IF TAGIF START
MODE = MODE+4; DREG = DREG-16; !SCARIFY
CONDIT(0)
MODE = MODE-4; DREG = DREG+16; !RESTORE
QLIM = QSTART; QSTART = TRANSF
FINISH
ASSEMBLE
->SEND
JUMP:
FLAG = TAG2-P; !POSITIVE IF SHORT
GET EXP
QUEUE(-26); !'JUMP'
->CONDQ
MINST:
MODE = -1
GET INST
QUEUE(-23); !'PLANT'
->CONDQ
MACCALL:
QUEUE(0); !(DEFPOS)
QUEUE(0); !SPARE
QUEUE(0); !(CALLPOS)
QUEUE(STARTPOS)
QUEUE(MP)
J = VAL; QQ = 0
CYCLE
EXIT IF CHAR(J) = NL; !END OF MAC DEF
I = GETPOS-1; !SAVE CALLPOS
GETPOS = J; GET SYM
!! %MONITOR 24 %IF %NOT TAG
TYPE = 0; VAL = 0
SCAN ARG
GET SYM IF SYM = ','
J = GETPOS-1; !SAVE DEFPOS
GETPOS = I; GET SYM; !RESTORE CALLPOS
SCAN ARG
GET SYM IF SYM = ','
QUEUE(TAG1); QUEUE(TAG2)
QUEUE(TYPE); QUEUE(VAL)
REPEAT
QQ = '?'
GET SYM IF SYM = ' '
IF TAGIF START
CONDIT(-18)
QLIM = QSTART
!! INTEGER(QBASE+4) = MP+8_700000
set INTEGER(QBASE+4, MP+8_700000)
FINISH
QUEUE(0)
STARTPOS = QLIM<<1
MP = QBASE
!! INTEGER(MP) = J+1; !START OF BODY
set INTEGER(MP, J+1); !START OF BODY
!! INTEGER(MP+2) = GETPOS-1
set INTEGER(MP+2, GETPOS-1)
->LEND
!CODING OF JUMPS: 1000 (SINGLE INST), 2000 (MAIN IF)
! 4000 (ELSE), 6000 (IF AFTER ELSE)
IFC:
CONDIT(-15)
->SEND
ELSE:
->CERR IF INTEGER(NP)&16_2000 = 0
QUEUE(0); QUEUE(0)
QUEUE(-16); ASSEMBLE
ATYPE = -1; CREG = -1
IF TAGIF START
CONDIT(-17)
FINISH
->SEND
FINISH:
->CERR IF INTEGER(NP)&16_6000 = 0
I = LOC
WHILE INTEGER(NP)&16_4000 # 0 CYCLE
IF INTEGER(NP)&16_2000 # 0 START; !IF AFTER ELSE
SET LAB(I)
finish ELSE START
SET LAB(LOC)
I = VAL+4
FINISH
REPEAT
SET LAB(I)
->SEND
WHILE:
I = LOC; ATYPE = -1; CREG = -1
CONDIT(-13)
NEST(I); NEST(1)
->SEND
CYCLE:
NEST(LOC); NEST(1)
ATYPE = -1; CREG = -1
->SEND
REPEAT:
->CERR IF INTEGER(NP) # 1
QUEUE(LOCTYPE); QUEUE(INTEGER(NP+1))
NP = NP+2
QUEUE(-26); !'JUMP'
FLAG = -1
->CONDQ
CERR:
FAULT('C')
->LEND
SEND:
SET LAB(LOC) IF INTEGER(NP)&16_1000 # 0
->LEND IF SYM = NL
->NEXT IF S(';')
ERR:FSYM = 'F'; FAULTPOS = GETPOS-1
PRINTPOS = STARTPOS
LEND:
->READ IF SKIP # 0 AND LIST&4 = 0
->READ IF FSYM = ' ' AND CHARS = 0 AND C
(PRINTPOS = 0 OR (MP#0 AND LIST&2=0))
PRINT LINE
->READ
ASSIF:
ASSCOND = ASSCOND<<1
->LEND IF SKIP # 0
A1: CONDIT(0)
SKIP = ASSCOND IF COND # 0
PRINT LINE IF PRINTPOS # 0
->LEND
ASSELSE:
IF SKIP = 0 START
->CERR IF ASSCOND&1 # 0
SKIP = ASSCOND
finish ELSE START
->LEND IF SKIP # ASSCOND
SKIP = 0
->A1 IF TAGIF
FINISH
ASSCOND = ASSCOND+1
->LEND
ASSFIN:
->CERR IF ASSCOND = 1
ASSCOND = ASSCOND>>1
SKIP = 0 IF SKIP>>1 = ASSCOND
->LEND
DEFINE:
FAULT('C') IF NP # STORELIM
I = TAG1
CYCLE
->ERR IF NOT (TAG AND S('='))
J = TAG1; K = TAG2
IF TAG START
TAGREF
IF TYPE&OPMASK # 0 START
GET INST
finish ELSE START
PEND = -1; GET EXP
FINISH
finish ELSE GET EXP
ASSEMBLE
TAG1 = J; TAG2 = K
IF I=DEF THEN LOOKUP(3) ELSE LOOKUP(2)
EXIT UNLESS S(',')
QLIM = QSTART
REPEAT
->SEND
NEWPAGE:
DO NEWLINE WHILE LINES # 0
->LEND
LISTC:
GET EXP; ASSEMBLE
LIST = VAL
->SEND
TEMP:
I = 0
IF SYM # NL START
CYCLE
GET EXP
FAULT('I') IF TYPE # REG
I = I!1<<VAL
EXIT UNLESS S(',')
REPEAT
FINISH
TEMPS = I
SET ACC
->SEND
LOCC:
I = TAG1
GET EXP; ASSEMBLE
IF TYPE&16_FF80 = 0 START
IF I = 13556 START; !LOC
OUTPUT RECORD IF BINCOUNT >= 203
PUT(3) IF (LOCTYPE!!TYPE)&RELMASK # 0
PUT(5); PUT WORD(VAL)
FINISH
LOCTYPE = TYPE&63+MEMMASK; LOC = VAL
finish ELSE FAULT('I')
->SEND
SAVC:
GET EXP; ASSEMBLE
SAVE = VAL
->SEND
MACDEF:
->CERR IF MP # 0
->ERR IF NOT TAG
J = TAG1; K = TAG2
I = GETPOS-1
IF SYM # NL START
CYCLE
->ERR IF NOT TAG
SCAN ARG
EXIT IF NOT S(',')
REPEAT
FINISH
->ERR IF SYM # NL
TAG1 = J; TAG2 = K
TYPE = MACRO; VAL = I
LOOKUP(3)
CYCLE
PRINT LINE
EXIT IF S('$') AND TAG AND TAG1 = END
STARTPOS = PUTPOS
STARTPOS = PSEUDOLIM+1 IF PSEUDOLIM # 0
READ LINE
REPEAT
PUTPOS = STARTPOS; PUT CHAR(0)
STARTPOS = PUTPOS
MACLIM = STARTPOS
->LEND
ROUTINE BNEST
!! BP = BP+4; %MONITOR 23 %IF BP-NP >= 0
BP = BP+4; !{}%signal 2,3 %IF BP-NP >= 0
!! INTEGER(BP-3) = SAVE; INTEGER(BP-2) = TEMPS
set INTEGER(BP-3, SAVE); set INTEGER(BP-2, TEMPS)
!! INTEGER(BP-1) = MACLIM; INTEGER(BP) = DEFMIN
set INTEGER(BP-1, MACLIM); set INTEGER(BP, DEFMIN)
END
BEGIN:
BNEST
->NEWPAGE IF SYM # NL
->LEND
BEND:
FAULT('C') IF NP # STORELIM OR MP # 0
MP = 0; NP = STORELIM
IF BP # LABLIM START
SAVE = INTEGER(BP-3); TEMPS = INTEGER(BP-2)
MACLIM = INTEGER(BP-1); STARTPOS = MACLIM
DEFMIN = INTEGER(BP)
SET ACC
BP = BP-4
->LEND IF BP # LABLIM
FINISH
CLOSE INPUT; SELECT INPUT(MAIN)
BNEST
LIST = 5
PASS = PASS+1
->DO PASS IF PASS # 2
OUTPUT RECORD IF BINCOUNT = 208
PUT(1)
OUTPUT RECORD
FAULT('$')
PRINT LOC; PRINT LINE
ENDOFPROGRAM