From: vandys@lindy.stanford.edu (Andy Valencia)
Newsgroups: comp.sources.misc
Subject: Forth interpreter in 68000 assembler
Message-ID: <2931@ncoast.UUCP>
Date: 18 Jul 87 00:29:03 GMT
Sender: allbery@ncoast.UUCP
Lines: 2148
Approved: allbery@ncoast.UUCP
X-Archive: comp.sources.misc/8707/52

[68000 assembler, yes.  Motorola format, not UN*X format; you'll have to change
all "bar.l"-type opcodes to "barl" (i.e. "move.l" to "movl") to use it on a Sun
or Plexus box.  ++bsa]

	Since I'm on the warpath, here's a hand-coded 68000 forth interpreter
which conforms to the Forth-83 standard.  As I recollect, it actually deviates
from it in two areas: first, words are 32 bits. Second, I didn't do Forth-
standard I/O; I just use a pushdown stack of file descriptors, and read and
write streams.
	I don't know what the policy is concerning machine-dependent code
(especially a monstrosity like this :-)), but it sure isn't doing anyone any
good sitting around here, and I'm sure you'll know what to do with it.

				Thanks,
				Andy Valencia
				vandys@lindy.stanford.edu

#!/bin/sh-----cut here-----cut here-----cut here-----cut here-----
#    This is a shell archive.
#    Run the following text with /bin/sh to extract.

cat - << \Funky!Stuff! > Makefile
forth: forth.o
	ld -N -o forth -e init forth.o -l881 -lm
	@size forth
	@echo "Forth done"
forth.o: forth.s
	as -o forth.o forth.s
Funky!Stuff!
cat - << \Funky!Stuff! > forth.s
;
; forth.s--a 68K forth interpreter
;
; Register allocation:
;	A7--68K stack pointer
;	A6--IP
;	A5--SP
;	A4--RSP
;	A3..A0--General
;	D7--Here
;	D6--Input line pointer
;	D5..D0--General
;

;
; Flag bits in status field
;
Priority	equ	1
Smudged		equ	2

;
; control structure checking flags
;
FlgDef		equ	1	; : .. ;
FlgBeg		equ	2	; begin .. again, while, repeat
FlgWhi		equ	5	;    the "while" part flag
FlgIf		equ	3	; if .. endif
FlgDo		equ	4	; do .. loop, +loop

;
; Other constants/offsets
;
stacksize equ	100
umem	equ	96		; K of dict. space for user
rstack	ds.l	stacksize	; 100 Words for return stack
stack	ds.l	stacksize	;  and 100 for user's stack
mstack	ds.l	stacksize	;  and 100 for the 68K processor stack
Inbufsize  equ	1024+4*3	; Input buffer record
InUnit	equ	1024+1		;  Unix file descriptor number
InbufIdx   equ	1024+4		;  Holds index into it for nesting of units
InbufPrev  equ	1024+8		;  Pointer to previous input unit (nesting)
MaxIn	equ	4		; Max # open input units
MaxOut	equ	MaxIn		;  and output units
inbufs
	ds.b	1024		; Input buffer
	dc.b	0,0		;  <NULL>, <STDIN>
	ds.b	2		;  two bytes wasted
	ds.l	1		;  holds index
	dc.l	0		;  ptr to prev--is NULL for first

	ds.b	Inbufsize*(MaxIn-1) ; The rest of the input units
End_inbufs

outfds	dc.l	1		; <STDOUT>
	ds.l	MaxOut-1	;  The rest of the output units

ounit	dc.l	outfds		; Current output unit
iunit	dc.l	inbufs		;  and current input unit

;
; init--start up forth. Set up our dictionary & use ABORT
;
	globl	init
init	move.l	#udict,d7		; Set up HERE

;
; abort--clear I/O, reset stacks, clear state, enter INTERP
;
abort	
	move.l	#rstack+stacksize,a4	; Initialize return stack
	move.l	#stack+stacksize,a5	;  and user stack
	move.l	#mstack+stacksize,a7	;  and processor stack
	clr.l	state1			; Set state back to interpretive

	move.l	#interp,a6		; Set IP to top of INTERP

	move.l	#inbufs,a0		; Set up & clear input buffer
	clr.b	(a0)
	clr.b	1024(a0)
	move.l	a0,d6
	move.l	d6,iunit
	clr.b	InUnit(a0)
	move.l	#outfds,a0		; Set up & clear output buffer
	move.l	#1,(a0)
	move.l	a0,ounit

	move.l	#3,-(a7)		; Close all open files
	clr.l	-(a7)			;   Dummy place holder
	move.l	#20,d3			;  How many units to close
abor1	moveq	#6,d0			;  UNIX "close" system call
	trap	#0
	addq.l	#1,4(a7)		;  Move to next file descriptor
	dbra	d3,abor1
	add.l	#8,a7			; Remove arguments from stack
					; Fall into...
					;	     V
;
; Next--the "fetch/execute" code of FORTH
;
next	move.l	(a6)+,a0		; Get CFA's addr, advance IP
next2	move.l	(a0)+,a1		; Get contents of CFA
	jmp	(a1)			; Jump to that address

;
; interp--a high level definition
; : interp
;	getword lookup if
;		state @ 0= or if execute else [compile] (lit) , endif
;	else
;		number if
;			state @ if , endif
;		else notfound abort endif
;	endif
; ;
;
interp	dc.l	ckstack,getword,lookup,zbranch,inter1
	dc.l	state,fetch,zeq,l_or,zbranch,inter2
	dc.l	execute,branch,interp
inter2	dc.l	comma,branch,interp
inter1	dc.l	number,zbranch,inter3
	dc.l	state,fetch,zbranch,interp
	dc.l	plit,plit,comma,comma,branch,interp
inter3	dc.l	notfound

;
; or--bitwise "or"
;
l_or2   dc.l    0
l_or    dc.l    l_or1,l_or1,0
        dc.b    'or      '
l_or1   move.l  (a5)+,d0
        or.l    d0,(a5)
        jmp     next
 
;
; and--logical bit-wise AND
;
l_and2  dc.l    l_or2,l_and1,l_and1,0
        dc.b    'and     '
l_and1  move.l  (a5)+,d0
        and.l   d0,(a5)
        jmp     next
 
;
; 0<--push whether top is less than 0
;
zlt2    dc.l    l_and2,zlt1,zlt1,0
        dc.b    '0<      '
zlt1    tst.l   (a5)
        blt     puttrue
        bra     putfalse
 
;
; 0>--push whether top is greater than 0
;
zgt2    dc.l    zlt2,zgt1,zgt1,0
        dc.b    '0>      '
zgt1    tst.l   (a5)
        bgt     puttrue
        bra     putfalse
 
;
; u<--unsigned version of "less than"
;
ult2    dc.l    zgt2,ult1,ult1,0
        dc.b    'u<      '
ult1    move.l  (a5)+,d0
        cmp.l   (a5),d0
	beq	putfalse
        bcc     puttrue
        bra     putfalse
 
;
; 0=--a logical "not"
;
zeq2    dc.l    ult2
zeq     dc.l    zeq1,zeq1,0
        dc.b    '0=      '
zeq1    tst.l   (a5)
        bne     putfalse
puttrue
        move.l  #-1,(a5)
        jmp     next
putfalse
        clr.l   (a5)
        jmp     next
 
;
; <--less than. Push whether second is less than top
;
lt2	dc.l	zeq2,lt1,lt1,0
	dc.b	'<       '
lt1	move.l	(a5)+,d0
	cmp.l	(a5),d0
	bgt	puttrue
	bra	putfalse

;
; >--greater than. Push whether second is greater than top
;
gt2	dc.l	lt2,gt1,gt1,0
	dc.b	'>       '
gt1	move.l	(a5)+,d0
	cmp.l	(a5),d0
	blt	puttrue
	bra	putfalse

;
; =--push whether top and second are equal
;
equal2	dc.l	gt2,equal1,equal1,0
	dc.b	'=       '
equal1	move.l	(a5)+,d0
	cmp.l	(a5),d0
	beq	puttrue
	bra	putfalse

;
; ccomma--store a byte into the next location
;
ccomma2	dc.l	equal2,ccomma1,ccomma1,0
	dc.b	'c,      '
ccomma1	move.l	d7,a0
	move.l	(a5)+,d0	; Get word off stack
	move.b	d0,(a0)		; Store its low byte
	addq.l	#1,d7		; Advance HERE
	jmp	next

;
; comma--store a word into the next free location, advancing the
;	current location pointer
;
comma2	dc.l	ccomma2
comma	dc.l	comma1,comma1,0
	dc.b	',       '
comma1	addq.l	#3,d7		; Word-align data
	and.l	#0xFFFFFFFC,d7
	move.l	d7,a0
	move.l	(a5)+,(a0)+
	move.l	a0,d7
	jmp	next

