86ef202.asm

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

		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+		( u u -- udsum )
;		Add two unsigned single numbers and return a double sum.

                $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

;   BASE	( -- a )
;		Storage of the radix base for numeric I/O.

		$USER	4,'BASE',BASE

;   tmp		( -- a )
;		A temporary storage location used in parse and find.

                $USER   COMPO+3,'tmp',TEMP

;   >IN		( -- a )
;		Hold the character pointer while parsing input stream.

		$USER	3,'>IN',INN

;   #TIB	( -- a )
;		Hold the current count in and address of the terminal input buffer.

		$USER	4,'#TIB',NTIB
		_USER = _USER+CELLL		;hold the base address of the terminal input buffer

;   'EVAL	( -- a )
;		Execution vector of EVAL.

                $USER   5,"'eval",TEVAL

;   HLD		( -- a )
;		Hold a pointer in building a numeric output string.

                $USER   3,'hld',HLD

;   CONTEXT	( -- a )
;		A area to specify vocabulary search order.

                $USER   7,'CONTEXT',CNTXT

;   CP		( -- a )
;		Point to the top of the code dictionary.

                $USER   2,'cp',CP

;   LAST	( -- a )
;		Point to the last name in the name dictionary.

                $USER   4,'last',LAST

;; Common functions

;   ?DUP	( w -- w w | 0 )
;		Dup tos if its is not zero.

		$COLON	4,'?DUP',QDUP
		DW	DUPP
		DW	QBRAN,QDUP1
		DW	DUPP
QDUP1:		DW	EXIT

;   ROT		( w1 w2 w3 -- w2 w3 w1 )
;		Rot 3rd item to top.

		$COLON	3,'ROT',ROT
		DW	TOR,SWAP,RFROM,SWAP,EXIT

;   2DROP	( w w -- )
;		Discard two items on stack.

		$COLON	5,'2DROP',DDROP
		DW	DROP,DROP,EXIT

;   2DUP	( w1 w2 -- w1 w2 w1 w2 )
;		Duplicate top two items.

		$COLON	4,'2DUP',DDUP
		DW	OVER,OVER,EXIT

;   +		( w w -- sum )
;		Add top two items.

		$COLON	1,'+',PLUS
		DW	UPLUS,DROP,EXIT

;   NOT		( w -- w )
;		One's complement of tos.

		$COLON	3,'NOT',INVER
		DW	DOLIT,-1,XORR,EXIT

;   NEGATE	( n -- -n )
;		Two's complement of tos.

		$COLON	6,'NEGATE',NEGAT
                DW      INVER,ONEP,EXIT

;   DNEGATE	( d -- -d )
;		Two's complement of top double.

		$COLON	7,'DNEGATE',DNEGA
		DW	INVER,TOR,INVER
		DW	DOLIT,1,UPLUS
		DW	RFROM,PLUS,EXIT

;   -		( n1 n2 -- n1-n2 )
;		Subtraction.

		$COLON	1,'-',SUBB
		DW	NEGAT,PLUS,EXIT

;   ABS		( n -- n )
;		Return the absolute value of n.

		$COLON	3,'ABS',ABSS
		DW	DUPP,ZLESS
		DW	QBRAN,ABS1
		DW	NEGAT
ABS1:		DW	EXIT

;   =		( w w -- t )
;		Return true if top two are equal.

		$COLON	1,'=',EQUAL
		DW	XORR
		DW	QBRAN,EQU1
		DW	DOLIT,0,EXIT
EQU1:		DW	DOLIT,TRUEE,EXIT

;   U<		( u u -- t )
;		Unsigned compare of top two items.

		$COLON	2,'U<',ULESS
		DW	DDUP,XORR,ZLESS
		DW	QBRAN,ULES1
		DW	SWAP,DROP,ZLESS,EXIT
ULES1:		DW	SUBB,ZLESS,EXIT

;   <		( n1 n2 -- t )
;		Signed compare of top two items.

		$COLON	1,'<',LESS
		DW	DDUP,XORR,ZLESS
		DW	QBRAN,LESS1
		DW	DROP,ZLESS,EXIT
LESS1:		DW	SUBB,ZLESS,EXIT

;   MAX		( n n -- n )
;		Return the greater of two top stack items.

		$COLON	3,'MAX',MAX
		DW	DDUP,LESS
		DW	QBRAN,MAX1
		DW	SWAP
MAX1:		DW	DROP,EXIT

;   MIN		( n n -- n )
;		Return the smaller of top two stack items.

		$COLON	3,'MIN',MIN
		DW	DDUP,SWAP,LESS
		DW	QBRAN,MIN1
		DW	SWAP
MIN1:		DW	DROP,EXIT

