eforth.asm

eForth is a small portable Forth design for a wide range of microprocessors. This is the first imple

TITLE 8086 eForth

PAGE 62,132	;62 lines per page, 132 characters per line

;===============================================================
;
;	eForth 1.0 by Bill Muench and C. H. Ting, 1990
;	Much of the code is derived from the following sources:
;		8086 figForth by Thomas Newman, 1981 and Joe smith, 1983
;		aFORTH by John Rible
;		bFORTH by Bill Muench
;
;	The goal of this implementation is to provide a simple eForth Model
;	which can be ported easily to many 8, 16, 24 and 32 bit CPU's.
;	The following attributes make it suitable for CPU's of the '90:
;
;		small machine dependent kernel and portable high level code
;		source code in the MASM format
;		direct threaded code
;		separated code and name dictionaries
;		simple vectored terminal and file interface to host computer
;		aligned with the proposed ANS Forth Standard
;		easy upgrade path to optimize for specific CPU
;
;	You are invited to implement this Model on your favorite CPU and
;	contribute it to the eForth Library for public use. You may use
;	a portable implementation to advertise more sophisticated and
;	optimized version for commercial purposes. However, you are
;	expected to implement the Model faithfully. The eForth Working
;	Group reserves the right to reject implementation which deviates
;	significantly from this Model.
;
;	As the ANS Forth Standard is still evolving, this Model will
;	change accordingly. Implementations must state clearly the
;	version number of the Model being tracked.
;
;	Representing the eForth Working Group in the Silicon Valley FIG Chapter.
;	Send contributions to:
;
;		Dr. C. H. Ting
;		156 14th Avenue
;		San Mateo, CA 94402
;		[phone]
;
;===============================================================

;; Version control

VER		EQU	01H			;major release version
EXT		EQU	01H			;minor extension

;; Constants

COMPO		EQU	040H			;lexicon compile only bit
IMEDD		EQU	080H			;lexicon immediate bit
MASKK		EQU	07F1FH			;lexicon bit mask

CELLL		EQU	2			;size of a cell
BASEE		EQU	10			;default radix
VOCSS		EQU	8			;depth of vocabulary stack

BKSPP		EQU	8			;backspace
LF		EQU	10			;line feed
CRR		EQU	13			;carriage return
ERR		EQU	27			;error escape
TIC		EQU	39			;tick

CALLL		EQU	0E890H			;NOP CALL opcodes

;; Memory allocation	0//code>--//--<name//up>--<sp//tib>--rp//em

EM		EQU	04000H			;top of memory
COLDD		EQU	00100H			;cold start vector

US		EQU	64*CELLL		;user area size in cells
RTS		EQU	64*CELLL		;return stack/TIB size

RPP		EQU	EM-8*CELLL		;start of return stack (RP0)
TIBB		EQU	RPP-RTS			;terminal input buffer (TIB)
SPP		EQU	TIBB-8*CELLL		;start of data stack (SP0)
UPP		EQU	EM-256*CELLL		;start of user area (UP0)
NAMEE		EQU	UPP-8*CELLL		;name dictionary
CODEE		EQU	COLDD+US		;code dictionary

;; Initialize assembly variables

_LINK	= 0					;force a null link
_NAME	= NAMEE					;initialize name pointer
_CODE	= CODEE					;initialize code pointer
_USER	= 4*CELLL				;first user variable offset

;; Define assembly macros

;	Adjust an address to the next cell boundary.

$ALIGN	MACRO
	EVEN					;;for 16bit systems
	ENDM

;	Compile a code definition header.

$CODE	MACRO	LEX,NAME,LABEL
	$ALIGN					;;force to cell boundary
LABEL:						;;assembly label
	_CODE	= $				;;save code pointer
	_LEN	= (LEX AND 01FH)/CELLL		;;string cell count, round down
	_NAME	= _NAME-((_LEN+3)*CELLL)	;;new header on cell boundary
