; LevBCPL.asm - Bcpl runtime machine code
; Copyright Xerox Corporation 1979
; Last modified December 10, 1978  12:30 AM by Boggs

	.titl LevBCPL

; These next lines are so that we
; can debug this mess by loading it with a normal
; BCPL program which smashes it into its proper place.
; When assembling this program for inclusion in the
; Operating System through non-subversive means, these
; lines should be de-activated.
;
;	.bext Z300
;	.bext UTILBEGIN, UTILEND
;	.srel
;UTILBEGIN:  UTIL
;UTILEND: UTILLAST
;	End of debugging junk


.ent LevBcpl
.bext StackOverflow

	.srel

LevBcpl:	.LevBcpl
StackOverflow:	StkOfl	; so swat can print a reasonable name.

	.bext OsFinish

; Error codes passed to the procedure called on a "finish"
;  If no error, pass 0
ecOfl = 1000.		; Stack overflow (common)
ecNYI = 1001.		; Not yet implemented

swat = 77400		; Debugger trap instruction

	.zrel

; Right shift constant amount

; LQ0
; Computes ac0 ← ac0 rshift n (n in range 1 to 7)
; Calling sequence is:
;	lda 0 value
;	jsr 314 - 2*n
; LQ1
; Computes ac1 ← ac1 rshift n (n in range 1 to 7)
; Calling sequence is:
;	lda 1 value
;	jsr 315 - 2*n
Z300:
LQ0:	movzr 0 0 skp
LQ1:	movzr 1 1 skp
	movzr 0 0 skp
	movzr 1 1 skp
	movzr 0 0 skp
	movzr 1 1 skp
	movzr 0 0 skp
	movzr 1 1 skp
	movzr 0 0 skp
	movzr 1 1 skp
	movzr 0 0 skp
	movzr 1 1
	jmp 0 3

; Left shift data a constant amount, then store in partial-word field
; in the same manner as SNQx.
;
; SQ0
; Executes @ac1 ← (@ac1 & not @ac3) + ((ac0 lshift n) & @ac3)
; Calling sequence is:
;	lda 0 value (right-justified)
;	lda 1 address of word being stored into
;	jsr 333 - 2*n (n is number of left shifts desired, in range 0-7)
;	 mask word (ones in field being stored into, zeroes elsewhere)
;	returns here
; SQ1
; Executes @ac0 ← (@ac0 & not @ac3) + ((ac1 lshift n) & @ac3)
; Calling sequence is:
;	lda 1 value (right-justified)
;	lda 0 address of word being stored into
;	jsr 334 - 2*n (n is number of left shifts desired, in range 0-7)
;	 mask word (ones in field being stored into, zeroes elsewhere)
;	returns here
Z315:
SQ0:	movzl 0 0 skp
SQ1:	movzl 1 1 skp
	movzl 0 0 skp
	movzl 1 1 skp
	movzl 0 0 skp
	movzl 1 1 skp
	movzl 0 0 skp
	movzl 1 1 skp
	movzl 0 0 skp
	movzl 1 1 skp
	movzl 0 0 skp
	movzl 1 1 skp
	movzl 0 0 skp
	movzl 1 1 skp
	jmp @360
	jmp @361

ZSMAX:	-1			; 335
ZSNXT:	-1
ZSMIN:	-1

Z340:	IOR
	XOR
	EQV
	MULT
	DIVREM
	DIVREM
	LSH
	RSH
Z350:	BRANCH
	LOOKUP
	0			; was once UTIL
FINL:	FINISH
	ABORT
	LONGJ
	GETLV
	MULPLUS
Z360:	SNQ0
Z361:	SNQ1
	LY01
	LY10
	SY01
	SY10
	RETURN
	STARGS
Z370:	GETFRM
	GETFRMALT		; was once START
	-1
	-1
	LWB01
	LWB10
	SWB01
	SWB10

	.nrel

.LevBcpl:	0		; The sacrificial word.....

fLast = 0			; The layout of a BCPL frame
fRet  = 1
fTemp = 2
fArgx = 3
fArg1 = 4
fArg2 = 5
fArg3 = 6

