.IIF	NDF	RSX	RSX	=	1	;Assume RSX	;01+
	.TITLE	AS3A
	.ident	/X01.06/

	.NLIST	BEX
	.ENABL	LC,GBL
	.LIST	MEB,CND						;01-

;
; AS
; MAIN ASSEMBLER
;
; VERSION X01
;
; DAVID G. CONROY	31-OCT-77
; LAST UPDATED:		11-JUN-79
;
; Edit history
; 01 04-Mar-80 MM	Added RT11 support
; 02 02-Jul-80 MM	Signed division requires sign extension
; 03 06-Jan-81 RBD	Use binary search for PST lookup
; 04 26-Feb-81 MM	Added .ident
; 05 26-Feb-82 RBD	Changes for binary tree UST, patch level comment
; 06 07-Aug-82 MM	Where did 'o' error disappear to?  New symbol table
;

	.GLOBL	ASEMBL
	.GLOBL	ERRTAB
	.GLOBL	ERREND
	.GLOBL	SPSAVE
	.GLOBL	LNO
	.GLOBL	AERROR
	.GLOBL	EERROR
	.GLOBL	NERROR
	.GLOBL	QERROR
	.GLOBL	RERROR
	.GLOBL	UERROR
	.GLOBL	EADDR
	.GLOBL	ETYPE
	.GLOBL	PASS

.IF NE	RSX							;01
	.MCALL	CALL
	.MCALL	CALLR
	.MCALL	RETURN
.ENDC								;01

; EQUIVALENCES

BTMAX	=	1024.		;MAX NUMBER OF MANAGED BRANCHES

; DATA

ERRTAB:
AERROR:	.BYTE	0,'a		;ADDRESSING
BERROR:	.BYTE	0,'b		;BYTE ALLIGNMENT
DERROR:	.BYTE	0,'.		;ILLEGAL OPERATION ON '.'
EERROR:	.BYTE	0,'e		;EXPRESSION SYNTAX
JERROR:	.BYTE	0,'j		;BRANCH EXTENDED TO JUMP
MERROR:	.BYTE	0,'m		;MULTIPLE DEFINITION
NERROR:	.BYTE	0,'n		;NUMBER
OERROR:	.BYTE	0,'o		;ILLEGAL OP CODE			;06
PERROR:	.BYTE	0,'p		;PHASE
QERROR:	.BYTE	0,'q		;QUESTIONABLE SYNTAX
RERROR:	.BYTE	0,'r		;RELOCATION
UERROR:	.BYTE	0,'u		;UNDEFINED SYMBOL
ERREND:

EADDR:	.BLKW	1		;.ENTRY ADDRESS
ETYPE:	.BLKW	1		;.ENTRY TYPE
FUZZ:	.BLKW	1		;SYMBOL FUZZ FOR PASS 2
BTPTR:	.BLKW	1		;BRANCH BITMAP POINTER
SDATA:	.BLKW	1		;SOURCE DATA
STYPE:	.BLKW	1		;SOURCE TYPE
DDATA:	.BLKW	1		;DESTINATION DATA
DTYPE:	.BLKW	1		;DESTINATION TYPE
SPSAVE:	.BLKW	1		;SAVE FOR SP IN CASE OF ABORT
LNO:	.BLKW	1		;LINE NUMBER
IDWORK:	.BLKW	6/2		;6 BYTE TEMP FOR .IDENT			;04
PASS:	.BLKB	1		;PASS NUMBER
ZFLAG:	.BLKB	1		;.ASCII/.ASCIZ FLAG

;
; FOR BIT INDEXING.
;

B:	.BYTE	001		;BIT 0
	.BYTE	002		;BIT 1
	.BYTE	004		;BIT 2
	.BYTE	010		;BIT 3
	.BYTE	020		;BIT 4
	.BYTE	040		;BIT 5
	.BYTE	100		;BIT 6
	.BYTE	200		;BIT 7

BTABLE:	.BLKB	<BTMAX+7>/8.	;BRANCH BIT TABLE
BTABND:

MSG01:	.ASCIZ	"FB table overflow!"
.IF NE	RSX							;01
MSG02:	.ASCIZ	":"
.ENDC								;01
	.EVEN


;+
; ** ASEMBL - ASSEMBLE A FILE
;
; THIS ROUTINE IS CALLED BY THE DRIVER TO ASSEMBLE A FILE. THE
; SOURCE FILE IS OPEN ON 'SFILE'; THE OBJECT FILE IS OPEN   ON
; 'OFILE'.
;
; USES:
;	ALL
;-

ASEMBL:	MOV	SP,SPSAVE	;IN CASE OF FATAL ERROR
	CALL	NEWFIL		;INITIALISE FOR A NEW FILE

	CALL	NEWPAS		;PASS 1
	MOVB	#1,PASS
10$:	CALL	GETLIN
	BCS	20$
	CALL	ASMLIN
	BR	10$

20$:	MOV	CURPS,R5	;FLUSH '.' INTO PSECT TABLES
	CALL	NEWDOT
	TSTB	GFLAG		;MAKE UNDEFINES GLOBL IF -G
	BEQ	30$
	CALL	GLOBS

30$:	CALL	NEWPAS		;PASS 2
	INCB	PASS
40$:	CALL	GETLIN
	BCS	50$
	CALL	ASMLIN
	BR	40$