;
; !--store second at address pointed to by top
;
store2	dc.l	comma2
store	dc.l	store1,store1,0
	dc.b	'!       '
store1	move.l	(a5)+,a0
	move.l	(a5)+,(a0)
	jmp	next

;
; @--replace top of stack with what it pointed to
;
fetch2	dc.l	store2
fetch	dc.l	fetch1,fetch1,0
	dc.b	'@       '
fetch1	move.l	(a5),a0
	move.l	(a0),(a5)
	jmp	next

;
; branch--replace IP with next sequential word in execution
;
branch2	dc.l	fetch2
branch	dc.l	branch1,branch1,0
	dc.b	'branch  '
branch1	move.l	(a6),a6
	jmp	next

;
; zbranch--"branch" if top of stack is zero
;
zbran2	dc.l	branch2
zbranch	dc.l	zbran1,zbran1,0
	dc.b	'zbranch '
zbran1	move.l	(a6)+,d0	; Get the conditional destination
	tst.l	(a5)+		; Should we take it?
	beq	zbran3
	jmp	next
zbran3	move.l	d0,a6		; Take the branch
	jmp	next

;
; run-time code to push the PFA to stack
;
getpfa	move.l	(a0),-(a5)
	jmp	next

;
; state--variable which holds the state: 0 == interp, <>0 == compiling
;
state2	dc.l	zbran2
state	dc.l	getpfa,state1,0
	dc.b	'state   '
state1	dc.l	0

;
; getword--get the next word from the input stream, put it in "pad".
;
getw2	dc.l	state2
getword	dc.l	getwo1,getwo1,0
	dc.b	'getword '
getwo1	jsr	getw1
	jmp	next

getw1	move.l	d6,a0		; A0 will be our line pointer
	jsr	skipwhite	; Skip leading white space
	move.l	#pad1,a1	; Build into "pad" via A1
	clr.b	8(a1)		;  Put in Null-termination
	move.l	#8,d1		; Count # chars stored
getw3	move.b	(a0)+,(a1)+	; Get next char
	bne.s	getw10		; Need to read in a new buffer?

	subq.l	#1,a1		;  Back up destination ptr
getw20	movem.l	a1/d1,-(a7)	;  Save registers
	jsr	getline		;  Get new line
	movem.l	(a7)+,a1/d1	;  Restore registers
	move.l	d6,a0		;  Update input line pointer
	bra.s	getw4

getw10	subq.l	#1,d1		; Decrement character count
	beq	getw5		;  If run out, truncate rest of word
getw4	jsr	iswhite		; See if at end of word
	bne	getw3
	tst.b	(a0)		; At end of buffer?
	beq.s	getw20

	tst.l	d1		; Blank-fill word
	beq	getw6
getw7	move.b	#32,(a1)+
	subq.l	#1,d1
	bne	getw7
getw6	move.l	a0,d6		; Save input pointer
	rts

getw5	tst.b	(a0)		; Get new buffer at end of current
	bne.s	getw11
	jsr	getline
	move.l	d6,a0
	bra.s	getw5
getw11	jsr	iswhite		; Quit when get white space
	beq.s	getw6
	addq.l	#1,a0		;  Skip over characters
	bra.s	getw5

;
; skipwhite--skip over white space.  For a number of bizarre reasons,
;	this is also the best place to read in a new buffer if we run
;	off the end of the current one. It is expected that all input lines
;	will end in NEWLINE--if they don't, you're taking a chance.
;
skipwhite
	jsr	iswhite		; Check next char:
	bne	skipw2		;  No white space, return
	tst.b	(a0)+		; At end of input buffer?
	bne	skipwhite	;  No--continue
	jsr	getline		;  Yes--get a fresh buffer
	move.l	d6,a0		;   update our line buffer pointer
	bra	skipwhite
skipw2	rts

;
; iswhite--return via the Z flag whether the char pointed to by A0
;	is a white space character. Uses D3 to hold the char.
;
iswhite	move.b	(a0),d3		; Get the char
	cmp.b	#32,d3		; Check space
	beq	iswh2
	cmp.b	#9,d3		;  ..Tab
	beq	iswh2
	cmp.b	#10,d3		;  ..Newline
	beq	iswh2
	tst.b	d3		;  ..NULL
iswh2	rts

;
; getline--get another buffer-full from the current input unit. If no
;	more input is available on it, pop back a level. If there are
;	no more levels (i.e., the user typed ^D), exit. If the input is
;	TTY, prompt.
;
ok_msg	dc.b	'Ok',10,'> ',0
	even
getline	move.l	iunit,a0	; Get ptr to head of current input record
	cmp.l	#inbufs,a0	; See if it's the TTY
	bne	getl9
	move.l	#ok_msg,a0	; Print "Ok"
	jsr	prstr
	move.l	iunit,a0	; restore A0

getl9	move.l	a0,d6		;  Set up our input line pointer

getl4	move.b	InUnit(a0),d0	; Get file descriptor
	ext.w	d0
        ext.l   d0              ; Turn file descriptor into longword
        move.l  #1024,-(a7)     ;  Third arg: # bytes
        move.l  a0,-(a7)        ;  Second: store buffer
        move.l  d0,-(a7)        ;  First arg is file descriptor
        clr.l   -(a7)           ;  Dummy space holder
        moveq   #3,d0		;  UNIX READ syscall
        trap    #0
        bcc     getl2           ; On carry set, abort on an I/O error
        jmp     io_err
getl2   add.l   #16,a7          ; Pop off arguments
        tst.l   d0              ; Zero bytes read means EOF--pop up a unit!
        beq.s	getl3
        add.l   d0,a0           ; Tack on the trailing NULL
        clr.b   (a0)
        rts                     ;  and return
 
getl3                           ; Hit EOF--pop back a unit, or exit
        move.l  InbufPrev(a0),d0 ; Get previous record
        beq     leave           ;  STDIN at EOF--exit
	move.l	d0,a0
        move.l  a0,iunit        ;  Update current unit
        move.l  InbufIdx(a0),d6 ;  Get the old line index
        rts
 
;
; leave--do an "exit" syscall
;
leave   move.l  #1,d0           ; Request 1 means "exit"
        clr.l   -(a7)           ;  We will give a return code of 0
        clr.l   -(a7)
        trap    #0
	trap	#1		; Shouldn't reach here!

;
; pad--an area of storage to use
;
pad2	dc.l	getw2
pad	dc.l	getpfa,pad1,0
	dc.b	'pad     '
pad1	ds.b	84

;
; lookup--search for the word represented by the first 8 bytes of PAD
;	in the dictionary. If it's not found, push FALSE. Otherwise,
;	push the CFA, the priority, and TRUE.
;
look2	dc.l	pad2
lookup	dc.l	look1,look1,0
	dc.b	'lookup  '
look1	jsr	look99
	jmp	next

look99	move.l	latest+4,a0		; Get pointer to latest definition
	move.l	pad1,d3			; Get search string
	move.l	pad1+4,d4
look5	cmp.l	16(a0),d3		; Compare first 4 bytes
	bne	look3
	cmp.l	20(a0),d4		; Compare second 4 bytes
	bne	look3
	move.l	12(a0),d5		; See if smudged
	and.l	#Smudged,d5
	bne	look3
	add.l	#4,a0			; turn A0 into CFA addr and push
	move.l	a0,-(a5)
	move.l	8(a0),d0		; Get status field
	and.l	#Priority,d0		; Push flag for priority
	move.l	d0,-(a5)
	move.l	#-1,-(a5)		; Push true flag--word found
	rts

look3	move.l	(a0),d0			; Move to next entry
	tst.l	d0			; Check null ptr (end of chain)
	beq	look4
	move.l	d0,a0			; Move back to A0
	bra	look5
look4	clr.l	-(a5)			; Not found--push false
	rts

;
; execute--pop a CFA off the stack & invoke that word
;
exec2	dc.l	look2
execute	dc.l	exec1,exec1,0
	dc.b	'execute '
exec1	move.l	(a5)+,a0
	jmp	next2

;
; number--if the string in PAD is not a legal number, push FALSE.
;	If it is, push the value and TRUE.
;
num2	dc.l	exec2
number	dc.l	num1,num1,0
	dc.b	'number  '
num1	move.l	#pad1,a0		; This is where our number is
	jsr	num99
	jmp	next

num99	clr.l	d0			; D0 accumulates the result
	move.l	base,d5			; D5 is the current base
	cmp.b	#45,(a0)		; Flag negation if leading '-' there
	seq	d3
	bne	num3
	add.l	#1,a0