FINISH:	mkzero 0 0 skp		; finishCode = fcOK
ABORT:	mkone 0 0		; finishCode = fcAbort
Blast:	mkzero 1 1		; Enter with AC0 set to code
	sta 1 ZSMAX		; Make bottom of stack very low for now.
	jsrii .+1
	 OsFinish		; call the OS finish routine

LWB01:				; replicated bit field manipulations
LWB10:				; are not implemented, though the
SWB01:				; compiler generates code for them.
SWB10:
GETLV:				; used on the Nova?
NOTYET:	swat
	lda 0 .+2
	jmp Blast
	ecNYI

; Getframe:

GETFRM:	sta 3 fTemp 2		; save return in old frame
	mov 2 3			; compute new frame by fetching
	lda 2 @fTemp 3		; frame size and subtracting

;BCPL used to assume that the minimum frame size was 4.
;Getframe unconditionally stored AC0 and AC1 in the first two locals.
;This could smash the previous frame.  The bug was fixed here in getframe
; by making it always allocate a frame 2 bigger than requested.
;The compiler has since been fixed so that the minimum frame size
; in code it generates is 6.  The inc 2 2, com 2 2 can be turned into
; a neg 2 2 whenever you think all code compiled with the old version
; of the compiler has gone away.  If you are wrong, the old code will
; act very flaky and be very hard to track down.
;The correct minimum frame size is 6.

GETFRMALT:			; Alternate entry point with ac2=frame size
	inc 2 2
	com 2 2
	add 3 2			; 2=> new frame

	sta 0 -1 3		; save ac0 below current frame (ahem)

	lda 0 ZSMAX		; stack moves "down".
	subz# 0 2 snc		; max must be less
	 jmp GFOFL		; overflow

	lda 0 -1 3		; pick up first arg
	sta 0 fArg1 2		; and save it in new frame
	sta 1 fArg2 2		; store second param
	sta 3 fLast 2		; and old stack pointer

	lda 0 @fRet 3
	lda 1 K3
	subl# 1 0 snc
	 jmp GFGE3
GFLE2:	lda 3 fTemp 3
	jmp 2 3
GFGE3:	sub 0 1 szr
	 jmp GFGR3
GFEQ3:	lda 1 fArgx 3
	sta 1 fArg3 2
	lda 3 fTemp 3
	jmp 2 3
GFGR3:	lda 1 fArgx 3
	add 3 1
	lda 3 fTemp 3
	jmp 1 3

K3:	3

GFOFL:	mov 3 2			; Put old stack back in 2 for viewing
StkOfl:	swat
	lda 0 .+2		; Error code for stack overflow.
	jmp Blast		; Abort
	ecOfl

; Return
; Performs:
;	AC2 ← AC2!0
;	PC ← AC2!1

RETURN:	lda 2 fLast 2
	lda 3 fRet 2
	jmp 1 3

; StoreArgs
; Assumes AC0 has actual parameter count
; and AC1 points to actual parameter
; vector-1, and that the first two parameters
; have already been transferred (by GetFrame usually).

STARGS:	sta 3 fRet 2
	sta 0 fTemp 2
	lda 3 K2
	sub 0 3			; AC3 ← -(ArgCount-2)
	inc 1 0
	inc 0 0 		; AC0 ← Pointer to third parameter-1
	lda 1 KFARG
	add 2 1
	sub 3 1			; AC1 ← AC2+(fArg1-1)+ArgCount
	blt			; Wheeeeee!
	lda 0 fTemp 2		; AC0 ← ArgCount again (for NumArgs)
	jmp @fRet 2

K2:	2
KFARG:	(fArg1-1)+2

; LongJump
; Jumps to AC3 + @AC3
; Calling sequence is:
;	jsr @355
;	 target-. (i.e., a self-relative pointer)

LONGJ:	lda 1 0 3
	add 1 3
	jmp 0 3

; Branch
; Calling sequence is:
;	lda 0 switchon value
;	jsr @350
;	 value of last case
;	 number of cases
;	 lastTarget-.
;	 ...
;	 firstTarget-.
;	return here if out of range, AC0 unchanged

BRANCH:	lda 1 0 3
	subz 0 1 snc
	 jmp BR2
	sta 3 fRet 2
	lda 3 1 3
	adcz# 1 3 snc
	 jmp BR1
	lda 3 fRet 2
	add 1 3
	lda 1 2 3
	add 1 3
	jmp 2 3