ORG	_NAME					;;set name pointer
	DW	 _CODE,_LINK			;;token pointer and link
	_LINK	= $				;;link points to a name string
	DB	LEX,NAME			;;name string
ORG	_CODE					;;restore code pointer
	ENDM

;	Compile a colon definition header.

$COLON	MACRO	LEX,NAME,LABEL
	$CODE	LEX,NAME,LABEL
	NOP					;;align to cell boundary
	CALL	DOLST				;;include CALL doLIST
	ENDM

;	Compile a user variable header.

$USER	MACRO	LEX,NAME,LABEL
	$CODE	LEX,NAME,LABEL
	NOP					;;align to cell boundary
	CALL	DOLST				;;include CALL doLIST
	DW	DOUSE,_USER			;;followed by doUSER and offset
	_USER	= _USER+CELLL			;;update user area offset
	ENDM

;	Compile an inline string.

D$	MACRO	FUNCT,STRNG
	DW	FUNCT				;;function
	_LEN	= $				;;save address of count byte
	DB	0,STRNG				;;count byte and string
	_CODE	= $				;;save code pointer
ORG	_LEN					;;point to count byte
	DB	_CODE-_LEN-1			;;set count
ORG	_CODE					;;restore code pointer
	$ALIGN
	ENDM

;	Assemble inline direct threaded code ending.

$NEXT	MACRO
	LODSW					;;next code address into AX
	JMP	AX				;;jump directly to code address
	ENDM

;; Main entry points and COLD start data

MAIN	SEGMENT
ASSUME	CS:MAIN,DS:MAIN,ES:MAIN,SS:MAIN

ORG	COLDD					;beginning of cold boot

ORIG:		MOV	AX,CS
		MOV	DS,AX			;DS is same as CS
		CLI				;disable interrupts, old 808x CPU bug
		MOV	SS,AX			;SS is same as CS
		MOV	SP,SPP			;initialize SP
		STI				;enable interrupts
		MOV	BP,RPP			;initialize RP
		MOV	AL,023H			;interrupt 23H
		MOV	DX,OFFSET CTRLC
		MOV	AH,025H			;MS-DOS set interrupt vector
		INT	021H
		CLD				;direction flag, increment
		JMP	COLD			;to high level cold start

CTRLC:		IRET				;control C interrupt routine

; COLD start moves the following to USER variables.
; MUST BE IN SAME ORDER AS USER VARIABLES.

$ALIGN						;align to cell boundary

UZERO:		DW	4 DUP (0)		;reserved
		DW	SPP			;SP0
		DW	RPP			;RP0
		DW	QRX			;'?KEY
		DW	TXSTO			;'EMIT
		DW	ACCEP			;'EXPECT
		DW	KTAP			;'TAP
		DW	TXSTO			;'ECHO
		DW	DOTOK			;'PROMPT
		DW	BASEE			;BASE
		DW	0			;tmp
		DW	0			;SPAN
		DW	0			;>IN
		DW	0			;#TIB
		DW	TIBB			;TIB
		DW	0			;CSP
		DW	INTER			;'EVAL
		DW	NUMBQ			;'NUMBER
		DW	0			;HLD
		DW	0			;HANDLER
		DW	0			;CONTEXT pointer
		DW	VOCSS DUP (0)		;vocabulary stack
		DW	0			;CURRENT pointer
		DW	0			;vocabulary link pointer
		DW	CTOP			;CP
		DW	NTOP			;NP
		DW	LASTN			;LAST
ULAST:

ORG	CODEE					;start code dictionary

;; Device dependent I/O

;   BYE		( -- )
;		Exit eForth.

		$CODE	3,'BYE',BYE
		INT	020H			;MS-DOS terminate process

;   ?RX		( -- c T | F )
;		Return input character and true, or a false if no input.

		$CODE	3,'?RX',QRX
		XOR	BX,BX			;BX=0 setup for false flag
		MOV	DL,0FFH			;input command
		MOV	AH,6			;MS-DOS Direct Console I/O
		INT	021H
		JZ	QRX3			;?key ready
		OR	AL,AL			;AL=0 if extended char
		JNZ	QRX1			;?extended character code
		INT	021H
		MOV	BH,AL			;extended code in msb
		JMP	QRX2