50$:	MOV	CURPS,R5	;FLUSH '.' INTO PSECT TABLES
	CALL	NEWDOT
	CALL	GSD		;PUT OUT GSD

	CALL	NEWPAS		;PASS 3
	INCB	PASS
	TSTB	LFLAG		;LISTING?				;05+
	BEQ	60$		;(NO)
	MOV	#PLSIZE,-(SP)	;PUT PATCH LEVEL COMMENT IN LISTING
	MOV	#PLEVEL,-(SP)
	MOV	#LFILE,R0
	CALL	PUTTXT
	BIT	(SP)+,(SP)+						;05-
60$:	CALL	GETLIN
	BCS	70$
	CALL	ASMLIN
	CALL	ERRORS
	CALL	LIST
	BR	60$

70$:	CALLR	WRAPUP		;FINISH OFF THE OBJECT FILE

;+
; ** ASMLIN - ASSEMBLE A LINE
;
; THIS ROUTINE ASSEMBLES A LINE OF SOURCE. THIS LINE HAS BEEN PUT
; IN A SECRET PLACE BY GETLIN, WHO HAS ALSO SET UP THE   POINTERS
; SO ALL THE TOKEN AND CHARACTER READERS WORK.
;
; USES:
;	ALL
;-

ASMLIN:	MOV	#ERRTAB,R0	;CLEAR ERROR FLAGS
5$:	CLRB	(R0)+
	INC	R0
	CMP	R0,#ERREND
	BLO	5$

	MOV	#LCBUF,LCPTR	;WIND BACK LISTING POINTER
	MOV	#LM.S,LMODE	;SET SOURCE LIST MODE

10$:	CALL	GETOKN		;GET TOKEN FROM THE INPUT AND
	BCS	11$		;LEAVE ON EOL OR '/'
	CMP	R0,#'/
	BNE	12$
11$:	JMP	90$

12$:	CMP	R0,#';		;IGNORE ANY SEMICOLONS
	BEQ	10$

	CMP	R0,#CON		;IS IT A CONSTANT (AS IN 0:)
	BNE	13$		;NO
	CALL	GETPCH		;TEST IF NEXT CHARACTER IS A ':'
	BCS	60$
	CMPB	R0,#':
	BNE	60$
	CALL	TLABEL		;DO TEMP LABEL STUFF
	BR	10$

13$:	CMP	R0,#'<		;UNIX STYLE ASCII
	BNE	15$		;NO
	MOV	#LM.B,LMODE	;SET BYTE LISTING MODE
	MOV	#'>,R5		;MAPC DELIMITER
14$:	CALL	MAPC		;GRAB CHARACTER
	BCS	10$		;DONE
	CALL	PUTB		;OUTPUT IT
	BR	14$		;MORE

15$:	CMP	R0,#ID		;FIRST TOKEN MUST BE AN ID THEN
	BNE	60$
	CALL	GETPCH		;PEEK AHEAD
	BCS	40$
	CMP	R0,#':		;LABEL
	BNE	20$
	CALL	LABEL
	BR	10$


20$:	CMPB	R0,#'=		;DIRECT ASSIGNMENT
	BNE	40$
	MOV	PC,R5		;AUTO INSERT SYMBOL, r5 non-zero	;05/06
	CALL	SRCUST		;LOOK UP/INSERT				;05
	CALL	GETOKN		;SKIP THE '=' AND			;05--
	CALL	EXPR		;GET THE EXPRESSION
	CMP	R5,#DOT		;IS THE ASSIGNMENT TO '.'
	BNE	35$		;NO
	CMP	S.T(R5),R1	;SAME PSECTION
	BNE	32$		;NO, ERROR
	CMP	R0,S.V(R5)	;IS '.' BACKING UP
	BHIS	37$		;NO
32$:	INCB	DERROR		;YES, ERROR
	BR	37$
35$:	CMP	S.T(R5),#ST.UND	;IS THE NAME UNDEFINED
	BEQ	37$		;YES, NO ERROR
	BIT	S.F(R5),#SF.ASG	;WAS THE SYMBOL DEFINED BY AN '='
	BNE	37$		;YES, NO ERROR
	INCB	MERROR		;MULTIDEFINITION
37$:	MOV	R0,S.V(R5)	;DEFINE THE SYMBOL
	MOV	R1,S.T(R5)	;SET ITS TYPE
	BIS	#SF.ASG,S.F(R5)	;SET 'BY ASSIGNMENT' FLAG.
	MOV	R0,LADDR	;SET UP FOR LISTING
	MOV	#LM.A,LMODE	;
	BR	10$		;

;
; KEYWORD STATEMENT.
;

40$:	MOV	DOT+S.V,LADDR	;SET FOR LISTING
	MOV	#LM.W,LMODE	;
	CALL	SRCPST		;MUST BE OPCODE, LOOK UP IN PST		;03
	BCC	45$		;FOUND IT!!
	CLR	R5		;NOT FOUND. LOOKUP IN UST, DISABLE INSERT ;05+
	CALL	SRCUST		;
	TST	R5		;FOUND?	
	BEQ	80$		;NOT THERE, 'O' ERROR			;05-/06
45$:	MOV	S.T(R5),R0	;SWITCH BASED ON THE TYPE
	MOV	#100$,R1	;
50$:	CMP	R0,(R1)+	;WELL?
	BEQ	70$		;AHA!!
	TST	(R1)+		;ONWARD
	CMP	R1,#110$	;
	BLO	50$		;

;
; EXPRESSION STATEMENT.
;