BR1:	mov 3 1
	lda 3 fRet 2
	add 1 3
	jmp 2 3

BR2:	lda 1 1 3
	add 1 3
	jmp 2 3

; Lookup
; Calling sequence is:
;	lda 0 switchon value
;	jsr @351
;	 number of cases
;	 case value 1
;	 target1-.
;	 ...
;	 case value n
;	 targetn-.
;	return here if out of range

LOOKUP:	lda 1 0 3
	sta 1 fRet 2

LK0:	inc 3 3
	inc 3 3
	lda 1 -1 3
	sub 0 1 snr
	 jmp LK1 
	dsz fRet 2
	jmp LK0
	jmp 1 3

LK1:	lda 1 0 3
	add 1 3
	jmp 0 3


; Right shift
; Computes ac0 ← ac0 rshift ac1
; Called by jsr @347
; Note that shift count may be either positive or negative

RSH:	sta 3 fRet 2	; Computes AC0 ← AC0 rshift AC1
	lda 3 K16
RSH0:	subz 3 1 szc
	 jmp RSH9
	jsr .+1
	sub 1 3
	jmp 1 3
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	movzr 0 0
	jmp @fRet 2

RSH9:	movl# 1 1 szc
	add 3 1 skp
	sub 0 0 skp
	neg 1 1 skp
	jmp @fRet 2
	jmp LSH0

; Left shift
; Computes ac0 ← ac0 lshift ac1
; called by jsr @346
; Note that shift count may be either positive or negative

LSH:	sta 3 fRet 2	; Computes AC0 ← AC0 lshift AC1
	lda 3 K16
LSH0:	subz 3 1 szc
	 jmp LSH9
	jsr .+1
	sub 1 3
	jmp 1 3
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	movzl 0 0
	jmp @fRet 2

LSH9:	movl# 1 1 szc
	add 3 1 skp
	sub 0 0 skp
	neg 1 1 skp
	jmp @fRet 2
	jmp RSH0

K16:	20

; Ior
; Computes ac0 ← ac0 % ac1
; Called by jsr @340

IOR:	com 1 1
	and 1 0
	adc 1 0
	jmp 0 3

; Xor
; Computes ac0 ← ac0 xor ac1
; Called by jsr @341

XOR:	sta 3 fRet 2
	mov 0 3
	andzl 1 3
	add 1 0
	sub 3 0
	jmp @fRet 2

; Eqv
; Computes ac0 ← ac0 eqv ac1
; Called by jsr @342

EQV:	sta 3 fRet 2
	mov 0 3
	andzl 1 3
	add 1 0
	sub 3 0
	com 0 0	
	jmp @fRet 2


; Mult
; Computes (ac0,ac1) ← ac0*ac1
; Called by jsr @343

MULT:	sta 3 fRet 2
	mov 2 3
	mov 0 2
	subc 0 0
	mul
	mov 3 2
	jmp @fRet 2


; DivRem
; Computes ac1 ← ac0/ac1 and ac0 ← ac0 rem ac1 (signed)
; Called by jsr@344 or jsr@345

DIVREM:	sta 3 fRet 2
	mov 2 3
	mov 1 2
	movl 1 1 szc
	 neg 2 2	; AC2 = ABS(Divisor)
	mov 0 1
	movr 0 0
	sta 0 fTemp 3	; High bit is sign of divisor, next bit
			; is sign of dividend
	movl# 1 1 szc
	 neg 1 1	; AC1 = ABS(Dividend)
	sub 0 0
	div
	 nop
	mov 3 2
	lda 3 fTemp 2
	movl 3 3 szc
	 neg 1 1	; Only if divisor was negative
	movl 3 3 snc
	 jmp @fRet 2	; Only if dividend was positive
	neg 1 1
	neg 0 0
	jmp @fRet 2

; MulPlus
; Computes ac0 ← ac3 ← (ac1*@ac3)+ac0
; Calling sequence is:
;	lda 0 addend
;	lda 1 multiplicand
;	jsr @357
;	 multiplier
;	return here with result in ac0 and ac3

MULPLUS:inc 3 3		; Computes AC0 ← AC3 ← (AC1*@AC3)+AC0
	sta 3 fRet 2
	mov 2 3
	lda 2 fRet 2
	lda 2 -1 2
	mul
	mov 1 0
	mov 3 2
	mov 1 3
	jmp @fRet 2	; go to (originalAC3+1)