QRX1:		MOV	BL,AL
QRX2:		PUSH	BX			;save character
		MOV	BX,-1			;true flag
QRX3:		PUSH	BX
		$NEXT

;   TX!		( c -- )
;		Send character c to the output device.

		$CODE	3,'TX!',TXSTO
		POP	DX			;char in DL
		CMP	DL,0FFH			;0FFH is interpreted as input
		JNZ	TX1			;do NOT allow input
		MOV	DL,32			;change to blank
TX1:		MOV	AH,6			;MS-DOS Direct Console I/O
		INT	021H			;display character
		$NEXT

;   !IO		( -- )
;		Initialize the serial I/O devices.

		$CODE	3,'!IO',STOIO
		$NEXT

;; The kernel

;   doLIT	( -- w )
;		Push an inline literal.

		$CODE	COMPO+5,'doLIT',DOLIT
		LODSW
		PUSH	AX
		$NEXT

;   doLIST	( a -- )
;		Process colon list.

		$CODE	COMPO+6,'doLIST',DOLST
		XCHG	BP,SP			;exchange pointers
		PUSH	SI			;push return stack
		XCHG	BP,SP			;restore the pointers
		POP	SI			;new list address
		$NEXT

;   EXIT	( -- )
;		Terminate a colon definition.

		$CODE	4,'EXIT',EXIT
		XCHG	BP,SP			;exchange pointers
		POP	SI			;pop return stack
		XCHG	BP,SP			;restore the pointers
		$NEXT

;   EXECUTE	( ca -- )
;		Execute the word at ca.

		$CODE	7,'EXECUTE',EXECU
		POP	BX
		JMP	BX			;jump to the code address

;   next	( -- )
;		Run time code for the single index loop.
;		: next ( -- ) \ hilevel model
;		  r> r> dup if 1 - >r @ >r exit then drop cell+ >r ;

		$CODE	COMPO+4,'next',DONXT
		SUB	WORD PTR [BP],1		;decrement the index
		JC	NEXT1			;?decrement below 0
		MOV	SI,0[SI]		;no, continue loop
		$NEXT
NEXT1:		ADD	BP,CELLL		;yes, pop the index
		ADD	SI,CELLL		;exit loop
		$NEXT

;   ?branch	( f -- )
;		Branch if flag is zero.

		$CODE	COMPO+7,'?branch',QBRAN
		POP	BX			;pop flag
		OR	BX,BX			;?flag=0
		JZ	BRAN1			;yes, so branch
		ADD	SI,CELLL		;point IP to next cell
		$NEXT
BRAN1:		MOV	SI,0[SI]		;IP:=(IP)
		$NEXT

;   branch	( -- )
;		Branch to an inline address.

		$CODE	COMPO+6,'branch',BRAN
		MOV	SI,0[SI]		;IP:=(IP)
		$NEXT

;   !		( w a -- )
;		Pop the data stack to memory.

		$CODE	1,'!',STORE
		POP	BX
		POP	0[BX]
		$NEXT

;   @		( a -- w )
;		Push memory location to the data stack.

		$CODE	1,'@',AT
		POP	BX
		PUSH	0[BX]
		$NEXT

;   C!		( c b -- )
;		Pop the data stack to byte memory.

		$CODE	2,'C!',CSTOR
		POP	BX
		POP	AX
		MOV	0[BX],AL
		$NEXT

;   C@		( b -- c )
;		Push byte memory location to the data stack.

		$CODE	2,'C@',CAT
		POP	BX
		XOR	AX,AX			;AX=0 zero the hi byte
		MOV	AL,0[BX]
		PUSH	AX
		$NEXT

