prim.mac

;PRIM.MAC
;860624 ALEX

;.INCLUDE 8KLISP.DEF

;	EXTRN ERR,MNUM,TEMP
;	EXTRN T1,T2,HEAPTR,HEAP

;COMPARE STRINGS HL AND DE
CMPSTR:
	PUSH HL				;SAVE PTRS
	PUSH DE
-:
	LD A,(DE)
	CP (HL)
	INC HL
	INC DE
	JR NZ,CSRET			;NOT EQUAL
	or a ;AND 80H
	jr nz,{-};JR Z,{-}
	XOR A
CSRET:
	POP DE
	POP HL
	RET					;EQUAL

;SEARCH SYMBOL TABLE, RETURN CARRY IF FOUND:
SEARCH:
;	di
;	halt
	LD BC,HEAP			;START OF SYMBOL CHAIN
SR10:
	LD DE,9				;OFFSET TO SYMBOL'S NAME
	EX DE,HL
	ADD HL,BC
	EX DE,HL			;DE ON NAME
	CALL CMPSTR
	JR Z,SRFOUND		;FOUND
	DEC DE				;DECREMENT TO LINK(HIGH)
	LD A,(DE)			;END OF CHAIN?
	OR A
	RET Z				;YES
	LD B,A
	DEC DE
	LD (TEMP),DE		;KEEP PTR TO LAST LINK
	LD A,(DE)
	LD C,A
	JR SR10				;CONT SEARCH
SRFOUND:
	LD H,B
	LD L,C				;GET RETURN VALUE
;	di
;	halt
BRKRET:
	SCF
	RET

;RETURN CARRY IF ESC KEY
BRKEY:
	in a,(4)
	and 8
	ret nz
	scf
	ret
	
	BDOS (11	)		;CHECK CONSOLE STATUS
	OR A			;CHAR PRESENT?
	RET Z			;NO-> CARRY CLEAR
	BDOS (1)
	CP 27			;ESC-KEY?
	JR Z,BRKRET		;YES
	OR A			;ELSE CARRY CLEAR
	RET

;RETURN NUMBER IN DEC
UNBXDE:
	EX DE,HL
UNBOX:
	CALL MNUM
	LD DE,0			;DEFAULT ZERO
	LD C,0
	INC HL			;GET COUNT
	LD A,(HL)
	OR A			;ZERO?
	RET Z			;YES
	INC HL
	LD C,(HL)
	DEC A
	RET Z
	INC HL
	LD E,(HL)
	DEC A
	RET Z
	INC HL
	LD D,(HL)
	DEC A
	RET Z
RANGERR:
	ERROR("Range")

;MACRO DEFINITIONS
/*LDC1 MACRO
	LD A,(HL)		;GET LENGTH
	AND 07FH		;STRIP SIGN
	LD C,A
	ENDM*/
.define LDC1 ld a,(hl) \ and 07fh \ ld c,a

/*LDB1 MACRO
	LD A,(DE)
	AND 07FH
	LD B,A
	ENDM*/
.define LDB1 ld a,(de) \ and 07fh \ ld b,a
;INCREMENT LENGTH INDICATOR
INRM:
	INC (HL)
	LD A,(HL)		;GET LENGTH
	AND 07FH
	CP MAXNUM+1		;TOO BIG?
	RET C			;OK
	POP HL			;ELSE DROP RET
	POP HL
OVRFL:
	ERROR("Ovrfl")

;DECREMENT LENGTH INDICATOR
DCRM:
	LD A,(HL)		;GET LENGTH
	CP 81H			;SPECIAL CASE?
	JR Z,DCRM1		;YES-JMP
	DEC (HL)
	RET Z			;RETURN WITH CONDITION CODE SET
	XOR (HL)
	RET
DCRM1:
	LD (HL),0		;GENERATE ZERO
	RET

;INSERT BYTE FROM A INTO LOW ORDER OF MULTIBYTE DATA
PSHL:
	PUSH AF			;SAVE BYTE
	LD B,0
	LD A,(HL)		;GET LENGTH
	OR A
	LD C,A
	JR Z,PSHL2
	ADD HL,BC
PSHL1:
	LD A,(HL)		;SHUFFLE UP DATA
	INC HL
	LD (HL),A
	DEC HL
	DEC HL
	DEC C
	JR NZ,PSHL1
PSHL2:
	INC (HL)		;INCREMENT LENGTH
	JR Z,OVRFL		;OVERFLOW ERROR
	POP AF			;RETRIEVE BYTE
	INC HL
	LD (HL),A		;INSERT IT
	DEC HL
	RET

