OPT PRT

; runtimelib FOR 8086
; Joel Matthew Rees September 2020

; Borrowing some concepts from fig-Forth.
; Not tested!
; In fact, I was never all that good with 8086 code, 
; and it has been almost 40 years, so ...
;     don't expect it to work without fixing it.
; Patterned after 6809 libs.
;
; Natural 16-bit version.
; Unnatural 32-bit version is a project for another day, 
; as is any attempt to work with segmentation.

; ------------------------------------LICENSE-------------------------------------
;
; Copyright (c) 2020 Joel Matthew Rees
;
; Permission is hereby granted, free of charge, to any person obtaining a copy
; of this software and associated documentation files (the "Software"), to deal
; in the Software without restriction, including without limitation the rights
; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
; copies of the Software, and to permit persons to whom the Software is
; furnished to do so, subject to the following conditions:
;
; The above copyright notice and this permission notice shall be included in
; all copies or substantial portions of the Software.
;
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
; THE SOFTWARE.
;
; --------------------------------END-OF-LICENSE----------------------------------
; 


; These must be edited for target runtime:

; Necessary here for fake forward referencing:


BYTESZ:	EQU 8	; bit count in byte

ADRWDSZ:	EQU 2	; bytes per address word
; This is a 16-bit library/run-time, 
; without pretensions to long pointers or 32 bit cell size.

; If at all possible, a CELL should be able to contain an address.
; Otherwise, fetch and store become oddities.
CELLSZ:	EQU ADRWDSZ
CELLBSZ:	EQU (ADRWDSZ*BYTESZ)	; bit count in CELL
DBLSZ:	EQU (ADRWDSZ*2)
DBLBSZ:	EQU (DBLSZ*BYTESZ)	; bit count in DOUBLE

GAPCT:	EQU 2	; address words for the gaps
ALLOGAP:	EQU (GAPCT*ADRWDSZ)	; For crude checks, gaps always zero.


; Declare initial Return Stack (flow-of-control stack):
RSTKBND:	EQU 08000H	; Bound: one beyond
RSTKINI:	EQU (RSTKBND)	; Init: next available byte on 8086 -- pre-dec
RSTKSZ:	EQU (62*ADRWDSZ)	; Size: Safe for most purposes.
RSTKLIM:	EQU (RSTKBND-RSTKSZ)	; Limit: Last useable
; Kibitzing -- CPUs really should have automatic stack bounds checking.
; Don't forget gaps for CPUs that don't automatically check.
; Crude guard rails is better than none?

; Declare initial Locals Stack (temporaries stack):
LSTKBND:	EQU (RSTKLIM-ALLOGAP)
LSTKINI:	EQU (LSTKBND-CELLSZ)	; 8080? pre-dec, but on address word boundary. 
LSTKSZ:	EQU (30*CELLSZ)	; Size: CELL addressing, small stacks.
LSTKLIM:	EQU (LSTKBND-LSTKSZ)

; Declare initial Parameter Stack (data stack):
SSTKBND:	EQU (LSTKLIM-ALLOGAP)
SSTKINI:	EQU (SSTKBND)	; Also pre-dec, but on address word boundary. 
SSTKSZ:	EQU (126*ADRWDSZ)	; Size: CELL addressing, small stacks.
SSTKLIM:	EQU (SSTKBND-SSTKSZ)

; The paramater stack and heap at opposite ends of the same region 
; has mixed benefits.

; The initial per-user allocation heap:
UPGBND:	EQU (SSTKLIM-ALLOGAP)
UPGSZ:	EQU 64*ADRWDSZ	; This will need adjusting in many cases.
UPGBASE:	EQU (UPGBND-UPGSZ)
UPGINI:	EQU UPGBASE




; ORG directives in older assemblers can get tangled up
; if they are convoluted.
; Keep the ORGs in assending order.


; Keep an eye on address handling!
	ORG 400H	; This assumes the library will be in the same space as interrupts.
; I'll try to keep the model sane if the interrupts are moved out.

; Internal registers --
; (When switching contexts, these must be saved and restored.):

; This is the small model, all segments are same.

