Digital-Research-Source-Code/CPM OPERATING SYSTEMS/CPM 2.X/CPM 2.0/as5oper.asm

	TITLE	'ASM OPERAND SCAN MODULE'
;	OPERAND SCAN MODULE
	ORG	1860H
;
;	EXTERNALS
IOMOD	EQU	200H	;I/O MODULE
SCMOD	EQU	1100H	;SCANNER MODULE
SYMOD	EQU	1340H	;SYMBOL TABLE MODULE
BMOD	EQU	15A0H	;BINARY SEARCH MODULE
;
;
PERR	EQU	IOMOD+18H
SCAN	EQU	SCMOD+6H	;SCANNER ENTRY POINT
CR	EQU	0DH	;CARRIAGE RETURN
;
LOOKUP	EQU	SYMOD+6H	;LOOKUP
FOUND	EQU	LOOKUP+3	;FOUND SYMBOL IF ZERO FLAG NOT SET
ENTER	EQU	FOUND+3		;ENTER SYMBOL
SETTY	EQU	ENTER+3		;SET TYPE FIELD
GETTY	EQU	SETTY+3		;SET TYPE FIELD
SETVAL	EQU	GETTY+3		;SET VALUE FIELD
GETVAL	EQU	SETVAL+3	;GET VALUE FIELD
;
BSEAR	EQU	BMOD+3	;BINARY SEARCH ROUTINE
BGET	EQU	BSEAR+3	;GET VALUES WITH SEARCH
;
;	COMMON EQUATES
PBMAX	EQU	120	;MAX PRINT SIZE
PBUFF	EQU	10CH	;PRINT BUFFER
PBP	EQU	PBUFF+PBMAX	;PRINT BUFFER POINTER
;
TOKEN	EQU	PBP+1	;CURRENT TOKEN UDER SCAN
VALUE	EQU	TOKEN+1	;VALUE OF NUMBER IN BINARY
ACCLEN	EQU	VALUE+2	;ACCUMULATOR LENGTH
ACMAX	EQU	64	;MAX ACCUMULATOR LENGTH
ACCUM	EQU	ACCLEN+1
;
EVALUE	EQU	ACCUM+ACMAX	;VALUE FROM EXPRESSION ANALYSIS
;
SYTOP	EQU	EVALUE+2	;CURRENT SYMBOL TOP
SYMAX	EQU	SYTOP+2		;MAX ADDRESS+1
;
PASS	EQU	SYMAX+2	;CURRENT PASS NUMBER
FPC	EQU	PASS+1	;FILL ADDRESS FOR NEXT HEX BYTE
ASPC	EQU	FPC+2	;ASSEMBLER'S PSEUDO PC
;
;	GLOBAL EQUATES
IDEN	EQU	1	;IDENTIFIER
NUMB	EQU	2	;NUMBER
STRNG	EQU	3	;STRING
SPECL	EQU	4	;SPECIAL CHARACTER
;
PLABT	EQU	0001B	;PROGRAM LABEL
DLABT	EQU	0010B	;DATA LABEL
EQUT	EQU	0100B	;EQUATE
SETT	EQU	0101B	;SET
MACT	EQU	0110B	;MACRO
;
EXTT	EQU	1000B	;EXTERNAL
REFT	EQU	1011B	;REFER
GLBT	EQU	1100B	;GLOBAL
;
;
;	TABLE DEFINITIONS
XBASE	EQU	0	;START OF OPERATORS
OPER	EQU	15	;LAST OPERATOR
RT	EQU	16
PT	EQU	RT+1	;RT IS REGISTER TYPE, PT IS PSEUDO OPERATION
OBASE	EQU	PT+1
;
PLUS	EQU	5
MINUS	EQU	6
NOTF	EQU	8	;NOT
LPAR	EQU	12
RPAR	EQU	13
OSMAX	EQU	10
VSMAX	EQU	8*2
;
;
;	BEGINNING OF MODULE
	JMP	ENDMOD	;PAST THIS MODULE
	JMP	OPAND	;SCAN OPERAND FIELD
	JMP	MULF	;MULTIPLY FUNCTION
	JMP	DIVE	;DIVIDE FUNCTION