num3	move.b	(a0)+,d1		; Get next char
	tst.b	d1			; At end of string?
	beq	num4
	cmp.b	#32,d1			; At the trailing blanks?
	beq	num4
	jsr	isdig			; Legal numeric digit?
	bne	num6			;  No, this isn't a number
	muls	d5,d0			;  Yes, shift and add
	add.l	d1,d0			;   ("isdigit" converts it)
	bra	num3

num4	tst.b	d3			; See if it should be negated
	beq	num5
	neg.l	d0
num5	move.l	d0,-(a5)		; Push number
	move.l	#-1,-(a5)		;  and true flag
	rts

num6	clr.l	-(a5)			; Not number, push false
	rts

;
; isdig--check whether the character in D1 is a legal digit. If it is,
;	return its value in D2, and Z set. Otherwise, return with
;	Z cleared. We assume that BASE has already been put in D5,
;
isdig	sub.l	#48,d1		; Shift '0' down to 0
	blt	isdi1		;  Was lower than '0'--can't be a digit
	cmp.b	#10,d1		; Was it 0..9?
	blt	isdi2
	sub.b	#7,d1		; Map 'A'..'F' down to 10..15
	blt	isdi1
	cmp.b	#16,d1		; Was it in range 10..15?
	blt	isdi2
	sub.b	#32,d1		; Finally, map 'a'..'f' down to 10..15
	blt	isdi1
	cmp.b	#16,d1		; Was it in range 10..15?
	bge	isdi1

isdi2	ext.w	d1		; Turn the number into a longword
	ext.l	d1
	cmp.l	d5,d1		; See if it's within the base
	bge	isdi1
	ori	#4,ccr		; Set Z--we have a legal number
	rts

isdi1	andi	#0xFB,ccr	; Clear Z--not a digit!
	rts

;
; (lit)--run-time word to push a literal onto the stack
;
plit2	dc.l	num2
plit	dc.l	plit1,plit1,0
	dc.b	'(lit)   '
plit1	move.l	(a6)+,-(a5)
	jmp	next

base2	dc.l	plit2,getpfa		; Current base for numbers
	dc.l	base,0
	dc.b	'base    '
base	dc.l	10

;
; prstr--print a string to the current output unit. No management of the
;	TTY is implied here--it just writes to the current output unit.
;	The string to print is pointed to by A0.
;
prstr	clr.l	d0		; String length counter
	move.l	a0,a1		; Local copy of the pointer
prst1	tst.b	(a1)+		; At end of string?
	beq	prst2
	add.l	#1,d0		; No, increment count
	bra	prst1		;  and loop
prst2	move.l	ounit,a1	; Build syscall parameters
	move.l	d0,-(a7)	;  Number of bytes
	move.l	a0,-(a7)	;  Buffer
	move.l	(a1),-(a7)	;  File descriptor
	clr.l	-(a7)		;  Dummy place holder
	move.l	#4,d0		; A write syscall
	trap	#0		;  Do the call
	add.l	#16,a7		; Remove the arguments
	bcc	prst3
	jmp	io_err		; Complain if the I/O failed
prst3	rts

;
; io_err--complain about an I/O error
;
io_err	move.l	#io_err_msg,a0	; The error message
	jsr	prstr
	jmp	abort
io_err_msg
	dc.b	10,'I/O error!',10,0
	even

;
; notfound--routine to call when the compiler gets a word it
;	doesn't know.
;
notf2	dc.l	base2
notfound
	dc.l	notf1,notf1,0
	dc.b	'notfound'
notf1	move.l	#pad1,a0	; Print the word
	jsr	prstr
	move.l	#notf_msg,a0	; Print ": not found"
	jsr	prstr
	jmp	abort
notf_msg
	dc.b	': not found',10,0
	even

;
; The match primitives--+, -, *, /
;
plus2	dc.l	notf2,plus1,plus1,0
	dc.b	'+       '
plus1	move.l	(a5)+,d0
	add.l	d0,(a5)
	jmp	next
sub2	dc.l	plus2,sub1,sub1,0
	dc.b	'-       '
sub1	move.l	(a5)+,d0
	sub.l	d0,(a5)
	jmp	next

	globl	_lrem
mod2	dc.l	sub2,mod1,mod1,0
	dc.b	'mod     '
mod1	move.l	(a5)+,-(sp)
	move.l	(a5),-(sp)
	jbsr	_lrem
	addq.l	#8,sp
	move.l	d0,(a5)
	jmp	next

	globl	_ldiv
div2    dc.l    mod2,div1,div1,0
        dc.b    '/       '
div1    move.l  (a5)+,-(sp)        ; Divisor
        move.l  (a5),-(sp)         ; Dividend
	jbsr	_ldiv
	addq	#8,sp
	move.l	d0,(a5)
        jmp     next

tdm2    dc.l    div2,tdm1,tdm1,0
        dc.b    '*/mod   '
tdm1    move.l  (a5)+,d0        ; Hold divisor
        move.l  (a5)+,d1        ; Get two multipliers
        move.l  (a5),d2
        muls    d1,d2
        divs    d0,d2           ; Divide into the product
        move.l  d2,d3           ; push remainder
        swap    d3
        ext.l   d3
        move.l  d3,(a5)
        ext.l   d2              ; now push quotient
        move.l  d2,-(a5)
        jmp     next
td2     dc.l    tdm2,td1,td1,0
        dc.b    '*/      '
td1     move.l  (a5)+,d0        ; Divisor
        move.l  (a5)+,d1        ; Two multipliers
        move.l  (a5),d2
        muls    d1,d2
        divs    d0,d2           ; divide into product
        ext.l   d2              ; Extend quotient to longword and push
        move.l  d2,(a5)
        jmp     next
 
divmod2 dc.l    td2,divmod1,divmod1,0
        dc.b    '/mod    '
divmod1 move.l  (a5)+,d0        ; Divisor
        move.l  (a5),d1         ; Dividend
        divs    d0,d1
        move.l  d1,d0
        swap    d0              ; Put remainder in low word
        ext.l   d0              ;  fill remainder to longword quantity
        move.l  d0,(a5)
        ext.l   d1              ; Now fill quotient to longword
        move.l  d1,-(a5)
        jmp     next

mul2    dc.l    divmod2,mul1,mul1,0
        dc.b    '*       '
mul1    move.l  (a5)+,d0
	move.w	d0,d1
	move.w	(a5)+,d0
	tst.l	d0
	beq.s	timesl1
	move.w	d1,a0
	mulu	d0,d1
	swap	d0
	mulu	(a5),d0
	add.w	d1,d0
	swap	d0
	clr.w	d0
	move.w	a0,d1
	mulu	(a5)+,d1
	add.l	d1,d0
	bra.s	timesl2
timesl1	move.w	(a5)+,d0
	mulu	d1,d0
timesl2	move.l  d0,-(a5)
        jmp     next
 
;
; u.--due to the stupidity of the 68K divide instructions, this has
;	to be just an alias for ".".
;
udot2	dc.l	mul2,dot1,dot1,0
	dc.b    'u.      '

;
; .--pop and print the top of stack in the current base
;
dot2    dc.l    udot2,dot1,dot1,0
        dc.b    '.       '
dot1    move.l	(a5)+,d0	; The number to print
	move.l	base,d2		;  In this base
	move.l	#pad1+20,a0	; Where to build the number
	clr.b	(a0)		;  A terminating NULL
	move.b	#32,-(a0)	;  Add a trailing blank
	tst.l	d0		; Handle negative numbers
	slt	d1		; Flag a negative
	move.l	d1,-(sp)
	bge	dot3
	neg.l	d0		; Negate a negative

dot3	move.l	d2,-(sp)
	move.l	d0,-(sp)
	jbsr	_lrem		; divide, getting the next digit
	addq.l	#8,sp
	add.b	#48,d0		; Move 0..9 to '0'..'9'
	cmp.b	#58,d0		; Hex digit?
	blt	dot4
	addq.b	#7,d0
dot4	move.b	d0,-(a0)	; Store the digit
	move.l	d1,d0		; Get quotient
	tst.l	d0		; All of the number printed?
	bne	dot3

	move.l	(sp)+,d2
	tst.b	d2		; Tack on a leading '-' if it's needed
	beq	dot7
	move.b	#45,-(a0)
dot7	jsr	prstr
dot9	jmp	next

;
; ckstack--check the user's stack for underflow
;
cks_msg	dc.b	'? Stack empty',10,0
	even
cks2	dc.l	dot2
ckstack	dc.l	cks1,cks1,0
	dc.b	'?stack  '
cks1	cmp.l	#stack+stacksize,a5
	ble	dot9
	move.l	#cks_msg,a0	; Underflowed--complain
	jsr	prstr
	jmp	abort

;
; words--list contents of dictionary
;
wrdpad	dc.b	'    '
word2	dc.l	cks2,word1,word1,0
	dc.b	'words   '

word1	move.l	late1,a2	; For following the dictionary chain