60$:	CALL	MBE		;MUST BE AT EVEN ADDRESS!
	MOV	DOT+S.V,LADDR	;LIST ADDRESS
	MOV	#LM.W,LMODE	;WORD MODE
	CALL	UNGET		;PUT TOKEN BACK
	CALL	EXPR		;DO .WORD
	CALL	PUTW		;
	JMP	10$		;MORE

;
; KEYWORD STATEMENT.
;

70$:	CMP	R1,#105$	;DO EVEN CHECK IF REQUIRED
	BLO	75$		;
	CALL	MBE		;

75$:	CALL	@(R1)+		;CALL PROCESSOR FOR THIS TYPE
	JMP	10$		;MORE

80$:	INCB	OERROR		;DON'T TRY TO PARSE BAD OP CODES	;06

90$:	RETURN

;
; SWITCH TABLE FOR KEYWORD STATEMENTS.
; SWITCH IS ON THE TYPE OF THE KEYWORD ID.
;

100$:	.WORD	ST.ASC,120$	;.ASCII
	.WORD	ST.ASZ,130$	;.ASCIZ
	.WORD	ST.BYT,150$	;.BYTE
	.WORD	ST.EVN,170$	;.EVEN
	.WORD	ST.ODD,180$	;.ODD
	.WORD	ST.BKB,200$	;.BLKB
	.WORD	ST.GBL,210$	;.GLOBL
	.WORD	ST.ENT,220$	;.ENTRY
	.WORD	ST.PST,230$	;.PSECT
105$:	.WORD	ST.WRD,160$	;.WORD (START OF WORD ALLIGNED)
	.WORD	ST.BKW,190$	;.BLKW
	.WORD	ST.LIM,LIM	;.LIMIT
	.WORD	ST.INH,240$	;HALT, WAIT, ...
	.WORD	ST.EMT,250$	;TRAP, EMT
	.WORD	ST.MRK,260$	;MARK
	.WORD	ST.RTS,270$	;RTS
	.WORD	ST.JSR,280$	;JSR, XOR
	.WORD	ST.FST,281$	;FPP STORES
	.WORD	ST.SOP,290$	;SINGLE OP
	.WORD	ST.MUL,300$	;MUL, DIV, ASH, ASHC
	.WORD	ST.FLD,301$	;FPP LOADS
	.WORD	ST.DOP,310$	;DOUBLE OP
	.WORD	ST.SOB,330$	;SOB
	.WORD	ST.BR, 340$	;BRANCHES
	.WORD	ST.FL2,400$	;.FLT2
	.WORD	ST.FL4,410$	;.FLT4
	.WORD	ST.IDN,500$	;.IDENT					;04
110$:

120$:	CLRB	ZFLAG		;.ASCII
	BR	140$
130$:	MOVB	#1,ZFLAG	;.ASCIZ
140$:	CALL	GETNB		;GET THE DELIMITER
	BCS	146$
	MOV	R0,R5
	MOV	#LM.B,LMODE	;SET BYTE LIST MODE
142$:	CALL	MAPC		;GET CHARACTER
	BCS	144$		;DONE
	CALL	PUTB		;PUT OUT THE BYTE (ABSOLUTE)
	BR	142$
144$:	TSTB	ZFLAG		;IF ASCIZ, PUT OUT A NULL BYTE
	BEQ	148$
	CLR	R0
	CALL	PUTB
	BR	148$
146$:	INCB	QERROR		;Q ERROR FOR FUNNY STUFF
148$:	RETURN

150$:	CALL	EXPR		;.BYTE
	CALL	MBA
	CALL	PUTB		;PUT OUT THE BYTE
	CALL	GETOKN
	CMP	R0,#',
	BEQ	150$		;LOOP AS LONG AS THE DELIMITER IS ','
	MOV	#LM.B,LMODE	;SET BYTE LISTING
	CALLR	UNGET

160$:	CALL	EXPR		;GET THE VALUE
	CALL	PUTW		;PUT OUT THE RELOCATABLE WORD
	CALL	GETOKN
	CMP	R0,#',
	BEQ	160$
	CALLR	UNGET

170$:	BIT	#1,DOT+S.V	;.EVEN
	BEQ	172$
	CLR	R0
	CALL	PUTB
172$:	MOV	#LM.S,LMODE
	RETURN

180$:	BIT	#1,DOT+S.V	;.ODD
	BNE	182$
	CLR	R0
	CALL	PUTB
182$:	MOV	#LM.S,LMODE
	RETURN

190$:	CALL	EXPR
	ASL	R0		;CONVERT TO BYTES
	BR	202$
200$:	CALL	EXPR		;.BLKB
202$:	CALL	MBA		;EXPRESSION MUST BE ABSOLUTE
	MOV	R0,R2		;PUT OUT A BLOCK OF ZEROS
	BEQ	208$
	CLR	R0
206$:	CALL	PUTB
	DEC	R2
	BNE	206$
208$:	MOV	#LM.A,LMODE
	RETURN

210$:	MOV	#LM.S,LMODE	;.GLOBL
211$:	CALL	GETOKN
	CMP	R0,#ID		;CAN ONLY GLOBL A NAME
	BNE	214$
	MOV	PC,R5		;ENABLE AUTO INSERT, r5 non-zero	;05/06
	CALL	SRCUST		;LOOKUP/INSERT				;05
	BIS	#SF.GBL,S.F(R5)	;SET THE GLOBL FLAG			;05--
	CALL	GETOKN		;CONTINUE IF DELIMITER IS ','
	CMP	R0,#',
	BEQ	211$
	CALLR	UNGET		;ELSE BACK UP AND RETURN