;INCREMENT THE MODULUS OF MULTIBYTE DATA
INCR:
	PUSH HL
	LDC1
	JR Z,INCR2
INCR1:
	INC HL
	INC (HL)		;INCREMENT DATA
	JR NZ,INCR3		;OVERFLOW
	DEC C
	JR NZ,INCR1
INCR2:
	INC HL
	LD (HL),1
	POP HL
	JR INRM
INCR3:
	POP HL
	RET

;SHIFT DATA LEFT ONE BIT
LEFT:
	LDC1
	RET Z
	PUSH HL
LEFT1:
	INC HL
	LD A,(HL)
	RLA
	LD (HL),A
	DEC C
	JR NZ,LEFT1
	JR C,INCR2		;OVERFLOW
	POP HL
	RET

;SHIFT DATA RIGHT ONE BIT
RIGHT:
	LDC1
	RET Z
	LD B,0
	ADD HL,BC
	LD A,(HL)
	RRA
	LD (HL),A
	LD B,A
RIGHT1:
	DEC HL
	DEC C
	JR Z,RIGHT2
	LD A,(HL)
	RRA
	LD (HL),A
	JR RIGHT1
RIGHT2:
	DEC B
	RET P
	PUSH AF			;SAVE CARRY = LOST BIT
	CALL DCRM		;DECREMENT LENGTH
	POP AF
	RET

;SET OPERANDS
SETOPS:
	LD HL,(HEAPTR)
	INC HL
	INC DE
;MOVE DATA FROM DE TO HL
MOOV:
	LDB1
	LD (HL),A		;MOVE ANY ZERO LENGTH
	RET Z
	LD A,(DE)		;ELSE MOVE PROPER LENGTH
	LD (HL),A
	PUSH DE
	PUSH HL
MOOV1:
	INC DE
	INC HL
	LD A,(DE)
	LD (HL),A
	DJNZ MOOV1
	POP HL
	POP DE
	RET

;EQUALITY TEST PRIMITIVE
EQUAL?:
	LD A,H
	OR A			;NIL?
	JR Z,EQATOM		;YES
	LD A,(HL)
	RRCA			;ATOM?
	JR NC,EQATOM	;YES
	LD A,(DE)		;SECOND ARG
	AND 1			;ATOM?
	DEC A
	RET NZ			;YES
	PUSH DE			;BOTH ARGS ARE LISTS
	POPLIST
	EX (SP),HL		;SAVE CDR OF ARG 1
	PUSH DE
	POPLIST
	EX (SP),HL		;SAVE CDR OF ARG 2
	CALL EQUAL?		;TEST CARS FOR EQUAL
	POP DE
	POP HL
	JR Z,EQUAL?		;TEST CDRS FOR EQUAL
	RET

EQATOM:
	CPDE			;POINTER EQUALITY?
	RET Z			;YES
	LD A,(HL)		;ELSE NUMBERS?
	AND 81H
	CP 80H
	RET NZ			;NO
	LD A,(DE)
	AND 81H
	CP 80H
	RET NZ			;NO
EQNUM:
	INC HL			;COMPARE NUMBERS
	INC DE

;COMPARE DE TO HL
SPARE:
	LD A,(DE)
	AND (HL)		;BOTH SIGNS NEGATIVE?
	JP M,PARE3		;YES
PARE:
	LD A,(HL)
	XOR 80H			;SET SIGN (HL) TRUE
	LD B,A
	LD A,(DE)
	XOR 80H			;SET SIGN (DE) TRUE
	CP B
	RET NZ			;NOT EQUAL LENGTH
	LDC1
	PUSH HL
	PUSH DE
	LD B,0
	ADD HL,BC		;MSB HL
	EX DE,HL
	ADD HL,BC
	EX DE,HL
PARE1:
	LD A,(DE)
	CP (HL)			;COMPARE BYTES
	JR NZ,PARE2
	DEC HL			;EQUAL: TRY NEXT LOWER BYTES
	DEC DE
	DEC C
	JR NZ,PARE1
PARE2:
	POP DE
	POP HL
	RET
PARE3:
	CALL PARE
	CCF				;CORRECT RESULT IF BOTH NUMBERS NEGATIVE
	RET

;ADD DATA DE TO HL
ADD1:
	LDC1
	RET Z
	PUSH DE
	PUSH HL
	LDB1
	SUB C			;COMPARE LENGTHS
	EX DE,HL
	JR NC,ADD11
	CPL
	ADC A,(HL)		;INCREASE AUGENDS
	LD (HL),A
	XOR A
	ADD A,B
	JR Z,ADD14		;AUGEND = ZERO