;   WITHIN	( u ul uh -- t )
;		Return true if u is within the range of ul and uh. ( ul <= u < uh )

		$COLON	6,'WITHIN',WITHI
		DW	OVER,SUBB,TOR
		DW	SUBB,RFROM,ULESS,EXIT

;; Divide

;   UM/MOD	( udl udh un -- ur uq )
;		Unsigned divide of a double by a single. Return mod and quotient.

		$COLON	6,'UM/MOD',UMMOD
		DW	DDUP,ULESS
		DW	QBRAN,UMM4
		DW	NEGAT,DOLIT,15,TOR
UMM1:		DW	TOR,DUPP,UPLUS
		DW	TOR,TOR,DUPP,UPLUS
		DW	RFROM,PLUS,DUPP
		DW	RFROM,RAT,SWAP,TOR
		DW	UPLUS,RFROM,ORR
		DW	QBRAN,UMM2
                DW      TOR,DROP,ONEP,RFROM
		DW	BRAN,UMM3
UMM2:		DW	DROP
UMM3:		DW	RFROM
		DW	DONXT,UMM1
		DW	DROP,SWAP,EXIT
UMM4:		DW	DROP,DDROP
		DW	DOLIT,-1,DUPP,EXIT

;   M/MOD	( d n -- r q )
;		Signed floored divide of double by single. Return mod and quotient.

		$COLON	5,'M/MOD',MSMOD
		DW	DUPP,ZLESS,DUPP,TOR
		DW	QBRAN,MMOD1
		DW	NEGAT,TOR,DNEGA,RFROM
MMOD1:		DW	TOR,DUPP,ZLESS
		DW	QBRAN,MMOD2
		DW	RAT,PLUS
MMOD2:		DW	RFROM,UMMOD,RFROM
		DW	QBRAN,MMOD3
		DW	SWAP,NEGAT,SWAP
MMOD3:		DW	EXIT

;   /MOD	( n n -- r q )
;		Signed divide. Return mod and quotient.

		$COLON	4,'/MOD',SLMOD
		DW	OVER,ZLESS,SWAP,MSMOD,EXIT

;   MOD		( n n -- r )
;		Signed divide. Return mod only.

		$COLON	3,'MOD',MODD
		DW	SLMOD,DROP,EXIT

;   /		( n n -- q )
;		Signed divide. Return quotient only.

		$COLON	1,'/',SLASH
		DW	SLMOD,SWAP,DROP,EXIT

;; Multiply

;   UM*		( u u -- ud )
;		Unsigned multiply. Return double product.

		$COLON	3,'UM*',UMSTA
		DW	DOLIT,0,SWAP,DOLIT,15,TOR
UMST1:		DW	DUPP,UPLUS,TOR,TOR
		DW	DUPP,UPLUS,RFROM,PLUS,RFROM
		DW	QBRAN,UMST2
		DW	TOR,OVER,UPLUS,RFROM,PLUS
UMST2:		DW	DONXT,UMST1
		DW	ROT,DROP,EXIT

;   *		( n n -- n )
;		Signed multiply. Return single product.

		$COLON	1,'*',STAR
		DW	UMSTA,DROP,EXIT

;   M*		( n n -- d )
;		Signed multiply. Return double product.

		$COLON	2,'M*',MSTAR
		DW	DDUP,XORR,ZLESS,TOR
		DW	ABSS,SWAP,ABSS,UMSTA
		DW	RFROM
		DW	QBRAN,MSTA1
		DW	DNEGA
MSTA1:		DW	EXIT

;   */MOD	( n1 n2 n3 -- r q )
;		Multiply n1 and n2, then divide by n3. Return mod and quotient.

		$COLON	5,'*/MOD',SSMOD
		DW	TOR,MSTAR,RFROM,MSMOD,EXIT

;   */		( n1 n2 n3 -- q )
;		Multiply n1 by n2, then divide by n3. Return quotient only.

		$COLON	2,'*/',STASL
		DW	SSMOD,SWAP,DROP,EXIT

;; Miscellaneous

;   CELL+	( a -- a )
;		Add cell size in byte to address.

                $COLON  5,'CELL+',CELLP
		DW	DOLIT,CELLL,PLUS,EXIT

;   CELL-	( a -- a )
;		Subtract cell size in byte from address.

                $COLON  5,'CELL-',CELLM
		DW	DOLIT,0-CELLL,PLUS,EXIT

;   CELLS	( n -- n )
;		Multiply tos by cell size in bytes.

                $COLON  5,'CELLS',CELLS
		DW	DOLIT,CELLL,STAR,EXIT

;   1+          ( a -- a )
;		Add cell size in byte to address.

                $COLON  2,'1+',ONEP
                DW      DOLIT,1,PLUS,EXIT

