\ Nick
10 CONSTANT linefeed-char
13 CONSTANT carriage-return-char
32 CONSTANT blank-char-value

1 CONSTANT char-size
2 CONSTANT cell-size
cell-size 8 * CONSTANT cell-size-in-bits

16 BASE !
  0FF CONSTANT max-char
  7FFF CONSTANT max-signed
  0FFFF CONSTANT max-unsigned
  8000 CONSTANT max-negative

  20 CONSTANT =compo
  40 CONSTANT =immed
  80 CONSTANT =seman
  1F CONSTANT =mask
DECIMAL

258 CONSTANT size-of-PAD

8 CONSTANT bsp#
9 CONSTANT tab#
13 CONSTANT cr#
10 CONSTANT lf#
127 CONSTANT del#

16 BASE !
  0E890 CONSTANT call-code
DECIMAL

\ ;;;;;;;;;;;;;;;
\ System dependent words -- Must be re-definded for each system.
\ ;;;;;;;;;;;;;;;
\ I/O words must be redefined if serial communication is used instead of
\ keyboard. Following words are for MS-DOS system.

\   TX? 	( -- flag )
\		Return true if output device is ready or device state is
\		indeterminate.

\		$CONST	NameTXQ,TXQ,TRUEE	;always true for MS-DOS

\   CR		( -- )				\ CORE
\		Carriage return and linefeed.

: CR		carriage-return-char EMIT  linefeed-char EMIT ;

\		$COLON	NameCR,CR
\		DW	DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT

\   hi		( -- )

: hi		CR ." hForth "
		S" CPU" ENVIRONMENT? DROP TYPE SPACE
		S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT
		S" version"  ENVIRONMENT? DROP TYPE
		."  by Wonyong Koh, 1997" CR
		." ALL noncommercial and commercial uses are granted." CR
		." Please send comment, bug report and suggestions to:" CR
		."   wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;

\		$COLON	NameHI,HI
\		DW	CR,DoLIT,HiStr1,COUNT,TYPEE
\		DW	DoLIT,CPUQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE,SPACE
\		DW	DoLIT,ModelQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE
\		DW	SPACE,DoLIT,'v',EMIT
\		DW	DoLIT,VersionQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE
\		DW	DoLIT,HiStr2,COUNT,TYPEE,CR
\		DW	DoLIT,HiStr3,COUNT,TYPEE,CR
\		DW	DoLIT,HiStr4,COUNT,TYPEE,CR
\		DW	DoLIT,HiStr5,COUNT,TYPEE,CR,EXIT

\   COLD	( -- )
\		The cold start sequence execution word.

: COLD		sp0 sp! rp0 rp! 		\ initialize stack
		'init-i/o EXECUTE
		'boot EXECUTE
		QUIT ;				\ start interpretation

\		$COLON	NameCOLD,COLD
\		DW	SPZero,SPStore,RPZero,RPStore
\		DW	TickINIT_IO,EXECUTE,TickBoot,EXECUTE
\		DW	QUIT

\   set-i/o ( -- )
\		Set input/output device.

: set-i/o	S" CON" stdin ;                 \ MS-DOS only

\		$COLON	NameSet_IO,Set_IO
\ Nick removed this, want to use ordinary DOS redirection instead
\		DW	DoLIT,Set_IOstr 	;MS-DOS only
\		DW	COUNT,STDIN		;MS-DOS only
\		DW	EXIT

\   asciiz	( ca1 u -- ca2 )
\		Return ASCIIZ string.

: asciiz	HERE SWAP 2DUP + 0 SWAP C! CHARS MOVE HERE ;

\		$COLON	NameASCIIZ,ASCIIZ
\		DW	HERE,SWAP,TwoDUP,Plus,DoLIT,0
\		DW	SWAP,CStore,CHARS,MOVE,HERE,EXIT

\   stdin	( ca u -- )

: stdin		asciiz redirect ?DUP
		IF -38 THROW THEN	\ non-existent file
		; COMPILE-ONLY

\		$COLON	NameSTDIN,STDIN
\		DW	ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1
\		DW	DoLIT,-38,THROW
\ STDIN1		DW	EXIT

\   <<		( "<spaces>ccc" -- )
\		Redirect input from the file 'ccc'. Should be used only in
\		interpretation state.

: <<		STATE @ IF ." Do not use '<<' in a definition." ABORT THEN
		PARSE-WORD stdin SOURCE >IN !  DROP ; IMMEDIATE

\		$COLON	NameFROM,FROM
\		DW	DoLIT,AddrSTATE,Fetch,ZBranch,FROM1
\		DW	CR
\		DW	DoLIT,FROMstr
\		DW	COUNT,TYPEE,ABORT
\ FROM1		DW	PARSE_WORD,STDIN,SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT

\ ;;;;;;;;;;;;;;;
\ Non-Standard words - Processor-dependent definitions
\	16 bit Forth for 8086/8
\ ;;;;;;;;;;;;;;;

\   PAUSE	( -- )
\		Stop current task and transfer control to the task of which
\		'status' USER variable is stored in 'follower' USER variable
\		of current task.

\ problem
\ : PAUSE		rp@ DUP sp@ stackTop !	follower @ code@ >R ; COMPILE-ONLY

\		  $COLON  NamePAUSE,PAUSE
\		  DW	  RPFetch,DUPP,SPFetch,StackTop,Store
\		  DW	  Follower,Fetch,CodeFetch,ToR,EXIT

\		$CODE	NamePAUSE,PAUSE
\		PUSH	BX
\		XCHG	BP,SP
\		PUSH	SI
\		XCHG	BP,SP
\		PUSH	BP
\		MOV	BX,WORD PTR AddrUserP
\ StackTopOffset = SysStackTop - SysUserP
\		MOV	[BX+StackTopOffset],SP
\ FollowerOffset = SysFollower - SysUserP
\		MOV	BX,[BX+FollowerOffset]
\		MOV	SI,CS:[BX]
\		$NEXT

\   wake	( -- )
\		Wake current task.

: wake		R> CELL+ code@ userP !	\ userP points 'follower' of current task
		stackTop @ sp! DROP	\ set data stack
		rp! ; COMPILE-ONLY	\ set return stack

\		  $COLON  NameWake,Wake
\		  DW	  RFrom,CELLPlus,CodeFetch,DoLIT,AddrUserP,Store
\		  DW	  StackTop,Fetch,SPStore,DROP,RPStore,EXIT

\		$CODE	NameWake,Wake
\		MOV	BX,CS:[SI+CELLL]
\		MOV	WORD PTR AddrUserP,BX
\		MOV	SP,[BX+StackTopOffset]
\		POP	BP
\		XCHG	BP,SP
\		POP	SI
\		XCHG	BP,SP
\		POP	BX
\		$NEXT

\   same?	( c-addr1 c-addr2 u -- -1|0|1 )
\		Return 0 if two strings, ca1 u and ca2 u, are same; -1 if
\		string, ca1 u is smaller than ca2 u; 1 otherwise. Used by
\		'(search-wordlist)'. Code definition is preferred to speed up
\		interpretation. Colon definition is shown below.

: same?		?DUP IF 	\ null strings are always same
		   0 DO OVER C@ OVER C@ XOR
			IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN
			CHAR+ SWAP CHAR+ SWAP
		   LOOP
		THEN 2DROP 0 ;

\		  $COLON  NameSameQ,SameQ
\		  DW	  QuestionDUP,ZBranch,SAMEQ4
\		  DW	  DoLIT,0,DoDO
\ SAMEQ3	  DW	  OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2
\		  DW	  UNLOOP,CFetch,SWAP,CFetch,GreaterThan
\		  DW	  TwoStar,OnePlus,EXIT
\ SAMEQ2	  DW	  CHARPlus,SWAP,CHARPlus
\		  DW	  DoLOOP,SAMEQ3
\ SAMEQ4	  DW	  TwoDROP,DoLIT,0,EXIT

\		$CODE	NameSameQ,SameQ
\		MOV	CX,BX
\		MOV	AX,DS
\		MOV	ES,AX
\		MOV	DX,SI		;save SI
\		MOV	BX,-1
\		POP	DI
\		POP	SI
\		OR	CX,CX
\		JZ	SAMEQ5
\		REPE CMPSB
\		JL	SAMEQ1
\		JZ	SAMEQ5
\		INC	BX
\ SAMEQ5: 	INC	BX
\ SAMEQ1: 	MOV	SI,DX
\		$NEXT