ADD11:
	INC HL
	INC DE
	LD A,(DE)
	ADC A,(HL)
	LD (HL),A
	DEC B
	JR Z,ADD15
	DEC C
	JR NZ,ADD11
ADD12:
	INC HL
	LD A,(HL)
	ADC A,C
	LD (HL),A
	DEC B
	JR NZ,ADD12
	JR NC,ADD16
ADD13:
	INC HL			;OVERFLOW
	LD (HL),1		;EXTEND DATA
	POP DE
	POP HL
	CALL INRM
	EX DE,HL
	RET
ADD14:
	INC HL
	INC DE
	LD A,(DE)
	ADC A,B
	LD (HL),A
ADD15:
	DEC C
	JR NZ,ADD14
	JR C,ADD13
ADD16:
	POP HL
	POP DE
	RET

;SUBTRACT DATA HL FROM DE
SUB1:
	LDC1
	RET Z
	PUSH HL
	PUSH DE
	LDB1
	SUB C
	JR NC,SUB11
	EX DE,HL
	CPL
	ADC A,(HL)		;INCREASE MINUENDS LENGTH (PRESERVE SIGN)
	LD (HL),A
	XOR A
	ADD A,B
	EX DE,HL
	JR Z,SUB12		;MINUEND = 0
SUB11:
	INC HL
	INC DE
	LD A,(DE)
	SBC A,(HL)
	LD (DE),A
	DEC C
	JR Z,SUB16		;SUBTRAHEND EXHAUSTED
	DEC B
	JR NZ,SUB11		;MINUEND EXHAUSTED
SUB12:
	INC HL
	INC DE
	LD A,B
	SBC A,(HL)
	LD (DE),A
	DEC C
	JR NZ,SUB12
SUB13:
	POP HL		;2'COMP THE -VE RESULT
	PUSH HL
	PUSH DE
	LD A,(HL)
	XOR 80H		;CHANGE SIGN
	LD (HL),A
	AND 7FH
	LD C,A		;LENGTH
	SCF
SUB14:
	INC HL
	LD A,(HL)
	CPL
	ADC A,B
	LD (HL),A
	DEC C
	JR NZ,SUB14
	POP DE
	JR SUB17
SUB15:
	INC DE
	LD A,(DE)
	SBC A,C
	LD (DE),A
SUB16:
	DEC B
	JR NZ,SUB15
	JR C,SUB13
SUB17:
	POP HL
SUB18:
	LD A,(DE)
	CP C
	JR NZ,SUB1A
	DEC DE
SUB19:
	CALL DCRM
	JR NZ,SUB18
SUB1A:
	EX DE,HL
	POP HL
	RET

;MULTIPLY: DE = DE * HL
MULT0:
	LD A,(DE)
	AND 07FH
	LD B,A
	RET Z
	PUSH HL
	LD A,(DE)
	XOR (HL)
	PUSH AF			;SAVE SIGNS
	PUSH DE
	PUSH HL
	LD HL,T1
	CALL MOOV		;MOVE MULTIPLICAND
	XOR A
	LD (DE),A		;CLEAR RESULT
	POP DE
	LD HL,T2
	CALL MOOV		;MOVE MULTIPLIER
	POP DE
MULT1:
	LD HL,T2		;MULTIPLICATION STARTS
	LD A,(HL)
	OR A
	JR Z,MULT3		;DONE
	CALL RIGHT
	LD HL,T1
	JR NC,MULT2		;LEAST SIGNIFICANT BIT NOT SET
	CALL ADD1
MULT2:
	CALL LEFT
	JR MULT1
MULT3:
	POP AF
	POP HL
	RET P
	LD A,(DE)
	XOR 80H		;CHANGE SIGN
	LD (DE),A
	RET

DIV00:
	POP AF			;GET FLAGS
	RLCA			;MOD?
	JR C,DVR10		;YES
	XOR A
	LD (DE),A		;ELSE RETURN ZERO
DVR10:
	POP HL
	RET

DIVZER:
	POP AF
	POP HL
	ERROR("Div/0")

;DIVIDE, DIVIDE&ROUND AND MODULO: DE = DE / HL
MOD0:
	XOR A
	ADD A,80H		;CLEAR CARRY, SET SIGN
	JR DIV1
DIVR:
	XOR A
	SCF				;SET CARRY
	JR DIV1

DIV0:
	XOR A			;CLEAR CARRY
DIV1:
	PUSH HL
	PUSH AF
	LD A,(DE)
	XOR (HL)
	RLCA
	JR NC,DIV2
	POP AF
	INC A			;PUT ANY DIFFERENCE IN SIGNS INTO BIT 0
	PUSH AF