UNARY:	DS	1	;TRUE IF NEXT OPERATOR IS UNARY
OPERV:	DS	OSMAX	;OPERATOR STACK
HIERV:	DS	OSMAX	;OPERATOR PRIORITY
VSTACK:	DS	VSMAX	;VALUE STACK
OSP:	DS	1	;OPERATOR STACK POINTER
VSP:	DS	1	;VALUE STACK POINTER
;
;
;
STKV:	;PLACE CURRENT H,L VALUE AT TOP OF VSTACK
	XCHG	;HOLD VALUE IN D,E
	LXI	H,VSP
	MOV	A,M
	CPI	VSMAX
	JC	STKV0
	CALL	ERREX	;OVERFLOW IN EXPRESSION
	MVI	M,0	;VSP=0
STKV0:	MOV	A,M	;GET VSP
	INR	M	;VSP=VSP+1
	INR	M	;VSP=VSP+2
	MOV	C,A	;SAVE VSP
	MVI	B,0	;DOUBLE VSP
	LXI	H,VSTACK
	DAD	B
	MOV	M,E	;LOW BYTE
	INX	H
	MOV	M,D	;HIGH BYTE
	RET
;
STKO:	;STACK OPERATOR (REG-A) AND PRIORITY (REG-B)
	PUSH	PSW	;SAVE IT
	LXI	H,OSP
	MOV	A,M
	CPI	OSMAX
	JC	STKO1
	MVI	M,0
	CALL	ERREX	;OPERATOR STACK OVERFLOW
STKO1:	MOV	E,M	;GET OSP
	MVI	D,0
	INR	M	;OSP=OSP+1
	POP	PSW	;RECALL OPERATOR
	LXI	H,OPERV
	DAD	D	;OPERV(OSP)
	MOV	M,A	;OPERV(OSP)=OPERATOR
	LXI	H,HIERV
	DAD	D
	MOV	M,B	;HIERV(OSP)=PRIORITY
	RET
;
LODV1:	;LOAD TOP ELEMENT FROM VSTACK TO H,L
	LXI	H,VSP
	MOV	A,M
	ORA	A
	JNZ	LODOK
	CALL	ERREX	;UNDERFLOW
	LXI	H,0
	RET
;
LODOK:	DCR	M
	DCR	M	;VSP=VSP-2
	MOV	C,M	;LOW BYTE
	MVI	B,0
	LXI	H,VSTACK
	DAD	B	;VSTACK(VSP)
	MOV	C,M	;GET LOW BYTE
	INX	H
	MOV	H,M
	MOV	L,C
	RET
;
LODV2:	;LOAD TOP TWO ELEMENTS DE HOLDS TOP, HL HOLDS TOP-1
	CALL	LODV1
	XCHG
	CALL	LODV1
	RET
;
APPLY:	;APPLY OPERATOR IN REG-A TO TOP OF STACK
	MOV	L,A
	MVI	H,0
	DAD	H	;OPERATOR NUMBER*2
	LXI	D,OPTAB
	DAD	D	;INDEXED OPTAB
	MOV	E,M	;LOW ADDRESS
	INX	H
	MOV	H,M	;HIGH ADDRESS
	MOV	L,E
	PCHL		;SET PC AND GO TO SUBROUTINE
