.TITLE	READ		
; JEFFREY KODOSKY	ARL	NOV75
;
; SUBR
; ENTRY:	NO ARGS
; EXIT:		1 ARG		<S>
;		C BIT SET AND %EOF RETURNED IF ATTEMPT TO
;		READ PAST END OF FILE AND NO OTHER ERRORS OCCURED
; ERRORS:	R1, ]), OUT OF CONTEXT
;		R2, . OUT OF CONTEXT
;		R3, UNMATCHED (
;		R4, TOO MANY [ OR (
;		R5, UNDECODABLE NUMBER
;		T2, CORRUPTED STACKS
; CALLS:	RDCHAR, READ A CHARACTER
;		LEXICL, IDENTIFY LEXICAL CLASS
;		RDBKUP, BACK UP READ POINTER
;		PNBUFI, INSERT CHARACTER IN PNAME BUFFER
;		STRBLD, STRING ATOM BUILDER
;		I2ATM,  INTEGER ATOM MAKER
;		R2ATM,  REAL NUMBER ATOM MAKER
;		OCI, OCTAL INPUT CONVERSION
;		ICI, INTEGER INPUT CONVERSION
;		RCI, FLOATING POINT INPUT CONVERSION
;		PNMBLD, LITERAL ATOM BUILDER
;		ATMOBL, INSTALL ATOM ON OBLIST
;		PARLBL, LABEL PARENTHESIS
;		PRINT
;		GET
;		GETC
;		PUT
;		RI
	.GLOBL	READ,ZREAD,QPNBUFI,QGET,QATM2N,QPRINT,QPUT
	.GLOBL	QR1ERR,QR2ERR,QR3ERR,QR4ERR,QT2ERR,QRDCHAR,QLEXICL
	.GLOBL	QSTRBLD,QRDBKUP,QI2ATM,QR2ATM,QPNMBLD
	.GLOBL	QATMOBL,QPARLBL,LSW,APVAL,ISW,EOF,ZSW,ZSWVAL
	.GLOBL	QUOTE,SSTART,QGETC,QR5ERR,QICI,QRCI,QOCI
	.GLOBL	QRI,LSWVAL,ISWVAL,INSYS,SUBSYS,C....R,SUBR
READ:	CLR	LBRAK	;INIT FLAGS, COUNTERS, ETC.
	CLR	PARCNT
	CLR	RDEPTH
	CLR	RBRK
	ROOM	4
	MOV	APVAL,-(R5)
	MOV	ISW,-(R5)
	QGET
	MOV	(R5)+,ISWVAL
	MOV	APVAL,-(R5)
	MOV	ZSW,-(R5)
	QGET
	MOV	(R5)+,ZSWVAL
	MOV	APVAL,-(R5)
	MOV	LSW,-(R5)
	QGET
	BCS	READ02
	QATM2N		;GET LSWITCH VALUE
	BCC	READ01
	QRI
READ01:	MOV	(SP)+,LSWVAL
	BR	.+4
READ02:	TST	(R5)+	;POP NIL
	MOV	#-1,NORPCD
	MOV	#READ03,(R4)+	;FAKE A TRAP TO READS
	BR	READS
READ03:	BCS	READ07	;JUMP IF EOF
READ04:	QRDCHAR		;LOGICAL END OF READ
	BCS	READ5A
	QLEXICL
	TST	R0
	BEQ	READ05	;IF <EOL>, READ TIL <LF> OR <FF>
	CMP	R0,#15.
	BEQ	READ04	;IGNORE SPACES AND TABS
	CMP	R0,#18.
	BNE	READ5A	;IF NOT COMMENT THEN READ COMPLETED
READ05:	CMP	R3,#12	;OTHERWISE IGNORE EVERYTHING UP TO
	BEQ	READ06	;NEXT <LF> OR <FF>
	CMP	R3,#14
	BEQ	READ06
	QRDCHAR
	BCC	READ05
READ5A:	QRDBKUP
READ06:	TST	SUBSYS	;NO ECHO IF READING SUBSYSTEMS
	BNE	READ6A
	CMP	LSWVAL,#2
	BNE	READ6A
	QPRINT		;ECHO INTERNAL FORMAT
READ6A:	CLC
READ07:	MOVB	#-1,INSYS+1	;RESTORE SYSIN
	JMP	@-(R4)
COMMA:	TSTB	NORPCD
	BPL	.+4
	QR1ERR		;ERROR IF , OUT OF CONTEXT
	MOV	#-1,NORPCD	;DON'T ALLOW .)], AFTER ,
	BR	READS1
STR01:	QPNBUFI
STRATM:	QRDCHAR		;GO PAST ' AND GET ANOTHER CHAR
	BCS	FILEND
	QLEXICL
	TST	R0
	BEQ	STRATM	;IGNORE <EOL>
	CMP	R0,#7
	BNE	STR02
	QRDCHAR		;STORE NEXT CHAR REGARDLESS OF CLASS
	BCS	FILEND
	QLEXICL
	TST	R0
	BNE	STR01
	MOV	#40,R3	;^<EOL> IS EXPANDED AS ^<SPACE>
	BR	STR01
STR02:	CMP	R0,#17.
	BNE	STR01
	CLR	R3	;ONLY ' DELIMITS STRING
	QPNBUFI
	QSTRBLD
	INC	RDEPTH
	CLC
	JMP	@-(R4)
READS:	ROOM	6	;CHECK FOR AMPLE ROOM
	CLR	R3	;CLEAR OUT PNAME BUFFER EVERY RECURSION
	QPNBUFI
READS1:	QRDCHAR	;(LOOP BACK TO READS1 & RECURSE TO READS)
	BCS	FILEND
	QLEXICL
	ASL	R0
	JMP	@RDISP(R0)	;DISPATCH ACCORDING TO CLASS
RDISP:	READS1		;END OF LINE
	LITATM		;START OF LITERAL ATOM
	NUMATM		;START OF NUMBER
	LITATM
	LITATM
	LITATM
	NORL		;NUMBER OR LITERAL ATOM
	NSTDLIT		;NON-STANDARD LITERAL ATOM
	ABORT		;RE-START READ OPERATION
	NONATM		;NON-ATOMIC S-EXPRESSION
	RPAR		;)
	NONSPC		;NON-ATOMIC S-EXPRESSION WITH MARKER
	RBRACK		;]
	NORDOT		;NUMBER OR 2ND HALF OF DOTTED PAIR
	COMMA		;,
	READS1		;IGNORE SPACES OR TABS
	AUTOQ		;EXPAND " TO (QUOTE ...)
	STRATM		;START OF STRING
	LINEND		;COMMENT EFFECTIVELY ENDS LINE
	LITATM
LINEND:	QRDCHAR		;IGNORE CHARS UNTIL NEXT LINE
	BCS	FILEND
	QLEXICL
	TST	R0
	BEQ	READS1
	BR	LINEND
FILEND:	TST	RDEPTH
	BEQ	RD01
	BMI	.+4
	QR3ERR		;UNMATCHED LPAR IF STUFF IS LEFT ON STACK
	QT2ERR		;RDEPTH SHOULD NEVER BE < 0 !
RD01:	MOV	EOF,-(R5)	;RETURN %EOF AND C BIT
	SEC
	JMP	@-(R4)
NORL:	QPNBUFI		;STORE CHAR IN PNAME BUFFER
	QRDCHAR
	BCS	NORL1	;<SIGN><EOF> IS LITATM
	QLEXICL
	TST	R0
	BEQ	NORL1	;<SIGN><EOL> IS LITATM
	CMP	R0,#2
	BEQ	NUMATM	;<SIGN><DIGIT> IS NUMBER
	CMP	R0,#13.
	BEQ	.+6
	JMP	LITATM
	QPNBUFI		;<SIGN>. IS STILL AMBIGUOUS
	QRDCHAR
	BCC	NORL2	;<SIGN>.<EOF> IS IMPROPER . CONSTRUCTION
	QR2ERR
NORL1:	JMP	LIT10
NORL2:	QLEXICL
	CMP	R0,#2
	BEQ	.NUMATM	;<SIGN>.<DIGIT> IS NUMBER
	QRDBKUP		;OTHERWISE DOTTED PAIR
	CLR	R3
	QPNBUFI
	CLRB	1(R3)	;LEAVE ONLY SIGN IN BUFFER
	JMP	LIT10A	;AND PROCESS AS LITATM
NORDOT:	QPNBUFI
	QRDCHAR
	BCS	RD02	;.<EOF> IS . OUT OF CONTEXT
	QLEXICL
	CMP	R0,#2
	BEQ	.NUMATM	;JUMP IF NUMBER
	QRDBKUP		;BACK UP READ POINTER
	ASR	NORPCD	;IS . ALLOWED?
	BCC	.+4
	QR2ERR		;NO: IMPROPER . CONSTRUCTION
	MOV	#-1,NORPCD	; NO .,)] ALLOWED NOW
	TST	-(R4)	;POP NONATM RETURN ADDR
	MOV	#RDA,(R4)+	;RECURSE TO GET CDR
	BR	READS	;FAKE A TRAP
RDA:	MOV	(R5)+,@(R5)+	;STORE IT IN OPEN CDR AND POP BOTH
	SUB	#2,RDEPTH
	BPL	.+4
	QT2ERR
	MOV	#377,NORPCD	;GET CLOSING )
	MOV	#RDB,(R4)+	;FAKE A TRAP
	BR	READS
RDB:	BCS	.+4
RD02:	QR2ERR		;IMPROPER . CONSTRUCTION
	TST	(R5)+	;POP NIL
RD03:	DEC	RDEPTH
	BPL	.+4
	QT2ERR
	JMP	@-(R4)
NUMATM:	CLR	NTYPE	;<SIGN><DIGIT>
	BR	NUM1
.NUMATM:MOV	#200,NTYPE	;. FOUND, NO MORE ALLOWED
NUM1:	CMPB	R3,#'8	;DIGIT WAS SEEN
	BLE	NUM2
	INC	NTYPE	;COUNT NON-OCTAL DIGITS
NUM2:	BICB	#177,NTYPE+1	;SIGN NOT ALLOWED NOW
NUM3:	QPNBUFI	;SAVE CHAR
	QRDCHAR	;GET NEXT CHAR
	BCS	RD08	;<EOF> TERMINATES NUMBER
	QLEXICL
	CMP	R0,#6	;<SIGN>?
	BNE	NUM4
	ASRB	NTYPE+1	;YES: ALLOWED?
	BCS	NUM3	;YES: DON'T ALLOW ANOTHER
	ASLB	NTYPE+1	;NO: MUST BE TERMINATOR
	BR	RD08
NUM4:	CMP	R0,#13.	;.?
	BNE	NUM5
	TSTB	NTYPE	;YES: ALLOWED?
	BMI	RD08	;NO: MUST BE TERMINATOR
	BIS	#200,NTYPE	;YES: DON'T ALLOW ANOTHER
	BR	NUM3
NUM5:	CMP	R0,#2	;<DIGIT>?
	BEQ	NUM1	;YES: CHECK TYPE AND SAVE IT
	CMP	R0,#4	;NO: E?
	BNE	NUM6
	TST	NTYPE	;YES: ALLOWED?
	BMI	RD08	;NO: MUST BE TERMINATOR
	BIS	#100600,NTYPE	;YES: NO MORE E'S OR .'S
	BR	NUM3	;BUT SIGN IS OK
NUM6:	CMP	R0,#5	;Q?
	BNE	RD08	;NO: ANYTHING ELSE TERMINATES NUMBER
	TST	NTYPE
	BNE	RD08	;Q TERMINATES DECIMAL NUMBER
	CLR	R3	;DECODE OCTAL NUMBER
	QPNBUFI
	QOCI
	BCC	.+4
	QR5ERR
	QI2ATM
	BR	RD11
RD08:	CLR	R3	;DECODE DECIMAL NUMBER
	QPNBUFI
	ASLB	NTYPE+1
	BEQ	1$	;UNDECODABLE NUMBER IF SIGN STILL ALLOWED
	QR5ERR		;OR IF NUMBER HASN'T FOLLOWED SIGN
1$:	BCS	RD09
	TSTB	NTYPE
	BMI	RD09
	QICI		;INTEGER CONVERT
	BCS	RD9
	QI2ATM
	BR	RD10
RD09:	QRCI		;REAL NUMBER CONVERT
	BIT	#77777,@SP	;CHECK IF INF RETURNED
	BNE	RD9
	TST	2(SP)
	BEQ	RD9
	TST	ZSWVAL	;IT WAS, IS IT ALLOWED?
	BNE	RD9
	QR5ERR		;NO: ERROR R5, UNDECODABLE NUMBER (INSTEAD
			;OF I4, HARD MATH ERROR, WHERE INF USUALLY
			;APPEARS)
RD9:	QR2ATM
RD10:	QRDBKUP
RD11:	INC	RDEPTH
	CLC
	JMP	@-(R4)
LITATM:	QPNBUFI
	QRDCHAR
	BCS	LIT10	;<EOF> TERMINATES AN ATOM PNAME
	QLEXICL
LIT01:	TST	R0
	BEQ	LIT10	;<EOL> TERMINATES AN ATOM PNAME
	CMP	R0,#7.
	BGT	LIT10	;CLASSES 8-19 DELIMIT ATOM PNAMES
	BLT	LITATM
NSTDLIT:QRDCHAR		;CLASS 7 STRIPS PROPERTIES OF NEXT CHAR
	BCS	LIT05	;^<EOF> EXPANDS TO ^<SPACE>
	QLEXICL
	TST	R0
	BNE	LITATM
LIT05:	MOV	#40,R3	;^<EOL> EXPANDS TO ^<SPACE>
	QPNBUFI
LIT10:	CLR	R3
	QPNBUFI
LIT10A:	MOV	R3,-(SP)
	QPNMBLD		;MAKE A NEW LITERAL ATOM
	QATMOBL		;INSTALL IT ON OBLIST
	MOV	(SP)+,R3
	TST	ISWVAL	;EXPAND C...R ATOMS?
	BNE	RD10	;NO: JUST RETURN THE ATOM
	CMPB	(R3)+,#'C	;YES: CHECK FOR THE FORM C...R
	BNE	RD10
	CLR	R0
LIT11:	CMPB	@R3,#'A
	BEQ	LIT12
	CMPB	@R3,#'D
	BNE	LIT13
LIT12:	CMPB	(R0)+,(R3)+
	BR	LIT11
LIT13:	CMPB	(R3)+,#'R
	BNE	RD10
	TSTB	@R3
	BNE	RD10
	DEC	R0	;ATOM IS OF THE FORM C...R
	BLE	RD10	;PUT[<ATOM>;SUBR;<CARCDR SUBR>]
	MOV	#C....R,-(SP)
	QI2ATM
	MOV	SUBR,-(R5)	;SPECIAL SUBR!!!
	MOV	4(R5),-(R5)
	QPUT
	TST	(R5)+
	BR	RD10
RBRACK:	INC	RBRK
RPAR:	TST	NORPCD
	BPL	.+4
	QR1ERR		;)] OUT OF CONTEXT
	DEC	PARCNT	;LABEL RPAR
	MOV	PARCNT,-(SP)
	QPARLBL
	MOVB	LBRAK,R0
	DECB	LPARB(R0)	;REDUCE PAR SUB COUNT
	BEQ	RPAR1
	TST	RBRK	;IF ] DETERMINE WHETHER OF NOT
	BEQ	RPAR2	;TO BUMP PAST
	QRDBKUP		;NO, POINT TO IT AGAIN
	BR	RPAR2