; RP	EQU ADRWDSZ	; the return/flow-of-control stack pointer is 8086 SP
; PSP	RMB ADRWDSZ	; the parameter/data stack pointer (Forth SP) is 8086 BP
; LSP	RMB ADRWDSZ	; the locals stack pointer is 8086 SI (save before other use)
; TEMP	RMB 2*ADRWDSZ	; for math on X -- all temps allocated local on BP
; GCOUNT	RMB ADRWDSZ	; general counter is 8086 CX
; IXDEST	RMB ADRWDSZ	; destination index pointer is often 8086 DI (after saving)
; IXSRC	RMB ADRWDSZ	; source index pointer is often 8086 SI (after saving)
; UP	RMB ADRWDSZ	; pointer to the per-task heap is 8086 DI (save before other use)
; BX will be general purpose index.



	ORG 480H
	NOP
COLD:	JMP COLDENT
	NOP
WARM:	JMP WARMENT


; _WORD_ AND Take logical AND of top two on stack ( n1 n2 --- n3 ):
AND:
	MOV AX,[BP]
	AND CELLSZ[BP],AX
	LEA BP,CELLSZ[BP]
	RET

; _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
OR:
	MOV AX,BYTE PTR [BP]
	OR CELLSZ[BP],AX
	LEA BP,CELLSZ[BP]
	RET

; _WORD_ Take logical OR of top two on stack ( n1 n2 --- n3 ):
XOR:
	MOV AX,[BP]
	XOR CELLSZ[BP],AX
	LEA BP,CELLSZ[BP]
	RET

; _WORD_ Add top two cells on stack ( n1 n2 --- sum ):
ADD:
	MOV AX,[BP]
	ADD CELLSZ[BP],AX
	LEA BP,CELLSZ[BP]
	RET

; _WORD_ Subtract top cell on stack from second ( n1 n2 --- difference(n1-n2) ):
SUB:
	MOV AX,[BP]
	ADD CELLSZ[BP],AX
	LEA BP,CELLSZ[BP]
	RET