214$:	INCB	QERROR
	RETURN

220$:	CALL	EXPR		;.ENTRY
	CMPB	PASS,#3		;IS THIS PASS 3
	BEQ	222$
	MOV	R0,EADDR	;NO, SAVE ADDRESS
	MOV	R1,ETYPE
	BR	226$
222$:	CMP	R0,EADDR	;YES, CHECK FOR PHASE ERROR
	BNE	224$
	CMP	R1,ETYPE
	BEQ	226$
224$:	INCB	PERROR
226$:	MOV	EADDR,LADDR
	MOV	#LM.A,LMODE
	RETURN

230$:	MOV	#LM.S,LMODE	;.PSECT
	CALL	GETOKN
	BCS	232$
	CMP	R0,#ID
	BNE	232$
	CALL	GETPS
	CALLR	NEWDOT
232$:	INCB	QERROR
	RETURN

240$:	MOV	S.V(R5),R0	;BASIC OPS LIKE HALT
	BR	274$
250$:	CALL	EXPR		;TRAP, EMT
	CALL	MBA
	BIC	#177400,R0
	BR	272$
260$:	CALL	EXPR		;MARK
	CALL	MBA
	BIC	#177700,R0
	BR	272$
270$:	CALL	REGXPR		;RTS
272$:	BIS	S.V(R5),R0
274$:	CALLR	PUTWA

280$:	CALL	REGXPR		;JSR, XOR
	BR	282$
281$:	CALL	FPPXPR		;FPP STORE
282$:	CALL	ASH60		;R0<<6
	BIS	S.V(R5),R0
	MOV	R0,R5		;SAVE OPCODE
	CALL	COMMA		;CHECK FOR ','
	BR	292$
290$:	MOV	S.V(R5),R5	;SINGLE OP
292$:	CALL	ADDRES
	BIS	R2,R5
	MOV	R0,DDATA
	MOV	R1,DTYPE
	MOV	R5,R0		;PUT OUT OPCODE
	CALL	PUTWA
	BR	318$

300$:	MOV	#REGXPR,-(SP)	;MUL DIV ...
	BR	302$
301$:	MOV	#FPPXPR,-(SP)	;FPP LOADS
302$:	MOV	S.V(R5),R5	;
	CALL	ADDRES
	BIS	R2,R5
	MOV	R0,DDATA	;SAVE DEST
	MOV	R1,DTYPE
	CALL	COMMA		;CHECK FOR ','
	CALL	@(SP)+		;REGISTER
	CALL	ASH60
	BIS	R5,R0		;ADD REG, PUT OUT INSTRUCTION
	CALL	PUTWA
	BR	318$

310$:	MOV	S.V(R5),R5	;DOUBLE OP
	CALL	ADDRES
	ASL	R2
	ASL	R2
	ASL	R2
	ASL	R2
	ASL	R2
	ASL	R2
	BIS	R2,R5
	MOV	R0,SDATA
	MOV	R1,STYPE
	CALL	COMMA		;CHECK FOR ','
	CALL	ADDRES		;DEST
	BIS	R2,R5
	CMP	R2,#67		;IF PC REL
	BEQ	314$		;AND
	CMP	R2,#77		;IF THE SOURCE
	BNE	316$		;OUTPUT A WORD AND
314$:	CMP	R1,#ST.ABS	;ITS IN THE SAME SEGMENT
	BNE	316$		;THEN
	TST	STYPE		;FIX THE
	BEQ	316$		;RELOCATION CONSTANT
	SUB	#2,R0		;TO ACCOUNT FOR THE WORD
316$:	MOV	R0,DDATA
	MOV	R1,DTYPE
	MOV	R5,R0		;PUT OUT THE OPCODE
	CALL	PUTWA
	MOV	SDATA,R0	;POSSIBLE SOURCE INDEX WORD
	MOV	STYPE,R1
	BEQ	318$
	CALL	PUTW
318$:	MOV	DDATA,R0	;POSSIBLE DEST INDEX WORD
	MOV	DTYPE,R1
	BEQ	320$
	CALL	PUTW
320$:	RETURN

330$:	MOV	S.V(R5),R5	;SOB
	CALL	REGXPR		;GET REGISTER
	CALL	ASH60
	BIS	R0,R5
	CALL	COMMA		;CHECK FOR ','
	CALL	EXPR		;GET THE ADDRESS
	CMP	R1,DOT+S.T	;MUST BE IN THE SAME PSECT AS '.'
	BEQ	332$
	INCB	RERROR
332$:	SUB	DOT+S.V,R0	;COMPUTE OFFSET
	SUB	#2,R0
	BGT	333$		;SEE IF IN RANGE
	CMP	R0,#-176
	BGE	334$
333$:	INCB	AERROR
334$:	NEG	R0		;PUT OFFSET INTO THE INSTRUCTION
	ASR	R0
	BIC	#177700,R0
	BIS	R5,R0
	CALLR	PUTWA

340$:	CALL	EXPR		;BRANCHES
	CMP	R1,DOT+S.T	;MUST HAVE SAME RELOCATION AS '.'
	BEQ	342$
	INCB	RERROR