RPAR1:	DEC	LBRAK
RPAR2:	CLR	RBRK
	CLR	-(R5)	;RETURN NIL
	INC	RDEPTH
	SEC		;AND RPAR FLAG
	JMP	@-(R4)
NONSPC:	MOVB	LBRAK,R0;OPEN ANOTHER PAR SUBCOUNTER
	INC	R0
	CMP	R0,#29.
	BLE	.+4
	QR4ERR		;TOO MANY [
	MOVB	R0,LBRAK
	CLRB	LPARB(R0)
NONATM:	MOVB	LBRAK,R0
	INCB	LPARB(R0)	;INCREMENT SUBCOUNTER
	BNE	.+4
	QR4ERR		;TOO MANY (
	MOV	PARCNT,-(SP)
	INC	PARCNT
	QPARLBL		;LABEL PARENTHESIS
	MOV	#377,NORPCD	;DON'T ALLOW ., BUT )] OK
	QGETC
	INC	RDEPTH	;RECURSE TO GET CAR
	MOV	#READ10,(R4)+	;FAKE A TRAP TO READS
	JMP	READS
READ10:	BCS	RD14	;JUMP IF ()
	MOV	(R5)+,R0;STORE CAR IN NEW CELL
	MOV	@R5,R3
	MOV	R0,(R3)+
	MOV	R3,-(R5)	;SAVE OPEN CDR
	INC	RDEPTH
RD12:	CLR	NORPCD	;RECURSE TO GET NEXT CAR OF LIST
	MOV	#READ12,(R4)+
	JMP	READS
READ12:	BCC	RD13
	CMP	(R5)+,(R5)+	;END OF LIST: POP NIL AND OPEN CDR
	SUB	#2,RDEPTH
	BPL	.+4
	QT2ERR
	CLC
	JMP	@-(R4)
RD13:	MOV	(R5)+,R3;POP NEXT CAR
	DEC	RDEPTH
	BPL	.+4
	QT2ERR
	QGETC
	MOV	(R5)+,R0
	MOV	R0,@(R5)+	;CHAIN TO LAST CELL
	MOV	R3,(R0)+	;STORE CAR
	MOV	R0,-(R5)	;SAVE NEW OPEN CDR
	BR	RD12
RD14:	TST	(R5)+	;DISCARD NEW CELL
	CLR	@R5	;AND RETURN NIL
	JMP	RD03
AUTOQ:	QGETC
	MOV	@R5,R0
	MOV	QUOTE,(R0)+	;CAR IS QUOTE
	MOV	R0,-(R5)
	ADD	#2,RDEPTH
	MOV	#-1,NORPCD	;DON'T ALLOW .,])
	MOV	#READ15,(R4)+	;FAKE A TRAP TO READS
	JMP	READS	;TO GET ARG OF QUOTE
READ15:	QGETC
	MOV	(R5)+,R0
	MOV	(R5)+,R3
	MOV	R0,@(R5)+
	MOV	R3,@R0	;(QUOTE <ARG>)
	DEC	RDEPTH
	CLC
	JMP	RD03
ABORT:	MOV	RDEPTH,R0	;FLUSH ARG STACK
	BMI	RD22
	ASL	R0
	ADD	R0,R5
RD20:	CMP	-(R4),#READ03
	BNE	RD21
	JMP	READ	;FOUND READ: RE-START IT
RD21:	CMP	R4,SSTART
	BHI	RD20
RD22:	QT2ERR
LBRAK:	.BYTE	0
LPARB:	.BLKB	29.
RBRK:	.WORD	0
PARCNT:	.WORD	0
RDEPTH:	.WORD	0
NORPCD:	.WORD	0
NTYPE:	.WORD	0	;BIT 15: E SEEN, BIT14: NODIGIT SEEN AFTER
			;SIGN, BIT8: SIGN ALLOWED, BIT7:. SEEN
ZREAD=.-READ
	.END