;   RP@		( -- a )
;		Push the current RP to the data stack.

		$CODE	3,'RP@',RPAT
		PUSH	BP
		$NEXT

;   RP!		( a -- )
;		Set the return stack pointer.

		$CODE	COMPO+3,'RP!',RPSTO
		POP	BP
		$NEXT

;   R>		( -- w )
;		Pop the return stack to the data stack.

		$CODE	2,'R>',RFROM
		PUSH	0[BP]
		ADD	BP,CELLL		;adjust RP
		$NEXT

;   R@		( -- w )
;		Copy top of return stack to the data stack.

		$CODE	2,'R@',RAT
		PUSH	0[BP]
		$NEXT

;   >R		( w -- )
;		Push the data stack to the return stack.

		$CODE	COMPO+2,'>R',TOR
		SUB	BP,CELLL		;adjust RP
		POP	0[BP]			;push
		$NEXT

;   SP@		( -- a )
;		Push the current data stack pointer.

		$CODE	3,'SP@',SPAT
		MOV	BX,SP			;use BX to index the stack
		PUSH	BX
		$NEXT

;   SP!		( a -- )
;		Set the data stack pointer.

		$CODE	3,'SP!',SPSTO
		POP	SP
		$NEXT

;   DROP	( w -- )
;		Discard top stack item.

		$CODE	4,'DROP',DROP
		ADD	SP,CELLL		;adjust SP
		$NEXT

;   DUP		( w -- w w )
;		Duplicate the top stack item.

		$CODE	3,'DUP',DUPP
		MOV	BX,SP			;use BX to index the stack
		PUSH	0[BX]
		$NEXT

;   SWAP	( w1 w2 -- w2 w1 )
;		Exchange top two stack items.

		$CODE	4,'SWAP',SWAP
		POP	BX
		POP	AX
		PUSH	BX
		PUSH	AX
		$NEXT

;   OVER	( w1 w2 -- w1 w2 w1 )
;		Copy second stack item to top.

		$CODE	4,'OVER',OVER
		MOV	BX,SP			;use BX to index the stack
		PUSH	CELLL[BX]
		$NEXT

;   0<		( n -- t )
;		Return true if n is negative.

		$CODE	2,'0<',ZLESS
		POP	AX
		CWD				;sign extend
		PUSH	DX
		$NEXT

;   AND		( w w -- w )
;		Bitwise AND.

		$CODE	3,'AND',ANDD
		POP	BX
		POP	AX
		AND	BX,AX
		PUSH	BX
		$NEXT

;   OR		( w w -- w )
;		Bitwise inclusive OR.

		$CODE	2,'OR',ORR
		POP	BX
		POP	AX
		OR	BX,AX
		PUSH	BX
		$NEXT

;   XOR		( w w -- w )
;		Bitwise exclusive OR.

		$CODE	3,'XOR',XORR
		POP	BX
		POP	AX
		XOR	BX,AX
		PUSH	BX
		$NEXT

;   UM+		( w w -- w cy )
;		Add two numbers, return the sum and carry flag.

		$CODE	3,'UM+',UPLUS
		XOR	CX,CX			;CX=0 initial carry flag
		POP	BX
		POP	AX
		ADD	AX,BX
		RCL	CX,1			;get carry
		PUSH	AX			;push sum
		PUSH	CX			;push carry
		$NEXT

;; System and user variables

;   doVAR	( -- a )
;		Run time routine for VARIABLE and CREATE.

		$COLON	COMPO+5,'doVAR',DOVAR
		DW	RFROM,EXIT

;   UP		( -- a )
;		Pointer to the user area.

		$COLON	2,'UP',UP
		DW	DOVAR
		DW	UPP

;   doUSER	( -- a )
;		Run time routine for user variables.

		$COLON	COMPO+6,'doUSER',DOUSE
		DW	RFROM,AT,UP,AT,PLUS,EXIT

;   SP0		( -- a )
;		Pointer to bottom of the data stack.

		$USER	3,'SP0',SZERO