\   (search-wordlist)	( c-addr u wid -- 0 | xt f 1 | xt f -1)
\		Search word list for a match with the given name.
\		Return execution token and not-compile-only flag and
\		-1 or 1 ( IMMEDIATE) if found. Return 0 if not found.
\
\		format is: wid---->[   a    ]
\				       |
\				       V
\		[   xt'  ][   a'   ][ccbbaann][ggffeedd]...
\			      |
\			      +--------+
\				       V
\		[   xt'' ][   a''  ][ccbbaann][ggffeedd]...
\
\		a, a' etc. point to the cell that contains the name of the
\		word. The length is in the low byte of the cell (little byte
\		for little-endian, big byte for big-endian).
\		Eventually, a''' contains 0 to indicate the end of the wordlist
\		(oldest entry). a=0 indicates an empty wordlist.
\		xt is the xt of the word. aabbccddeedd etc. is the name of
\		the word, packed into cells.

: (search-wordlist)
		ROT >R SWAP DUP 0= IF -16 THROW THEN
				\ attempt to use zero-length string as a name
		>R		\ wid  R: ca1 u
		BEGIN @ 	\ ca2  R: ca1 u
		   DUP 0= IF R> R> 2DROP EXIT THEN	\ not found
		   DUP COUNT [ =mask ] LITERAL AND R@ = \ ca2 ca2+char f
		      IF   R> R@ SWAP DUP >R		\ ca2 ca2+char ca1 u
			   same?			\ ca2 flag
		    \ ELSE DROP -1	\ unnecessary since ca2+char is not 0.
		      THEN
		WHILE cell-		\ pointer to next word in wordlist
		REPEAT
		R> R> 2DROP DUP name>xt SWAP		\ xt ca2
		C@ 2DUP [ =seman ] LITERAL AND 0= 0=	\ xt char xt f
		AND TO specialComp?
		DUP [ =compo ] LITERAL AND 0= SWAP
		[ =immed ] LITERAL AND 0= 2* 1+ ;

\		  $COLON  NameParenSearch_Wordlist,ParenSearch_Wordlist
\		  DW	  ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6
\		  DW	  ToR
\ PSRCH1	  DW	  Fetch
\		  DW	  DUPP,ZBranch,PSRCH9
\		  DW	  DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals
\		  DW	  ZBranch,PSRCH5
\		  DW	  RFrom,RFetch,SWAP,DUPP,ToR,SameQ
\ PSRCH5	  DW	  ZBranch,PSRCH3
\		  DW	  CellMinus,Branch,PSRCH1
\ PSRCH3	  DW	  RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP
\		  DW	  CFetch,TwoDUP,DoLIT,SEMAN,ANDD,ZeroEquals,ZeroEquals
\		  DW	  ANDD,DoTO,AddrSpecialCompQ
\		  DW	  DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP
\		  DW	  DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT
\ PSRCH9	  DW	  RFrom,RFrom,TwoDROP,EXIT
\ PSRCH6	  DW	  DoLIT,-16,THROW

\		$CODE	NameParenSearch_Wordlist,ParenSearch_Wordlist
\		POP	AX	;u
\		POP	DX	;c-addr
\		OR	AX,AX
\		JZ	PSRCH1
\		PUSH	SI
\		MOV	CX,DS
\		MOV	ES,CX
\		SUB	CX,CX
\ PSRCH2: 	MOV	BX,[BX]
\		OR	BX,BX
\		JZ	PSRCH4		; end of wordlist?
\		MOV	CL,[BX]
\		SUB	BX,CELLL	;pointer to nextword
\		AND	CL,MASKK	;max name length = MASKK
\		CMP	CL,AL
\		JNZ	PSRCH2
\		MOV	SI,DX
\		MOV	DI,BX
\		ADD	DI,CELLL+CHARR
\		REPE CMPSB
\		JNZ	PSRCH2
\		POP	SI
\		PUSH	[BX-CELLL]	;xt
\		MOV	AL,0FFh
\		MOV	CL,[BX+CELLL]
\		AND	AL,CL		;test SEMAN = 080h
\		CBW
\		CWD
\		AND	DX,[BX-CELLL]
\		MOV	AddrSpecialCompQ,DX
\		XOR	DX,DX
\		TEST	CL,COMPO
\		JNZ	PSRCH5
\		DEC	DX
\ PSRCH5: 	PUSH	DX
\		TEST	CL,IMMED
\		MOV	BX,-1
\		JZ	PSRCH3
\		NEG	BX
\ PSRCH3: 	$NEXT
\ PSRCH1: 	MOV	BX,-16	;attempt to use zero-length string as a name
\		JMP	THROW
\ PSRCH4: 	POP	SI
\		$NEXT

\   ?call	( xt1 -- xt1 0 | code-addr xt2 )
\		Return xt of the CALLed run-time word if xt starts with machine
\		CALL instruction and leaves the next cell address after the
\		CALL instruction. Otherwise leaves the original xt1 and zero.

: ?call		DUP code@ call-code =
		IF   CELL+ DUP code@ SWAP CELL+ DUP ROT + EXIT THEN
			\ Direct Threaded Code 8086 relative call
		0 ;

\		  $COLON  NameQCall,QCall
\		  DW	  DUPP,CodeFetch,DoLIT,CALLL,Equals,ZBranch,QCALL1
\		  DW	  CELLPlus,DUPP,CodeFetch,SWAP,CELLPlus,DUPP,ROT,Plus
\		  DW	  EXIT
\ QCALL1	  DW	  DoLIT,0,EXIT

\		$CODE	NameQCall,QCall
\		MOV	AX,CS:[BX]
\		CMP	AX,CALLL
\		JE	QCALL1
\		PUSH	BX
\		XOR	BX,BX
\		$NEXT
\ QCALL1: 	ADD	BX,2*CELLL
\		PUSH	BX
\		ADD	BX,CS:[BX-CELLL]
\		$NEXT

\   xt, 	( xt1 -- xt2 )
\		Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and
\		CREATE . Return xt2 of current definition.

: xt,		xhere ALIGNED DUP TO xhere SWAP
		call-code code, 	\ Direct Threaded Code
		xhere CELL+ - code, ;	\ 8086 relative call

\		  $COLON  NamextComma,xtComma
\		  DW	  XHere,ALIGNED,DUPP,DoTO,AddrXHere,SWAP
\		  DW	  DoLIT,CALLL,CodeComma
\		  DW	  XHere,CELLPlus,Minus,CodeComma,EXIT

\		$CODE	NamextComma,xtComma
\		MOV	AX,AddrXHere
\		XCHG	BX,AX
\		INC	BX
\		AND	BX,0FFFEh
\		MOV	WORD PTR CS:[BX],CALLL
\		MOV	CX,BX
\		ADD	CX,2*CELLL
\		MOV	AddrXHere,CX
\		SUB	AX,CX
\		MOV	CS:[BX+CELLL],AX
\		$NEXT

\   doLIT	( -- x )
\		Push an inline literal. The inline literal is at the current
\		value of the fpc, so put it onto the stack and point past it.

\		$CODE	NameDoLIT,DoLIT
\		PUSH	BX
\		LODS	WORD PTR CS:[SI]
\		MOV	BX,AX
\		$NEXT

\   doCONST	( -- x )
\		Run-time routine of CONSTANT and initializable system
\		VARIABLE. When you quote a constant or variable you execute
\		its code, which consists of a call to here, followed by an
\		inline literal. The literal is a constant (for a CONSTANT) or
\		the address at which a VARIABLE's value is stored. Although
\		you come here as the result of a native machine call, you
\		never go back to the return address -- you jump back up a
\		level by continuing at the new fpc value. For 8086, Z80 the
\		inline literal is at the return address stored on the top of
\		the hardware stack.

\		$CODE	NameDoCONST,DoCONST
\		MOV	DI,SP
\		XCHG	BX,[DI]
\		MOV	BX,CS:[BX]
\		$NEXT

\   doVALUE	( -- x )
\		Run-time routine of VALUE. Return the value of VALUE word.
\		This is like an invocation of doCONST for a VARIABLE but
\		instead of returning the address of the variable, we return
\		the value of the variable -- in other words, there is another
\		level of indirection.

\		$CODE	NameDoVALUE,DoVALUE
\		MOV	DI,SP
\		XCHG	BX,[DI]
\		MOV	BX,CS:[BX]
\		MOV	BX,[BX]
\		$NEXT

\   doCREATE	( -- a-addr )
\		Run-time routine of CREATE. For CREATEd words with an
\		associated DOES>, get the address of the CREATEd word's data
\		space and execute the DOES> actions. For CREATEd word without
\		an associated DOES>, return the address of the CREATE'd word's
\		data space. A CREATEd word starts its execution through this
\		routine in exactly the same way as a colon definition uses
\		doLIST. In other words, we come here through a native machine
\		branch.
\
\		Structure of CREATEd word:
\			| call-doCREATE | 0 or DOES> code addr | a-addr |
\
\		The DOES> address holds a native call to doLIST. This routine
\		doesn't alter the fpc. We never come back *here* so we never
\		need to preserve an address that would bring us back *here*.
\
\		Example : myVARIABLE CREATE , DOES> ;
\		56 myVARIABLE JIM
\		JIM \ stacks the address of the data cell that contains 56

: doCREATE		  SWAP		  \ switch BX and top of 8086 stack item
		  DUP CELL+ code@ SWAP code@ ?DUP IF EXECUTE THEN
		  ; COMPILE-ONLY

\		  $COLON  NameDoCREATE,DoCREATE
\		  DW	  SWAP,CELLPlus,DUPP,CodeFetch,SWAP,CodeFetch
\		  DW	  QuestionDUP,ZBranch,DOCREAT1
\		  DW	  EXECUTE
\ DOCREAT1	  DW	  EXIT

\		$CODE	NameDoCREATE,DoCREATE
\		MOV	DI,SP
\		XCHG	BX,[DI]
\		MOV	AX,CS:[BX]
\		MOV	BX,CS:[BX+CELLL]
\		OR	AX,AX
\		JNZ	DOCREAT1
\		$NEXT
\ DOCREAT1:	JMP	AX
\		$ALIGN

\   doTO	( x -- )
\		Run-time routine of TO. Store x at the address in the
\		following cell. The inline literal holds the address
\		to be modified.

\		$CODE	NameDoTO,DoTO
\		LODS	WORD PTR CS:[SI]
\		XCHG	BX,AX
\		MOV	[BX],AX
\		POP	BX
\		$NEXT

\   doUSER	( -- a-addr )
\		Run-time routine of USER. Return address of data space.
\		This is like doCONST but a variable offset is added to the
\		result. By changing the value at AddrUserP (which happens
\		on a taskswap) the whole set of user variables is switched
\		to the set for the new task.

\		$CODE	NameDoUSER,DoUSER
\		MOV	DI,SP
\		XCHG	BX,[DI]
\		MOV	BX,CS:[BX]
\		ADD	BX,AddrUserP
\		$NEXT

\   doLIST	( -- ) ( R: -- nest-sys )
\		Process colon list.
\		The first word of a definition (the xt for the word) is a
\		native machine-code instruction for the target machine. For
\		high-level definitions, that code is emitted by xt, and
\		performs a call to doLIST. doLIST executes the list of xt that
\		make up the definition. The final xt in the definition is EXIT.
\		The address of the first xt to be executed is passed to doLIST
\		in a target-specific way. Two examples:
\		Z80, 8086: native machine call, leaves the return address on
\		the hardware stack pointer, which is used for the data stack.

\		$CODE	NameDoLIST,DoLIST
\		SUB	BP,2
\		MOV	[BP],SI 		;push return stack
\		POP	SI			;new list address
\		$NEXT

\   doLOOP	( -- ) ( R: loop-sys1 -- | loop-sys2 )
\		Run time routine for LOOP.

\		$CODE	NameDoLOOP,DoLOOP
\		INC	WORD PTR [BP]		;increase loop count
\		JO	DoLOOP1 		;?loop end
\		MOV	SI,CS:[SI]		;no, go back
\		$NEXT
\ DoLOOP1:	ADD	SI,CELLL		;yes, continue past the branch offset
\		ADD	BP,2*CELLL		;clear return stack
\		$NEXT

\   do+LOOP	( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\		Run time routine for +LOOP.

\		$CODE	NameDoPLOOP,DoPLOOP
\		ADD	WORD PTR [BP],BX	;increase loop count
\		JO	DoPLOOP1		;?loop end
\		MOV	SI,CS:[SI]		;no, go back
\		POP	BX
\		$NEXT
\ DoPLOOP1:	ADD	SI,CELLL		;yes, continue past the branch offset
\		ADD	BP,2*CELLL		;clear return stack
\		POP	BX
\		$NEXT

\   0branch	( flag -- )
\		Branch if flag is zero.

\		$CODE	NameZBranch,ZBranch
\		OR	BX,BX			;?flag=0
\		JZ	ZBRAN1			;yes, so branch
\		ADD	SI,CELLL		;point IP to next cell
\		POP	BX
\		$NEXT
\ ZBRAN1: 	MOV	SI,CS:[SI]		;IP:=(IP)
\		POP	BX
\		$NEXT

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

\		$CODE	NameBranch,Branch
\		MOV	SI,CS:[SI]		;IP:=(IP)
\		$NEXT

\   rp@ 	( -- a-addr )
\		Push the current RP to the data stack.

\		$CODE	NameRPFetch,RPFetch
\		PUSH	BX
\		MOV	BX,BP
\		$NEXT

\   rp! 	( a-addr -- )
\		Set the return stack pointer.

\		$CODE	NameRPStore,RPStore
\		MOV	BP,BX
\		POP	BX
\		$NEXT

\   sp@ 	( -- a-addr )
\		Push the current data stack pointer.

\		$CODE	NameSPFetch,SPFetch
\		PUSH	BX
\		MOV	BX,SP
\		$NEXT

\   sp! 	( a-addr -- )
\		Set the data stack pointer.

\		$CODE	NameSPStore,SPStore
\		MOV	SP,BX
\		POP	BX
\		$NEXT

\   um+ 	( u1 u2 -- u3 1|0 )
\		Add two unsigned numbers, return the sum and carry.

\		$CODE	NameUMPlus,UMPlus
\		XOR	CX,CX
\		POP	AX
\		ADD	BX,AX
\		PUSH	BX			;push sum
\		RCL	CX,1			;get carry
\		MOV	BX,CX
\		$NEXT

\   code!	( x code-addr -- )
\		Store x at a code space address.

\		$CODE	NameCodeStore,CodeStore
\		POP	CS:[BX]
\		POP	BX
\		$NEXT

\   codeB!	( b code-addr -- )
\		Store byte at a code space address.

\		$CODE	NameCodeBStore,CodeBStore
\		POP	AX
\		MOV	CS:[BX],AL
\		POP	BX
\		$NEXT

\   code@	( code-addr -- x )
\		Push the contents at code space addr to the data stack.

\		$CODE	NameCodeFetch,CodeFetch
\		MOV	BX,CS:[BX]
\		$NEXT

\   codeB@	( code-addr -- b )
\		Push the contents at code space byte addr to the data stack.

\		$CODE	NameCodeBFetch,CodeBFetch
\		MOV	BL,CS:[BX]
\		XOR	BH,BH
\		$NEXT

\   code,	( x -- )
\		Reserve one cell in code space and store x in it.

: code,		xhere DUP CELL+ TO xhere code! ;

\		  $COLON  NameCodeComma,CodeComma
\		  DW	  XHere,DUPP,CELLPlus,DoTO,AddrXHere,CodeStore,EXIT

\		$CODE	NameCodeComma,CodeComma
\		MOV	DI,AddrXHere
\		MOV	CS:[DI],BX
\		ADD	DI,CELLL
\		POP	BX
\		MOV	AddrXHere,DI
\		$NEXT

\ ;;;;;;;;;;;;;;;
\ Standard words - Processor-dependent definitions
\	16 bit Forth for 8086/8
\ ;;;;;;;;;;;;;;;

\   ALIGN	( -- )				\ CORE
\		Align the data space pointer.

: ALIGN		HERE ALIGNED TO HERE ;

\		$COLON	NameALIGNN,ALIGNN
\		DW	HERE,ALIGNED,DoTO,AddrHERE,EXIT

\   ALIGNED	( addr -- a-addr )		\ CORE
\		Align address to the cell boundary.

: ALIGNED	DUP 0 cell-size UM/MOD DROP DUP
		IF cell-size SWAP - THEN + ;

\		  $COLON  NameALIGNED,ALIGNED
\		  DW	  DUPP,DoLIT,0,DoLIT,CELLL
\		  DW	  UMSlashMOD,DROP,DUPP
\		  DW	  ZBranch,ALGN1
\		  DW	  DoLIT,CELLL,SWAP,Minus
\ ALGN1 	  DW	  Plus,EXIT

\		$CODE	NameALIGNED,ALIGNED
\		INC	BX
\		AND	BX,0FFFEh
\		$NEXT

\   CELLS	( n1 -- n2 )			\ CORE
\		Calculate number of address units for n1 cells.

\ : CELLS		cell-size * ;	\ slow, very portable
: CELLS		2* ;		\ fast, must be redefined for each system

\		  $COLON  NameCELLS,CELLS
\		  DW	  TwoStar,EXIT

\		$CODE	NameCELLS,CELLS
\		SHL	BX,1
\		$NEXT

\   CHARS	( n1 -- n2 )			\ CORE
\		Calculate number of address units for n1 characters.

\ : CHARS		char-size * ;	\ slow, very portable
: CHARS		;		\ fast, must be redefined for each system

\	       $COLON  NameCHARS,CHARS
\	       DW      EXIT

\   1chars/	( n1 -- n2 )
\		Calculate number of chars for n1 address units.

\ : 1chars/		1 CHARS / ;	\ slow, very portable
: 1chars/		;		\ fast, must be redefined for each system

\		$COLON	NameOneCharsSlash,OneCharsSlash
\		DW	EXIT

\   !		( x a-addr -- ) 		\ CORE
\		Store x at a aligned address.

\		$CODE	NameStore,Store
\		POP	[BX]
\		POP	BX
\		$NEXT

\   0<		( n -- flag )			\ CORE
\		Return true if n is negative.

\		$CODE	NameZeroLess,ZeroLess
\		MOV	AX,BX
\		CWD		;sign extend
\		MOV	BX,DX
\		$NEXT

\   0=		( x -- flag )			\ CORE
\		Return true if x is zero.

\		$CODE	NameZeroEquals,ZeroEquals
\		OR	BX,BX
\		MOV	BX,TRUEE
\		JZ	ZEQUAL1
\		INC	BX
\ ZEQUAL1:	$NEXT

\   2*		( x1 -- x2 )			\ CORE
\		Bit-shift left, filling the least significant bit with 0.

\		$CODE	NameTwoStar,TwoStar
\		SHL	BX,1
\		$NEXT

\   2/		( x1 -- x2 )			\ CORE
\		Bit-shift right, leaving the most significant bit unchanged.

\		$CODE	NameTwoSlash,TwoSlash
\		SAR	BX,1
\		$NEXT

\   >R		( x -- ) ( R: -- x )		\ CORE
\		Move top of the data stack item to the return stack.

\		$CODE	NameToR,ToR
\		SUB	BP,CELLL		;adjust RP
\		MOV	[BP],BX
\		POP	BX
\		$NEXT

\   @		( a-addr -- x ) 		\ CORE
\		Push the contents at a-addr to the data stack.

\		$CODE	NameFetch,Fetch
\		MOV	BX,[BX]
\		$NEXT

\   AND 	( x1 x2 -- x3 ) 		\ CORE
\		Bitwise AND.

\		$CODE	NameANDD,ANDD
\		POP	AX
\		AND	BX,AX
\		$NEXT

\   C!		( char c-addr -- )		\ CORE
\		Store char at c-addr.

\		$CODE	NameCStore,CStore
\		POP	AX
\		MOV	[BX],AL
\		POP	BX
\		$NEXT

\   C@		( c-addr -- char )		\ CORE
\		Fetch the character stored at c-addr.

\		$CODE	NameCFetch,CFetch
\		MOV	BL,[BX]
\		XOR	BH,BH
\		$NEXT

\   DROP	( x -- )			\ CORE
\		Discard top stack item.

\		$CODE	NameDROP,DROP
\		POP	BX
\		$NEXT

\   DUP 	( x -- x x )			\ CORE
\		Duplicate the top stack item.

\		$CODE	NameDUPP,DUPP
\		PUSH	BX
\		$NEXT

\   EXECUTE	( i*x xt -- j*x )		\ CORE
\		Perform the semantics indentified by execution token, xt.

\		$CODE	NameEXECUTE,EXECUTE
\		MOV	AX,BX
\		POP	BX
\		JMP	AX			;jump to the code address
\		$ALIGN

\   EXIT	( -- ) ( R: nest-sys -- )	\ CORE
\		Return control to the calling definition.

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

\   MOVE	( addr1 addr2 u -- )		\ CORE
\		Copy u address units from addr1 to addr2 if u is greater
\		than zero. This word is CODE defined since no other Standard
\		words can handle address unit directly.

\		$CODE	NameMOVE,MOVE
\		POP	DI
\		POP	DX
\		OR	BX,BX
\		JZ	MOVE2
\		MOV	CX,BX
\		XCHG	DX,SI			;save SI
\		MOV	AX,DS
\		MOV	ES,AX			;set ES same as DS
\		CMP	SI,DI
\		JC	MOVE1
\		REP MOVSB
\		MOV	SI,DX
\ MOVE2:		POP	BX
\		$NEXT
\ MOVE1:		STD
\		ADD	DI,CX
\		DEC	DI
\		ADD	SI,CX
\		DEC	SI
\		REP MOVSB
\		CLD
\		MOV	SI,DX
\		POP	BX
\		$NEXT

\   OR		( x1 x2 -- x3 ) 		\ CORE
\		Return bitwise inclusive-or of x1 with x2.

\		$CODE	NameORR,ORR
\		POP	AX
\		OR	BX,AX
\		$NEXT

\   OVER	( x1 x2 -- x1 x2 x1 )		\ CORE
\		Copy second stack item to top of the stack.

\		$CODE	NameOVER,OVER
\		MOV	DI,SP
\		PUSH	BX
\		MOV	BX,[DI]
\		$NEXT

\   R>		( -- x ) ( R: x -- )		\ CORE
\		Move x from the return stack to the data stack.

\		$CODE	NameRFrom,RFrom
\		PUSH	BX
\		MOV	BX,[BP]
\		ADD	BP,CELLL		;adjust RP
\		$NEXT

\   R@		( -- x ) ( R: x -- x )		\ CORE
\		Copy top of return stack to the data stack.

\		$CODE	NameRFetch,RFetch
\		PUSH	BX
\		MOV	BX,[BP]
\		$NEXT

\   SWAP	( x1 x2 -- x2 x1 )		\ CORE
\		Exchange top two stack items.

\		$CODE	NameSWAP,SWAP
\		MOV	DI,SP
\		XCHG	BX,[DI]
\		$NEXT

\   XOR 	( x1 x2 -- x3 ) 		\ CORE
\		Bitwise exclusive OR.

\		$CODE	NameXORR,XORR
\		POP	AX
\		XOR	BX,AX
\		$NEXT

\ ;;;;;;;;;;;;;;;
\ System constants and variables
\ ;;;;;;;;;;;;;;;

\   #order0	( -- a-addr )
\		Start address of default search order.

\		$CONST	NameNumberOrder0,NumberOrder0,AddrNumberOrder0

\   'ekey?      ( -- a-addr )
\		Execution vector of EKEY?.

\		$VALUE	NameTickEKEYQ,TickEKEYQ,AddrTickEKEYQ

\   'ekey       ( -- a-addr )
\		Execution vector of EKEY.

\		$VALUE	NameTickEKEY,TickEKEY,AddrTickEKEY

\   'emit?      ( -- a-addr )
\		Execution vector of EMIT?.

\		$VALUE	NameTickEMITQ,TickEMITQ,AddrTickEMITQ

\   'emit       ( -- a-addr )
\		Execution vector of EMIT.

\		$VALUE	NameTickEMIT,TickEMIT,AddrTickEMIT

\   'init-i/o   ( -- a-addr )
\		Execution vector to initialize input/output devices.

\		$VALUE	NameTickINIT_IO,TickINIT_IO,AddrTickINIT_IO

\   'prompt     ( -- a-addr )
\		Execution vector of '.prompt'.

\		$VALUE	NameTickPrompt,TickPrompt,AddrTickPrompt

\   'boot       ( -- a-addr )
\		Execution vector of COLD.

\		$VALUE	NameTickBoot,TickBoot,AddrTickBoot

\   SOURCE-ID	( -- 0 | -1 )			\ CORE EXT
\		Identify the input source. -1 for string (via EVALUATE) and
\		0 for user input device.

\		$VALUE	NameSOURCE_ID,SOURCE_ID,AddrSOURCE_ID

\   HERE	( -- addr )			\ CORE
\		Return data space pointer.

\		$VALUE	NameHERE,HERE,AddrHERE

\   xhere	( -- code-addr )
\		Return next available code space address.

\		$VALUE	NameXHere,XHere,AddrXHere

\   'doWord     ( -- a-addr )
\		Execution vectors for 'interpret'.

\		$CONST	NameTickDoWord,TickDoWord,AddrTickDoWord

\   BASE	( -- a-addr )			\ CORE
\		Return the address of the radix base for numeric I/O.

\		$CONST	NameBASE,BASE,AddrBASE

\   THROWMsgTbl ( -- a-addr )			\ CORE
\		Return the address of the THROW message table.

\		$CONST	NameTHROWMsgTbl,THROWMsgTbl,AddrTHROWMsgTbl

\   memTop	( -- a-addr )
\		Top of free memory.

\		$VALUE	NameMemTop,MemTop,AddrMemTop

\   bal 	( -- n )
\		Return the depth of control-flow stack.

\		$VALUE	NameBal,Bal,AddrBal

\   notNONAME?	( -- f )
\		Used by ';' whether to do 'linkLast' or not

\		$VALUE	NameNotNONAMEQ,NotNONAMEQ,AddrNotNONAMEQ

\   rakeVar	( -- a-addr )
\		Used by 'rake' to gather LEAVE.

\		$CONST	NameRakeVar,RakeVar,AddrRakeVar

\   #order	( -- a-addr )
\		Hold the search order stack depth.

\		$CONST	NameNumberOrder,NumberOrder,AddrNumberOrder

\   current	( -- a-addr )
\		Point to the wordlist to be extended.

\		$CONST	NameCurrent,Current,AddrCurrent

\   FORTH-WORDLIST   ( -- wid ) 		\ SEARCH
\		Return wid of Forth wordlist.

\		$CONST	NameFORTH_WORDLIST,FORTH_WORDLIST,AddrFORTH_WORDLIST

\   NONSTANDARD-WORDLIST   ( -- wid )
\		Return wid of non-standard wordlist.

\		$CONST	NameNONSTANDARD_WORDLIST,NONSTANDARD_WORDLIST,AddrNONSTANDARD_WORDLIST

\   envQList	( -- wid )
\		Return wid of ENVIRONMENT? string list. Never put this wid in
\		search-order. It should be used only by SET-CURRENT to add new
\		environment query string after addition of a complete wordset.

\		$CONST	NameEnvQList,EnvQList,AddrEnvQList

\   userP	( -- a-addr )
\		Return address of USER variable area of current task.

\		$CONST	NameUserP,UserP,AddrUserP

\   SystemTask	( -- a-addr )
\		Return system task's tid.

\		$CONST	NameSystemTask,SystemTask,SysTask

\   follower	( -- a-addr )
\		Point next task's 'status' USER variable.

\		$USER	NameFollower,Follower,SysFollower-SysUserP

\   status	( -- a-addr )
\		Status of current task. Point 'pass' or 'wake'.

\		$USER	NameStatus,Status,SysStatus-SysUserP

\   stackTop	( -- a-addr )
\		Store current task's top of stack position.

\		$USER	NameStackTop,StackTop,SysStackTop-SysUserP

\   throwFrame	( -- a-addr )
\		THROW frame for CATCH and THROW need to be saved for eack task.

\		$USER	NameThrowFrame,ThrowFrame,SysThrowFrame-SysUserP

\   taskName	( -- a-addr )
\		Current task's task ID.

\		$USER	NameTaskName,TaskName,SysTaskName-SysUserP

\   user1	( -- a-addr )
\		One free USER variable for each task.

\		$USER	NameUser1,User1,SysUser1-SysUserP

\ ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be
\ EXECUTEd. This wordlist is completely hidden to Forth system except
\ ENVIRONMENT? .

\ CPU:
\		NOP
\		CALL	DoLIST
\		DW	DoLIT,CPUStr,COUNT,EXIT

\ Model:
\		NOP
\		CALL	DoLIST
\		DW	DoLIT,ModelStr,COUNT,EXIT

\ Version:
\		NOP
\		CALL	DoLIST
\		DW	DoLIT,VersionStr,COUNT,EXIT

\ SlashCOUNTED_STRING:
\		NOP
\		CALL	DoCONST
\		DW	MaxChar

\ SlashHOLD:
\		NOP
\		CALL	DoCONST
\		DW	PADSize

\ SlashPAD:
\		NOP
\		CALL	DoCONST
\		DW	PADSize

\ ADDRESS_UNIT_BITS:
\		NOP
\		CALL	DoCONST
\		DW	8

\ CORE:
\		NOP
\		CALL	DoCONST
\		DW	TRUEE

\ FLOORED:
\		NOP
\		CALL	DoCONST
\		DW	TRUEE

\ MAX_CHAR:
\		NOP
\		CALL	DoCONST
\		DW	MaxChar 	;max value of character set

\ MAX_D:
\		NOP
\		CALL	DoLIST
\		DW	DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT

\ MAX_N:
\		NOP
\		CALL	DoCONST
\		DW	MaxSigned

\ MAX_U:
\		NOP
\		CALL	DoCONST
\		DW	MaxUnsigned

\ MAX_UD:
\		NOP
\		CALL	DoLIST
\		DW	MAX_U,MAX_U,EXIT

\ RETURN_STACK_CELLS:
\		NOP
\		CALL	DoCONST
\		DW	RTCells

\ STACK_CELLS:
\		NOP
\		CALL	DoCONST
\		DW	DTCells

\ EXCEPTION:
\		NOP
\		CALL	DoCONST
\		DW	TRUEE

\ EXCEPTION_EXT:
\		NOP
\		CALL	DoCONST
\		DW	TRUEE

\ WORDLISTS:
\		NOP
\		CALL	DoCONST
\		DW	OrderDepth

\ ;;;;;;;;;;;;;;;
\ Non-Standard words - Colon definitions
\ ;;;;;;;;;;;;;;;

\   (')         ( "<spaces>name" -- xt 1 | xt -1 )
\		Parse a name, find it and return execution token and
\		-1 or 1 ( IMMEDIATE) if found

: (')		PARSE-WORD search-word ?DUP IF NIP EXIT THEN
		errWord 2!	\ if not found error
		-13 THROW ;	\ undefined word

\		$COLON	NameParenTick,ParenTick
\		DW	PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1
\		DW	NIP,EXIT
\ PTICK1		DW	DoLIT,AddrErrWord,TwoStore,DoLIT,-13,THROW

\   (d.)	( d -- c-addr u )
\		Convert a double number to a string.

: (d.)		SWAP OVER  DUP 0< IF  DNEGATE  THEN
		<#  #S ROT SIGN  #> ;

\		$COLON	NameParenDDot,ParenDDot
\		DW	SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1
\		DW	DNEGATE
\ PARDD1		DW	LessNumberSign,NumberSignS,ROT
\		DW	SIGN,NumberSignGreater,EXIT

\   .ok 	( -- )
\		Display 'ok'.

: .ok		." okay" ;

\		$COLON	NameDotOK,DotOK
\		DW	DoLIT,DotOKStr
\		DW	COUNT,TYPEE,EXIT

\   .prompt	    ( -- )
\		Disply Forth prompt. This word is vectored.

: .prompt		'prompt EXECUTE ;

\		$COLON	NameDotOK,DotPrompt
\		DW	TickPrompt,EXECUTE,EXIT

\   0		( -- 0 )
\		Return zero.

\		$CONST	NameZero,Zero,0

\   1		( -- 1 )
\		Return one.

\		$CONST	NameOne,One,1

\   -1		( -- -1 )
\		Return -1.

\		$CONST	NameMinusOne,MinusOne,-1

\   abort"msg   ( -- a-addr )
\		Abort" error message string address.

\		$CONST	NameAbortQMsg,AbortQMsg,AddrAbortQMsg

\   bal+	( -- )
\		Increase bal by 1.

: bal+		bal 1+ TO bal ;

\		  $COLON  4,'bal+',BalPlus,_SLINK
\		  DW	  Bal,OnePlus,DoTO,AddrBal,EXIT

\		$CODE	NameBalPlus,BalPlus
\		INC	AddrBal
\		$NEXT

\   bal-	( -- )
\		Decrease bal by 1.

: bal-		bal 1- TO bal ;

\		  $COLON  NameBalMinus,BalMinus
\		  DW	  Bal,OneMinus,DoTO,AddrBal,EXIT

\		$CODE	NameBalMinus,BalMinus
\		DEC	AddrBal
\		$NEXT

\   cell-	( a-addr1 -- a-addr2 )
\		Return previous aligned cell address.

: cell-		[ cell-size NEGATE ] LITERAL + ;

\		 $COLON  NameCellMinus,CellMinus
\		 DW	 DoLIT,0-CELLL,Plus,EXIT

\		$CODE	NameCellMinus,CellMinus
\		SUB	BX,CELLL
\		$NEXT

\   COMPILE-ONLY   ( -- )
\		Make the most recent definition an compile-only word.

: COMPILE-ONLY	lastName [ =compo ] LITERAL OVER @ OR SWAP ! ;

\		$COLON	NameCOMPILE_ONLY,COMPILE_ONLY
\		DW	LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT

\   doDO	( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )
\		Run-time funtion of DO.

: doDO		>R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;

\		  $COLON  NameDoDO,DoDO
\		  DW	  ToR,DoLIT,MaxNegative,Plus,RFrom
\		  DW	  OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT

\		$CODE	NameDoDO,DoDO
\		SUB	BP,2*CELLL
\		POP	AX
\		ADD	AX,MaxNegative
\		MOV	[BP+CELLL],AX
\		SUB	BX,AX
\		MOV	[BP],BX
\		POP	BX
\		$NEXT

\   errWord	( -- a-addr )
\		Last found word. To be used to display the word causing error.

\		$CONST	NameErrWord,ErrWord,AddrErrWord

\   head,	( xt "<spaces>name" -- )
\		Parse a word and build a dictionary entry.

: head,		>R  PARSE-WORD DUP 0=
		IF errWord 2! -16 THROW THEN
				\ attempt to use zero-length string as a name
		DUP =mask > IF -19 THROW THEN	\ definition name too long
		2DUP GET-CURRENT SEARCH-WORDLIST  \ name exist?
		IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined
		ALIGN R@ ,			\ align and store xt
		GET-CURRENT @ , 		\ build wordlist link
		HERE DUP >R pack" ALIGNED TO HERE \ pack the name in name space
		R> DUP R> cell- code!		\ store name addr in code space
		TO lastName ;

\		$COLON	NameHeadComma,HeadComma
\		DW	ToR,PARSE_WORD,DUPP,ZBranch,HEADC1
\		DW	DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3
\		DW	DoLIT,-19,THROW
\ HEADC3		DW	TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2
\		DW	DROP
\		DW	DoLIT,HEADCstr
\		DW	COUNT,TYPEE,TwoDUP,TYPEE,SPACE
\ HEADC2		DW	ALIGNN,RFetch,Comma
\		DW	GET_CURRENT,Fetch,Comma
\		DW	HERE,DUPP,ToR,PackQuote,ALIGNED,DoTO,AddrHERE
\		DW	RFrom,DUPP,RFrom,CellMinus,CodeStore
\		DW	DoTO,AddrLastName,EXIT
\ HEADC1		DW	DoLIT,AddrErrWord,TwoStore,DoLIT,-16,THROW

\   hld 	( -- a-addr )
\		Hold a pointer in building a numeric output string.

\		$CONST	NameHLD,HLD,AddrHLD

\   interpret	( i*x -- j*x )
\		Intrepret input string.

: interpret	BEGIN  DEPTH 0< IF -4 THROW THEN	\ stack underflow
		       PARSE-WORD DUP
		WHILE  2DUP errWord 2!
		       search-word	    \ ca u 0 | xt f -1 | xt f 1
		       DUP IF
			 SWAP STATE @ OR 0= \ compile-only in interpretation
			 IF -14 THROW THEN  \ interpreting a compile-only word
		       THEN
		       1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE
		REPEAT 2DROP ;

\		$COLON	NameInterpret,Interpret
\ INTERP1 	DW	DEPTH,ZeroLess,ZBranch,INTERP2
\		DW	DoLIT,-4,THROW
\ INTERP2 	DW	PARSE_WORD,DUPP,ZBranch,INTERP3
\		DW	TwoDUP,DoLIT,AddrErrWord,TwoStore
\		DW	Search_word,DUPP,ZBranch,INTERP5
\		DW	SWAP,DoLIT,AddrSTATE,Fetch,ORR,ZBranch,INTERP4
\ INTERP5 	DW	OnePlus,TwoStar,DoLIT,AddrSTATE,Fetch,OnePlus,Plus,CELLS
\		DW	DoLIT,AddrTickDoWord,Plus,Fetch,EXECUTE
\		DW	Branch,INTERP1
\ INTERP3 	DW	TwoDROP,EXIT
\ INTERP4 	DW	DoLIT,-14,THROW

\   optiCOMPILE, ( xt -- )
\		Optimized COMPILE, . Reduce doLIST ... EXIT sequence if
\		xt is COLON definition which contains less than two words.

: optiCOMPILE,
		DUP ?call ['] doLIST = IF
		    DUP code@ ['] EXIT = IF         \ if first word is EXIT
		      2DROP EXIT THEN
		    DUP CELL+ code@ ['] EXIT = IF   \ if second word is EXIT
		      code@ DUP ['] doLIT XOR   \ make sure it is not literal
		      IF SWAP THEN THEN
		THEN DROP COMPILE, ;

\		  $COLON  NameOptiCOMPILEComma,OptiCOMPILEComma
\		  DW	  DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2
\		  DW	  DUPP,CodeFetch,DoLIT,EXIT,Equals,ZBranch,OPTC1
\		  DW	  TwoDROP,EXIT
\ OPTC1 	  DW	  DUPP,CELLPlus,CodeFetch,DoLIT,EXIT,Equals
\		  DW	  ZBranch,OPTC2
\		  DW	  CodeFetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2
\		  DW	  SWAP
\ OPTC2 	  DW	  DROP,COMPILEComma,EXIT

\		$CODE	NameOptiCOMPILEComma,OptiCOMPILEComma
\		CMP	WORD PTR CS:[BX],CALLL
\		JNE	OPTC1
\		MOV	AX,CS:[BX+CELLL]
\		ADD	AX,BX
\		ADD	AX,2*CELLL
\		CMP	AX,OFFSET DoLIST
\		JNE	OPTC1
\		MOV	DX,OFFSET EXIT
\		MOV	AX,CS:[BX+2*CELLL]
\		CMP	AX,DX
\		JE	OPTC2
\		CMP	DX,CS:[BX+3*CELLL]
\		JNE	OPTC1
\		CMP	AX,OFFSET DoLIT
\		JE	OPTC1
\		MOV	BX,AX
\ OPTC1:		JMP	COMPILEComma
\ OPTC2:		POP	BX
\		$NEXT

\   singleOnly	( c-addr u -- x )
\		Handle the word not found in the search-order. If the string
\		is legal, leave a single cell number in interpretation state.

: singleOnly
		0 DUP 2SWAP OVER C@ [CHAR] -
		= DUP >R IF 1 /STRING THEN
		>NUMBER IF -13 THROW THEN	\ undefined word
		2DROP R> IF NEGATE THEN ;

\		$COLON	NameSingleOnly,SingleOnly
\		DW	DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\		DW	Equals,DUPP,ToR,ZBranch,SINGLEO4
\		DW	DoLIT,1,SlashSTRING
\ SINGLEO4	DW	ToNUMBER,ZBranch,SINGLEO1
\		DW	DoLIT,-13,THROW
\ SINGLEO1	DW	TwoDROP,RFrom,ZBranch,SINGLEO2
\		DW	NEGATE
\ SINGLEO2	DW	EXIT 
\   singleOnly, ( c-addr u -- )
\		Handle the word not found in the search-order. Compile a
\		single cell number in compilation state.

: singleOnly,
		singleOnly POSTPONE LITERAL ;

\		$COLON	NameSingleOnlyComma,SingleOnlyComma
\		DW	SingleOnly,LITERAL,EXIT

\   (doubleAlso) ( c-addr u -- x 1 | x x 2 )
\		If the string is legal, leave a single or double cell number
\		and size of the number.

: (doubleAlso)
		0 DUP 2SWAP OVER C@ [CHAR] -
		= DUP >R IF 1 /STRING THEN
		>NUMBER ?DUP
		IF   1- IF -13 THROW THEN     \ more than one char is remained
		     DUP C@ [CHAR] . XOR      \ last char is not '.'
		     IF -13 THROW THEN	      \ undefined word
		     R> IF DNEGATE THEN
		     2 EXIT		  THEN
		2DROP R> IF NEGATE THEN       \ single number
		1 ;

\		$COLON	NameParenDoubleAlso,ParenDoubleAlso
\		DW	DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'
\		DW	Equals,DUPP,ToR,ZBranch,DOUBLEA1
\		DW	DoLIT,1,SlashSTRING
\ DOUBLEA1	DW	ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4
\		DW	OneMinus,ZBranch,DOUBLEA3
\ DOUBLEA2	DW	DoLIT,-13,THROW
\ DOUBLEA3	DW	CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2
\		DW	RFrom,ZBranch,DOUBLEA5
\		DW	DNEGATE
\ DOUBLEA5	DW	DoLIT,2,EXIT
\ DOUBLEA4	DW	TwoDROP,RFrom,ZBranch,DOUBLEA6
\		DW	NEGATE
\ DOUBLEA6	DW	DoLIT,1,EXIT

\   doubleAlso	( c-addr u -- x | x x )
\		Handle the word not found in the search-order. If the string
\		is legal, leave a single or double cell number in
\		interpretation state.

: doubleAlso
		(doubleAlso) DROP ;

\		$COLON	NameDoubleAlso,DoubleAlso
\		DW	ParenDoubleAlso,DROP,EXIT

\   doubleAlso, ( c-addr u -- )
\		Handle the word not found in the search-order. If the string
\		is legal, compile a single or double cell number in
\		compilation state.

: doubleAlso,
		(doubleAlso) 1- IF SWAP POSTPONE LITERAL THEN POSTPONE LITERAL ;

\		$COLON	NameDoubleAlsoComma,DoubleAlsoComma
\		DW	ParenDoubleAlso,OneMinus,ZBranch,DOUBC1
\		DW	SWAP,LITERAL
\ DOUBC1		DW	LITERAL,EXIT

\   -.		( -- )
\		You don't need this word unless you care that '-.' returns
\		double cell number 0. Catching illegal number '-.' in this way
\		is easier than make 'interpret' catch this exception.

: -.		-13 THROW ; IMMEDIATE	\ undefined word

\		$COLON	NameMinusDot,MinusDot
\		DW	DoLIT,-13,THROW

\   lastName	( -- c-addr )
\		Return the address of the last definition name.

\		$VALUE	NameLastName,LastName,AddrLastName

\   linkLast	( -- )
\		Link the word being defined to the current wordlist.
\		Do nothing if the last definition is made by :NONAME .

: linkLast	lastName  GET-CURRENT ! ;

\		  $COLON  NameLinkLast,LinkLast
\		  DW	  LastName,GET_CURRENT,Store,EXIT

\		$CODE	NameLinkLast,LinkLast
\		MOV	AX,AddrLastName
\		MOV	DI,AddrCurrent
\		MOV	[DI],AX
\		$NEXT

\   name>xt	( c-addr -- xt )
\		Return execution token using counted string at c-addr.

: name>xt		cell- cell- @ ;

\		  $COLON  NameNameToXT,NameToXT
\		  DW	  CellMinus,CellMinus,Fetch,EXIT

\		$CODE	NameNameToXT,NameToXT
\		MOV	BX,[BX-2*CELLL]
\		$NEXT

\   pack"       ( c-addr u a-addr -- a-addr2 )
\		Place a string c-addr u at a-addr and gives the next
\		cell-aligned address. Fill the rest of the last cell with
\		null character.

: pack"		2DUP SWAP CHARS + CHAR+ DUP >R  \ ca u aa aa+u+1
		ALIGNED cell- 0 SWAP !		\ fill 0 at the end of string
		2DUP C! CHAR+ SWAP		\ c-addr a-addr+1 u
		CHARS MOVE R> ALIGNED ;

\		  $COLON  5,'pack"',PackQuote,_SLINK
\		  DW	  TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR
\		  DW	  ALIGNED,CellMinus,Zero,SWAP,Store
\		  DW	  TwoDUP,CStore,CHARPlus,SWAP
\		  DW	  CHARS,MOVE,RFrom,ALIGNED,EXIT

\		$CODE	NamePackQuote,PackQuote
\		MOV	DI,BX
\		MOV	DX,SI
\		MOV	AX,DS
\		MOV	ES,AX
\		POP	CX
\		POP	SI
\		MOV	BYTE PTR [DI],CL
\		INC	DI
\		REP MOVSB
\		TEST	DI,1		;odd address?
\		JZ	PACKQ2
\		MOV	BYTE PTR [DI],0
\		INC	DI
\ PACKQ2: 	MOV	BX,DI
\		MOV	SI,DX
\		$NEXT

\   PARSE-WORD	( "<spaces>ccc<space>" -- c-addr u )
\		Skip leading spaces and parse a word. Return the name.

: PARSE-WORD	BL skipPARSE ;

\		  $COLON  NamePARSE_WORD,PARSE_WORD
\		  DW	  DoLIT,' ',SkipPARSE,EXIT

\		$CODE	NamePARSE_WORD,PARSE_WORD
\		PUSH	BX
\		MOV	BX,' '
\		JMP	SkipPARSE
\		$ALIGN

\   pipe	( -- ) ( R: xt -- )
\		Connect most recently defined word to code following DOES>.
\		Structure of CREATEd word:
\		|compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |

: pipe		lastName name>xt ?call DUP IF	\ code-addr xt2
		    ['] doCREATE = IF
		    R> SWAP code!	\ change DOES> code of CREATEd word
		    EXIT
		THEN THEN
		-32 THROW	\ invalid name argument, no-CREATEd last name
		; COMPILE-ONLY

\		$COLON	NamePipe,Pipe
\		DW	LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1
\		DW	DoLIT,DoCREATE,Equals,ZBranch,PIPE1
\		DW	RFrom,SWAP,CodeStore,EXIT
\ PIPE1		DW	DoLIT,-32,THROW

\   skipPARSE	( char "<chars>ccc<char>" -- c-addr u )
\		Skip leading chars and parse a word using char as a
\		delimeter. Return the name.

: skipPARSE
		>R SOURCE >IN @ /STRING    \ c_addr u  R: char
		DUP IF
		   BEGIN  OVER C@ R@ =
		   WHILE  1- SWAP CHAR+ SWAP DUP 0=
		   UNTIL  R> DROP EXIT
		   ELSE THEN
		   DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT
		THEN R> DROP ;

\		  $COLON  NameSkipPARSE,SkipPARSE
\		  DW	  ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING
\		  DW	  DUPP,ZBranch,SKPAR1
\ SKPAR2	  DW	  OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3
\		  DW	  OneMinus,SWAP,CHARPlus,SWAP
\		  DW	  DUPP,ZeroEquals,ZBranch,SKPAR2
\		  DW	  RFrom,DROP,EXIT
\ SKPAR3	  DW	  DROP,SOURCE,DROP,Minus,OneCharsSlash
\		  DW	  DoLIT,AddrToIN,Store,RFrom,PARSE,EXIT
\ SKPAR1	  DW	  RFrom,DROP,EXIT

\		$CODE	NameSkipPARSE,SkipPARSE
\		MOV	AH,BL
\		MOV	DX,SI
\		MOV	SI,AddrSourceVar+CELLL
\		MOV	BX,AddrSourceVar
\		MOV	CX,AddrToIN
\		ADD	SI,CX
\		SUB	BX,CX
\		MOV	CX,SI
\		OR	BX,BX
\		JZ	PARSW1
\ PARSW5: 	LODSB
\		CMP	AL,AH
\		JNE	PARSW4
\		DEC	BX
\		OR	BX,BX
\		JNZ	PARSW5
\		MOV	AX,AddrSourceVar
\		MOV	AddrToIN,AX
\ PARSW1: 	PUSH	SI
\		MOV	SI,DX
\		$NEXT
\ PARSW4: 	DEC	SI
\		SUB	SI,AddrSourceVar+CELLL
\		MOV	AddrToIN,SI
\		XOR	BX,BX
\		MOV	BL,AH
\		MOV	SI,DX
\		JMP	PARSE
\		$ALIGN

\   specialComp? ( -- xt|0 )
\		Return xt for special compilation semantics of the last found
\		word. Return 0 if there is no special compilation action.

\		$VALUE	NameSpecialCompQ,SpecialCompQ,AddrSpecialCompQ

\   rake	( C: do-sys -- )
\		Gathers LEAVEs.

: rake		DUP code, rakeVar @
		BEGIN  2DUP U<
		WHILE  DUP code@ xhere ROT code!
		REPEAT rakeVar ! DROP
		?DUP IF 		\ check for ?DO
		   1 bal+ POSTPONE THEN \ orig type is 1
		THEN bal- ; COMPILE-ONLY

\		$COLON	Namerake,rake
\		DW	DUPP,CodeComma,DoLIT,AddrRakeVar,Fetch
\ RAKE1		DW	TwoDUP,ULess,ZBranch,RAKE2
\		DW	DUPP,CodeFetch,XHere,ROT,CodeStore,Branch,RAKE1
\ RAKE2		DW	DoLIT,AddrRakeVar,Store,DROP
\		DW	QuestionDUP,ZBranch,RAKE3
\		DW	One,BalPlus,THENN
\ RAKE3		DW	BalMinus,EXIT

\   rp0 	( -- a-addr )
\		Pointer to bottom of the return stack.

: rp0		userP @ CELL+ CELL+ @ ;

\		$COLON	NameRPZero,RPZero
\		DW	DoLIT,AddrUserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT

\   search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)
\		Search dictionary for a match with the given name. Return
\		execution token, not-compile-only flag and -1 or 1
\		( IMMEDIATE) if found; c-addr u 0 if not.

: search-word
		#order @ DUP			\ not found if #order is 0
		IF 0
		   DO 2DUP			\ ca u ca u
		      I CELLS #order CELL+ + @	\ ca u ca u wid
		      (search-wordlist) 	\ ca u; 0 | w f 1 | w f -1
		      ?DUP IF			\ ca u; 0 | w f 1 | w f -1
			 >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1
		      THEN			\ ca u
		   LOOP 0			\ ca u 0
		THEN ;

\		$COLON	NameSearch_word,Search_word
\		DW	NumberOrder,Fetch,DUPP,ZBranch,SEARCH1
\		DW	DoLIT,0,DoDO
\ SEARCH2 	DW	TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch
\		DW	ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3
\		DW	ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT
\ SEARCH3 	DW	DoLOOP,SEARCH2
\		DW	DoLIT,0
\ SEARCH1 	DW	EXIT

\   sourceVar	( -- a-addr )
\		Hold the current count and address of the terminal input buffer.

\		$CONST	NameSourceVar,SourceVar,AddrSourceVar

\   sp0 	( -- a-addr )
\		Pointer to bottom of the data stack.

: sp0		userP @ CELL+ @ ;

\		$COLON	NameSPZero,SPZero
\		DW	DoLIT,AddrUserP,Fetch,CELLPlus,Fetch,EXIT

\ ;;;;;;;;;;;;;;;
\ Essential Standard words - Colon definitions
\ ;;;;;;;;;;;;;;;

\   #		( ud1 -- ud2 )			\ CORE
\		Extract one digit from ud1 and append the digit to
\		pictured numeric output string. ( ud2 = ud1 / BASE )

: # 		0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP
		9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +
		[ CHAR 0 ] LITERAL + HOLD R> ;

\		  $COLON  NameNumberSign,NumberSign
\		  DW	  DoLIT,0,DoLITFetch,AddrBASE,UMSlashMOD,ToR
\		  DW	  DoLITFetch,AddrBASE,UMSlashMOD,SWAP
\		  DW	  DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus
\		  DW	  DoLIT,'0',Plus,HOLD,RFrom,EXIT

\		$CODE	NameNumberSign,NumberSign
\		XOR	DX,DX
\		MOV	AX,BX
\		MOV	CX,AddrBASE
\		DIV	CX		;0:TOS / BASE
\		MOV	BX,AX		;quotient
\		POP	AX
\		DIV	CX
\		PUSH	AX		;BX:AX = ud2
\		MOV	AL,DL
\		CMP	AL,9
\		JBE	NUMSN1
\		ADD	AL,'A'-'9'-1
\ NUMSN1: 	ADD	AL,'0'
\		MOV	DI,AddrHLD
\		DEC	DI
\		MOV	AddrHLD,DI
\		MOV	[DI],AL
\		$NEXT

\   #>		( xd -- c-addr u )		\ CORE
\		Prepare the output string to be TYPE'd.
\		||HERE>WORD/#-work-area|

: #>		2DROP hld @ HERE size-of-PAD + OVER - 1chars/ ;

\		$COLON	NameNumberSignGreater,NumberSignGreater
\		DW	TwoDROP,DoLIT,AddrHLD,Fetch,HERE,DoLIT,PADSize*CHARR,Plus
\		DW	OVER,Minus,OneCharsSlash,EXIT

\   #S		( ud -- 0 0 )			\ CORE
\		Convert ud until all digits are added to the output string.

: #S		BEGIN # 2DUP OR 0= UNTIL ;

\		$COLON	NameNumberSignS,NumberSignS
\ NUMSS1		DW	NumberSign,TwoDUP,ORR
\		DW	ZeroEquals,ZBranch,NUMSS1
\		DW	EXIT

\   '           ( "<spaces>name" -- xt )        \ CORE
\		Parse a name, find it and return xt.

: '		(') DROP ;

\		$COLON	NameTick,Tick
\		DW	ParenTick,DROP,EXIT

\   +		( n1|u1 n2|u2 -- n3|u3 )	\ CORE
\		Add top two items and gives the sum.

: +		um+ DROP ;

\		  $COLON  NamePlus,Plus
\		  DW	  UMPlus,DROP,EXIT

\		$CODE	NamePlus,Plus
\		POP	AX
\		ADD	BX,AX
\		$NEXT

\   +!		( n|u a-addr -- )		\ CORE
\		Add n|u to the contents at a-addr.

: +!		SWAP OVER @ + SWAP ! ;

\		  $COLON  NamePlusStore,PlusStore
\		  DW	  SWAP,OVER,Fetch,Plus
\		  DW	  SWAP,Store,EXIT

\		$CODE	NamePlusStore,PlusStore
\		POP	AX
\		ADD	[BX],AX
\		POP	BX
\		$NEXT

\   ,		( x -- )			\ CORE
\		Reserve one cell in data space and store x in it.

: ,		HERE !	HERE CELL+ TO HERE ;

\		  $COLON  NameComma,Comma
\		  DW	  HERE,Store,HERE,CELLPlus,DoTO,AddrHERE,EXIT

\		$CODE	NameComma,Comma
\		MOV	DI,AddrHERE
\		MOV	[DI],BX
\		ADD	DI,CELLL
\		MOV	AddrHERE,DI
\		POP	BX
\		$NEXT

\   -		( n1|u1 n2|u2 -- n3|u3 )	\ CORE
\		Subtract n2|u2 from n1|u1, giving the difference n3|u3.

: - 		NEGATE + ;

\		  $COLON  NameMinus,Minus
\		  DW	  NEGATE,Plus,EXIT
\
\		$CODE	NameMinus,Minus
\		POP	AX
\		SUB	AX,BX
\		MOV	BX,AX
\		$NEXT

\   .		( n -- )			\ CORE
\		Display a signed number followed by a space.

: .		S>D D. ;

\		$COLON	NameDot,Dot
\		DW	SToD,DDot,EXIT

\   /		( n1 n2 -- n3 ) 		\ CORE
\		Divide n1 by n2, giving single-cell quotient n3.

: / 		/MOD NIP ;

\		$COLON	NameSlash,Slash
\		DW	SlashMOD,NIP,EXIT

\   /MOD	( n1 n2 -- n3 n4 )		\ CORE
\		Divide n1 by n2, giving single-cell remainder n3 and
\		single-cell quotient n4.

: /MOD		>R S>D R> FM/MOD ;

\		  $COLON  NameSlashMOD,SlashMOD
\		  DW	  ToR,SToD,RFrom,FMSlashMOD,EXIT

\		$CODE	NameSlashMOD,SlashMOD
\		POP	AX
\		CWD
\		PUSH	AX
\		PUSH	DX
\		JMP	FMSlashMOD
\		$ALIGN

\   /STRING	( c-addr1 u1 n -- c-addr2 u2 )	\ STRING
\		Adjust the char string at c-addr1 by n chars.

: /STRING	DUP >R - SWAP R> CHARS + SWAP ;

\		  $COLON  NameSlashSTRING,SlashSTRING
\		  DW	  DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT

\		$CODE	NameSlashSTRING,SlashSTRING
\		POP	AX
\		SUB	AX,BX
\		POP	DX
\		ADD	DX,BX
\		PUSH	DX
\		MOV	BX,AX
\		$NEXT

\   1+		( n1|u1 -- n2|u2 )		\ CORE
\		Increase top of the stack item by 1.

: 1+		1 + ;

\		  $COLON  NameOnePlus,OnePlus
\		  DW	  DoLIT,1,Plus,EXIT

\		$CODE	NameOnePlus,OnePlus
\		INC	BX
\		$NEXT

\   1-		( n1|u1 -- n2|u2 )		\ CORE
\		Decrease top of the stack item by 1.

: 1-		-1 + ;

\		  $COLON  NameOneMinus,OneMinus
\		  DW	  DoLIT,-1,Plus,EXIT

\		$CODE	NameOneMinus,OneMinus
\		DEC	BX
\		$NEXT

\   2!		( x1 x2 a-addr -- )		\ CORE
\		Store the cell pare x1 x2 at a-addr, with x2 at a-addr and
\		x1 at the next consecutive cell.

: 2!		SWAP OVER ! CELL+ ! ;

\		  $COLON  NameTwoStore,TwoStore
\		  DW	  SWAP,OVER,Store,CELLPlus,Store,EXIT
\
\		$CODE	NameTwoStore,TwoStore
\		POP	[BX]
\		POP	[BX+CELLL]
\		POP	BX
\		$NEXT

\   2@		( a-addr -- x1 x2 )		\ CORE
\		Fetch the cell pair stored at a-addr. x2 is stored at a-addr
\		and x1 at the next consecutive cell.

: 2@		DUP CELL+ @ SWAP @ ;

\		  $COLON  NameTwoFetch,TwoFetch
\		  DW	  DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT

\		$CODE	NameTwoFetch,TwoFetch
\		PUSH	[BX+CELLL]
\		MOV	BX,[BX]
\		$NEXT

\   2DROP	( x1 x2 -- )			\ CORE
\		Drop cell pair x1 x2 from the stack.

: 2DROP		DROP DROP ;

\		  $COLON  NameTwoDROP,TwoDROP
\		  DW	  DROP,DROP,EXIT

\		$CODE	NameTwoDROP,TwoDROP
\		POP	BX
\		POP	BX
\		$NEXT

\   2DUP	( x1 x2 -- x1 x2 x1 x2 )	\ CORE
\		Duplicate cell pair x1 x2.

: 2DUP		OVER OVER ;

\		  $COLON  NameTwoDUP,TwoDUP
\		  DW	  OVER,OVER,EXIT

\		$CODE	NameTwoDUP,TwoDUP
\		MOV	DI,SP
\		PUSH	BX
\		PUSH	[DI]
\		$NEXT

\   2SWAP	( x1 x2 x3 x4 -- x3 x4 x1 x2 )	\ CORE
\		Exchange the top two cell pairs.

: 2SWAP		ROT >R ROT R> ;

\		  $COLON  NameTwoSWAP,TwoSWAP
\		  DW	  ROT,ToR,ROT,RFrom,EXIT

\		$CODE	NameTwoSWAP,TwoSWAP
\		POP	AX
\		POP	CX
\		POP	DX
\		PUSH	AX
\		PUSH	BX
\		PUSH	DX
\		MOV	BX,CX
\		$NEXT

\   :		( "<spaces>name" -- colon-sys ) \ CORE
\		Start a new colon definition using next word as its name.

: : 		xhere ALIGNED CELL+ TO xhere  \ reserve a cell for name pointer
		:NONAME ROT head,  -1 TO notNONAME? ;

\		$COLON	NameCOLON,COLON
\		DW	XHere,ALIGNED,CELLPlus,DoTO,AddrXHere
\		DW	ColonNONAME,ROT,HeadComma
\		DW	DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT

\   :NONAME	( -- xt colon-sys )		\ CORE EXT
\		Create an execution token xt, enter compilation state and
\		start the current definition.

: :NONAME	bal IF -29 THROW THEN		\ compiler nesting
		['] doLIST xt, DUP -1
		0 TO notNONAME?  1 TO bal  ] ;
		IMMEDIATE

\		$COLON	NameColonNONAME,ColonNONAME
\		DW	Bal,ZBranch,NONAME1
\		DW	DoLIT,-29,THROW
\ NONAME1 	DW	DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1
\		DW	DoLIT,0,DoTO,AddrNotNONAMEQ
\		DW	One,DoTO,AddrBal,RightBracket,EXIT

\   ;		( colon-sys -- )		\ CORE
\		Terminate a colon definition.

: ;		bal 1- IF -22 THROW THEN	\ control structure mismatch
		NIP 1+ IF -22 THROW THEN	\ colon-sys type is -1
		notNONAME? IF	\ if the last definition is not created by ':'
		  linkLast  0 TO notNONAME?	\ link the word to wordlist
		THEN  POSTPONE EXIT	\ add EXIT at the end of the definition
		0 TO bal  POSTPONE [ ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameSemicolon,Semicolon
\		DW	Bal,OneMinus,ZBranch,SEMI1
\		DW	DoLIT,-22,THROW
\ SEMI1		DW	NIP,OnePlus,ZBranch,SEMI2
\		DW	DoLIT,-22,THROW
\ SEMI2		DW	NotNONAMEQ,ZBranch,SEMI3
\		DW	LinkLast,DoLIT,0,DoTO,AddrNotNONAMEQ
\ SEMI3		DW	DoLIT,EXIT,COMPILEComma
\		DW	DoLIT,0,DoTO,AddrBal,LeftBracket,EXIT

\   <		( n1 n2 -- flag )		\ CORE
\		Returns true if n1 is less than n2.

: < 		2DUP XOR 0<		\ same sign?
		IF DROP 0< EXIT THEN	\ different signs, true if n1 <0
		- 0< ;			\ same signs, true if n1-n2 <0

\		  $COLON  NameLessThan,LessThan
\		  DW	  TwoDUP,XORR,ZeroLess,ZBranch,LESS1
\		  DW	  DROP,ZeroLess,EXIT
\ LESS1 	  DW	  Minus,ZeroLess,EXIT

\		$CODE	NameLessThan,LessThan
\		POP	AX
\		SUB	AX,BX
\		MOV	BX,-1
\		JL	LESS1
\		INC	BX
\ LESS1:		$NEXT

\   <#		( -- )				\ CORE
\		Initiate the numeric output conversion process.
\		||HERE>WORD/#-work-area|

: <#		HERE size-of-PAD + hld ! ;

\		$COLON	NameLessNumberSign,LessNumberSign
\		DW	HERE,DoLIT,PADSize*CHARR,Plus,DoLIT,AddrHLD,Store,EXIT

\   =		( x1 x2 -- flag )		\ CORE
\		Return true if top two are equal.

: = 		XOR 0= ;

\		  $COLON  NameEquals,Equals
\		  DW	  XORR,ZeroEquals,EXIT

\		$CODE	NameEquals,Equals
\		POP	AX
\		CMP	BX,AX
\		MOV	BX,-1
\		JE	EQUAL1
\		INC	BX
\ EQUAL1: 	$NEXT

\   >		( n1 n2 -- flag )		\ CORE
\		Returns true if n1 is greater than n2.

: > 		SWAP < ;

\		  $COLON  NameGreaterThan,GreaterThan
\		  DW	  SWAP,LessThan,EXIT

\		$CODE	NameGreaterThan,GreaterThan
\		POP	AX
\		SUB	AX,BX
\		MOV	BX,-1
\		JG	GREAT1
\		INC	BX
\ GREAT1: 	$NEXT

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

\		$CONST	NameToIN,ToIN,AddrToIN

\   >NUMBER	( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )	\ CORE
\		Add number string's value to ud1. Leaves string of any
\		unconverted chars.

: >NUMBER	BEGIN  DUP
		WHILE  >R  DUP >R C@			\ ud char  R: u c-addr
		       DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN
			   IF DROP R> R> EXIT THEN
		       [ CHAR 0 ] LITERAL - 9 OVER <
		       [ CHAR A CHAR 9 1 + - ] LITERAL AND -
		       DUP 0 BASE @ WITHIN
		WHILE  SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING
		REPEAT DROP R> R>
		THEN ;

\		  $COLON  NameToNUMBER,ToNUMBER
\ TONUM1	  DW	  DUPP,ZBranch,TONUM3
\		  DW	  ToR,DUPP,ToR,CFetch,DUPP
\		  DW	  DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2
\		  DW	  DoLIT,'0',Minus,DoLIT,9,OVER,LessThan
\		  DW	  DoLIT,'A'-'9'-1,ANDD,Minus,DUPP
\		  DW	  DoLIT,0,DoLIT,AddrBASE,Fetch,WITHIN,ZBranch,TONUM2
\		  DW	  SWAP,DoLIT,AddrBASE,Fetch,UMStar,DROP,ROT,DoLIT,AddrBASE,Fetch
\		  DW	  UMStar,DPlus,RFrom,RFrom,DoLIT,1,SlashSTRING
\		  DW	  Branch,TONUM1
\ TONUM2	  DW	  DROP,RFrom,RFrom
\ TONUM3	  DW	  EXIT

\		$CODE	NameToNUMBER,ToNUMBER
\		POP	DI
\ TONUM4: 	OR	BX,BX
\		JZ	TONUM2
\		XOR	CX,CX
\		MOV	CL,[DI]
\		SUB	CX,'0'
\		JS	TONUM2		;not valid digit
\		CMP	CX,'9'-'0'
\		JLE	TONUM3
\		CMP	CX,'A'-'0'
\		JL	TONUM2		;not valid digit
\		SUB	CX,'A'-'9'-1
\ TONUM3: 	CMP	CX,AddrBASE
\		JGE	TONUM2		;not valid digit
\		POP	AX
\		MUL	AddrBASE
\		POP	DX
\		PUSH	AX
\		MOV	AX,DX
\		MUL	AddrBASE
\		ADD	AX,CX
\		POP	CX
\		ADC	DX,CX
\		PUSH	AX
\		PUSH	DX
\		INC	DI
\		DEC	BX
\		JMP	TONUM4
\ TONUM2: 	PUSH	DI
\		$NEXT

\   ?DUP	( x -- x x | 0 )		\ CORE
\		Duplicate top of the stack if it is not zero.

: ?DUP		DUP IF DUP THEN ;

\		  $COLON  NameQuestionDUP,QuestionDUP
\		  DW	  DUPP,ZBranch,QDUP1
\		  DW	  DUPP
\ QDUP1 	  DW	  EXIT

\		$CODE	NameQuestionDUP,QuestionDUP
\		OR	BX,BX
\		JZ	QDUP1
\		PUSH	BX
\ QDUP1:		$NEXT

\   ABORT	( i*x -- ) ( R: j*x -- )	\ EXCEPTION EXT
\		Reset data stack and jump to QUIT.

: ABORT		-1 THROW ;

\		$COLON	NameABORT,ABORT
\		DW	DoLIT,-1,THROW

\   ACCEPT	( c-addr +n1 -- +n2 )		\ CORE
\		Accept a string of up to +n1 chars. Return with actual count.
\		Implementation-defined editing. Stops at EOL# .
\		Supports backspace and delete editing.

: ACCEPT	>R 0
		BEGIN  DUP R@ < 		\ ca n2 f  R: n1
		WHILE  EKEY max-char AND
		       DUP BL <
		       IF   DUP  cr# = IF ROT 2DROP R> DROP EXIT THEN
			    DUP  tab# =
			    IF	 DROP 2DUP + BL DUP EMIT SWAP C! 1+
			    ELSE DUP  bsp# =
				 SWAP del# = OR
				 IF DROP DUP
					\ discard the last char if not 1st char
				 IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN
			    THEN
		       ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+  \ Nick THEN
		       THEN
		REPEAT SWAP  R> 2DROP ;

\		$COLON	NameACCEPT,ACCEPT
\		DW	ToR,DoLIT,0
\ ACCPT1		DW	DUPP,RFetch,LessThan,ZBranch,ACCPT5
\		DW	EKEY,DoLIT,MaxChar,ANDD
\		DW	DUPP,DoLIT,' ',LessThan,ZBranch,ACCPT3
\		DW	DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4
\		DW	ROT,TwoDROP,RFrom,DROP,EXIT
\ ACCPT4		DW	DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6
\		DW	DROP,TwoDUP,Plus,DoLIT,' ',DUPP,EMIT,SWAP,CStore,OnePlus
\		DW	Branch,ACCPT1
\ ACCPT6		DW	DUPP,DoLIT,BKSPP,Equals
\		DW	SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1
\		DW	DUPP,ZBranch,ACCPT1
\		DW	OneMinus,DoLIT,BKSPP,EMIT,DoLIT,' ',EMIT,DoLIT,BKSPP,EMIT
\		DW	Branch,ACCPT1
\ ACCPT3		DW	ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore
\		DW	OnePlus,Branch,ACCPT1
\ ACCPT5		DW	SWAP,RFrom,TwoDROP,EXIT

\   AGAIN	( C: dest -- )			\ CORE EXT
\		Resolve backward reference dest. Typically used as
\		BEGIN ... AGAIN . Move control to the location specified by
\		dest on execution.

: AGAIN		IF -22 THROW THEN  \ control structure mismatch; dest type is 0
		POSTPONE branch code, bal- ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameAGAIN,AGAIN
\		DW	ZBranch,AGAIN1
\		DW	DoLIT,-22,THROW
\ AGAIN1		DW	DoLIT,Branch,COMPILEComma,CodeComma,BalMinus,EXIT

\   AHEAD	( C: -- orig )			\ TOOLS EXT
\		Put the location of a new unresolved forward reference onto
\		control-flow stack.

: AHEAD		POSTPONE branch xhere 0 code,
		1 bal+		\ orig type is 1
		; COMPILE-ONLY IMMEDIATE

\		$COLON	NameAHEAD,AHEAD
\		DW	DoLIT,Branch,COMPILEComma,XHere,DoLIT,0,CodeComma
\		DW	One,BalPlus,EXIT

\   BL		( -- char )			\ CORE
\		Return the value of the blank character.

: BL		blank-char-value EXIT ;

\		$CONST NameBLank,BLank,' '

\   CATCH	( i*x xt -- j*x 0 | i*x n )	\ EXCEPTION
\		Push an exception frame on the exception stack and then execute
\		the execution token xt in such a way that control can be
\		transferred to a point just after CATCH if THROW is executed
\		during the execution of xt.

: CATCH		sp@ >R throwFrame @ >R		\ save error frame
		rp@ throwFrame !  EXECUTE	\ execute
		R> throwFrame ! 		\ restore error frame
		R> DROP  0 ;			\ no error

\		$COLON	NameCATCH,CATCH
\		DW	SPFetch,ToR,ThrowFrame,Fetch,ToR
\		DW	RPFetch,ThrowFrame,Store,EXECUTE
\		DW	RFrom,ThrowFrame,Store
\		DW	RFrom,DROP,DoLIT,0,EXIT

\   CELL+	( a-addr1 -- a-addr2 )		\ CORE
\		Return next aligned cell address.

: CELL+		cell-size + ;

\		  $COLON  NameCELLPlus,CELLPlus
\		  DW	  DoLIT,CELLL,Plus,EXIT

\		$CODE	NameCELLPlus,CELLPlus
\		ADD	BX,CELLL
\		$NEXT

\   CHAR+	( c-addr1 -- c-addr2 )		\ CORE
\		Returns next character-aligned address.

: CHAR+		char-size + ;

\		  $COLON  NameCHARPlus,CHARPlus
\		  DW	  DoLIT,CHARR,Plus,EXIT

\		$CODE	NameCHARPlus,CHARPlus
\		INC	BX
\		$NEXT

\   COMPILE,	( xt -- )			\ CORE EXT
\		Compile the execution token on data stack into current
\		colon definition.
\		Structure of words with special compilation action
\		    for default compilation behavior
\		|compile_xt|name_ptr| execution_code |

: COMPILE,	DUP specialComp? = IF DUP cell- cell- code@ EXECUTE EXIT THEN
		code, ;

\		  $COLON  NameCOMPILEComma,COMPILEComma
\		  DW	  DUPP,SpecialCompQ,Equals,ZBranch,COMPILEC1
\		  DW	  DUPP,CellMinus,CellMinus,CodeFetch,EXECUTE,EXIT
\ COMPILEC1	  DW	  CodeComma,EXIT

\		$CODE	NameCOMPILEComma,COMPILEComma
\		CMP	BX,AddrSpecialCompQ
\		JE	COMPILEC1
\		MOV	DI,AddrXHere
\		MOV	CS:[DI],BX
\		ADD	DI,CELLL
\		POP	BX
\		MOV	AddrXHere,DI
\		$NEXT
\ COMPILEC1:	MOV	AX,CS:[BX-2*CELLL]
\		JMP	AX
\		$ALIGN

\   compileCONST ( xt -- )
\		Compile a CONSTANT word of which xt is given.
\		Structure of CONSTANT word:
\		|compile_xt|name_ptr| call-doCONST | x |

: compileCONST
		CELL+ CELL+ code@ POSTPONE LITERAL ;

\		  $COLON  NameCompileCONST,CompileCONST
\		  DW	  CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT

\		$CODE	NameCompileCONST,CompileCONST
\		MOV	CX,CS:[BX+2*CELLL]
\		MOV	DI,AddrXHere
\		MOV	AX,OFFSET DoLIT
\		MOV	CS:[DI],AX
\		MOV	CS:[DI+CELLL],CX
\		ADD	DI,2*CELLL
\		POP	BX
\		MOV	AddrXHere,DI
\		$NEXT

\   CONSTANT	( x "<spaces>name" -- )         \ CORE
\		name Execution: ( -- x )
\		Create a definition for name which pushes x on the stack on
\		execution.

: CONSTANT	bal IF -29 THROW THEN		\ compiler nesting
		xhere ALIGNED TO xhere
		['] compileCONST code,
		xhere CELL+ TO xhere
		['] doCONST xt, head,
		code, linkLast
		lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;

\		$COLON	NameCONSTANT,CONSTANT
\		DW	Bal,ZBranch,CONST1
\		DW	DoLIT,-29,THROW
\ CONST1		DW	XHere,ALIGNED,DoTO,AddrXHere
\		DW	DoLIT,CompileCONST,CodeComma
\		DW	XHere,CELLPlus,DoTO,AddrXHere
\		DW	DoLIT,DoCONST,xtComma,HeadComma
\		DW	CodeComma,LinkLast
\		DW	LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT

\   COUNT	( c-addr1 -- c-addr2 u )	\ CORE
\		Convert counted string to string specification. c-addr2 is
\		the next char-aligned address after c-addr1 and u is the
\		contents at c-addr1.

: COUNT		DUP CHAR+ SWAP C@ ;

\		  $COLON  NameCOUNT,COUNT
\		  DW	  DUPP,CHARPlus,SWAP,CFetch,EXIT

\		$CODE	NameCOUNT,COUNT
\		MOV	AX,BX
\		INC	AX
\		MOV	BL,[BX]
\		XOR	BH,BH
\		PUSH	AX
\		$NEXT

\   compileCREATE ( xt -- )
\		Compile a CREATEd word of which xt is given.
\		Structure of CREATEd word:
\		|compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |

: compileCREATE
		DUP CELL+ CELL+ code@		\ 0 or DOES>_xt
		IF code, EXIT THEN
		CELL+ CELL+ CELL+ code@ POSTPONE LITERAL ;

\		$COLON	NameCompileCREATE,CompileCREATE
\		DW	DUPP,CELLPlus,CELLPlus,CodeFetch,ZBranch,COMPCREAT1
\		DW	CodeComma,EXIT
\ COMPCREAT1	DW	CELLPlus,CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT

\   CREATE	( "<spaces>name" -- )           \ CORE
\		name Execution: ( -- a-addr )
\		Create a data object in RAM/ROM data space, which return
\		data object address on execution

: CREATE	bal IF -29 THROW THEN		\ compiler nesting
		xhere ALIGNED TO xhere
		['] compileCREATE code,
		xhere CELL+ TO xhere	\ reserve space for nfa
		['] doCREATE xt, head,
		0 code, 		\ no DOES> code yet
		ALIGN HERE code,	\ >BODY returns this address
		linkLast		\ link CREATEd word to current wordlist
		lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;

\		$COLON	NameCREATE,CREATE
\		DW	Bal,ZBranch,CREAT1
\		DW	DoLIT,-29,THROW
\ CREAT1		DW	XHere,ALIGNED,DoTO,AddrXHere
\		DW	DoLIT,CompileCREATE,CodeComma
\		DW	XHere,CELLPlus,DoTO,AddrXHere
\		DW	DoLIT,DoCREATE,xtComma,HeadComma,DoLIT,0,CodeComma
\		DW	ALIGNN,HERE,CodeComma,LinkLast
\		DW	LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT

\   D+		( d1|ud1 d2|ud2 -- d3|ud3 )	\ DOUBLE
\		Add double-cell numbers.

: D+		>R SWAP >R um+ R> R> + + ;

\		  $COLON  NameDPlus,DPlus
\		  DW	  ToR,SWAP,ToR,UMPlus
\		  DW	  RFrom,RFrom,Plus,Plus,EXIT

\		$CODE	NameDPlus,DPlus
\		POP	CX
\		POP	DX
\		POP	AX
\		ADD	CX,AX
\		ADC	BX,DX
\		PUSH	CX
\		$NEXT

\   D.		( d -- )			\ DOUBLE
\		Display d in free field format followed by a space.

: D.		(d.) TYPE SPACE ;

\		$COLON	NameDDot,DDot
\		DW	ParenDDot,TYPEE,SPACE,EXIT

\   DECIMAL	( -- )				\ CORE
\		Set the numeric conversion radix to decimal 10.

: DECIMAL	10 BASE ! ;

\		$COLON	NameDECIMAL,DECIMAL
\		DW	DoLIT,10,DoLIT,AddrBASE,Store,EXIT

\   DEPTH	( -- +n )			\ CORE
\		Return the depth of the data stack.

: DEPTH		sp@ sp0 SWAP - cell-size / ;

\		  $COLON  NameDEPTH,DEPTH
\		  DW	  SPFetch,SPZero,SWAP,Minus
\		  DW	  DoLIT,CELLL,Slash,EXIT

\		$CODE	NameDEPTH,DEPTH
\		PUSH	BX
\		MOV	BX,AddrUserP
\		MOV	BX,[BX+CELLL]
\		SUB	BX,SP
\		SAR	BX,1
\		$NEXT

\   DNEGATE	( d1 -- d2 )			\ DOUBLE
\		Two's complement of double-cell number.

: DNEGATE	INVERT >R INVERT 1 um+ R> + ;

\		  $COLON  NameDNEGATE,DNEGATE
\		  DW	  INVERT,ToR,INVERT
\		  DW	  DoLIT,1,UMPlus
\		  DW	  RFrom,Plus,EXIT

\		$CODE	NameDNEGATE,DNEGATE
\		POP	AX
\		NEG	AX
\		PUSH	AX
\		ADC	BX,0
\		NEG	BX
\		$NEXT

\   EKEY	( -- u )			\ FACILITY EXT
\		Receive one keyboard event u.

: EKEY		BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;

\		$COLON	NameEKEY,EKEY
\ EKEY1		DW	PAUSE,EKEYQuestion,ZBranch,EKEY1
\		DW	TickEKEY,EXECUTE,EXIT

\   EMIT	( x -- )			\ CORE
\		Send a character to the output device.

: EMIT		'emit EXECUTE ;

\		  $COLON  NameEMIT,EMIT
\		  DW	  TickEMIT,EXECUTE,EXIT

\		$CODE	NameEMIT,EMIT
\		MOV	AX,AddrTickEMIT
\		JMP	AX
\		$ALIGN

\   FM/MOD	( d n1 -- n2 n3 )		\ CORE
\		Signed floored divide of double by single. Return mod n2
\		and quotient n3.

: FM/MOD	DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN
		R@ ABS UM/MOD DUP 0<
		IF DUP [ 16 BASE ! ] 8000 [ DECIMAL ] XOR IF -11 THROW THEN THEN \ result out of range
		SWAP R> 0< IF NEGATE THEN
		SWAP R> 0< IF NEGATE OVER IF R@ ROT - SWAP 1- THEN THEN
		R> DROP ;

\		  $COLON  6,'FM/MOD',FMSlashMOD,_FLINK
\		  DW	  DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess
\		  DW	  ZBranch,FMMOD1
\		  DW	  DNEGATE
\ FMMOD1	  DW	  RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,FMMOD2
\		  DW	  DUPP,DoLIT,08000h,XORR,ZBranch,FMMOD2
\		  DW	  DoLIT,-11,THROW
\ FMMOD2	  DW	  SWAP,RFrom,ZeroLess,ZBranch,FMMOD3
\		  DW	  NEGATE
\ FMMOD3	  DW	  SWAP,RFrom,ZeroLess,ZBranch,FMMOD4
\		  DW	  NEGATE,OVER,ZBranch,FMMOD4
\		  DW	  RFetch,ROT,Minus,SWAP,OneMinus
\ FMMOD4	  DW	  RFrom,DROP,EXIT

\		$CODE	NameFMSlashMOD,FMSlashMOD
\		POP	DX
\		POP	AX
\		OR	DX,DX
\		JS	FMMOD2
\		OR	BX,BX
\		JZ	FMMOD1
\		JS	FMMOD3
\		CMP	DX,BX
\		JAE	FMMOD6
\		DIV	BX		;positive dividend, positive divisor
\		CMP	AX,08000h
\		JA	FMMOD6
\		PUSH	DX
\		MOV	BX,AX
\		$NEXT
\ FMMOD3: 	NEG	BX		;positive dividend, negative divisor
\		CMP	DX,BX
\		JAE	FMMOD6
\		DIV	BX
\		CMP	AX,08000h
\		JA	FMMOD6
\		OR	DX,DX
\		JZ	FMMOD7		;modulo = 0
\		SUB	DX,BX
\		NOT	AX		;AX=-AX-1
\		PUSH	DX
\		MOV	BX,AX
\		$NEXT
\ FMMOD2: 	NEG	AX		;DNEGATE
\		ADC	DX,0
\		NEG	DX
\		OR	BX,BX
\		JZ	FMMOD1
\		JS	FMMOD4
\		CMP	DX,BX		;negative dividend, positive divisor
\		JAE	FMMOD6
\		DIV	BX
\		CMP	AX,08000h
\		JA	FMMOD6
\		OR	DX,DX
\		JZ	FMMOD7
\		SUB	BX,DX
\		NOT	AX		;AX=-AX-1
\		PUSH	BX
\		MOV	BX,AX
\		$NEXT
\ FMMOD7: 	NEG	AX
\		PUSH	DX
\		MOV	BX,AX
\		$NEXT
\ FMMOD4: 	NEG	BX		;negative dividend, negative divisor
\		CMP	DX,BX
\		JAE	FMMOD6
\		DIV	BX
\		CMP	AX,08000h
\		JA	FMMOD6
\		NEG	DX
\		MOV	BX,AX
\		PUSH	DX
\		$NEXT
\ FMMOD6: 	MOV	BX,-11		;result out of range
\		JMP	THROW
\ FMMOD1: 	MOV	BX,-10		;divide by zero
\		JMP	THROW
\		$ALIGN

\   GET-CURRENT   ( -- wid )			\ SEARCH
\		Return the indentifier of the compilation wordlist.

: GET-CURRENT	current @ ;

\		$COLON	NameGET_CURRENT,GET_CURRENT
\		DW	DoLIT,AddrCurrent,Fetch,EXIT

\   HOLD	( char -- )			\ CORE
\		Add char to the beginning of pictured numeric output string.

: HOLD		hld @  1 CHARS - DUP hld ! C! ;

\		  $COLON  NameHOLD,HOLD
\		  DW	  DoLIT,AddrHLD,Fetch,DoLIT,0-CHARR,Plus
\		  DW	  DUPP,DoLIT,AddrHLD,Store,CStore,EXIT

\		$CODE	NameHOLD,HOLD
\		MOV	DI,AddrHLD
\		DEC	DI
\		MOV	AddrHLD,DI
\		MOV	[DI],BL
\		POP	BX
\		$NEXT

\   I		( -- n|u ) ( R: loop-sys -- loop-sys )	\ CORE
\		Push the innermost loop index.

: I		rp@ [ 1 CELLS ] LITERAL + @
		rp@ [ 2 CELLS ] LITERAL + @  +	; COMPILE-ONLY

\		  $COLON  NameI,I
\		  DW	  RPFetch,DoLIT,CELLL,Plus,Fetch
\		  DW	  RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT

\		$CODE	NameI,I
\		PUSH	BX
\		MOV	BX,[BP]
\		ADD	BX,[BP+2]
\		$NEXT

\   IF		Compilation: ( C: -- orig )		\ CORE
\		Run-time: ( x -- )
\		Put the location of a new unresolved forward reference orig
\		onto the control flow stack. On execution jump to location
\		specified by the resolution of orig if x is zero.

: IF		POSTPONE 0branch xhere 0 code,
		1 bal+ ;		\ orig type is 1
		COMPILE-ONLY IMMEDIATE

\		$COLON	NameIFF,IFF
\		DW	DoLIT,ZBranch,COMPILEComma,XHere,DoLIT,0,CodeComma
\		DW	One,BalPlus,EXIT

\   INVERT	( x1 -- x2 )			\ CORE
\		Return one's complement of x1.

: INVERT	-1 XOR ;

\		  $COLON  NameINVERT,INVERT
\		  DW	  DoLIT,-1,XORR,EXIT

\		$CODE	NameINVERT,INVERT
\		NOT	BX
\		$NEXT

\   KEY 	( -- char )			\ CORE
\		Receive a character. Do not display char.

: KEY		EKEY max-char AND ;

\		$COLON	NameKEY,KEY
\		DW	EKEY,DoLIT,MaxChar,ANDD,EXIT

\   LITERAL	Compilation: ( x -- )		\ CORE
\		Run-time: ( -- x )
\		Append following run-time semantics. Put x on the stack on
\		execution

: LITERAL	POSTPONE doLIT code, ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameLITERAL,LITERAL
\		DW	DoLIT,DoLIT,COMPILEComma,CodeComma,EXIT

\   NEGATE	( n1 -- n2 )			\ CORE
\		Return two's complement of n1.

: NEGATE	INVERT 1+ ;

\		  $COLON  NameNEGATE,NEGATE
\		  DW	  INVERT,OnePlus,EXIT

\		$CODE	NameNEGATE,NEGATE
\		NEG	BX
\		$NEXT

\   NIP 	( n1 n2 -- n2 ) 		\ CORE EXT
\		Discard the second stack item.

: NIP		SWAP DROP ;

\		  $COLON  NameNIP,NIP
\		  DW	  SWAP,DROP,EXIT

\		$CODE	NameNIP,NIP
\		POP	AX
\		$NEXT

\   PARSE	( char "ccc<char>"-- c-addr u )         \ CORE EXT
\		Scan input stream and return counted string delimited by char.

: PARSE		>R  SOURCE >IN @ /STRING	\ c-addr u  R: char
		DUP IF
		   OVER CHARS + OVER	   \ c-addr c-addr+u c-addr  R: char
		   BEGIN  DUP C@ R@ XOR
		   WHILE  CHAR+ 2DUP =
		   UNTIL  DROP OVER - 1chars/ DUP
		   ELSE   NIP  OVER - 1chars/ DUP CHAR+
		   THEN   >IN +!
		THEN   R> DROP EXIT ;

\		  $COLON  5,'PARSE',PARSE,_FLINK
\		  DW	  ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING
\		  DW	  DUPP,ZBranch,PARSE4
\		  DW	  OVER,CHARS,Plus,OVER
\ PARSE1	  DW	  DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3
\		  DW	  CHARPlus,TwoDUP,Equals,ZBranch,PARSE1
\ PARSE2	  DW	  DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5
\ PARSE3	  DW	  NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus
\ PARSE5	  DW	  DoLIT,AddrToIN,PlusStore
\ PARSE4	  DW	  RFrom,DROP,EXIT

\		$CODE	NamePARSE,PARSE
\		MOV	AH,BL
\		MOV	DX,SI
\		MOV	SI,AddrSourceVar+CELLL
\		MOV	BX,AddrSourceVar
\		MOV	CX,AddrToIN
\		ADD	SI,CX
\		SUB	BX,CX
\		MOV	CX,SI
\		PUSH	SI
\		OR	BX,BX
\		JZ	PARSE1
\ PARSE5: 	LODSB
\		CMP	AL,AH
\		JE	PARSE4
\		DEC	BX
\		OR	BX,BX
\		JNZ	PARSE5
\		MOV	BX,SI
\		SUB	SI,AddrSourceVar+CELLL
\		SUB	BX,CX
\		MOV	AddrToIN,SI
\ PARSE1: 	MOV	SI,DX
\		$NEXT
\ PARSE4: 	MOV	BX,SI
\		SUB	SI,AddrSourceVar+CELLL
\		SUB	BX,CX
\		DEC	BX
\		MOV	AddrToIN,SI
\		MOV	SI,DX
\		$NEXT

\   QUIT	( -- ) ( R: i*x -- )		\ CORE
\		Empty the return stack, store zero in SOURCE-ID, make the user
\		input device the input source, and start text interpreter.

: QUIT		BEGIN
		  rp0 rp!  0 TO SOURCE-ID  0 TO bal  POSTPONE [
		  BEGIN CR REFILL DROP SPACE	\ REFILL returns always true
			['] interpret CATCH ?DUP 0=
		  WHILE STATE @ 0= IF .prompt THEN
		  REPEAT
		  DUP -1 XOR IF 				\ ABORT
		  DUP -2 = IF SPACE abort"msg 2@ TYPE    ELSE   \ ABORT"
		  SPACE errWord 2@ TYPE
		  SPACE [CHAR] ? EMIT SPACE
		  DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception
		  CELLS THROWMsgTbl + @ COUNT TYPE	 THEN THEN THEN
		  sp0 sp!
		AGAIN ;

\		$COLON	NameQUIT,QUIT
\ QUIT1		DW	RPZero,RPStore,DoLIT,0,DoTO,AddrSOURCE_ID
\		DW	DoLIT,0,DoTO,AddrBal,LeftBracket
\ QUIT2		DW	CR,REFILL,DROP,SPACE
\		DW	DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals
\		DW	ZBranch,QUIT3
\		DW	DoLIT,AddrSTATE,Fetch,ZeroEquals,ZBranch,QUIT2
\		DW	DotPrompt,Branch,QUIT2
\ QUIT3		DW	DUPP,DoLIT,-1,XORR,ZBranch,QUIT5
\		DW	DUPP,DoLIT,-2,Equals,ZBranch,QUIT4
\		DW	SPACE,DoLIT,AddrAbortQMsg,TwoFetch,TYPEE,Branch,QUIT5
\ QUIT4		DW	SPACE,DoLIT,AddrErrWord,TwoFetch,TYPEE
\		DW	SPACE,DoLIT,'?',EMIT,SPACE
\		DW	DUPP,DoLIT,-1,DoLIT,-58,WITHIN,ZBranch,QUIT7
\		DW	DoLIT,QUITstr
\		DW	COUNT,TYPEE,Dot,Branch,QUIT5
\ QUIT7		DW	CELLS,DoLIT,AddrTHROWMsgTbl,Plus,Fetch,COUNT,TYPEE
\ QUIT5		DW	SPZero,SPStore,Branch,QUIT1

\   REFILL	( -- flag )			\ CORE EXT
\		Attempt to fill the input buffer from the input source. Make
\		the result the input buffer, set >IN to zero, and return true
\		if successful. Return false if the input source is a string
\		from EVALUATE.

\ Nick, possible problem here
\ : REFILL	SOURCE-ID IF 0 EXIT THEN
\		memTop [ size-of-PAD CHARS ] LITERAL - DUP
\		size-of-PAD ACCEPT sourceVar 2!
\		0 >IN ! -1 ;

\		$COLON	NameREFILL,REFILL
\		DW	SOURCE_ID,ZBranch,REFIL1
\		DW	DoLIT,0,EXIT
\ REFIL1		DW	MemTop,DoLIT,0-PADSize*CHARR,Plus,DUPP
\		DW	DoLIT,PADSize*CHARR,ACCEPT,DoLIT,AddrSourceVar,TwoStore
\		DW	DoLIT,0,DoLIT,AddrToIN,Store,DoLIT,-1,EXIT

\   ROT 	( x1 x2 x3 -- x2 x3 x1 )	\ CORE
\		Rotate the top three data stack items.

: ROT		>R SWAP R> SWAP ;

\		  $COLON  NameROT,ROT
\		  DW	  ToR,SWAP,RFrom,SWAP,EXIT

\		 $CODE	NameROT,ROT
\		 POP	AX
\		 POP	CX
\		 PUSH	AX
\		 PUSH	BX
\		 MOV	BX,CX
\		 $NEXT

\   S>D 	( n -- d )			\ CORE
\		Convert a single-cell number n to double-cell number.

: S>D		DUP 0< ;

\		  $COLON  NameSToD,SToD
\		  DW	  DUPP,ZeroLess,EXIT

\		$CODE	NameSToD,SToD
\		PUSH	BX
\		MOV	AX,BX
\		CWD
\		MOV	BX,DX
\		$NEXT

\   SEARCH-WORDLIST	( c-addr u wid -- 0 | xt 1 | xt -1)	\ SEARCH
\		Search word list for a match with the given name.
\		Return execution token and -1 or 1 ( IMMEDIATE) if found.
\		Return 0 if not found.

: SEARCH-WORDLIST
		(search-wordlist) DUP IF NIP THEN ;

\		$COLON	NameSEARCH_WORDLIST,SEARCH_WORDLIST
\		DW	ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1
\		DW	NIP
\ SRCHW1		DW	EXIT

\   SIGN	( n -- )			\ CORE
\		Add a minus sign to the numeric output string if n is negative.

: SIGN		0< IF [CHAR] - HOLD THEN ;

\		  $COLON  NameSIGN,SIGN
\		  DW	  ZeroLess,ZBranch,SIGN1
\		  DW	  DoLIT,'-',HOLD
\ SIGN1 	  DW	  EXIT

\		$CODE	NameSIGN,SIGN
\		OR	BX,BX
\		JNS	SIGN1
\		MOV	AL,'-'
\		MOV	DI,AddrHLD
\		DEC	DI
\		MOV	AddrHLD,DI
\		MOV	[DI],AL
\ SIGN1:		POP	BX
\		$NEXT

\   SOURCE	( -- c-addr u ) 		\ CORE
\		Return input buffer string.

: SOURCE		sourceVar 2@ ;

\		$COLON	NameSOURCE,SOURCE
\		DW	DoLIT,AddrSourceVar,TwoFetch,EXIT

\   SPACE	( -- )				\ CORE
\		Send the blank character to the output device.

: SPACE		32 EMIT ;

\		  $COLON  NameSPACE,SPACE
\		  DW	  DoLIT,' ',EMIT,EXIT

\		$CODE	NameSPACE,SPACE
\		PUSH	BX
\		MOV	BX,' '
\		MOV	AX,AddrTickEMIT
\		JMP	AX
\		$ALIGN

\   STATE	( -- a-addr )			\ CORE
\		Return the address of a cell containing compilation-state flag
\		which is true in compilation state or false otherwise.

\		$CONST	NameSTATE,STATE,AddrSTATE

\   THEN	Compilation: ( C: orig -- )	\ CORE
\		Run-time: ( -- )
\		Resolve the forward reference orig.

: THEN		1- IF -22 THROW THEN	\ control structure mismatch
					\ orig type is 1
		xhere SWAP code! bal- ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameTHENN,THENN
\		DW	OneMinus,ZBranch,THEN1
\		DW	DoLIT,-22,THROW
\ THEN1		DW	XHere,SWAP,CodeStore,BalMinus,EXIT

\   THROW	( k*x n -- k*x | i*x n )	\ EXCEPTION
\		If n is not zero, pop the topmost exception frame from the
\		exception stack, along with everything on the return stack
\		above the frame. Then restore the condition before CATCH and
\		transfer control just after the CATCH that pushed that
\		exception frame.

: THROW		?DUP
		IF   throwFrame @ rp!	\ restore return stack
		     R> throwFrame !	\ restore THROW frame
		     R> SWAP >R sp!	\ restore data stack
		     DROP R>
		     'init-i/o EXECUTE
		THEN ;

\		$COLON	NameTHROW,THROW
\		DW	QuestionDUP,ZBranch,THROW1
\		DW	ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store
\		DW	RFrom,SWAP,ToR,SPStore,DROP,RFrom
\		DW	TickINIT_IO,EXECUTE
\ THROW1		DW	EXIT

\   TYPE	( c-addr u -- ) 		\ CORE
\		Display the character string if u is greater than zero.

: TYPE		?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;

\		  $COLON  NameTYPEE,TYPEE
\		  DW	  QuestionDUP,ZBranch,TYPE2
\		  DW	  DoLIT,0,DoDO
\ TYPE1 	  DW	  DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1
\ TYPE2 	  DW	  DROP,EXIT

\		$CODE	NameTYPEE,TYPEE
\		POP	DI
\		OR	BX,BX
\		JZ	TYPE2
\		PUSH	SI
\		SUB	BP,CELLL
\		MOV	[BP],BX
\		MOV	BX,DI
\ TYPE4:		MOV	DI,BX
\		XOR	BX,BX
\		MOV	BL,[DI]
\		INC	DI
\		PUSH	DI
\		MOV	SI,OFFSET TYPE3
\		MOV	AX,AddrTickEMIT
\		JMP	AX
\ TYPE1:		DEC	WORD PTR [BP]
\		JNZ	TYPE4
\		POP	SI
\		ADD	BP,CELLL
\ TYPE2:		POP	BX
\		$NEXT
\ TYPE3		DW	TYPE1

\   U<		( u1 u2 -- flag )		\ CORE
\		Unsigned compare of top two items. True if u1 < u2.

: U<		2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;

\		  $COLON  NameULess,ULess
\		  DW	  TwoDUP,XORR,ZeroLess
\		  DW	  ZBranch,ULES1
\		  DW	  NIP,ZeroLess,EXIT
\ ULES1 	  DW	  Minus,ZeroLess,EXIT

\		$CODE	NameULess,ULess
\		POP	AX
\		SUB	AX,BX
\		MOV	BX,-1
\		JB	ULES1
\		INC	BX
\ ULES1:		$NEXT

\   UM* 	( u1 u2 -- ud ) 		\ CORE
\		Unsigned multiply. Return double-cell product.

: UM*		0 SWAP cell-size-in-bits 0 DO
		   DUP um+ >R >R DUP um+ R> +
		   R> IF >R OVER um+ R> + THEN	   \ if carry
		LOOP ROT DROP ;

\		  $COLON  NameUMStar,UMStar
\		  DW	  DoLIT,0,SWAP,DoLIT,CELLL*8,DoLIT,0,DoDO
\ UMST1 	  DW	  DUPP,UMPlus,ToR,ToR
\		  DW	  DUPP,UMPlus,RFrom,Plus,RFrom
\		  DW	  ZBranch,UMST2
\		  DW	  ToR,OVER,UMPlus,RFrom,Plus
\ UMST2 	  DW	  DoLOOP,UMST1
\		  DW	  ROT,DROP,EXIT

\		$CODE	NameUMStar,UMStar
\		POP	AX
\		MUL	BX
\		PUSH	AX
\		MOV	BX,DX
\		$NEXT

\   UM/MOD	( ud u1 -- u2 u3 )		\ CORE
\		Unsigned division of a double-cell number ud by a single-cell
\		number u1. Return remainder u2 and quotient u3.

: UM/MOD	DUP 0= IF -10 THROW THEN	\ divide by zero
		2DUP U< IF
		   NEGATE cell-size-in-bits 0
		   DO	>R DUP um+ >R >R DUP um+ R> + DUP
			R> R@ SWAP >R um+ R> OR
			IF >R DROP 1+ R>
			ELSE DROP THEN
			R>
		   LOOP DROP SWAP EXIT
		ELSE -11 THROW		\ result out of range
		THEN ;

\		  $COLON  NameUMSlashMOD,UMSlashMOD
\		  DW	  DUPP,ZBranch,UMM5
\		  DW	  TwoDUP,ULess,ZBranch,UMM4
\		  DW	  NEGATE,DoLIT,CELLL*8,DoLIT,0,DoDO
\ UMM1		  DW	  ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP
\		  DW	  RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2
\		  DW	  ToR,DROP,OnePlus,RFrom,Branch,UMM3
\ UMM2		  DW	  DROP
\ UMM3		  DW	  RFrom,DoLOOP,UMM1
\		  DW	  DROP,SWAP,EXIT
\ UMM5		  DW	  DoLIT,-10,THROW
\ UMM4		  DW	  DoLIT,-11,THROW

\		$CODE	NameUMSlashMOD,UMSlashMOD
\		OR	BX,BX
\		JZ	UMM1
\		POP	DX
\		CMP	DX,BX
\		JAE	UMM2
\		POP	AX
\		DIV	BX
\		PUSH	DX
\		MOV	BX,AX
\		$NEXT
\ UMM1:		MOV	BX,-10		;divide by zero
\		JMP	THROW
\ UMM2:		MOV	BX,-11		;result out of range
\		JMP	THROW
\		$ALIGN

\   UNLOOP	( -- ) ( R: loop-sys -- )	\ CORE
\		Discard loop-control parameters for the current nesting level.
\		An UNLOOP is required for each nesting level before the
\		definition may be EXITed.

: UNLOOP	R> R> R> 2DROP >R ;

\		  $COLON  NameUNLOOP,UNLOOP
\		  DW	  RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT

\		$CODE	NameUNLOOP,UNLOOP
\		ADD	BP,2*CELLL
\		$NEXT

\   WITHIN	( n1|u1 n2|n2 n3|u3 -- flag )	\ CORE EXT
\		Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or
\		(n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).

: WITHIN	OVER - >R - R> U< ;

\		  $COLON  NameWITHIN,WITHIN
\		  DW	  OVER,Minus,ToR		  ;ul <= u < uh
\		  DW	  Minus,RFrom,ULess,EXIT

\		$CODE	NameWITHIN,WITHIN
\		POP	AX
\		SUB	BX,AX
\		POP	DX
\		SUB	DX,AX
\		CMP	DX,BX
\		MOV	BX,-1
\		JB	WITHIN1
\		INC	BX
\ WITHIN1:	$NEXT

\   [		( -- )				\ CORE
\		Enter interpretation state.

: [		0 STATE ! ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameLeftBracket,LeftBracket
\		DW	DoLIT,0,DoLIT,AddrSTATE,Store,EXIT

\   ]		( -- )				\ CORE
\		Enter compilation state.

: ]		-1 STATE ! ;

\		$COLON	NameRightBracket,RightBracket
\		DW	DoLIT,-1,DoLIT,AddrSTATE,Store,EXIT

\ ;;;;;;;;;;;;;;;
\ Rest of CORE words and two facility words, EKEY? and EMIT?
\ ;;;;;;;;;;;;;;;
\	Following definitions can be removed from assembler source and
\	can be colon-defined later.

\   (		( "ccc<)>" -- )                 \ CORE
\		Ignore following string up to next ) . A comment.

: (		[CHAR] ) PARSE 2DROP ; IMMEDIATE

\		$COLON	NameParen,Paren
\		DW	DoLIT,')',PARSE,TwoDROP,EXIT

\   *		( n1|u1 n2|u2 -- n3|u3 )	\ CORE
\		Multiply n1|u1 by n2|u2 giving a single product.

: *		UM* DROP ;

\		  $COLON  NameStar,Star
\		  DW	  UMStar,DROP,EXIT

\		$CODE	NameStar,Star
\		POP	AX
\		IMUL	BX
\		MOV	BX,AX
\		$NEXT

\   */		( n1 n2 n3 -- n4 )		\ CORE
\		Multiply n1 by n2 producing double-cell intermediate,
\		then divide it by n3. Return single-cell quotient.

: */		*/MOD NIP ;

\		$COLON	NameStarSlash,StarSlash
\		DW	StarSlashMOD,NIP,EXIT

\   */MOD	( n1 n2 n3 -- n4 n5 )		\ CORE
\		Multiply n1 by n2 producing double-cell intermediate,
\		then divide it by n3. Return single-cell remainder and
\		single-cell quotient.

: */MOD		>R M* R> FM/MOD ;

\		  $COLON  NameStarSlashMOD,StarSlashMOD
\		  DW	  ToR,MStar,RFrom,FMSlashMOD,EXIT

\		$CODE	NameStarSlashMOD,StarSlashMOD
\		POP	AX
\		POP	CX
\		IMUL	CX
\		PUSH	AX
\		PUSH	DX
\		JMP	FMSlashMOD
\		$ALIGN

\   +LOOP	Compilation: ( C: do-sys -- )	\ CORE
\		Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )
\		Terminate a DO-+LOOP structure. Resolve the destination of all
\		unresolved occurences of LEAVE.
\		On execution add n to the loop index. If loop index did not
\		cross the boundary between loop_limit-1 and loop_limit,
\		continue execution at the beginning of the loop. Otherwise,
\		finish the loop.

: +LOOP		POSTPONE do+LOOP  rake ; COMPILE-ONLY IMMEDIATE

\		$COLON	NamePlusLOOP,PlusLOOP
\		DW	DoLIT,DoPLOOP,COMPILEComma,rake,EXIT

\   ."          ( "ccc<">" -- )                 \ CORE
\		Run-time ( -- )
\		Compile an inline string literal to be typed out at run time.

: ."		POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameDotQuote,DotQuote
\		DW	SQuote,DoLIT,TYPEE,COMPILEComma,EXIT

\   2OVER	( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )	  \ CORE
\		Copy cell pair x1 x2 to the top of the stack.

: 2OVER		>R >R 2DUP R> R> 2SWAP ;

\		  $COLON  NameTwoOVER,TwoOVER
\		  DW	  ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT

\		$CODE	NameTwoOVER,TwoOVER
\		MOV	DI,SP
\		PUSH	BX
\		PUSH	[DI+2*CELLL]
\		MOV	BX,[DI+CELLL]
\		$NEXT

\   >BODY	( xt -- a-addr )		\ CORE
\		Push data field address of CREATEd word.

: >BODY		?call DUP IF			\ code-addr xt2
		    ['] doCREATE = IF           \ should be call-doCREATE
		    CELL+ code@ EXIT
		THEN THEN
		-31 THROW ;		\ >BODY used on non-CREATEd definition

\		$COLON	NameToBODY,ToBODY
\		DW	QCall,DUPP,ZBranch,TBODY1
\		DW	DoLIT,DoCREATE,Equals,ZBranch,TBODY1
\		DW	CELLPlus,CodeFetch,EXIT
\ TBODY1		DW	DoLIT,-31,THROW

\   ABORT"      ( "ccc<">" -- )                 \ EXCEPTION EXT
\		Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )
\		Conditional abort with an error message.

: ABORT"	POSTPONE S" POSTPONE ROT
		POSTPONE IF POSTPONE abort"msg POSTPONE 2!
		-2 POSTPONE LITERAL POSTPONE THROW
		POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN
		;  COMPILE-ONLY IMMEDIATE

\		$COLON	NameABORTQuote,ABORTQuote
\		DW	SQuote,DoLIT,ROT,COMPILEComma
\		DW	IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate
\		DW	DoLIT,TwoStore,COMPILEComma
\		DW	DoLIT,-2,LITERAL		 ; LITERAL is immediate
\		DW	DoLIT,THROW,COMPILEComma
\		DW	ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are
\		DW	THENN,EXIT			 ; immediate

\   ABS 	( n -- u )			\ CORE
\		Return the absolute value of n.

: ABS		DUP 0< IF NEGATE THEN ;

\		  $COLON  NameABSS,ABSS
\		  DW	  DUPP,ZeroLess,ZBranch,ABS1
\		  DW	  NEGATE
\ ABS1		  DW	  EXIT

\		$CODE	NameABSS,ABSS
\		OR	BX,BX
\		JNS	ABS1
\		NEG	BX
\ ABS1:		$NEXT

\   ALLOT	( n -- )			\ CORE
\		Allocate n bytes in data space.

: ALLOT		HERE + TO HERE ;

\		$COLON	NameALLOT,ALLOT
\		DW	HERE,Plus,DoTO,AddrHERE,EXIT

\   BEGIN	( C: -- dest )			\ CORE
\		Start an infinite or indefinite loop structure. Put the next
\		location for a transfer of control, dest, onto the data
\		control stack.

: BEGIN		xhere 0 bal+		\ dest type is 0
		; COMPILE-ONLY IMMEDIATE

\		$COLON	NameBEGIN,BEGIN
\		DW	XHere,DoLIT,0,BalPlus,EXIT

\   C,		( char -- )			\ CORE
\		Compile a character into data space.

: C,		HERE C!  HERE CHAR+ TO HERE ;

\		  $COLON  NameCComma,CComma
\		  DW	  HERE,CStore,HERE,CHARPlus,DoTO,AddrHERE,EXIT

\		$CODE	NameCComma,CComma
\		MOV	DI,AddrHERE
\		MOV	[DI],BL
\		INC	DI
\		MOV	AddrHERE,DI
\		POP	BX
\		$NEXT

\   CHAR	( "<spaces>ccc" -- char )       \ CORE
\		Parse next word and return the value of first character.

: CHAR		PARSE-WORD DROP C@ ;

\		$COLON	NameCHAR,CHAR
\		DW	PARSE_WORD,DROP,CFetch,EXIT

\   DO		Compilation: ( C: -- do-sys )	\ CORE
\		Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )
\		Start a DO-LOOP structure in a colon definition. Place do-sys
\		on control-flow stack, which will be resolved by LOOP or +LOOP.

: DO		0 rakeVar !  0			\ ?DO-orig is 0 for DO
		POSTPONE doDO xhere  bal+ ;	\ DO-dest
		COMPILE-ONLY IMMEDIATE

\		$COLON	NameDO,DO
\		DW	DoLIT,0,RakeVar,Store,DoLIT,0
\		DW	DoLIT,DoDO,COMPILEComma,XHere,BalPlus,EXIT

\   DOES>	( C: colon-sys1 -- colon-sys2 ) \ CORE
\		Build run time code of the data object CREATEd.

: DOES>		bal 1- IF -22 THROW THEN	\ control structure mismatch
		NIP 1+ IF -22 THROW THEN	\ colon-sys type is -1
		POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameDOESGreater,DOESGreater
\		DW	Bal,OneMinus,ZBranch,DOES1
\		DW	DoLIT,-22,THROW
\ DOES1		DW	NIP,OnePlus,ZBranch,DOES2
\		DW	DoLIT,-22,THROW
\ DOES2		DW	DoLIT,Pipe,COMPILEComma
\		DW	DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT

\   ELSE	Compilation: ( C: orig1 -- orig2 )	\ CORE
\		Run-time: ( -- )
\		Start the false clause in an IF-ELSE-THEN structure.
\		Put the location of new unresolved forward reference orig2
\		onto control-flow stack.

: ELSE		POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameELSEE,ELSEE
\		DW	AHEAD,TwoSWAP,THENN,EXIT

\   ENVIRONMENT?   ( c-addr u -- false | i*x true )	\ CORE
\		Environment query.

: ENVIRONMENT?
		envQList SEARCH-WORDLIST
		DUP >R IF EXECUTE THEN R> ;

\		$COLON	NameENVIRONMENTQuery,ENVIRONMENTQuery
\		DW	DoLIT,AddrEnvQList,SEARCH_WORDLIST
\		DW	DUPP,ToR,ZBranch,ENVRN1
\		DW	EXECUTE
\ ENVRN1		DW	RFrom,EXIT

\   EVALUATE	( i*x c-addr u -- j*x ) 	\ CORE
\		Evaluate the string. Save the input source specification.
\		Store -1 in SOURCE-ID.

: EVALUATE	SOURCE >R >R >IN @ >R  SOURCE-ID >R
		-1 TO SOURCE-ID
		sourceVar 2!  0 >IN !  interpret
		R> TO SOURCE-ID
		R> >IN ! R> R> sourceVar 2! ;

\		$COLON	NameEVALUATE,EVALUATE
\		DW	SOURCE,ToR,ToR,DoLIT,AddrToIN,Fetch,ToR,SOURCE_ID,ToR
\		DW	DoLIT,-1,DoTO,AddrSOURCE_ID
\		DW	DoLIT,AddrSourceVar,TwoStore,DoLIT,0,DoLIT,AddrToIN,Store,Interpret
\		DW	RFrom,DoTO,AddrSOURCE_ID
\		DW	RFrom,DoLIT,AddrToIN,Store,RFrom,RFrom,DoLIT,AddrSourceVar,TwoStore,EXIT

\   FILL	( c-addr u char -- )		\ CORE
\		Store char in each of u consecutive characters of memory
\		beginning at c-addr.

: FILL		ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;

\		  $COLON  NameFILL,FILL
\		  DW	  ROT,ROT,QuestionDUP,ZBranch,FILL2
\		  DW	  DoLIT,0,DoDO
\ FILL1 	  DW	  TwoDUP,CStore,CHARPlus,DoLOOP,FILL1
\ FILL2 	  DW	  TwoDROP,EXIT

\		$CODE	NameFILL,FILL
\		POP	CX
\		MOV	DX,SI
\		POP	SI
\		OR	CX,CX
\		JZ	FILL1
\		MOV	[SI],BL
\		MOV	AX,DS
\		MOV	ES,AX
\		MOV	DI,SI
\		DEC	CX
\		INC	DI
\		REP MOVSB
\ FILL1:		MOV	SI,DX
\		POP	BX
\		$NEXT

\   FIND	( c-addr -- c-addr 0 | xt 1 | xt -1)	 \ SEARCH
\		Search dictionary for a match with the given counted name.
\		Return execution token and -1 or 1 ( IMMEDIATE) if found;
\		c-addr 0 if not found.

: FIND		DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN
		2DROP 0 ;

\		$COLON	NameFIND,FIND
\		DW	DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1
\		DW	NIP,ROT,DROP,EXIT
\ FIND1		DW	TwoDROP,DoLIT,0,EXIT

\   IMMEDIATE	( -- )				\ CORE
\		Make the most recent definition an immediate word.

: IMMEDIATE	lastName [ =immed ] LITERAL OVER @ OR SWAP ! ;

\		$COLON	NameIMMEDIATE,IMMEDIATE
\		DW	LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT

\   J		( -- n|u ) ( R: loop-sys -- loop-sys )	\ CORE
\		Push the index of next outer loop.

: J		rp@ [ 3 CELLS ] LITERAL + @
		rp@ [ 4 CELLS ] LITERAL + @  +	; COMPILE-ONLY

\		  $COLON  NameJ,J
\		  DW	  RPFetch,DoLIT,3*CELLL,Plus,Fetch
\		  DW	  RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT

\		$CODE	NameJ,J
\		PUSH	BX
\		MOV	BX,[BP+2*CELLL]
\		ADD	BX,[BP+3*CELLL]
\		$NEXT

\   LEAVE	( -- ) ( R: loop-sys -- )	\ CORE
\		Terminate definite loop, DO|?DO  ... LOOP|+LOOP, immediately.

: LEAVE		POSTPONE UNLOOP POSTPONE branch
		xhere rakeVar DUP @ code, ! ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameLEAVEE,LEAVEE
\		DW	DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma
\		DW	XHere,DoLIT,AddrRakeVar,DUPP,Fetch,CodeComma,Store,EXIT

\   LOOP	Compilation: ( C: do-sys -- )	\ CORE
\		Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )
\		Terminate a DO|?DO ... LOOP structure. Resolve the destination
\		of all unresolved occurences of LEAVE.

: LOOP		POSTPONE doLOOP  rake ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameLOOPP,LOOPP
\		DW	DoLIT,DoLOOP,COMPILEComma,rake,EXIT

\   LSHIFT	( x1 u -- x2 )			\ CORE
\		Perform a logical left shift of u bit-places on x1, giving x2.
\		Put 0 into the least significant bits vacated by the shift.

: LSHIFT	?DUP IF 0 DO 2* LOOP THEN ;

\		  $COLON  NameLSHIFT,LSHIFT
\		  DW	  QuestionDUP,ZBranch,LSHIFT2
\		  DW	  DoLIT,0,DoDO
\ LSHIFT1	  DW	  TwoStar,DoLOOP,LSHIFT1
\ LSHIFT2	  DW	  EXIT

\		$CODE	NameLSHIFT,LSHIFT
\		MOV	CX,BX
\		POP	BX
\		OR	CX,CX
\		JZ	LSHIFT2
\		SHL	BX,CL
\ LSHIFT2:	$NEXT

\   M*		( n1 n2 -- d )			\ CORE
\		Signed multiply. Return double product.

: M*		2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;

\		  $COLON  NameMStar,MStar
\		  DW	  TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS
\		  DW	  UMStar,RFrom,ZBranch,MSTAR1
\		  DW	  DNEGATE
\ MSTAR1	  DW	  EXIT

\		$CODE	NameMStar,MStar
\		POP	AX
\		IMUL	BX
\		PUSH	AX
\		MOV	BX,DX
\		$NEXT

\   MAX 	( n1 n2 -- n3 ) 		\ CORE
\		Return the greater of two top stack items.

: MAX		2DUP < IF SWAP THEN DROP ;

\		  $COLON  NameMAX,MAX
\		  DW	  TwoDUP,LessThan,ZBranch,MAX1
\		  DW	  SWAP
\ MAX1		  DW	  DROP,EXIT

\		$CODE	NameMAX,MAX
\		POP	AX
\		CMP	AX,BX
\		JLE	MAX1
\		MOV	BX,AX
\ MAX1:		$NEXT

\   MIN 	( n1 n2 -- n3 ) 		\ CORE
\		Return the smaller of top two stack items.

: MIN		2DUP > IF SWAP THEN DROP ;

\		  $COLON  NameMIN,MIN
\		  DW	  TwoDUP,GreaterThan,ZBranch,MIN1
\		  DW	  SWAP
\ MIN1		  DW	  DROP,EXIT

\		$CODE	NameMIN,MIN
\		POP	AX
\		CMP	AX,BX
\		JGE	MIN1
\		MOV	BX,AX
\ MIN1:		$NEXT

\   MOD 	( n1 n2 -- n3 ) 		\ CORE
\		Divide n1 by n2, giving the single cell remainder n3.
\		Returns modulo of floored division in this implementation.

: MOD		/MOD DROP ;

\		$COLON	NameMODD,MODD
\		DW	SlashMOD,DROP,EXIT

\   PICK	( x_u ... x1 x0 u -- x_u ... x1 x0 x_u )	\ CORE EXT
\		Remove u and copy the uth stack item to top of the stack. An
\		ambiguous condition exists if there are less than u+2 items
\		on the stack before PICK is executed.

: PICK		DEPTH DUP 2 < IF -4 THROW THEN	  \ stack underflow
		2 - OVER U< IF -4 THROW THEN
		1+ CELLS sp@ + @ ;

\		  $COLON  NamePICK,PICK
\		  DW	  DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1
\		  DW	  DoLIT,-4,THROW
\ PICK1 	  DW	  DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2
\		  DW	  DoLIT,-4,THROW
\ PICK2 	  DW	  OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT

\		$CODE	NamePICK,PICK
\		MOV	DI,AddrUserP
\		MOV	DI,[DI+CELLL]	; sp0
\		SUB	DI,SP
\		SAR	DI,1		; depth-1 in DI
\		DEC	DI
\		JS	PICK1
\		CMP	DI,BX
\		JB	PICK1
\		SHL	BX,1
\		ADD	BX,SP
\		MOV	BX,[BX]
\		$NEXT
\ PICK1:		MOV	BX,-4
\		JMP	THROW
\		$ALIGN

\   POSTPONE	( "<spaces>name" -- )           \ CORE
\		Parse name and find it. Append compilation semantics of name
\		to current definition.
\		Structure of words with special compilation action
\		    for default compilation behavior
\		|compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |

: POSTPONE	(') 0< IF
		    specialComp? OVER = IF	\ special compilation action
			DUP POSTPONE LITERAL
			cell- cell- code@
			POSTPONE LITERAL
			POSTPONE EXECUTE EXIT  THEN
		    POSTPONE LITERAL			\ non-IMMEDIATE
		    POSTPONE code, EXIT        THEN
		code, ; COMPILE-ONLY IMMEDIATE		\ IMMEDIATE

\		$COLON	NamePOSTPONE,POSTPONE
\		DW	ParenTick,ZeroLess,ZBranch,POSTP1
\		DW	SpecialCompQ,OVER,Equals,ZBranch,POSTP2
\		DW	DUPP,LITERAL,CellMinus,CellMinus,CodeFetch
\		DW	LITERAL,DoLIT,EXECUTE,CodeComma,EXIT
\ POSTP2		DW	LITERAL,DoLIT,CodeComma
\ POSTP1		DW	CodeComma,EXIT

\   RECURSE	( -- )				\ CORE
\		Append the execution semactics of the current definition to
\		the current definition.

: RECURSE	bal 1- 2* PICK 1+ IF -22 THROW THEN
			\ control structure mismatch; colon-sys type is -1
		bal 1- 2* 1+ PICK	\ xt of current definition
		COMPILE, ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameRECURSE,RECURSE
\		DW	Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1
\		DW	DoLIT,-22,THROW
\ RECUR1		DW	Bal,OneMinus,TwoStar,OnePlus,PICK
\		DW	COMPILEComma,EXIT

\   REPEAT	( C: orig dest -- )		\ CORE
\		Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve
\		backward reference dest and forward reference orig.

: REPEAT	POSTPONE AGAIN POSTPONE THEN ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameREPEAT,REPEATT
\		DW	AGAIN,THENN,EXIT

\   RSHIFT	( x1 u -- x2 )			\ CORE
\		Perform a logical right shift of u bit-places on x1, giving x2.
\		Put 0 into the most significant bits vacated by the shift.

: RSHIFT	?DUP IF
			0 SWAP	cell-size-in-bits SWAP -
			0 DO  2DUP D+  LOOP
			NIP
		THEN ;

\		  $COLON  NameRSHIFT,RSHIFT
\		  DW	  QuestionDUP,ZBranch,RSHIFT2
\		  DW	  DoLIT,0,SWAP,DoLIT,CELLL*8,SWAP,Minus,DoLIT,0,DoDO
\ RSHIFT1	  DW	  TwoDUP,DPlus,DoLOOP,RSHIFT1
\		  DW	  NIP
\ RSHIFT2	  DW	  EXIT

\		$CODE	NameRSHIFT,RSHIFT
\		MOV	CX,BX
\		POP	BX
\		OR	CX,CX
\		JZ	RSHIFT2
\		SHR	BX,CL
\ LSHIFT2:	$NEXT

\   SLITERAL	( c-addr1 u -- )		\ STRING
\		Run-time ( -- c-addr2 u )
\		Compile a string literal. Return the string on execution.

: SLITERAL	ALIGN HERE POSTPONE LITERAL DUP POSTPONE LITERAL
		CHARS HERE  2DUP + ALIGNED TO HERE
		SWAP MOVE ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameSLITERAL,SLITERAL
\		DW	ALIGNN,HERE,LITERAL,DUPP,LITERAL
\		DW	CHARS,HERE,TwoDUP,Plus,ALIGNED,DoTO,AddrHERE
\		DW	SWAP,MOVE,EXIT

\   S"          Compilation: ( "ccc<">" -- )    \ CORE
\		Run-time: ( -- c-addr u )
\		Parse ccc delimetered by " . Return the string specification
\		c-addr u on execution.

: S"		[CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameSQuote,SQuote
\		DW	DoLIT,'"',PARSE,SLITERAL,EXIT

\   SM/REM	( d n1 -- n2 n3 )		\ CORE
\		Symmetric divide of double by single. Return remainder n2
\		and quotient n3.

: SM/REM	OVER >R >R DUP 0< IF DNEGATE THEN
		R@ ABS UM/MOD DUP 0<
		IF DUP [ 16 BASE ! ] 8000 [ DECIMAL ] XOR IF -11 THROW THEN THEN \ result out of range
		R> R@ XOR 0< IF NEGATE THEN
		R> 0< IF SWAP NEGATE SWAP THEN ;

\		  $COLON  6,'SM/REM',SMSlashREM,_FLINK
\		  DW	  OVER,ToR,ToR,DUPP,ZeroLess,ZBranch,SMREM1
\		  DW	  DNEGATE
\ SMREM1	  DW	  RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,SMREM4
\		  DW	  DUPP,DoLIT,08000h,XORR,ZBranch,SMREM4
\		  DW	  DoLIT,-11,THROW
\ SMREM4	  DW	  RFrom,RFetch,XORR,ZeroLess,ZBranch,SMREM2
\		  DW	  NEGATE
\ SMREM2	  DW	  RFrom,ZeroLess,ZBranch,SMREM3
\		  DW	  SWAP,NEGATE,SWAP
\ SMREM3	  DW	  EXIT

\		$CODE	NameSMSlashREM,SMSlashREM
\		POP	DX
\		POP	AX
\		OR	DX,DX
\		JS	SMREM2
\		OR	BX,BX
\		JZ	SMREM1
\		JS	SMREM3
\		CMP	DX,BX
\		JAE	SMREM6
\		DIV	BX		;positive dividend, positive divisor
\		CMP	AX,08000h
\		JA	SMREM6
\		PUSH	DX
\		MOV	BX,AX
\		$NEXT
\ SMREM3: 	NEG	BX		;positive dividend, negative divisor
\		CMP	DX,BX
\		JAE	SMREM6
\		DIV	BX
\		CMP	AX,08000h
\		JA	SMREM6
\		MOV	BX,AX
\		PUSH	DX
\		NEG	BX
\		$NEXT
\ SMREM2: 	NEG	AX		;DNEGATE
\		ADC	DX,0
\		NEG	DX
\		OR	BX,BX
\		JZ	SMREM1
\		JS	SMREM4
\		CMP	DX,BX		;negative dividend, positive divisor
\		JAE	SMREM6
\		DIV	BX
\		CMP	AX,08000h
\		JA	SMREM6
\		NEG	DX
\		MOV	BX,AX
\		PUSH	DX
\		NEG	BX
\		$NEXT
\ SMREM4: 	NEG	BX		;negative dividend, negative divisor
\		CMP	DX,BX
\		JAE	SMREM6
\		DIV	BX
\		CMP	AX,08000h
\		JA	SMREM6
\		NEG	DX
\		MOV	BX,AX
\		PUSH	DX
\		$NEXT
\ SMREM6: 	MOV	BX,-11		;result out of range
\		JMP	THROW
\ SMREM1: 	MOV	BX,-10		;divide by zero
\		JMP	THROW
\		$ALIGN

\   SPACES	( n -- )			\ CORE
\		Send n spaces to the output device if n is greater than zero.

: SPACES	DUP 0 > IF 0 DO SPACE LOOP EXIT THEN DROP ;

\		  $COLON  6,'SPACES',SPACES,_FLINK
\		  DW	  DUPP,Zero,GreaterThan,ZBranch,SPACES1
\		  DW	  Zero,DoDO
\ SPACES2	  DW	  SPACE,DoLOOP,SPACES2
\		  DW	  EXIT
\ SPACES1	  DW	  DROP,EXIT

\		$CODE	NameSPACES,SPACES
\		OR	BX,BX
\		JLE	SPACES2
\		PUSH	SI
\		SUB	BP,CELLL
\		MOV	[BP],BX
\		MOV	BX,' '
\ SPACES4:	PUSH	BX
\		MOV	SI,OFFSET SPACES3
\		MOV	AX,AddrTickEMIT
\		JMP	AX
\ SPACES1:	DEC	WORD PTR [BP]
\		JNZ	SPACES4
\		POP	SI
\		ADD	BP,CELLL
\ SPACES2:	POP	BX
\		$NEXT
\ SPACES3 	DW	SPACES1

\   TO		Interpretation: ( x "<spaces>name" -- ) \ CORE EXT
\		Compilation:	( "<spaces>name" -- )
\		Run-time:	( x -- )
\		Store x in name.

: TO		' ?call ?DUP IF         \ should be CALL
		  ['] doVALUE =         \ verify VALUE marker
		  IF code@ STATE @
		     IF POSTPONE doTO code, EXIT THEN
		     ! EXIT
		     THEN THEN
		-32 THROW ; IMMEDIATE	\ invalid name argument (e.g. TO xxx)

\		$COLON	NameTO,TO
\		DW	Tick,QCall,QuestionDUP,ZBranch,TO1
\		DW	DoLIT,DoVALUE,Equals,ZBranch,TO1
\		DW	CodeFetch,DoLIT,AddrSTATE,Fetch,ZBranch,TO2
\		DW	DoLIT,DoTO,COMPILEComma,CodeComma,EXIT
\ TO2		DW	Store,EXIT
\ TO1		DW	DoLIT,-32,THROW

\   U.		( u -- )			\ CORE
\		Display u in free field format followed by space.

: U.		0 D. ;

\		$COLON	NameUDot,UDot
\		DW	DoLIT,0,DDot,EXIT

\   UNTIL	( C: dest -- )			\ CORE
\		Terminate a BEGIN-UNTIL indefinite loop structure.

: UNTIL		IF -22 THROW THEN  \ control structure mismatch; dest type is 0
		POSTPONE 0branch code, bal- ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameUNTIL,UNTIL
\		DW	ZBranch,UNTIL1
\		DW	DoLIT,-22,THROW
\ UNTIL1		DW	DoLIT,ZBranch,COMPILEComma,CodeComma,BalMinus,EXIT

\   VALUE	( x "<spaces>name" -- )         \ CORE EXT
\		name Execution: ( -- x )
\		Create a value object with initial value x.

: VALUE		bal IF -29 THROW THEN		\ compiler nesting
		xhere ALIGNED CELL+ TO xhere
		['] doVALUE xt, head,
		ALIGN HERE code,
		, linkLast ; \ store x and link CREATEd word to current wordlist

\		$COLON	NameVALUE,VALUE
\		DW	Bal,ZBranch,VALUE1
\		DW	DoLIT,-29,THROW
\ VALUE1		DW	XHere,ALIGNED,CELLPlus,DoTO,AddrXHere
\		DW	DoLIT,DoVALUE,xtComma,HeadComma
\		DW	ALIGNN,HERE,CodeComma
\		DW	Comma,LinkLast,EXIT

\   VARIABLE	( "<spaces>name" -- )           \ CORE
\		name Execution: ( -- a-addr )
\		Parse a name and create a variable with the name.
\		Resolve one cell of data space at an aligned address.
\		Return the address on execution.

: VARIABLE	bal IF -29 THROW THEN		\ compiler nesting
		xhere ALIGNED TO xhere
		['] compileCONST code,
		xhere CELL+ TO xhere
		['] doCONST xt, head,
		ALIGN HERE
		1 CELLS ALLOT		\ allocate one cell in data space
		code, linkLast
		lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;

\		$COLON	NameVARIABLE,VARIABLE
\		DW	Bal,ZBranch,VARIA1
\		DW	DoLIT,-29,THROW
\ VARIA1		DW	XHere,ALIGNED,DoTO,AddrXHere
\		DW	DoLIT,CompileCONST,CodeComma
\		DW	XHere,CELLPlus,DoTO,AddrXHere
\		DW	DoLIT,DoCONST,xtComma,HeadComma
\		DW	ALIGNN,HERE,DoLIT,1*CELLL,ALLOT
\		DW	CodeComma,LinkLast
\		DW	LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT

\   WHILE	( C: dest -- orig dest )	\ CORE
\		Put the location of a new unresolved forward reference orig
\		onto the control flow stack under the existing dest. Typically
\		used in BEGIN ... WHILE ... REPEAT structure.

: WHILE		POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameWHILE,WHILEE
\		DW	IFF,TwoSWAP,EXIT

\   WORD	( char "<chars>ccc<char>" -- c-addr )   \ CORE
\		Skip leading delimeters and parse a word. Return the address
\		of a transient region containing the word as counted string.

: WORD		skipPARSE HERE pack" DROP HERE ;

\		$COLON	NameWORDD,WORDD
\		DW	SkipPARSE,HERE,PackQuote,DROP,HERE,EXIT

\   [']         Compilation: ( "<spaces>name" -- )      \ CORE
\		Run-time: ( -- xt )
\		Parse name. Return the execution token of name on execution.

: [']		' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameBracketTick,BracketTick
\		DW	Tick,LITERAL,EXIT

\   [CHAR]	Compilation: ( "<spaces>name" -- )      \ CORE
\		Run-time: ( -- char )
\		Parse name. Return the value of the first character of name
\		on execution.

: [CHAR]	CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE

\		$COLON	NameBracketCHAR,BracketCHAR
\		DW	CHAR,LITERAL,EXIT

\   \		( "ccc<eol>" -- )               \ CORE EXT
\		Parse and discard the remainder of the parse area.

: \ 		SOURCE >IN ! DROP ; IMMEDIATE

\		$COLON	NameBackslash,Backslash
\		DW	SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT

\ Optional Facility words

\   EKEY?	( -- flag )			\ FACILITY EXT
\		If a keyboard event is available, return true.

: EKEY?		'ekey? EXECUTE ;

\		  $COLON  NameEKEYQuestion,EKEYQuestion
\		  DW	  TickEKEYQ,EXECUTE,EXIT

\		$CODE	NameEKEYQuestion,EKEYQuestion
\		MOV	AX,AddrTickEKEYQ
\		JMP	AX
\		$ALIGN

\   EMIT?	( -- flag )			\ FACILITY EXT
\		flag is true if the user output device is ready to accept data
\		and the execution of EMIT in place of EMIT? would not have
\		suffered an indefinite delay. If device state is indeterminate,
\		flag is true.

: EMIT?		'emit? EXECUTE ;

\		  $COLON  NameEMITQuestion,EMITQuestion
\		  DW	  TickEMITQ,EXECUTE,EXIT

\		$CODE	NameEMITQuestion,EMITQuestion
\		MOV	AX,AddrTickEMITQ
\		JMP	AX
\		$ALIGN

\ Nick
\ ' RX? TO 'ekey?
\ ' RX@ TO 'ekey
\ ' TX? TO 'emit?
\ ' TX! TO 'emit
' set-i/o TO 'init-i/o
' .ok TO 'prompt
' hi TO 'boot
' optiCOMPILE, 'doWord !
\ ' EXECUTE 'doWord 2 + !
' doubleAlso, 'doWord 4 + !
' doubleAlso 'doWord 6 + !
\ ' EXECUTE 'doWord 8 + !
\ ' EXECUTE 'doWord 10 + !

<< CON