342$:	CMPB	PASS,#1		;PASS 1
	BNE	344$
	ADD	#4,DOT+S.V	;ASSUME MAX LENGTH
	CMP	S.V(R5),#400	;BR
	BEQ	370$
	ADD	#2,DOT+S.V
	BR	370$

344$:	CMPB	PASS,#2		;PASS 2
	BNE	360$
	CMP	R0,DOT+S.V	;CORRECT FORWARD BY FUZZ
	BLO	346$
	SUB	FUZZ,R0
346$:	ADD	#2,DOT+S.V	;FIX PC
	SUB	DOT+S.V,R0	;SEE IF THE BRANCH REACHES
	BPL	348$
	NEG	R0
348$:	CLR	R1		;SET R1 BIT 0 IF MUST BE LONG
	CMP	R0,#254.
	BLOS	350$
	INC	R1
350$:	CALL	SETBR		;SET BIT IN THE BRANCH TABLE
	TST	R1
	BEQ	370$
	ADD	#2,DOT+S.V
	CMP	S.V(R5),#400	;BR
	BEQ	370$
	ADD	#2,DOT+S.V
	BR	370$

360$:	CALL	GETBR		;PASS 3
	BCC	366$		;BR IF SHORT
	TSTB	BFLAG		;J ERROR IF -B
	BEQ	362$
	INCB	JERROR

362$:	MOV	R0,-(SP)	;SAVE ADDRESS
	MOV	S.V(R5),R0	;GET THE OPCODE
	CMP	R0,#400		;IF BR, JUST A JMP
	BEQ	364$
	ADD	#2,R0		;.+6
	BIT	#400,R0		;FLIP COND
	BNE	3620$		;
	BIS	#400,R0		;
	BR	3622$		;
3620$:	BIC	#400,R0		;
3622$:	CALL	PUTWA
364$:	MOV	#167,R0		;JMP
	CALL	PUTWA
	MOV	(SP)+,R0	;ADDRESS
	SUB	DOT+S.V,R0	;-.
	SUB	#2,R0		;-2
	CALL	PUTWA		;ABSOLUTE
	BR	370$

366$:	SUB	DOT+S.V,R0	;SHORT BRANCH
	SUB	#2,R0
	ASR	R0
	BIC	#177400,R0
	BIS	S.V(R5),R0
	CALL	PUTWA
370$:	RETURN

;
; .FLT2 (400$)
; .FLT4 (410$)
;

400$:	MOV	#405$,R5	;GET OUTPUT CODE.
	BR	420$

405$:	CALL	PUTWA		;1 WORD
	MOV	R1,R0
	CALLR	PUTWA		;2 WORD

410$:	MOV	#415$,R5	;GET OUTPUT CODE.
	BR	420$

415$:	CALL	405$		;2 WORD
	MOV	R2,R0
	CALL	PUTWA		;3 WORD
	MOV	R3,R0
	CALLR	PUTWA		;4 WORD

420$:	CALL	ATOF		;GET F.P. CONSTANT
	CALL	(R5)		;PUT IT OUT
	CALL	GETOKN		;LOOP IF ","
	BCS	430$		;EOL
	CMP	R0,#',
	BEQ	420$
	CALL	UNGET		;DONE!
430$:	RETURN

;
; .IDENT /foobar/							;04+
;

500$:	CALL	GETNB		;SKIP TO DELIMITER
	BCC	510$		;CONTINUE IF OK
	JMP	146$		;-> Q ERROR FOR FUNNY STUFF

510$:	MOV	R0,R5		;SET DELIMITER BYTE IN R5 FOR MAPC
	MOV	#IDWORK+4,R1	;ID TEMP BUFFER (CAN WE SHARE ONE?)
	CLR	(R1)		;CLEAN
	CLR	-(R1)		; IT
	CLR	-(R1)		;  OUT

520$:	CALL	MAPC		;GET IDENT ARGUMENT BYTE
	BCS	530$		;EXIT IF DONE
	CMP	R1,#IDWORK+6	;IF ID BUFFER IS FULL,
	BHIS	520$		;IGNORE IT
	MOVB	R0,(R1)+	;STUFF IT OUT
	BR	520$		;AND GET ANOTHER.

530$:	MOV	#IDWORK,R0	;R0 -> ID TEXT
	CALL	CAT5B		;CONVERT TO RAD50
	MOV	R1,IDENT	;SAVE FIRST WORD
	CALL	CAT5B		;CONVERT TO RAD50
	MOV	R1,IDENT+2	;AND SAVE SECOND WORD
	RETURN			;THAT'S ALL THAT'S NEEDED.		;04-

;+
; ** MBE - CHECK IF '.' IS EVEN
;
; USES:
;	R0
;-

MBE:	BIT	#1,DOT+S.V
	BEQ	10$
	CLR	R0
	CALL	PUTB
	INCB	BERROR
10$:	RETURN

;+
; ** MBA - CHECK IF THE TYPE OF AN EXPRESSION IS ABSOLUTE
;
; INPUTS:
;	R1=TYPE
;-

MBA:	CMP	R1,#ST.ABS
	BEQ	10$
	INCB	RERROR
10$:	RETURN

;+
; ** COMMA - CHECK IF THE NEXT TOKEN IS A COMMA
;
; USES:
;	R0, R1
;-

COMMA:	CALL	GETOKN
	BCS	10$
	CMP	R0,#',
	BEQ	20$
10$:	INCB	QERROR
20$:	RETURN