;
OPTAB:	DW	MULOP
	DW	DIVOP
	DW	MODOP
	DW	SHLOP
	DW	SHROP
	DW	ADDOP
	DW	SUBOP
	DW	NEGOP
	DW	NOTOP
	DW	ANDOP
	DW	OROP
	DW	XOROP
	DW	ERREX	;(
;
;	SPECIFIC HANDLERS FOLLOW
SHFT:	;SET UP OPERANDS FOR SHIFT L AND R
	CALL	LODV2
	MOV	A,D	;ENSURE 0-15
	ORA	A
	JNZ	SHERR
	MOV	A,E
	CPI	17
	RC		;RETURN IF 0-16 SHIFT
SHERR:	CALL	ERREX
	MVI	A,16
	RET
;
NEGF:	;COMPUTE 0-H,L TO H,L
	XRA	A
	SUB	L
	MOV	L,A
	MVI	A,0
	SBB	H
	MOV	H,A
	RET
;
DIVF:	CALL	LODV2
DIVE:	;(EXTERNAL ENTRY FROM MAIN PROGRAM)
	XCHG		;SWAP D,E WITH H,L FOR DIVIDE FUNCTION
;	COMPUTE X/Y WHERE X IS IN D,E AND Y IS IN H,L
;	THE VALUE OF X/Y APPEARS IN D,E AND X MOD Y IS IN H,L
;
	SHLD	DTEMP	;SAVE X IN TEMPORARY
	LXI	H,BNUM	;STORE BIT COUNT
	MVI	M,11H
	LXI	B,0	;INTIALIZE RESULT
	PUSH	B
	XRA	A	;CLEAR FLAGS
DLOOP:
	MOV	A,E	;GET LOW Y BYTE
	RAL
	MOV	E,A
	MOV	A,D
	RAL
	MOV	D,A
	DCR	M	;DECREMENT BIT COUNT
	POP	H	;RESTORE TEMP RESULT
	RZ		;ZERO BIT COUNT MEANS ALL DONE
	MVI	A,0	;ADD IN CARRY
	ACI	0	;CARRY
	DAD	H	;SHIFT TEMP RESULT LEFT ONE BIT
	MOV	B,H	;COPY HA AND L TO A A ND C
	ADD	L
	LHLD	DTEMP	;GET ADDRESS OF X
	SUB	L	;SUBTRACT FROM TEMPORARY RESULT
	MOV	C,A
	MOV	A,B
	SBB	H
	MOV	B,A
	PUSH	B	;SAVE TEMP RESULT IN STACK
	JNC	DSKIP	;NO BORROW FROM SUBTRACT
	DAD	B	;ADD X BACK IN
	XTHL	;REPLACE TEMP RESULT ON STACK
DSKIP:	LXI	H,BNUM	;RESTORE H,L
	CMC
	JMP	DLOOP	;REPEAT LOOP STEPS
;
DTEMP:	DS	2
BNUM:	DS	1
;
MULF:	;MULTIPLY D,E BY H,L AND REPLACE H,L WITH RESULT
	MOV	B,H
	MOV	C,L	;COPY OF 1ST VALUE TO B,C FOR SHIFT AND ADD
	LXI	H,0	;H,L IS THE ACCUMULATOR
MUL0:	XRA	A
	MOV	A,B	;CARRY IS CLEARED
	RAR
	MOV	B,A
	MOV	A,C
	RAR
	MOV	C,A
	JC	MUL1	;SKIP THIS ADD IF LSB IS ZERO
	ORA	B
	RZ		;RETURN WITH H,L
	JMP	MUL2	;SKIP ADD
MUL1:	DAD	D	;ADD CURRENT VALUE OF D
MUL2:	XCHG	;READY FOR *2
	DAD	H
	XCHG
	JMP	MUL0
;
MULOP:	;MULTIPLY D,E BY H,L
	CALL	LODV2
	CALL	MULF
	JMP	ENDOP
;
DIVOP:	;DIVIDE H,L BY D,E
	CALL	DIVF
	XCHG		;RESULT TO H,L
	JMP	ENDOP
;
MODOP:	CALL	DIVF
	JMP	ENDOP
;
SHLOP:	CALL	SHFT	;CHECK VALUES
SHL0:	ORA	A	;DONE?
	JZ	ENDOP
	DAD	H	;HL=HL*2
	DCR	A
	JMP	SHL0
;
SHROP:	CALL	SHFT
SHR0:	ORA	A	;DONE?
	JZ	ENDOP
	PUSH	PSW	;SAVE CURRENT COUNT
	XRA	A
	MOV	A,H
	RAR
	MOV	H,A
	MOV	A,L
	RAR
	MOV	L,A
	POP	PSW
	DCR	A
	JMP	SHR0
;
ADDOP:	CALL	LODV2
ADD0:	DAD	D
	JMP	ENDOP
;
SUBOP:	CALL	LODV2
	XCHG		;TREAT AS HL+(-DE)
	CALL	NEGF	;0-HL
	JMP	ADD0
;
NEGOP:	CALL	LODV1
NEG0:	CALL	NEGF	;COMPUTE 0-HL
	JMP	ENDOP
;
NOTOP:	CALL	LODV1
	INX	H	;65536-HL = 65535-(HL+1)
	JMP	NEG0
;
ANDOP:	CALL	LODV2
	MOV	A,D
	ANA	H
	MOV	H,A
	MOV	A,E
	ANA	L
	MOV	L,A
	JMP	ENDOP
;
OROP:	CALL	LODV2
	MOV	A,D
	ORA	H
	MOV	H,A
	MOV	A,E
	ORA	L
	MOV	L,A
	JMP	ENDOP
;
XOROP:	CALL	LODV2
	MOV	A,D
	XRA	H
	MOV	H,A
	MOV	A,E
	XRA	L
	MOV	L,A
;
ENDOP:	JMP	STKV
;
;
;
ENDEXP:	;RETURNS ZERO FLAG IF SYMBOL IS CR, ;, OR ,
	LDA	TOKEN
	CPI	SPECL
	RNZ		;NOT END IF NOT SPECIAL
;
	LDA	ACCUM
	CPI	CR
	RZ
	CPI	';'
	RZ
	CPI	','
	RZ
	CPI	'!'
	RET
;
OPAND:	;SCAN THE OPERAND FIELD OF AN INSTRUCTION
;	(NOT A DB WITH FIRST TOKEN STRING > 2 OR 0)
	XRA	A
	STA	OSP	;ZERO OPERATOR STACK POINTER
	STA	VSP
	DCR	A	;255
	STA	UNARY
	LXI	H,0
	SHLD	EVALUE
;
OP0:	;ARRIVE HERE WITH NEXT ITEM ALREADY SCANNED
	CALL	ENDEXP	;DONE?
	JNZ	OP1
;	EMPTY THE OPERATOR STACK
EMPOP:	LXI	H,OSP
	MOV	A,M	;GET THE OSP AND CHECK FOR EMPTY
	ORA	A
	JZ	CHKVAL	;JUMP IF EMPTY
	DCR	M	;POP ELEMENT
	MOV	E,A	;COPY FOR DOUBLE ADD
	DCR	E
	MVI	D,0
	LXI	H,OPERV
	DAD	D	;INDEXED - OPERV(OSP)
	MOV	A,M	;GET OPERATOR
	CALL	APPLY	;APPLY OPERATOR
	JMP	EMPOP
;
CHKVAL:
	LDA	VSP	;MUST HAVE ONE ELEMENT IT THE STACK
	CPI	2
	CNZ	ERREX
	LDA	PBUFF
	CPI	' '
	RNZ		;EVALUE REMAINS AT ZERO
	LHLD	VSTACK	;GET DOUBLE BYTE IN STACK
	SHLD	EVALUE
	RET
;
OP1:	;MORE TO SCAN
	LDA	PBUFF
	CPI	' '
	JNZ	GETOP
	LDA	TOKEN
	CPI	STRNG	;IS THIS A STRING?
	JNZ	OP3
;
;	STRING - CONVERT TO DOUBLE PRECISION
	LDA	ACCLEN
	ORA	A
	CZ	ERREX	;ERROR IF LENGTH=0
	CPI	3
	CNC	ERREX	;ERROR IF LENGTH>2
	MVI	D,0
	LXI	H,ACCUM
	MOV	E,M	;LSBYTE
	INX	H
	DCR	A	;A HAS THE LENGTH
	JZ	OP2	;ONE OR TWO BYTES
	MOV	D,M	;FILL HIGH ORDER
OP2:	XCHG		;VALUE TO H,L
	JMP	STNUM	;STORE TO STACK
;
OP3:	;NOT A STRING, CHECK FOR NUMBER
	CPI	NUMB
	JNZ	OP4
	LHLD	VALUE	;NUMERIC VALUE
	JMP	STNUM
;
OP4:	;NOT STRING OR NUMBER, MUST BE ID OR SPECL
	CALL	BGET	;BINARY SEARCH, GET ATTRIBUTES
	JNZ	OP6	;MATCH?
;	YES, MAY BE OPERATOR
	CPI	OPER+1
	JNC	OP5
;	OPERATOR ENCOUNTERED MS NIBBLE OF B IS PRIORITY NUMBER LS NIBBLE
;	IS THE OPERATOR
;	ACC HAS THE OPERATOR NUMBER, B HAS PRIORITY
	CPI	LPAR	;(?
	MOV	C,A	;SAVE COPY OF OPERATOR NUMBER
	LDA	UNARY
	JNZ	OPER1	;JUMP IF NOT A (
;	( ENCOUNTERED, UNARY MUST BE TRUE
	ORA	A
	CZ	ERREX
	MVI	A,0FFH
	STA	UNARY	;UNARY IS SET TRUE
	MOV	A,C	;RECOVER OPERATOR
	JMP	OPER4	;CALLS STKO AND SETS UNARY TO TRUE
;
;
OPER1:	;NOT A LEFT PAREN
	ORA	A
	JNZ	OPER6	;MUST BE + OR - SINCE UNARY IS SET
;
;	UNARY NOT SET, MUST BE BINARY OPERATOR
OPER2:	;COMPARE HIERARCHY OF TOS
	PUSH	B	;SAVE PRIORITY AND OPERATOR NUMBER
	LDA	OSP
	ORA	A
	JZ	OPER3	;NO MORE OPERATORS IN STACK
	MOV	E,A	;OSP TO E
	DCR	E	;OSP-1
	MVI	D,0
	LXI	H,HIERV
	DAD	D	;HL ADDRESSES TOP OF OPERATOR STACK
	MOV	A,M	;PRIORITY OF TOP OPERATOR
	CMP	B	;CURRENT GREATER?
	JC	OPER3	;JUMP IF SO
;	APPLY TOP OPERATOR TO VALUE STACK
	LXI	H,OSP
	MOV	M,E	;OSP=OSP-1
	LXI	H,OPERV
	DAD	D
	MOV	A,M	;OPERATOR NUMBER TO ACC
	CALL	APPLY
	POP	B	;RESTORE OPERATOR NUMBER AND PRIORITY
	JMP	OPER2	;FOR ANOTHER TEST
;
OPER3:	;ARRIVE HERE WHEN OPERATOR IS STACKED
;	CHECK FOR RIGHT PAREN BALANCE
	POP	B	;OPERATOR NUMBER IN C, PRIORITY IN B
	MOV	A,C
	CPI	RPAR
	JNZ	OPER4	;JUMP IF NOT A RIGHT PAREN
;
;	RIGHT PAREN FOUND, STACK MUST CONTAIN LEFT PAREN TO DELETE
	LXI	H,OSP
	MOV	A,M
	ORA	A	;ZERO?
	JZ	LPERR	;PAREN ERROR IF SO
	DCR	A	;OSP-1
	MOV	M,A	;STORED TO MEMORY
	MOV	E,A
	MVI	D,0
	LXI	H,OPERV
	DAD	D
	MOV	A,M	;TOP OPERATOR IN REG-A
	CPI	LPAR
	JZ	NLERR	;JMP IF NO ERROR - PARENS BALANCE
LPERR:	CALL	ERREX
NLERR:	;ERROR REPORTING COMPLETE
	XRA	A
	JMP	OPER5	;TO CLEAR UNARY FLAG
;
OPER4:	;ORDINARY OPERATOR
	CALL	STKO
	MVI	A,0FFH	;TO SET UNARY FLAG
OPER5:	STA	UNARY
	JMP	GETOP	;FOR ANOTHER ELEMENT
;
OPER6:	;UNARY SET, MUST BE + OR -
	MOV	A,C	;RECALL OPERATOR
	CPI	PLUS
	JZ	GETOP	;IGNORE UNARY PLUS
	CPI	MINUS
	JNZ	CHKNOT
	INR	A	;CHANGE TO UNARY MINUS
	MOV	C,A
	JMP	OPER2
CHKNOT:	;UNARY NOT SYMBOL?
	CPI	NOTF
	CNZ	ERREX
	JMP	OPER2
;
;
OP5:	;ELEMENT FOUND IN TABLE, NOT AN OPERATOR
	CPI	PT	;PSEUDO OPERATOR?
	CZ	ERREX	;ERROR IF SO
	MOV	L,B	;GET LOW VALUE TO L
	MVI	H,0	;ZERO HIGH ORDER BYTE
	JMP	STNUM	;STORE IT
;
OP6:	;NOT FOUND IN TABLE SCAN, $?
	LDA	TOKEN
	CPI	SPECL
	JNZ	OP7
	LDA	ACCUM
	CPI	'$'
	JZ	CURPC	;USE CURRENT PC
	CALL	ERREX
	LXI	H,0
	JMP	STNUM
CURPC:	LHLD	ASPC	;GET CURRENT PC
	JMP	STNUM
;
OP7:	;NOT $, LOOK IT UP
	CALL	LOOKUP
	CALL	FOUND
	JNZ	FIDENT
;	NOT FOUND IN SYMBOL TABLE, ENTER IF PASS 1
	MVI	A,'P'
	CALL	PERR
	CALL	ENTER	;ENTER SYMBOL WITH ZERO TYPE FIELD
	JMP	FIDE0
FIDENT:	CALL	GETTY	;TYPE TO H,L
	ANI	111B
	MVI	A,'U'
	CZ	PERR
;
FIDE0:
	CALL	GETVAL	;VALUE TO H,L
;
STNUM:	;STORE H,L TO VALUE STACK
	LDA	UNARY
	ORA	A	;UNARY OPERATION SET
	CZ	ERREX	;OPERAND ENCOUNTERED WITH UNARY OFF
	XRA	A
	STA	UNARY	;SET TO OFF
	CALL	STKV	;STACK THE VALUE
;
GETOP:	CALL	SCAN
	JMP	OP0
;
ERREX:	;PUT 'E' ERROR IN OUTPUT BUFFER
	PUSH	H
	MVI	A,'E'
	CALL	PERR
	POP	H
	RET
;
ENDMOD	EQU	($ AND 0FFE0H) + 20H	;NEXT HALF PAGE
	END