DIV2:
	LDC1
	JR Z,DIVZER		;DIVISOR ZERO
	LDB1
	SUB C
	JP M,DIV00		;DIVISOR > DIVIDEND
	PUSH DE
	INC A
	LD B,A
	LD C,A
	PUSH BC			;SAVE LENGTH DIFFERENCE
	LD A,(DE)
	AND 7FH			;CLEAR SIGN DIVIDEND
	LD (DE),A
	EX DE,HL
	LD HL,T1
	LD A,(HL)
	AND 7FH			;CLEAR SIGN OF PARTIAL DIVISOR
	LD (HL),A
	CALL MOOV		;MOVE DIVISOR
	XOR A
	LD (T2),A
	POP DE
DIV3:
	CALL PSHL
	DEC E
	JR NZ,DIV3
	LD C,A
	LD B,D
DIV4:
	POP DE			;DIVISION STARTS
	PUSH DE
	PUSH BC
	LD HL,T1
	CALL PARE		;PARTIAL DIVIDEND >= PARTIAL DIVISOR?
	JR C,DIV5		;NO
	CALL SUB1		;ELSE SUBTRACT
	LD HL,T2
	CALL INCR
DIV5:
	LD HL,T1		;RIGHT SHIFT PARTIAL DIVISOR
	CALL RIGHT
	POP BC
	DEC C			;REDUCE COUNT
	JP P,DIV6
	LD C,7
	DEC B
	JP M,DIV7		;END
DIV6:
	PUSH BC
	LD HL,T2
	CALL LEFT		;LEFT SHIFT PARTIAL RESULT
	POP BC
	JR DIV4
DIV7:
	POP DE			;REM
	POP AF
	JP M,DIVB		;MODULO
	JR NC,DIV9		;NOT ROUND
	PUSH AF
	CALL PARE		;PARTIAL DIVISOR/2 < REM?
	JR C,DIV8
	JR Z,DIV8
	LD HL,T2		;YES
	CALL INCR		;INCREMENT RESULT
DIV8:
	POP AF
DIV9:
	EX DE,HL
	LD DE,T2
	AND 1
	JR Z,DIVA		;NO CHANGE OF SIGN
	LD A,(DE)
	OR 80H
	LD (DE),A
DIVA:
	CALL MOOV		;MOVE RESULT TO (DE)
	EX DE,HL
DIVB:
	XOR A
	POP HL
	RET

;SQUARE ROOT DE
SQRTR:
	OR A			;CLEAR CARRY FOR ROUND
	JR SQRT1
SQRT0:
	SCF				;SET CARRY FOR NOT ROUND
SQRT1:
	PUSH AF			;SAVE OPERATION TYPE
	LD A,(DE)
	OR A
	SCF
	JP P,SQRT2
	POP BC
	RET				;RETURN UNDONE -VE OR ZERO
SQRT2:
	LD C,1
	LD HL,T2
	LD (HL),C
	INC HL
	LD (HL),C		;INIT T2 TO 1
	PUSH DE
	LD D,A
	XOR A
	DEC HL
SQRT3:
	CALL PSHL
	DEC D			;MAKE T2 > N (T2 MUST BE SQUARE NUMBER)
	JR NZ,SQRT3
	LD DE,T1
	LD (DE),A		;CLEAR T1
SQRT4:
	CALL ADD1		;T1 = T1+T2
	EX DE,HL
	POP DE
	CALL PARE		;N >= T1?
	PUSH AF
	CALL NC,SUB1	;YES: N = N-T1
	POP AF
	PUSH DE
	EX DE,HL
	LD HL,T2
	PUSH AF
	CALL NC,ADD1	;YES: T1 = T1+T2
	POP AF
	CALL C,SUB1		;NO: T1 = T1-T2
	EX DE,HL
	CALL RIGHT		;T1 = T1/2
	EX DE,HL
	CALL RIGHT
	CALL RIGHT		;T2 = T2/4
	LD A,(HL)
	OR A			;T2 = 0?
	JR NZ,SQRT4		;NO
	POP HL
	POP AF			;WAS IT ROUND?
	JR C,SQRT5		;NO
	CALL PARE		;N>T1?
	JR NC,SQRT5
	EX DE,HL
	CALL INCR		;YES: T1 = T1+1
	EX DE,HL
SQRT5:
	CALL MOOV		;PUT RESULT
	EX DE,HL
	OR A			;CLEAR CARRY FOR GOOD RESULT
	RET

	END