;+
; ** TLABEL - DEFINE A TEMPORARY LABEL
;
; INPUTS:
;	R1=THE VALUE OF THE CONSTANT IN THE LABEL
;-

TLABEL:	CALL	FBOK		;CHECK RANGE OF THE LABEL

	CMPB	PASS,#1		;IS THIS PASS 1
	BNE	10$
	MOV	FB,R0		;MAKE A NEW ENTRY IN THE FB TABLE
	CMP	R0,#FBMAX
	BHIS	60$
	MOVB	DOT+S.T,(R0)+	;F.T
	MOVB	R1,(R0)+	;F.N
	MOV	DOT+S.V,(R0)+	;F.V
	MOV	R0,FB
	BR	40$

10$:	MOV	R1,R0		;GET OFFSET INTO FB TABLES
	ASL	R0
	MOV	FBF(R0),R2	;GET CURRENT 'F' LABEL
	CMPB	PASS,#2		;PASS 2
	BNE	13$		;NO
	MOV	F.V(R2),FUZZ	;YES, RESET FUZZ
	SUB	DOT+S.V,FUZZ
	MOVB	DOT+S.T,F.T(R2)	;RESET THE LABEL
	MOV	DOT+S.V,F.V(R2)
	BR	15$

13$:	CMPB	DOT+S.T,F.T(R2)	;PASS 3, CHECK FOR LOSS OF PHASE
	BNE	14$
	CMP	DOT+S.V,F.V(R2)
	BEQ	15$
14$:	INCB	PERROR

15$:	CLR	FBF(R0)		;DEFAULT TO NO 'F' LABEL
	MOV	R2,FBB(R0)	;CHANGE THE 'B' LABEL
20$:	ADD	#F.SIZE,R2	;SEARCH FORWARD FOR A NEW 'F' LABEL
	CMP	R2,FB
	BHIS	40$		;NO NEW 'F' LABEL
	CMPB	R1,F.N(R2)
	BNE	20$
	MOV	R2,FBF(R0)	;SET NEW 'F' LABEL

40$:	CALLR	GETOKN		;IN BOTH CASES, SKIP OVER THE ':'

60$:								;01
.IF NE	RSX							;01
	TST	ARGV+2		;1 FILE
	BEQ	70$		;YES, NO NAME
	MOV	@ARGVPT,R4	;GET FILE NAME
	BEQ	70$		;
	MOV	#MSG02,R5	;FILE:
	CALL	FMSG		;
.ENDC								;01
70$:	MOV	#MSG01,R5
	CALL	MSG
	MOV	SPSAVE,SP
	RETURN			;FROM ASEMBL

;+
; ** LABEL - DEFINE A LABEL
;
; PASS 1 AND 2:
;	DEFINE THE LABEL AT THE CURRENT LOCATION OF '.' WITH
;	THE CURRENT TYPE. IF THE NAME IS ALREADY DEFINED AND
;	IT WASN'T DEFINED WITH AN '=' GIVE AN 'M' ERROR.
;	ALSO SET THE CELL 'FUZZ' FOR THE BRANCH ADJUSTER  IN
;	PASS 2.
;
; PASS 3:
;	BY THIS TIME THE VALUE OF THE SYMBOL SHOULD BE FINAL
;	TEST FOR PHASE ERRORS AND GIVE 'P' FLAG.
;
; USES:
;	R5
;-

LABEL:	MOV	PC,R5		;ENABLE AUTO INSERT, r5 non-zero	;05/06
	CALL	SRCUST		;LOOKUP/INSERT				;05
	CMP	R5,#DOT		;CHECK FOR ILLEGAL LABEL '.'		;05--
	BNE	15$
	INCB	DERROR		;ITS AN ERROR TO PLAY WITH '.'
	BR	60$

15$:	CMPB	PASS,#3		;IS THIS PASS 3
	BEQ	30$		;YES, GO DO PASS 3 LOGIC
	CMPB	PASS,#2		;IS THIS PASS 2
	BEQ	20$		;YES, SKIP MULTIDEFINED CHECKS
	CMP	S.T(R5),#ST.UND	;IF THE NAME IS UNDEFINED, NO ERROR
	BEQ	20$
	BIT	S.F(R5),#SF.ASG	;IF DEFINED BY '=', NO ERROR
	BNE	20$
	BIS	#SF.MDF,S.F(R5)	;SET MULTIDEFINED FLAG
20$:	MOV	S.V(R5),FUZZ	;COMPUTE FUZZ FOR PASS 2
	SUB	DOT+S.V,FUZZ
	MOV	DOT+S.V,S.V(R5)	;SET SYMBOL VALUE
	MOV	DOT+S.T,S.T(R5)	;SET SYMBOL TYPE
	BR	60$

30$:	BIT	#SF.MDF,S.F(R5)	;SET 'M' ERROR IF MULTIDEFINED
	BEQ	40$
	INCB	MERROR
40$:	CMP	DOT+S.V,S.V(R5)	;CHECK FOR PHASE ERRORS
	BNE	50$
	CMP	DOT+S.T,S.T(R5)
	BEQ	60$
50$:	INCB	PERROR

60$:	CALLR	GETOKN		;FOR BOTH PASSES, SKIP OVER THE ':'