;   1-          ( a -- a )
;		Subtract cell size in byte from address.

                $COLON  2,'1-',ONEM
                DW      DOLIT,-1,PLUS,EXIT

;   2/          ( n -- n )
;		Multiply tos by cell size in bytes.

                $COLON  2,'2/',TWOSL
                DW      DOLIT,CELLL,SLASH,EXIT

;   BL		( -- 32 )
;		Return 32, the blank character.

		$COLON	2,'BL',BLANK
		DW	DOLIT,' ',EXIT

;   >CHAR       ( c -- c )
;		Filter non-printing characters.

                $COLON  5,'>CHAR',TCHAR
		DW	DOLIT,07FH,ANDD,DUPP	;mask msb
		DW	DOLIT,127,BLANK,WITHI	;check for printable
		DW	QBRAN,TCHA1
		DW	DROP,DOLIT,'_'		;replace non-printables
TCHA1:		DW	EXIT

;   DEPTH	( -- n )
;		Return the depth of the data stack.

		$COLON	5,'DEPTH',DEPTH
                DW      SPAT,DOLIT,SPP,SWAP,SUBB
		DW	DOLIT,CELLL,SLASH,EXIT

;   PICK	( ... +n -- ... w )
;		Copy the nth stack item to tos.

		$COLON	4,'PICK',PICK
                DW      ONEP,CELLS
		DW	SPAT,PLUS,AT,EXIT

;; Memory access

;   +!		( n a -- )
;		Add n to the contents at address a.

		$COLON	2,'+!',PSTOR
		DW	SWAP,OVER,AT,PLUS
		DW	SWAP,STORE,EXIT

;   2!		( d a -- )
;		Store the double integer to address a.

		$COLON	2,'2!',DSTOR
		DW	SWAP,OVER,STORE
		DW	CELLP,STORE,EXIT

;   2@		( a -- d )
;		Fetch double integer from address a.

		$COLON	2,'2@',DAT
		DW	DUPP,CELLP,AT
		DW	SWAP,AT,EXIT

;   COUNT	( b -- b +n )
;		Return count byte of a string and add 1 to byte address.

		$COLON	5,'COUNT',COUNT
                DW      DUPP,ONEP
		DW	SWAP,CAT,EXIT

;   HERE	( -- a )
;		Return the top of the code dictionary.

		$COLON	4,'HERE',HERE
		DW	CP,AT,EXIT

;   PAD		( -- a )
;		Return the address of the text buffer above the code dictionary.

		$COLON	3,'PAD',PAD
		DW	HERE,DOLIT,80,PLUS,EXIT

;   TIB		( -- a )
;		Return the address of the terminal input buffer.

		$COLON	3,'TIB',TIB
		DW	NTIB,CELLP,AT,EXIT

;   @EXECUTE	( a -- )
;		Execute vector stored in address a.

		$COLON	8,'@EXECUTE',ATEXE
		DW	AT,QDUP			;?address or zero
		DW	QBRAN,EXE1
		DW	EXECU			;execute if non-zero
EXE1:		DW	EXIT			;do nothing if zero

;   CMOVE	( b1 b2 u -- )
;		Copy u bytes from b1 to b2.

		$COLON	5,'CMOVE',CMOVE
		DW	TOR
		DW	BRAN,CMOV2
CMOV1:		DW	TOR,DUPP,CAT
		DW	RAT,CSTOR
                DW      ONEP
                DW      RFROM,ONEP
CMOV2:		DW	DONXT,CMOV1
		DW	DDROP,EXIT

;   FILL	( b u c -- )
;		Fill u bytes of character c to area beginning at b.

		$COLON	4,'FILL',FILL
		DW	SWAP,TOR,SWAP
		DW	BRAN,FILL2
FILL1:          DW      DDUP,CSTOR,ONEP
FILL2:		DW	DONXT,FILL1
		DW	DDROP,EXIT

;   ERASE       ( b u -- )
;               Erase u bytes beginning at b.

                $COLON  5,'ERASE',ERASE
                DW      DOLIT,0,FILL
                DW      EXIT

;   PACK$	( b u a -- a )
;		Build a counted string with u characters from b. Null fill.

                $COLON  5,'PACK$',PACKS
                DW      DUPP,TOR          ;strings only on cell boundary
                DW      DDUP,CSTOR,ONEP ;save count
		DW	SWAP,CMOVE,RFROM,EXIT	;move string

;; Numeric output, single precision

;   DIGIT	( u -- c )
;		Convert digit u to a character.

                $COLON  5,'DIGIT',DIGIT
		DW	DOLIT,9,OVER,LESS
		DW	DOLIT,7,ANDD,PLUS
		DW	DOLIT,'0',PLUS,EXIT