word3	move.l	#pad1,a1	; Set up for next line
	moveq	#6,d0		; Number of entries per line
word4	cmp.l	#0,a2		; See if at end of chain
	beq	word5
	move.l	16(a2),(a1)+	; Copy string
	move.l	20(a2),(a1)+
	move.l	wrdpad,(a1)+	; Pad with 4 spaces
	move.l	(a2),a2		; Advance to next entry
	subq.l	#1,d0
	bne	word4
word5	move.b	#10,(a1)+	; Trailing newline
	clr.b	(a1)		;  and NULL
	move.l	#pad1,a0	; Write it
	jsr	prstr
	cmp.l	#0,a2		; All done?
	bne	word3
	jmp	next

;
; make_head--build a FORTH header, return its address in
;	register A0.
;
make_head
	move.l	d7,a0		; For returning it
	move.l	d7,a1		; For storing sequentially
	move.l	late1,(a1)+	; Build this def into the chain
	move.l	d7,late1
	clr.l	(a1)+		; Empty CFA
	lea	24(a0),a2	; Point PFA to the def body
	move.l	a2,(a1)+
	clr.l	(a1)+
	movem.l	a0/a1,-(a5)	; Stash our work reg
	jsr	getw1		; Build the name in-line
	movem.l	(a5)+,a0/a1	; Stash our work reg
	move.l	pad1,(a1)+
	move.l	pad1+4,(a1)+
	move.l	a1,d7		; Reset D7
	rts

;
; variable--allocate a variable in the dictionary
;
var2	dc.l	word2,var1,var1,0
	dc.b	'variable'
var1	addq.l	#3,d7		; Word-align HERE
	and.l	#0xFFFFFFFC,d7
	jsr	make_head	; Build a header
	move.l	#getpfa,4(a0)	; Our run-time code will push the PFA
	addq.l	#4,d7		; Our body starts with one word
	jmp	next

;
; constant--allocate a constant in the dictionary
;
const2	dc.l	var2,const1,const1,0
	dc.b	'constant'
const1	addq.l	#3,d7		; Word-align HERE
	and.l	#0xFFFFFFFC,d7
	jsr	make_head	; Build header
	move.l	#getpfa,4(a0)	; run-time code pushes PFA
	move.l	(a5)+,8(a0)	; Our PFA is the number on-stack
	jmp	next

;
; colon--go into compilation mode
;
colon2	dc.l	const2,colon1,colon1,0
	dc.b	':       '
colon1	addq.l	#3,d7		; Word-align definitions
	and.l	#0xFFFFFFFC,d7
	move.l	#1,state1	; Go into compilation state
	jsr	make_head	; Build our header
	move.l	#hilev,4(a0)	; our CFA invokes a high-level def
	move.l	#Smudged,12(a0)	;  and we start Smudged
	move.l	#FlgDef,-(a5)	; Push our flag for a definition
	jmp	next

;
; semicolon--come out of compilation mode
;
semi_msg
	dc.b	'control structure not matched',10,0
	even
semi2	dc.l	colon2,semi1,semi1,Priority
	dc.b	59,'       '
semi1	clr.l	state1		; Back to interpretive state
	move.l	late1,a0	; Turn off the smudge bit
	clr.l	12(a0)
	move.l	d7,a0		; Compile in a trailing ';s'
	move.l	#popup,(a0)+
	move.l	a0,d7
	cmp.l	#FlgDef,(a5)+	; See if control structures matched
	bne	semi3
	jmp	next
semi3	move.l	#semi_msg,a0	; Complain
	jsr	prstr
	jmp	abort

;
; hilev--the machine code which sets off a high-level definition
;
hilev	move.l	a6,-(a4)	; Save old IP
	move.l	(a0),a6		; Get new IP
	jmp	next

;
; popup--aka ';s'. Pop the IP from the return stack. For exiting
;	a high-level word.
;
pop2	dc.l	semi2
popup	dc.l	pop1,pop1,0
	dc.b	59,'s      '
pop1	move.l	(a4)+,a6
	jmp	next

;
; do--build the opening part of a do..loop
;
do2	dc.l	pop2,do1,do1,Priority
	dc.b	'do      '
do1	move.l	d7,a0
	move.l	#pushr,(a0)+	; Generate code to get the loop parameters
	move.l	#pushr,(a0)+
	move.l	a0,-(a4)	; Save this place for backbranching
	move.l	#pdo,(a0)+	; compile (do)
	clr.l	(a0)+		; Leave room for our forward branch
	move.l	#FlgDo,-(a5)	; Flag our control structure
	move.l	a0,d7
do3	jmp	next

;
; (do)--run-time word to set off a do..loop
;
pdo2	dc.l	do2
pdo	dc.l	pdo1,pdo1,0
	dc.b	'(do)    '
pdo1	move.l	4(a4),d0	; Check for exit condition
	cmp.l	(a4),d0		; Check for exit condition
	blt	pdo3
	addq.l	#8,a4		; Clear the loop parameters
	move.l	(a6),a6		; Jump out of loop
	jmp	next

pdo3	addq.l	#4,a6		; Loop's not done--advance IP
	jmp	next		;  and continue

;
; loop--compile in the closing part of a loop
;
loop2	dc.l	pdo2,loop1,loop1,Priority
	dc.b	'loop    '
loop1	cmp.l	#FlgDo,(a5)	; See if they botched
	bne	loop3
	addq.l	#4,a5		; Free the flag
	move.l	d7,a0
	move.l	#ploop,(a0)+	; Compile (loop)
	move.l	(a4)+,a1	; Get address of "loop"
	move.l	a1,(a0)+	; This is our backbranch address
	move.l	a0,4(a1)	; Give them the forward branch address
	move.l	a0,d7		; Restore HERE
	jmp	next
loop3	move.l	#loop_msg,a0
	jsr	prstr
	jmp	abort
loop_msg
	dc.b	10,'do not matched by loop',10,0
	even

;
; +loop--compile in the closing part of a loop
;
aloop2	dc.l	loop2,aloop1,aloop1,Priority
	dc.b	'+loop   '
aloop1	cmp.l	#FlgDo,(a5)	; See if they botched
	bne	aloop3
	addq.l	#4,a5		; Free the flag
	move.l	d7,a0
	move.l	#paloop,(a0)+	; Compile (loop)
	move.l	(a4)+,a1	; Get address of "loop"
	move.l	a1,(a0)+	; This is our backbranch address
	move.l	a0,4(a1)	; Give them the forward branch address
	move.l	a0,d7		; Restore HERE
	jmp	next
aloop3	move.l	#loop_msg,a0
	jsr	prstr
	jmp	abort
aloop_msg
	dc.b	10,'do not matched by +loop',10,0
	even

;
; (+loop)--run-time loop execution
;
paloop2	dc.l	aloop2
paloop	dc.l	paloop1,paloop1,0
	dc.b	'(+loop) '
paloop1	move.l	(a5)+,d0	; Add on number from user's stack
	add.l	d0,4(a4)
	move.l	(a6),a6		; branch back
	jmp	next

;
; (loop)--run-time loop execution
;
ploop2	dc.l	paloop2
ploop	dc.l	ploop1,ploop1,0
	dc.b	'(loop)  '
ploop1	addq.l	#1,4(a4)	; Increment the run-time index
	move.l	(a6),a6		; branch back
	jmp	next

;
; >r--pop top of operand stack & push on return stack
;
pushr2	dc.l	ploop2
pushr	dc.l	pushr1,pushr1,0
	dc.b	'>r      '
pushr1	move.l	(a5)+,-(a4)
	jmp	next

;
; r>--pop top of return stack & push on operand stack
;
popr2   dc.l    pushr2
popr    dc.l    popr1,popr1,0
        dc.b    'r>      '
popr1   move.l  (a4)+,-(a5)
        jmp     next
 
;
; r@--copy top of return stack to user stack
;
rget2   dc.l    popr2,rget1,rget1,0
        dc.b    'r@      '
rget1   move.l  (a4),-(a5)
        jmp     next
 
;
; depth--tell how many elements are on user stack
;
depth2  dc.l    rget2,depth1,depth1,0
        dc.b    'depth   '
depth1  move.l  #stack+stacksize,d0
        sub.l   a5,d0
        asr.l   #2,d0
        move.l  d0,-(a5)
        jmp     next
 
;
; i--push index of innermost do..loop context
;
push_i2 dc.l    depth2,push_i1,push_i1,0
        dc.b    'i       '
push_i1 move.l  4(a4),-(a5)
        jmp     next
;
; j--like i, but second most-innermost
;
push_j2 dc.l    push_i2,push_j1,push_j1,0
        dc.b    'j       '
push_j1 move.l  12(a4),-(a5)
        jmp     next