;+
; ** NEWFIL - SET UP FOR A NEW FILE
;
; THIS ROUTINE CLEARS THE USER SYMBOL TABLE, ZEROS OUT THE BIT
; MAP USED BY THE BRANCH ADJUSTER, CLEARS THE .ENTRY FLAGS AND
; PERFORMS OTHER ONCE PER FILE INITIALISATIONS.
;
; USES:
;	R0
;-

NEWFIL:	CLR	EADDR		;CLEAR .ENTRY CELLS
	CLR	ETYPE

	MOV	#BTABLE,R0	;ZERO BRANCH BITMAP
10$:	CLRB	(R0)+
	CMP	R0,#BTABND
	BLO	10$

	CALL	USTCLR		;CLEAR UST				;05
	MOV	#PSECTO,PSECT	;CLEAR PSECT TABLE
	MOV	#FBORG,FB	;CLEAR FB TABLE

	RETURN

;+
; ** NEWPAS - SET UP FOR A NEW PASS
;
; THIS ROUTINE PERFORMS THE INITIALISATION REQUIRED AT THE START
; OF A NEW PASS. THE SOURCE FILE IS REWOUND, '.' IS SET BACK  TO
; ITS DEFAULT VALUE, ETC.
;
; USES:
;	R0, R1, R2, R3
;-

NEWPAS:	MOV	#SFILE,R0	;REWIND THE SOURCE FILE
	CALL	REWIND						;01

	MOV	#PSECT2,R0	;SET LENGTH OF ALL PSECTS TO 0	;01
10$:	CMP	R0,PSECT
	BHIS	20$
	CLR	P.L(R0)
	CLR	P.FUZZ(R0)
	ADD	#P.SIZE,R0
	BR	10$

20$:	CLR	R0		;SET UP FBF AND FBB TABLES
30$:	MOV	R0,R1
	ASL	R1
	CLR	FBB(R1)		;NO 'B' ENTRY
	CLR	FBF(R1)		;FIRST FB SYMBOL IS 'F' ENTRY
	MOV	#FB2,R2						;01
40$:	CMP	R2,FB
	BHIS	60$
	CMPB	R0,F.N(R2)
	BEQ	50$
	ADD	#F.SIZE,R2
	BR	40$
50$:	MOV	R2,FBF(R1)
60$:	INC	R0
	CMP	R0,#10.
	BLO	30$

	CLR	LNO		;START AT LINE 0
	CLR	FUZZ		;CLEAR BRANCH FUZZ
	CLR	BTPTR		;BRANCH BITMAP POINTER
	CLR	DOT+S.V		;SET '.' TO LOCATION 0 IN
	MOV	#ST.REL,DOT+S.T	;THE DEFAULT PSECTION
	MOV	#PSECT2,CURPS	;SET CURRENT PSECT TO DEFAULT	;01

	RETURN

;+
; ** NEWDOT - SET UP A NEW DOT
;
; INPUTS:
;	R5=POINTER TO PSECT TABLE SLOT OF NEW PSECT
;-

NEWDOT:	MOV	R0,-(SP)	;SAVE REGISTERS
	MOV	R1,-(SP)

	MOV	CURPS,R1	;COPY '.' BACK INTO PSECT TABLE
	MOV	DOT+S.V,P.L(R1)	;IT CANNOT BACK UP ('D' ERROR)
	MOV	FUZZ,P.FUZZ(R1)	;COPY FUZZ BACK TOO
	MOV	P.L(R5),DOT+S.V	;AND RESET '.' FROM TARGET PSECT
	MOV	P.FUZZ(R5),FUZZ	;ALSO FUZZ
	CLR	R0		;HIGH-ORDER DIVIDEND		;02
	MOV	R5,R1		;NOW COMPUTE THE TYPE OF '.'
	SUB	#PSECT2,R1					;01
	BPL	5$		;CONTINUE IF POSITIVE		;02
	COM	R0		;SIGN-EXTEND TO HIGH-ORDER	;02
5$:								;02
	MOV	#P.N+8.,-(SP)
	CALL	$DIVR0
	TST	(SP)+
	ADD	#ST.REL,R0
	MOV	R0,DOT+S.T

	CMPB	PASS,#3		;IS THIS PASS 3
	BNE	10$
	TSTB	NFLAG		;AND NOT -N
	BEQ	10$		;BR IF NO OBJECT FILE		;01
	MOV	R5,NXTPS	;FLUSH TBUF AND RBUF
	CALL	FTAR1

10$:	MOV	R5,CURPS	;RESET CURRENT PSECTION
	MOV	(SP)+,R1	;RETURN
	MOV	(SP)+,R0
	RETURN

;+
; ** SETBR - SET BIT IN BRANCH TABLE
;
; INPUTS:
;	R1=BIT TO SET (IN BIT 0)
;    BTPTR=BIT OFFSET
;
; USES:
;	R2, R3
;-

SETBR:	MOV	BTPTR,R2	;GET BIT OFFSET
	CMP	R2,#BTMAX	;JUST LEAVE IF TOO MANY BRANCHES
	BHIS	10$		;
	INC	BTPTR		;BUMP POINTER

	TST	R1		;IS ANYTHING GOING TO CHANGE
	BEQ	10$		;NO

	MOV	R2,R3		;GET BIT NUMBER
	ASR	R2		;BYTE OFFSET
	ASR	R2		;
	ASR	R2		;
	BIC	#160000,R2	;J.I.C.
	BIC	#177770,R3	;BIT OFFSET
	BISB	B(R3),BTABLE(R2);SET THE BIT
10$:	RETURN			;