; _WORD_ Fetch byte only pointed to by top cell on stack ( adr --- b(at adr) ):
; (Refer to Forth's C@, but byte is not character!)
BFETCH:
	MOV BX,[BP]
	MOV AL,[BX]
	CBW
	MOV [BP],AX
	RET

; _WORD_ Store low byte of cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
; (Refer to Forth's C!, but byte is not character!)
BSTORE:
	MOV BX,[BP]
	MOV AL,CELLSZ[BP]	; Least Significant First, no auto-inc, so this works.
	MOV [BX],AL
	LEA BP,CELLSZ+ADRWDSZ[BP]
	RET

; _WORD_ Fetch cell pointed to by top cell on stack ( adr --- n(at adr) ):
FETCH:
	MOV BX,[BP]
	MOV AX,[BX]
	MOV [BP],AX
	RET

; _WORD_ Store cell at 2nd at address on top of stack, deallocate both ( n adr --- ):
STORE:
	MOV BX,[BP]
	MOV AX,CELLSZ[BP]
	MOV [BX],AX
	LEA BP,CELLSZ+ADRWDSZ[BP]
	RET

; _WORD_ Unsigned multiply of top two on stack ( u1 u2 --- udproduct(n1*n2) ):
; Run-time optimize for small numbers.
USTAR:
	MOV AX,[BP]
	MOV CX,CELLSZ[BP]
	MOV DX,CX
	OR DH,AH
	JZ USTARB
	MUL CX
	JMP USTARD
USTARB:
	XOR DX,DX
	MUL CL
USTARD:
	MOV [BP],AX
	MOV CELLSZ[BP],DX
	RET

; _WORD_ SWAP swap top two cells on stack ( n1 n2 --- n2 n1 ):
SWAP
	MOV AX,[BP]
	MOV DX,CELLSZ[BP]
	MOV [BP],DX
	MOV CELLSZ[BP],AX
	RET

; _WORD_ Unsigned divide of unsigned double dividend in 2nd:3rd on stack by top unsigned divisor 
; ( ud u --- uremainder uquotient )
; Run-time optimize for small numbers.
; Dividend should be range of product of 16 by 16 bit unsigned multiply,
; divisor should be the multiplier or multiplicand:
USLASH:
	MOV AX,CELLSZ[BP]
	MOV CX,[BP]
	MOV DX,CX
	OR DH,AH
	JZ USLASB
	DIV CX	; CX/AX => DX is modulus, AX is quotient
	JMP USLASD
USLASB:
	XOR DX,DX	; clear DX to receive low byte
	DIV CL	; CL/AL => AH is modulus, AL is quotient
	MOV DL,AH
	XOR AH,AH	; clear AH so AX is unsigned quotient
USLASD:
	MOV CELLSZ[BP],DX
	MOV [BP],AX
	RET

; _WORD_ >L Save top cell on parameter stack to locals stack ( n --- ) { --- n }:
TOL:
	MOV AX,[BP]
	LEA BP,CELLSZ[BP]
	LEA SI,-CELLSZ[SI]
	MOV [SI],AX
	RET


; _WORD_ Save top cell on parameter stack to return stack ( n --- ) { --- n }:
TOR:
	MOV AX,[BP]
	LEA BP,CELLSZ[BP]
	POP BX	; return address, oh forgetful one!
	PUSH AX
	JMP BX

; _WORD_ L> Pop top of locals stack to parameter stack ( --- n ) { n --- }:
LFROM:
	MOV AX,[SI]
	LEA SI,CELLSZ[SI]
	LEA BP,-CELLSZ[BP]
	MOV [BP],AX
	RET

; _WORD_ Pop top of return stack to parameter stack ( --- n ) { n --- }:
RFROM:
	POP BX	; return address, oh forgetful one!
	POP AX
	LEA BP,-CELLSZ[BP]
	MOV [BP],AX
	JMP BX


* _WORD_ L Retrieve, do not pop top of locals stack to parameter stack ( --- n ) { n --- n }:
L:
	MOV AX,[SI]
	LEA BP,-CELLSZ[BP]
	MOV [BP],AX
	RET

; _WORD_ Retrieve, do not pop top of return stack to parameter stack ( --- n ) { n --- n }:
R:
	MOV BX,SP
	MOV AX,SS:CELLSZ[BX]	; skip return address, oh forgetful one!
	LEA BP,-CELLSZ[BP]
	MOV [BP],AX
	RET

******

; Should true be set as 1 or -1?
; Going with all bits False (0) 
; or all bits True (-1) as the flag to set.
; D really doesn't help here.
; _WORD_ Test top cell on stack for zero ( n --- f(top==0) ):
ZEQU:
	LDX PSP
	CLRA
	LDAB 0,X
	ORAB 1,X
	BNE ZEQUF
	COMA
ZEQUF:
	STAA 0,X
	STAA 1,X
	RTS
;
; True as 1 would look like
; ZEQU
;	LDX PSP
;	CLRA
;	LDAB 0,X
;	ORAB 1,X
;	BNE ZEQUF
;	INCA
; ZEQUF
;	CLR 0,X
;	STAA 1,X
;	RTS

	

; _LOWORD_ Duplicate (count in B) bytes on stack:
NDUP:
;	STX TEMP



;***** Working in here to make it go both ways.
;***** Also need to check multiply and divide.


; _LOWORD_ Move 256 bytes or less:
; 0=256, do not enter without pretesting for 0 count!
; source in X, destination in Y, count in B:
; Overlaps only work if source is higher than dest.
SMOVE:
	LDA ,X+ 
	STA ,Y+
	DECB
	BNE SMOVE
	RTS

; _WORD_ Move up to 32K bytes ( src dest count --- ):
; Copies zero when count >= 2^15
; Compare CMOVE in Forth.
BMOVE:
	LDX 2*ADRWDSZ,U	; src
	LDY ADRWDSZ,U ; dest
	LDD 0,U	; count 
	BEQ BMOVEX	; Pre-test, do nothing if zero,
	BMI BMOVEX	; or too big.
BMOVEL:	BSR SMOVE	; partial block and full blocks
	DEC 0,U	; count high byte down (blocks)
	BPL BMOVEL ; This limits the count.
BMOVEX:	LEAU 3*ADRWDSZ,U
	RTS

; _WORD_ Execute the address on the stack:
EXEC:
	JMP [,U++]	; For debugging and flattening, no early optimizations.



COLDENT:
	MOV SP,RSTKINI
	MOV BP,SSTKINI
	MOV SI,LSTKINI
	MOV DI,UPGINI
WARMENT:
	EQU COLDENT