;
; leave--jump out of the innermost loop structure. Note that control
;	structure matching isn't done here, since we will probably be
;	inside of multiple if..endif contexts--meaningful error checking
;	would be very difficult to provide.
;
leave2	dc.l	push_j2,leave1,leave1,Priority
	dc.b	'leave   '
leave1	move.l	(a4),a1		; This is the address of the (do) part
	move.l	d7,a0		; We will be compiling some stuff in:
	move.l	#pleave,(a0)+	;  (leave)
	addq.l	#4,a1		;  addr of the exit location--(do)+1
	move.l	a1,(a0)+
	move.l	a0,d7
	jmp	next

;
; (leave)--fetch via the word which follows us, and make that the IP
;
pleave2	dc.l	leave2
pleave	dc.l	pleave1,pleave1,0
	dc.b	'(leave) '
pleave1	move.l	(a6),a0		; Addr of exit address
	move.l	(a0),a6		; Set IP to it
	addq.l	#8,a4		; Clear the do..loop's parameters of rstack
	jmp	next

;
; if--starting part of a conditional
;
if2	dc.l	pleave2,if1,if1,Priority
	dc.b	'if      '
if1	move.l	d7,a0
	move.l	#zbranch,(a0)+	; If false, branch around
	move.l	a0,-(a5)	;  save this place for back-branch
	clr.l	(a0)+		;  leave room for it
	move.l	a0,d7
	move.l	#FlgIf,-(a5)	; Flag the control structure
	jmp	next

;
; else--optional middle part of a conditional
;
else2	dc.l	if2,else1,else1,Priority
	dc.b	'else    '
else1	cmp.l	#FlgIf,(a5)	; Check control structure
	bne	else3
	move.l	d7,a0
	move.l	4(a5),a1	; Save location to backpatch
	move.l	#branch,(a0)+	; Patch in a branch out of the conditional
	move.l	a0,4(a5)	;  the new back-patch location
	clr.l	(a0)+
	move.l	a0,(a1)		; Now patch in address of false part of cond.
	move.l	a0,d7
	jmp	next

else3	move.l	#else_msg,a0	; Complain about bad control structure
	jsr	prstr
	jmp	abort
else_msg
	dc.b	10,'else does not match an if',10,0
	even

;
; endif--ending part of a conditional
;
endif2	dc.l	else2,endif1,endif1,Priority
	dc.b	'endif   '
endif1	cmp.l	#FlgIf,(a5)	; Check control strucure
	bne	endif3
	addq.l	#4,a5		; Pop off flag
	move.l	(a5)+,a0	; Get address to back-patch
	move.l	d7,(a0)		;  backpatch it
	jmp	next

endif3	move.l	#endif_msg,a0	; complain
	jsr	prstr
	jmp	abort
endif_msg
	dc.b	10,'endif does not match if/else',10,0
	even

;
; stack manipulation words--dup, swap, rot, -rot, drop, over
;
over2   dc.l    endif2,over1,over1,0
        dc.b    'over    '
over1   move.l  4(a5),-(a5)
        jmp     next
pick2   dc.l    over2,pick1,pick1,0
        dc.b    'pick    '
pick1   move.l  (a5)+,d0
        asl.l   #2,d0           ; Scale D0 for a word offset
        move.l  0(a5,d0.l),-(a5)
        jmp     next
roll2   dc.l    pick2,roll1,roll1,0
        dc.b    'roll    '
roll1   move.l  (a5)+,d0
        asl.l   #2,d0
        move.l  0(a5,d0.l),d1           ; Save word rolling into
roll3   tst.l   d0                      ; While not to top of stack...
        beq     roll4
        move.l  -4(a5,d0.l),0(a5,d0.l)  ; Copy down a word
        subq.l  #4,d0                   ; Advance a word
        bra     roll3
roll4   move.l  d1,(a5)                 ; Replace top with word
        jmp     next
dup2    dc.l    roll2,dup1,dup1,0
        dc.b    'dup     '
dup1    move.l  (a5),-(a5)
        jmp     next
qdup2   dc.l    dup2,qdup1,qdup1,0
        dc.b    '?dup    '
qdup1   move.l  (a5),d0
        beq     qdup3
        move.l  d0,-(a5)
qdup3   jmp    next
swap2   dc.l    qdup2,swap1,swap1,0
        dc.b    'swap    '
swap1   move.l  (a5)+,d0
        move.l  (a5),d1
        move.l  d0,(a5)
        move.l  d1,-(a5)
        jmp     next
rot2    dc.l    swap2,rot1,rot1,0
        dc.b    'rot     '
rot1    move.l  (a5)+,d0
        move.l  (a5)+,d1
        move.l  (a5),d2
        move.l  d1,(a5)
        move.l  d0,-(a5)
        move.l  d2,-(a5)
        jmp     next
drot2   dc.l    rot2,drot1,drot1,0
        dc.b    '-rot    '
drot1	move.l	(a5)+,d0
	move.l	(a5)+,d1
  move.l  (a5),d2
        move.l  d0,(a5)
        move.l  d2,-(a5)
        move.l  d1,-(a5)
        jmp     next
drop2   dc.l    drot2,drop1,drop1,0
        dc.b    'drop    '
drop1   addq.l  #4,a5
        jmp     next
 
;
; begin--start a structured loop
;
beg2    dc.l    drop2,beg1,beg1,Priority
        dc.b    'begin   '
beg1    move.l  d7,-(a5)
        move.l  #FlgBeg,-(a5)
        jmp     next
 
;
; again--unconditional branch back; an infinite loop
;
again2  dc.l    beg2,again1,again1,Priority
        dc.b    'again   '
again1  cmp.l   #FlgBeg,(a5)
        bne     again3          
        addq.l  #4,a5
        move.l  d7,a0
        move.l  #branch,(a0)+
        move.l  (a5)+,(a0)+
        move.l  a0,d7
        jmp     next
again3  move.l  #again_msg,a0
        jsr     prstr
        jmp     abort
again_msg
        dc.b    10,'again does not match a begin',10,0
        even
 
;
; until--branch back until condition becomes true
;
until2  dc.l    again2,until1,until1,Priority
        dc.b    'until   '
until1  cmp.l   #FlgBeg,(a5)
        bne     until3
        addq.l  #4,a5
        move.l  d7,a0
        move.l  #zbranch,(a0)+
        move.l  (a5)+,(a0)+
        move.l  a0,d7
        jmp     next
until3  move.l  #until_msg,a0
        jsr     prstr
        jmp     abort
until_msg
        dc.b    10,'until does not match a begin',10,0
        even
 
;
; while..repeat: loop with exit check up front
;
while2	dc.l	until2,while1,while1,Priority
	dc.b	'while   '
while1	cmp.l	#FlgBeg,(a5)		; Check control structure
	bne	while3
	move.l	d7,a0
	move.l	#zbranch,(a0)+		; Branch out on false
	move.l	a0,(a5)			;  save where to backpatch
	clr.l	(a0)+
	move.l	a0,d7
	move.l	#FlgWhi,-(a5)		; And place our own flag
	jmp	next
while3	move.l	#while_msg,a0		; Complain
	jsr	prstr
	jmp	abort
while_msg
	dc.b	10,'while does not match a begin',10,0
	even

;
; repeat--the closing part of a begin..while..repeat structure
;
rep2	dc.l	while2,rep1,rep1,Priority
	dc.b	'repeat  '
rep1	cmp.l	#FlgWhi,(a5)		; Check control structure
	bne	rep3
        addq.l  #4,a5
        move.l  (a5)+,a1                ; Save where to backpatch
        move.l  d7,a0
        move.l  #branch,(a0)+           ; Generate a backbranch
        move.l  (a5)+,(a0)+             ;  to top of loop
        move.l  a0,d7
        move.l  d7,(a1)                 ; Backpatch exit location, HERE
        jmp     next
rep3    move.l  #rep_msg,a0             ; Complain
        jsr     prstr
        jmp     abort
rep_msg dc.b    10,'repeat does not match a while',10,0
        even
 
;
; xor--exclusive OR
;
xor2    dc.l    rep2,xor1,xor1,0
        dc.b    'xor     '
xor1    move.l  (a5)+,d0
        eor     d0,(a5)
        jmp     next
 
;
; not--one's complement
;
not2    dc.l    xor2,not1,not1,0
        dc.b    'not     '
not1    eor     #0xFFFFFFFF,(a5)
        jmp     next
 
;
; 1+, 1-, 2+, 2-, 2*, 2/--common, quick math operations
;
onep2   dc.l    not2,onep1,onep1,0
        dc.b    '1+      '
onep1   addq.l  #1,(a5)
        jmp     next
onem2   dc.l    onep2,onem1,onem1,0
        dc.b    '1-      '
onem1   subq.l  #1,(a5)
        jmp     next