;+
; ** GETBR - GET BIT FROM BRANCH TABLE
;
; INPUTS:
;    BTPTR=BIT OFFSET
;
; OUTPUTS:
;	 C=THE BIT FROM THE TABLE
;
; USES:
;	R2, R3
;-

GETBR:	MOV	BTPTR,R2	;GET BIT OFFSET
	CMP	R2,#BTMAX	;OFF THE END
	BHIS	10$		;YES, MAKE LONG
	INC	BTPTR		;ADVANCE TO THE NEXT BIT


	MOV	R2,R3		;COPY DISPLACEMENT
	ASR	R2		;BYTE OFFSET
	ASR	R2		;
	ASR	R2		;
	BIC	#160000,R2	;J.I.C.
	BIC	#177770,R3	;TEST BIT
	BITB	B(R3),BTABLE(R2);
	BNE	10$		;ITS SET
	CLC			;CLEAR BIT
	RETURN			;

10$:	SEC			;SET BIT
	RETURN			;

;+
; ** ASH60 -- DO AN ASH #6,R0
;
; INPUTS:
;	R0=OLD VALUE
;
; OUTPUTS:
;	R0=64*OLD VALUE
;-

ASH60:	ASL	R0		;UGH
	ASL	R0		;
	ASL	R0		;
	ASL	R0		;
	ASL	R0		;
	ASL	R0		;
	RETURN			;

;+
; ** ADDRES - EVALUATE ADDRESS FIELD
;
; OUTPUTS:
;	R0=VALUE
;	R1=TYPE
;	R2=MODE
;
; IF THE WORD (R0,R1) IS NOT NEEDED THEN R0 AND R1 ARE 0.
;-

ADDRES:	CLR	R2		;START WITH MODE 0

10$:	CALL	GETOKN		;LOOK FOR LEADING '*'
	BCS	78$
	CMP	R0,#'*
	BNE	30$
	TST	R2		;CANNOT HAVE TWO OF THEM
	BNE	20$
	MOV	#10,R2		;TURN ON THE INDIRECT BIT
	BR	10$
20$:	INCB	AERROR
	BR	10$

30$:	CMP	R0,#'(		;(R) (R)+
	BNE	50$
	CALL	REGXPR
	BIS	R0,R2
	CALL	RPCHEK
	CALL	GETOKN		;LOOK FOR '+'
	BCS	42$
	CMP	R0,#'+
	BNE	40$
	BIS	#20,R2
	BR	80$

40$:	CALL	UNGET		;PUT TOKEN BACK
42$:	BIT	#10,R2		;*(R) IS ACTUALLY *0(R)
	BNE	44$
	BIS	#10,R2		;(R)
	BR	80$
44$:	BIS	#70,R2		;MAKE INDEX MODE
	CLR	R0
	MOV	#ST.ABS,R1
	BR	90$

50$:	CMP	R0,#'$		;LITERAL MODE
	BNE	60$
	CALL	EXPR
	BIS	#27,R2
	BR	90$

60$:	CMP	R0,#'-		;POSSIBLE -(R)
	BNE	70$
	CALL	GETPCH		;LOOK FOR THE '('
	BCS	70$
	CMPB	R0,#'(
	BNE	70$
	CALL	GETOKN		;SKIP THE '('
	CALL	REGXPR
	BIS	R0,R2
	CALL	RPCHEK
	BIS	#40,R2
	BR	80$

70$:	CALL	UNGET		;INDEX MODE
	CALL	EXPR
	CMP	R1,#ST.REG	;IS IT A REGISTER
	BNE	71$
	BIS	R0,R2		;YES
	BR	80$

71$:	MOV	R0,-(SP)	;SAVE VALUE
	MOV	R1,-(SP)	;AND TYPE
	CALL	GETOKN		;LOOK FOR INDEXING
	BCS	74$
	CMP	R0,#'(
	BNE	72$
	CALL	REGXPR		;GET THE INDEX REG
	BIS	R0,R2		;SET THE REG INTO THE MODE
	CALL	RPCHEK
	BR	75$
72$:	CALL	UNGET
74$:	BIS	#7,R2		;PC
75$:	BIS	#60,R2		;INDEX MODE
	MOV	(SP)+,R1	;RESTORE TYPE
	MOV	(SP)+,R0	;RESTORE VALUE
	CMP	R2,#67		;IS IT A PC REL ADDRESS
	BEQ	76$		;YES
	CMP	R2,#77		;IS IT A PC REL ADDRESS
	BNE	90$		;NO
76$:	CMP	R1,DOT+S.T	;YES, SAME SEGMENT
	BEQ	77$		;YES
	BIS	#PCREL,R1	;JUST TURN ON THE PC REL FLAG
	BR	90$
77$:	SUB	DOT+S.V,R0	;IF SAME SEG, ITS ABSOLUTE
	SUB	#4,R0
	MOV	#ST.ABS,R1
	BR	90$

78$:	INCB	AERROR
80$:	CLR	R0		;NO EXTRA WORD
	CLR	R1
90$:	RETURN

;+
; ** RPCHEK - CHECK IF NEXT TOKEN IS A ')'
;-

RPCHEK:	MOV	R0,-(SP)
	MOV	R1,-(SP)
	CALL	GETOKN
	BCS	10$
	CMP	R0,#')
	BEQ	20$
10$:	INCB	QERROR
20$:	MOV	(SP)+,R1
	MOV	(SP)+,R0
	RETURN

	.END