; Snq0
; Stores partial-word field into a structure.
; Executes @ac1 ← (@ac1 & not @ac3) + (ac0 & @ac3)
; Calling sequence is:
;	lda 0 value (must be bit-aligned with field being stored into)
;	lda 1 address of word being stored into
;	jsr @360
;	 mask word (ones in field being stored into, zeroes elsewhere)
;	returns here

SNQ0:	sta 3 fRet 2
	sta 1 fTemp 2
	lda 1 0 3
	and 1 0
	lda 3 fTemp 2
	lda 3 0 3
	com 1 1
	and 3 1
	add 1 0
	lda 3 fTemp 2
	sta 0 0 3
	lda 3 fRet 2
	jmp 1 3

; Snq1
; Stores partial-word field into a structure.
; Executes @ac0 ← (@ac0 & not @ac3) + ac1 & @ac3
; Calling sequence is:
;	lda 1 value (must be bit-aligned with field being stored into)
;	lda 0 address of word being stored into
;	jsr @360
;	 mask word (ones in field being stored into, zeroes elsewhere)
;	returns here

SNQ1:	sta 3 fRet 2
	sta 0 fTemp 2
	lda 0 0 3
	and 0 1
	lda 3 fTemp 2
	lda 3 0 3
	com 0 0
	and 3 0
	add 0 1
	lda 3 fTemp 2
	sta 1 0 3
	lda 3 fRet 2
	jmp 1 3

; Ly01
; Load byte from array
; Loads the ac1'th byte from the array pointed to by ac0
; and returns it right-justified in ac0.
; Called by jsr @362
; Note:  ac1 may be negative.

LY01:	sta 3 fRet 2
	movl# 1 1 szc
	movor 1 3 skp
	movzr 1 3 skp
	addc 0 3 skp
	add 0 3
	lda 1 0 3
	lda 0 K377R
	mov# 0 0 snc
	movs 0 0 skp
	and 1 0 skp
	ands 1 0
	jmp @fRet 2

; Sy01
; Store byte into array
; Stores the byte now contained in frame temp 3 (ac2!3) into
; the ac1'th byte of the array pointed to by ac0.
; Called by jsr@364
; Note:  ac1 may be negative.

SY01:	sta 3 fRet 2
	movl# 1 1 szc
	movor 1 3 skp
	movzr 1 3 skp
	addc 0 3 skp
	add 0 3
	sta 3 fTemp 2
	lda 3 0 3
	lda 1 fArgx 2
	lda 0 K377R
	mov# 0 0 szc
	and 0 1 skp
	and 0 3 skp
	movs 0 0 skp
	ands 1 0 skp
	and 3 0 skp
	add 3 0 skp
	add 1 0
	lda 3 fTemp 2
	sta 0 0 3
	jmp @fRet 2

; Ly10
; Load byte from array
; Loads the ac0'th byte from the array pointed to by ac1
; and returns it right-justified in ac1.
; Called by jsr @363
; Note:  ac0 may be negative.

LY10:	sta 3 fRet 2
	movl# 0 0 szc
	movor 0 3 skp
	movzr 0 3 skp
	addc 1 3 skp
	add 1 3
	lda 0 0 3
	lda 1 K377R
	mov# 1 1 snc
	movs 1 1 skp
	and 0 1 skp
	ands 0 1
	jmp @fRet 2

; Sy10
; Store byte into array
; Stores the byte now contained in frame temp 3 (ac2!3) into
; the ac0'th byte of the array pointed to by ac1.
; Called by jsr@365
; Note:  ac0 may be negative.

SY10:	sta 3 fRet 2
	movl# 0 0 szc
	movor 0 3 skp
	movzr 0 3 skp
	addc 1 3 skp
	add 1 3
	sta 3 fTemp 2
	lda 3 0 3
	lda 0 fArgx 2
	lda 1 K377R
	mov# 1 1 szc
	and 1 0 skp
	and 1 3 skp
	movs 1 1 skp
	ands 0 1 skp
	and 3 1 skp
	add 3 1 skp
	add 0 1
	lda 3 fTemp 2
	sta 1 0 3
	jmp @fRet 2

UTILLAST:
K377R:	377

	.end