twop2   dc.l    onem2,twop1,twop1,0
        dc.b    '2+      '
twop1   addq.l  #2,(a5)
        jmp     next
twom2   dc.l    twop2,twom1,twom1,0
        dc.b    '2-      '
twom1   subq.l  #2,(a5)
        jmp     next
twot2   dc.l    twom2,twot1,twot1,0
        dc.b    '2*      '
twot1   move.l  (a5),d0
        asl.l   #1,d0
        move.l  d0,(a5)
        jmp     next
twod2   dc.l    twot2,twod1,twod1,0 
        dc.b    '2/      '
twod1   move.l  (a5),d0
        asr.l   #1,d0
        move.l  d0,(a5)
        jmp     next
 
;
; c@, c!--character fetch/store
;
cfetch2 dc.l    twod2,cfetch1,cfetch1,0
        dc.b    'c@      '
cfetch1 move.l  (a5),a0
        move.b  (a0),d0
        ext.w   d0
        ext.l   d0
        move.l  d0,(a5)
        jmp     next
cstore2 dc.l    cfetch2,cstore1,cstore1,0
        dc.b    'c!      '
cstore1 move.l  (a5)+,a0
        move.l  (a5)+,d0
        move.b  d0,(a0)
        jmp     next
pstore2 dc.l    cstore2,pstore1,pstore1,0
        dc.b    '+!      '
pstore1 move.l  (a5)+,a0
        move.l  (a5)+,d0
        add.l   d0,(a0)
        jmp     next
 
;
; min and max--push greater or less of two numbers
;
min2    dc.l    pstore2,min1,min1,0
        dc.b    'min     '
min1    move.l  (a5)+,d0
        cmp.l   (a5),d0
        bge     min3
min4    move.l  d0,(a5)
min3    jmp     next
max2    dc.l    min2,max1,max1,0
        dc.b    'max     '
max1    move.l  (a5)+,d0
        cmp.l   (a5),d0
        ble     min3
        bra     min4
 
;
; abs, negate--replace number with its absolute value or negation
;
abs2    dc.l    max2,abs1,abs1,0
        dc.b    'abs     '
abs1    move.l  (a5),d0
        bge     min3
        neg.l   (a5)
        jmp     next
neg2    dc.l    abs2,neg1,neg1,0
        dc.b    'negate  '
neg1    neg.l   (a5)
        jmp     next
 
;
; cmove--move a range of bytes
;
cmov2	dc.l	neg2,cmov1,cmov1,0
	dc.b	'cmove   '
cmov1	move.l	(a5)+,d0	; Count
	move.l	(a5)+,a0	; Destination
	move.l	(a5)+,a1	; Source
	tst.l	d0		; Catch case of zero-length
	beq	cmov4
cmov3	move.b	(a1)+,(a0)+	; Move bytes
	dbra	d0,cmov3
cmov4	jmp	next

;
; cmove>--like cmove, but set up to guard against the "ripple" effect
;
cmovu2	dc.l	cmov2,cmovu1,cmovu1,0
	dc.b	'cmove>  '
cmovu1	move.l	(a5)+,d0	; Count
	move.l	(a5)+,a0	; Destination
	move.l	(a5)+,a1	; Source
	tst.l	d0		; Zero-length?
	beq	cmov4
	add.l	d0,a0		; Point to end of destination
	add.l	d0,a1		;  same for source
cmovu3	move.b	-(a1),-(a0)	; Move bytes
	dbra	d0,cmovu3
	jmp	next

;
; fill--fill a range of bytes with a constant
;
fill2	dc.l	cmovu2,fill1,fill1,0
	dc.b	'fill    '
fill1	move.l	(a5)+,d0	; Get byte constant to use
	move.l	(a5)+,d1	; # Bytes to fill
	move.l	(a5)+,a0	; Where to start
	tst.l	d0		; Avoid zero-length
	beq	cmov4
fill3	move.b	d0,(a0)+	; Fill bytes
	subq.l	#1,d1
	bne	fill3
	jmp	next

;
; count--get byte at addr, advance addr
;
count2	dc.l	fill2,count1,count1,0
	dc.b	'count   '
count1	move.l	(a5),a0		; Get addr
	move.b	(a0)+,d0	; Get byte at addr, advance
	move.l	a0,(a5)		; Store back addr
	ext.w	d0		;  and extended byte
	ext.l	d0
	move.l	d0,-(a5)
	jmp	next

;
; -trailing--trim trailing spaces
;
dtrail2	dc.l	count2,dtrail1,dtrail1,0
	dc.b	'-trailin'
dtrail1	move.l	(a5)+,d0	; Current count
	beq	dtrail4		;  handle zero-length
	move.l	(a5),a0		; Address of string
	add.l	d0,a0		; Get address of current end of string
dtrail3	cmp.b	#32,-(a0)	; Check next char
	beq	dtrail4
	subq.l	#1,d0
	bne	dtrail3
dtrail4	move.l	d0,-(a5)	; Push back count
	jmp	next

;
; decimal, hex, octal--set BASE
;
deci2	dc.l	dtrail2,deci1,deci1,0
	dc.b	'decimal '
deci1	move.l	#10,base
	jmp	next
hexa2	dc.l	deci2,hexa1,hexa1,0
	dc.b	'hex     '
hexa1	move.l	#16,base
	jmp	next
octa2	dc.l	hexa2,octa1,octa1,0
	dc.b	'octal   '
octa1	move.l	#8,base
	jmp	next

;
; The number printing words--<# # #> #s hold sign
;
lsh_pos	ds.l	1			; Position in output buffer

lsh2	dc.l	octa2,lsh1,lsh1,0
	dc.b	'<#      '		; Prepare for conversion
lsh1	move.l	#pad1+70,lsh_pos
	jmp	next

sh2	dc.l	lsh2,sh1,sh1,0
	dc.b	'#       '		; Convert next digit
sh1	jsr	sh99
	jmp	next

sh99	move.l	base,-(sp)		;  get BASE--format is wrong in mem.
	move.l	(a5),-(sp)
	jbsr	_lrem
	move.l	d1,(a5)			;  put quotient back to stack
	add.l	#48,d0			;  Remainder: map 0 to '0'
	cmp.l	#58,d0			;  Check for HEX digits
	blt	sh3
	addq.l	#7,d0			;  Map 10 to 'A'
sh3	move.l	lsh_pos,a0		;  Store character into PAD, advance
	move.b	d0,-(a0)
	move.l	a0,lsh_pos
	rts

shg2	dc.l	sh2,shg1,shg1,0
	dc.b	'#>      '		; End conversion
shg1	move.l	lsh_pos,d0
	move.l	d0,(a5)			; Push address
	move.l	#pad1+70,d1		; Calculate count
	sub.l	d0,d1
	move.l	d1,-(a5)		; Push count
	jmp	next

shs2	dc.l	shg2,shs1,shs1,0
	dc.b	'#s      '		; Convert all remaining digits
shs1	jsr	sh99			; Do a digit
	tst.l	(a5)			; See if done
	bne	shs1
	jmp	next

hold2	dc.l	shs2,hold1,hold1,0
	dc.b	'hold    '		; Put a char into the string
hold1	move.l	lsh_pos,a0
	move.l	(a5)+,d0
	move.b	d0,-(a0)
	move.l	a0,lsh_pos
hold3	jmp	next

sign2	dc.l	hold2,sign1,sign1,0
	dc.b	'sign    '		; Add a '-' if sign negative
sign1	tst.l	(a5)+
	bge	hold3
	move.l	#45,-(a5)
	bra	hold1

;
; ."--generate code to print a string at run-time
;
dotq2	dc.l	sign2,dotq1,dotq1,Priority
	dc.b	'."      '
dotq1	move.l	d7,a0
	move.l	#pdotq,(a0)+	; Compile (.")
	move.l	d6,a1		; Get line pointer
	addq.l	#1,a1		;  advance past current word delimiter
dotq3
	move.b	(a1)+,d0	; Get next char
	beq	dotq5		;  read a new buffer if we run out
	cmp.b	#34,d0		; End when we find the closing "
	beq	dotq4
	move.b	d0,(a0)+	; Add the character
	bra	dotq3

dotq5	move.l	a0,-(sp)
	jsr	getline		; Get new buffer
	move.l	(sp)+,a0
	move.l	d6,a1
	bra	dotq3

dotq4	clr.b	(a0)+		; Terminating NULL
	move.l	a1,d6		; Update line pointer
	move.l	a0,d7
	addq.l	#3,d7		; Longword-align DP
	and.l	#0xFFFFFFFC,d7
	jmp	next

;
; (.")--run-time word to print a string
;
pdotq2	dc.l	dotq2
pdotq	dc.l	pdotq1,pdotq1,0
	dc.b	'(.")    '
pdotq1	move.l	a6,a0
	jsr	prstr
pdotq3	tst.b	(a6)+		; Skip past text
	bne	pdotq3
	move.l	a6,d0
	addq.l	#3,d0		; Align IP
	and.l	#0xFFFFFFFC,d0
	move.l	d0,a6
	jmp	next

;
; .(--print a message to the terminal from the input stream
;
dotp2	dc.l	pdotq2,dotp1,dotp1,Priority
	dc.b	'.(      '
dotp1	move.l	d6,a1		; Get line pointer
	addq.l	#1,a1		;  advance past current word delimiter
	move.l	#pad1,a0	; Build message into PAD

dotp3	move.b	(a1)+,d0	; Get next char
	beq	dotp5		;  read a new buffer if we run out
	cmp.b	#41,d0		; End when we find the closing "
	beq	dotp4
	move.b	d0,(a0)+	; Add the character
	bra	dotp3

dotp5	jsr	getline		; Get new buffer
	move.l	d6,a1
	bra	dotp3

dotp4	clr.b	(a0)+		; Terminating NULL
	move.l	a1,d6		; Update line pointer
	move.l	#pad1,a0	; Print the message
	jsr	prstr
	jmp	next

;
; cr--print newline
;
cr_msg	dc.b	10,0
cr2	dc.l	dotp2,cr1,cr1,0
	dc.b	'cr      '
cr1	move.l	#cr_msg,a0
	jsr	prstr
	jmp	next

;
; emit--print out a character
;
emit_buf
	ds.b	1
	dc.b	0,0,0		; Terminating NULL, 2 wasted
emit2	dc.l	cr2,emit1,emit1,0
	dc.b	'emit    '
emit1	move.l	(a5)+,d0
	move.b	d0,emit_buf
	move.l	#emit_buf,a0
	jsr	prstr
	jmp	next

;
; type--print out a string given a count & a pointer
;
type2	dc.l	emit2,type1,type1,0
	dc.b	'type    '
type1	move.l	(a5)+,d0	; Count
	move.l	(a5)+,a0	; Addr
	move.l	#pad1,a1	; Where to buffer to
type3	tst.l	d0		; Out of chars?
	beq	type4
	move.b	(a0)+,(a1)+	; Store a char
	subq.l	#1,d0		; Decrement count
	bra	type3
type4	clr.b	(a1)		; Terminating NULL
	move.l	#pad1,a0
	jsr	prstr
	jmp	next

;
; space--emit a space
;
space2	dc.l	type2,space1,space1,0
	dc.b	'space   '
space1	move.l	#32,-(a5)
	bra	emit1

;
; spaces--emit N spaces
;
spac_buf			; A printable space
	dc.b	32,0,0,0
spaces2	dc.l	space2,spaces1,spaces1,0
	dc.b	'spaces  '
spaces1	tst.l	(a5)		; Enough spaces?
	beq	spaces3
	move.l	#spac_buf,a0
	jsr	prstr
	sub.l	#1,(a5)		; Decrement count
	bra	spaces1
spaces3	addq.l	#4,a5		; Pop count
	jmp	next

;
; key--get a key from STDIN. Normally, this will block until a whole
;	line is entered. However, if the TTY is put into RAW mode,
;	this will respond on a key-by-key basis.
;
keybuf	ds.l	1		; Holds the keystroke
key2	dc.l	spaces2,key1,key1,0
	dc.b	'key     '
key1	move.l	#1,-(a7)	; Build READ syscall parameters--1 byte
	move.l	#keybuf,-(a7)	;  buffer address
	clr.l	-(a7)		;  0--STDIN
	clr.l	-(a7)		;  dummy
        moveq   #3,d0		;  UNIX READ syscall
	trap	#0
	add.l	#16,a7		; Remove the parameters from stack
	move.b	keybuf,d0	; Push byte
	ext.w	d0
	ext.l	d0
	move.l	d0,-(a5)
	jmp	next

;
; expect--read a number of chars from the terminal
;
expect2	dc.l	key2,expect1,expect1,0
	dc.b	'expect  '
expect1	move.l	(a5)+,-(a7)	; UNIX syscall: N bytes
	move.l	(a5)+,-(a7)	;  to buffer
	clr.l	-(a7)		;  STDIN
	clr.l	-(a7)		;  dummy
        moveq   #3,d0		;  UNIX READ syscall
	trap	#0
	move.l	d0,span		; Store # bytes read
	add.l	#16,a7		; Remove the parameters from stack
	jmp	next
span2	dc.l	expect2,getpfa,span,0
	dc.b	'span    '
span	ds.l	1

;
; abort--jump to abort
;
abort2	dc.l	span2
do_abort dc.l	abort,abort,0
	dc.b	'abort   '

;
; abort"--if top is true, print a message and abort
;
qabort2	dc.l	abort2,qabort1,qabort1,Priority
	dc.b	'abort"  '
qabort1	move.l	d7,a0
	move.l	#zbranch,(a0)+	; Skip the whole shebang on false
	move.l	a0,a2		; Mark where to backpatch
	clr.l	(a0)+		; Leave room for the branch address

	move.l	#pdotq,(a0)+	; Compile (.")
	move.l	d6,a1		; Get line pointer
	addq.l	#1,a1		;  advance past current word delimiter
qabort3
	move.b	(a1)+,d0	; Get next char
	beq	qabort5		;  read a new buffer if we run out
	cmp.b	#34,d0		; End when we find the closing "
	beq	qabort4
	move.b	d0,(a0)+	; Add the character
	bra	qabort3

qabort5	jsr	getline		; Get new buffer
	move.l	d6,a1
	bra	qabort3

qabort4	clr.b	(a0)+		; Terminating NULL
	move.l	a1,d6		; Update line pointer
	move.l	a0,d7
	addq.l	#3,d7		; Longword-align DP
	and.l	#0xFFFFFFFC,d7
	move.l	d7,a0
	move.l	#do_abort,(a0)+	; Put in ABORT
	move.l	a0,d7
	move.l	d7,(a2)		; Backpatch false case
	jmp	next

;
; quit--leave parameter stack alone, but return to INTERP
;
quit2	dc.l	qabort2,quit1,quit1,0
	dc.b	'quit    '
quit1	move.l	#rstack+stacksize,a4	; Clear return stack
	move.l	#interp,a6
	jmp	next

;
; here--push address of next free location
;
here2	dc.l	quit2,here1,here1,0
	dc.b	'here    '
here1	move.l	d7,-(a5);
	jmp	next

;
; tib--address of text input buffer
;
tib2	dc.l	here2,tib1,tib1,0
	dc.b	'tib     '
tib1	move.l	iunit,-(a5)
	jmp	next

;
; >body--turn pointer to CFA field into pointer to parameter field
;
gbod2	dc.l	tib2,gbod1,gbod1,0
	dc.b	'>body   '
gbod1	move.l	(a5),a0
	move.l	4(a0),(a5)
	jmp	next

;
; (--start a forth comment )
;
paren2	dc.l	gbod2,paren1,paren1,Priority
	dc.b	'(       '	; )
paren1	move.l	d6,a0
paren4	move.b	(a0)+,d0	; Get next char
	cmp.b	#41,d0		; End on closing paren
	beq	paren3
	tst.b	d0		; Get new buffer on end of current
	bne	paren4
	jsr	getline
	bra	paren1
paren3	move.l	a0,d6		; Restore line pointer
	jmp	next

;
; allot--allocate N bytes off end of dictionary
;
allot2	dc.l	paren2,allot1,allot1,0
	dc.b	'allot   '
allot1	move.l	(a5)+,d0
	add.l	d0,d7
	jmp	next

;
; does>--terminate execution of word which calls this, but also set it up
;	so that the LATEST word has its PFA directed to after this word.
;	: definer create ...1... does> ...2... ;
;	Will be used as: definer <word>
;	<word> will be added to the dictionary, and ...1... may do any
;	actions it wishes. When <word> is later executed, it will run
;	the code ...2...
;
does2	dc.l	allot2,does1,does1,Priority
	dc.b	'does>   '
does1	move.l	d7,a0
	move.l	#pdoes,(a0)+	; Compile in (does)
	move.l	a0,d7
	jmp	next
pdoes2	dc.l	does2
pdoes	dc.l	pdoes1,pdoes1,0
	dc.b	'(does)  '
pdoes1	move.l	late1,a0	; Get LFA of latest definition
	move.l	#hilev,4(a0)	; Make this execute as a high-level def
	move.l	a6,8(a0)	; Fill in PFA with rest of this word's body
	move.l	(a4)+,a6	; Return from this word
	jmp	next

;
; immediate--set the Priority bit of the latest definition
;
immed2	dc.l	pdoes2,immed1,immed1,0
	dc.b	'immediat'
immed1	move.l	late1,a0
	or.l	#Priority,12(a0)	; Set Priority in SFA word
	jmp	next

;
; [compile], compile--immediate & non-immediate versions of compile
;
bcomp2	dc.l	immed2,bcomp1,bcomp1,Priority
	dc.b	'[compile'
bcomp1	jsr	getw1		; Fetch next word from stream
	jsr	look99		; See if it can be found
	tst.l	(a5)+		; Error if it couldn't
	beq	bcomp3
	addq.l	#4,a5		; Drop the priority field
	move.l	d7,a0		; Compile in CFA
	move.l	(a5)+,(a0)+
	move.l	a0,d7
	jmp	next
bcomp3	jmp	notf1		; Not found: complain

comp2	dc.l	bcomp2,bcomp1,bcomp1,0
	dc.b	'compile '

;
; literal--compile a literal
;
lit2	dc.l	comp2,lit1,lit1,Priority
	dc.b	'literal '
lit1	move.l	d7,a0
	move.l	#plit,(a0)+
	move.l	(a5)+,(a0)+
	move.l	a0,d7
	jmp	next

;
; [, ]--turn compilation off & on, respectively
;
compon2	dc.l	lit2,compon1,compon1,0
	dc.b	']       '
compon1	move.l	#-1,state1
	jmp	next
compof2	dc.l	compon2,compof1,compof1,Priority
	dc.b	'[       '
compof1	clr.l	state1
	jmp	next

;
; word--get a word from the input stream, put in string
;
word_buf ds.b	84
gword2	dc.l	compof2,gword1,gword1,0
	dc.b	'word    '
gword1	move.l	(a5)+,d0	; Delimiter char
	move.l	#word_buf+1,a0	; Where to put the chars
	move.l	d6,a1		; Input line buffer
	clr.l	d2		; Count # chars received
gword3	move.b	(a1)+,d1	; Get next char
	beq	gword4		;  get new bufferfull if current empty
	cmp.b	d0,d1		; Found delimiter?
	beq	gword5
	move.b	d1,(a0)+	; Store char
	addq.l	#1,d2		; Increment count
	bra	gword3
gword4
	movem.l	d0/a0,-(a7)	; Save d0 and a0
	jsr	getline		; Get next line
	movem.l	(a7)+,d0/a0
	move.l	d6,a1
	bra	gword3
gword5
	clr.b	(a0)		; Add NULL termination
	move.b	d2,word_buf	; Store count in first byte
	move.l	a1,d6		; Update line pointer
	move.l	#word_buf,-(a5)	; Return pointer to it
	jmp	next

;
; >in--give a byte offset into current buffer
;
to_in2	dc.l	gword2,to_in1,to_in1,0
	dc.b	'>in     '
to_in1	move.l	d6,d0
	sub.l	iunit,d0
	move.l	d0,-(a5)
	jmp	next

;
; #tib--length of current input buffer
;
ntib2	dc.l	to_in2,ntib1,ntib1,0
	dc.b	'#tib    '
ntib1	move.l	iunit,a0	; Ptr into buf
	clr.l	d1		; Counter of # chars
ntib3	tst.b	(a0)+		; Check next byte
	beq	ntib4
	addq.l	#1,d1
	bra	ntib3
ntib4	move.l	d1,-(a5)	; Push count
	jmp	next

;
; create--create a dictionary entry
;
creat2	dc.l	ntib2,creat1,creat1,0
	dc.b	'create  '
creat1	jsr	make_head	; Build the header
	move.l	#getpfa,4(a0)	; Set it up to be variable/constant
	jmp	next

;
; '--push address of CFA
;
tick2	dc.l	creat2,tick1,tick1,0
	dc.b	39,'       '
tick1	jsr	getw1		; Get word
	jsr	look99		; Look up word
	tst.l	(a5)+		; Abort on error
	beq	tick3
	addq.l	#4,a5		; Drop priority flag
	jmp	next
tick3
	jmp	notf1

;
; [']--for compiling in a compilation address as a literal
;
btick2	dc.l	tick2,btick1,btick1,Priority
	dc.b	'[',39,']     '
btick1	jsr	getw1		; Get word
	jsr	look99		; Look up word
	tst.l	(a5)+		; Abort on error
	beq	tick3
	addq.l	#4,a5		; Drop priority flag
	move.l	d7,a0		; Compile in (lit)
	move.l	#plit,(a0)+
	move.l	(a5)+,(a0)+	;  <compilation addr>
	move.l	a0,d7
	jmp	next

;
; find--find a string in the dictionary
;
find2	dc.l	btick2,find1,find1,0
	dc.b	'find    '
find1	move.l	latest+4,a0		; Get pointer to latest definition
	move.l	(a5),a1			; Get search string
	move.l	(a1),d3
	move.l	4(a1),d4
	jsr	look5			; Go find the string
	tst.l	(a5)			; See if it was found
	beq	find3			;  wasn't, can just return
	addq.l	#4,a5			; Was, pop boolean flag
	tst.l	(a5)+			; Change priority flag
	bne	find4

	move.l	(a5),4(a5)		; Move comp addr over string addr
	move.l	#-1,(a5)		;  not priority, flag -1
	bra	find3

find4	move.l	(a5),4(a5)		; Move comp addr over string addr
	move.l	#1,(a5)			;  was priority, flag 1

find3	jmp	next

;
; forget--find a word in the dictionary, and remove it
;
forg2	dc.l	find2,forg1,forg1,0
	dc.b	'forget  '
forg1	jsr	getw1		; Get the name to forget
	jsr	look99		; Find it in the dictionary
	tst.l	(a5)+		; Found it?
	beq	forg3		;  nope...
	addq.l	#4,a5		; Drop priority flag
	move.l	(a5)+,a0	; Put CFA into A0
	subq.l	#4,a0		; Put A0 back to LFA
	move.l	(a0),late1	; Point LATEST to previous word
	move.l	a0,d7		; Free memory back to here
	jmp	next

forg3	jmp	notf1		; Forget WHO?

;
; input <file>--redirect input from a file
;
input2	dc.l	forg2,input1,input1,0
	dc.b	'input   '
input1	move.l	iunit,a0	; Room for more nesting?
	add.l	#Inbufsize,a0
	cmp.l	#End_inbufs,a0
	beq	input4
	move.l	a0,-(a7)	; Save address of new buffer

	move.l	d6,a0		; Read in until end of word
	jsr	skipwhite
	lea	pad1,a1		; Where to build into
input10	jsr	iswhite		; While not at end of word
	bne.s	input11
	tst.b	(a0)		; At end of input buffer?
	bne.s	input12
	move.l	a1,-(a7)	; Get new buffer-full
	jsr	getline
	move.l	(a7)+,a1
	move.l	d6,a0
	bra.s	input10

input11	move.b	(a0)+,(a1)+	; Store next char
	bra.s	input10

input12	clr.b	(a1)		; Trailing NULL
	move.l	a0,d6		;  update input pointer
	clr.l	-(a7)		; Mode 0=read
	pea	pad1		; Pointer to file name
	clr.l	-(a7)		; dummy space
	moveq	#5,d0		; Open request
	trap	#0
	bcs	input3
	add.l	#12,a7		; Get rid of parameters
	move.l	(a7)+,a0	; Get new buffer addr again
	move.l	iunit,a1	; Get previous
	move.l	a1,InbufPrev(a0) ;  Save
	move.l	d6,InbufIdx(a1)	;   Save index into old buffer
	move.l	a0,InbufIdx(a0)	; Clear the buffer
	move.b	d0,InUnit(a0)	; Save UNIX FD to use
	clr.b	(a0)
	move.l	a0,d6
	move.l	a0,iunit	; Update current input unit
	jmp	next

input3	lea	input_msg,a0
input5	jsr	prstr
	jmp	abort
input4	lea	input_msg2,a0
	bra.s	input5
input_msg asciz	'Could not open file for input'
input_msg2 asciz 'Too many files nested'
	even

;
; exit--return from the current high-level word
;
exit2	dc.l	input2,pop1,pop1,0
	dc.b	'exit    '

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Insert new definitions above here ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; latest--pointer to most current LFA defined
;
late2   dc.l    exit2
latest  dc.l    getpfa,late1,0
        dc.b    'latest  '
late1   dc.l    late2
 
;
; The user dictionary space
;
	comm	udict,umem*1024	; User dictionary space
 
;
; The End!
;
Funky!Stuff!
cat - << \Funky!Stuff! > primes.fth
: isprime ( n -- b | Return whether 'n' is prime )
(  dup 2 mod 0= if drop 0 exit endif )
  -1 swap dup 2/ 1+ 3 do
    dup i mod 0= if swap drop 0 swap leave endif
  2 +loop
  drop
;
 
: primes
  2001 5 do
    i isprime if i . cr endif
  2 +loop
;
Funky!Stuff!
.