[net.sources] Andy Valencia's "vforth"

riddle@ut-sally.UUCP (posted for Andy Valencia) (01/03/85)

: This is a shar archive.  Extract with sh, not csh.
echo x - README
sed -e 's/^X//' > README << '!RoNnIe!RaYgUn!'
X	What follows is a 32-bit forth. In general, it is based on the FIG
Xmodel, but it deviates where necessity or religion demanded. It will
Xrun on a VAX running 4.2, and tends to use the UNIX system calls in only
Xthe most generic of ways (read: should move to 4.1 without problems).
XIt uses subroutine threading and in-line code generation to "up" the
Xspeed; this is explained in the accompanying documentation.
X
X	It has been used to implement a 3D viewing system, which runs
Xrather nicely; if you're interested in such a thing, send me mail;
Xif I get enough queries, I'll post it to net.sources--otherwise, I'll
Xsend it direct.
X
X	Thanks much to Prentiss Riddle for posting this to me! Please
Xdirect all questions to me, not him! We can't post to notes from here,
Xbut net mail works fine.
X
X
X					Andy Valencia
X					...!fortune!hpda!vandys
X					...!ucbvax!hpda!vandys
X
XHeavy legal lines:
X	The software which follows is put into the public domain for
Xprivate use only; using or distributing this software for a profit is
Xforbidden. This software comes with no support offered or implied--
Xyou're on your own!
!RoNnIe!RaYgUn!
echo x - Makefile
sed -e 's/^X//' > Makefile << '!RoNnIe!RaYgUn!'
Xvforth: vforth.o
X	ld -N -o vforth vforth.o
Xvforth.o: vforth.s
X	as -o vforth.o vforth.s
!RoNnIe!RaYgUn!
echo x - glossary
sed -e 's/^X//' > glossary << '!RoNnIe!RaYgUn!'
X
X	This is a list of all the FORTH words implemented. In the case where
Xthere are two functions, one for integer, one for floating, they will be
Xlisted together; the floating version will start with "f".
X
X	A "word" refers to a VAX 32-bit longword; a "float" refers
Xto an 32-bit F-format VAX floating word. The term "opstack" or
X"operand stack" will refer to the regular FORTH stack; "return stack"
Xis the "other" stack, and is implemented with the VAX's SP register.
X
Xover ( x y -- x y x )
X	Copy second to top
X
Xabs, fabs ( x -- |x| )
X	Change sign of top of stack if it's negative
X
Xmax, fmax ( x y -- max(x,y) )
X	Take the greater of the top two elements
X
Xmin, fmin (x y -- min(x,y) )
X	Take the lesser of the top two elements
X
Xc@ ( d a -- )
X	Store the byte quantity "d" at byte address "a".
X
Xc! ( a -- d)
X	Fetch the byte quantity "d" from byte address "a".
X
Xnegate, fnegate ( x -- -x )
X	Replace top of stack with its negation.
X
Xhere ( -- a )
X	Push the address of the next open memory location in the
Xdictionary to stack.
X
X>r ( -- d )
X	Move one word from the return stack to the operand stack.
X
Xr> ( d -- )
X	Move one word from the operand stack to return stack.
X
Xfill ( a n d -- )
X	Fill "n" bytes of memory starting at "a" with the value "d".
X
Xpick ( d -- x )
X	Get the "d"th word on the opstack (zero-based, starting from the
Xword below "d") to the top of stack.
X
X, ( d -- )
X	Move the word "d" into the next open dictionary word, advancing
XHERE.
X
Xc, ( d -- )
X	As ",", but only a byte operation is done.
X
Xrot ( x y z -- y z x )
X	Move the third element to the top.
X
X-rot ( y z x -- x y z )
X	Move the top element to the third.
X
Xallot ( d -- )
X	Add "d" to HERE, effectively moving the bottom of the dictionary
Xforward "d" bytes.
X
X2dup ( x y -- x y x y )
X	Duplicate the top two words.
X
X2swap ( w x y z -- y z w x )
X	Swap the top two words with the second-to-the-top two words.
X
X(
X	Start a comment which is ended by a ")" or newline.
X
Xabort
X	Initialize forth, start interpreting from the keyboard again.
X
Xhalt
X	Exit back to UNIX.
X
Xoutpop
X	Close the current output file & start using the previous output
Xfile. This is a no-op if this is the first output file.
X
Xoutput
X	Take the next word in the input stream & try to open it for writing.
XIf you can't, call "abort". Otherwise, make it the current output file,
Xpushing the current output onto a stack so that a later "outpop" will
Xclose this file & continue with the old one.
X
Xinput
X	As output, but open for reading. There is no corresponding "inpop",
Xas EOF status will cause the equivalent action.
X
Xtrue, false ( -- b )
X	Push the boolean true and false values onto the stack. These
Xvalues are used uniformly by all of Vforth.
X
Xor, and
X	Bitwise OR and AND operations. These will work with "true"
Xand "false" to provide logical functionality.
X
X=, f= ( x y -- b )
X	Return whether x is equal to y.
X
X>, f> ( x y -- b )
X	Return whether x is greater than y.
X
X<, f< ( x y -- b )
X	Return whether x is less than y.
X
Xdrop ( x -- )
X	Drop the top of stack.
X
X2drop ( x y -- )
X	Drop the top two items from the stack.
X
Xswap ( x y -- y x )
X	Exchange the top two items.
X
Xdup ( x -- x x )
X	Duplicate the top item.
X
Xif ... [ else ] ... endif
X	The conditional structure. Note "endif", not "then".
X
Xbegin ... again
X	Unconditional looping structure.
X
Xbegin ... until
X	Conditional looping--will loop until the "until" receives a
Xboolean "true" on the stack.
X
Xbegin ... while ... repeat
X	Looping structure where the test is at the "while" word.
X
Xdo ... loop
X	Counting loop.
X
Xdo ... +loop
X	As do...loop, but +loop takes the amount to increment by.
X
Xleave
X	Causes the innermost loop to reach its exit condition. The
Xnext execution of "loop" or "+loop" will fall through.
X
Xi,j,k
X	The loop indices of (respectively) the innermost, second, and
Xthird loops.
X
X@ ( a -- x )
X	Fetch a word at address "a".
X
X! ( x a -- )
X	Store a word at address "a".
X
Xvariable
X	Take the next word and add it to the dictionary as a variable.
XSubsequent references to this name will return an address which is the
Xword allocated to this variable. Uses such as
Xvariable foobar 400 allot
X	will make "foobar" return the address of a 404-byte array (the
Xinitially allocated longword, 4 bytes, plus the allot'ed 400 bytes).
X
Xconstant
X	Like variable, but later references to this word return the
Xnumerical constant. Thus
X42 constant ascii_star
Xascii_star emit
X	will print a star to the current output device.
X
X:
X	Start compilation mode for the next word in the stream.
X
X;
X	End compilation mode, unsmudge the entry.
X
Xmod ( x y -- r )
X	Return the remainder of x/y. This is explicitly calculated
Xas x-int(x/y)*x.
X
X/,f/ ( x y -- d )
X	Return the result of x/y. Dividing by zero is undefined.
X
X*,f*,-,f-,+,f+ ( x y -- d )
X	Return the result of the applied binary operation to the
Xtwo arguments.
X
Xi->f ( i -- f )
X	Convert the integer "i" to the equivalent floating format
X"f".
X
Xf->i ( f -- i )
X	Convert the floating number "f" to the equivalent integer "i".
XInteger portions of "f" will be truncated; for details, refer to the
X"cvtfl" instruction in the VAX architecture handbook.
X
Xemit ( c -- )
X	Print the specified character to the current output unit.
X
Xcr
X	Print a newline sequence to the current output unit.
X
Xf. ( f -- )
X	Print the floating-point number.
X
X."
X	Print the string immediately (in interpretive mode) or compile
Xcode which will print the string (in compilation mode).
X
X(.")
X	Run-time support word for .".
X
X. ( i -- )
X	Print the integer.
X
Xsintab
X	An array of sin() values.
X
Xsin ( i -- s )
X	"i" is a degree measure; "s" is sin(i)*10000.
X
Xfsin ( f -- s )
X	"f" is the degree measure; "s" is the sin() value.
X
Xcos, fcos
X	As sin, fsin, but for cos() values.
X
Xdecimal
X	Set Vforth's current base to 10.
X
Xhex
X	Set Vforth's current base to hexadecimal (16).
X
Xbase
X	A Vforth variable which holds the current base.
X
Xstate
X	A variable which holds the current state; 0 = interpreting,
Xnon-0 means compiling.
!RoNnIe!RaYgUn!
echo x - vforth.doc
sed -e 's/^X//' > vforth.doc << '!RoNnIe!RaYgUn!'
X	Vforth is a 32-bit Threaded Interpretive Language for the VAX
Xminicomputer. It uses a combination of subroutine-threading and in-line
Xcode generation to provide significant execution speed improvement. It
Xwas developed for the express purpose of running a graphics which was
Xdeveloped under JHU forth. As such, it only follows the FIG model to
Xthe extent required to allow the JHU forth code to run with minimal
Xmodification. This code is the sole property of Hewlett-Packard company,
Xbut is put into the public domain for non-profit use only. No support
Xwhatsoever is implied for this code--you're on your own!
X
X	Now that we have the "heavy" stuff out of the way, I may proceed
Xto describe exactly what we have here. Vforth's internals are unique, but
Xits external behavior closely mimics FIG-forth for those words provided;
Xthe set of words chosen was mostly driven by the graphics package written
Xoriginally for JHU forth. This file, "vforth.doc", is a brief description
Xof the internal structure of vforth; the set of words implemented is in
Xthe file "glossary".
X
X	The classic approach in forth is to have a register (the Interpretive
XPointer) which points to successive words. Each word points to the CFA (Code
XField Address) of another word. By jumping via the CFA, one invokes the word
Xindicated by the word the IP points to. The central code which chases all these
Xpointers is called "NEXT"; its speed is crucial in providing a fast forth
Xinterpreter.
X
X	Vforth takes this one step further by generating a subroutine call
Xin front of each address. By doing this, the code may be executed in-line;
Xno time is used executing auxiliary code. Thus, the invokation of a word
Xoccurs at the full speed of the machine's subroutine-call facility. A word's
Xdefinition ends with a subroutine return opcode, again saving time over
Xexplicit execution of code.
X
X	The header of a Vforth assembly language word is:
X
X	LFA - longword
X	CFA - longword
X	SFP - word
X	SFA - word
X	"name\0" - array of char
X	<start of executable code>
X
X	LFA is the Link Field Address and is the "usual"--it points to the
Xprevious word's LFA. CFA always points to the start of the executable code.
XSFP (Status Field Parameter) is special and is associated with one of
Xthe bits in SFA. SFA (Status Field Address) contains bits which tell about
Xthe word. In particular, there are bits for a Priority word, for a Smudged
Xword, and for a Primitive word. "Priority" and "Smudge" are just what one
Xexpects; "Primitive" is unique to Vforth. During compilation, a word whose
XSFA has the Primitive bit set will have its executable code copied in-line
Xto the function being compiled. The number of bytes copied is in SFP. Thus,
Xthe definition for the addition word might be:
X
X	.long	prev_fun,temp
X	.word	3,Primitive
X	.asciz	"+"
Xtemp:	addl2	(R11)+,(R11)
X	rsb
X
X	The "addl2" line takes three bytes; these are the three copied
Xduring compilation. If one is not currently compiling, the code is executed
Xdirectly; thus, the trailing "rsb" is needed for interpretive use, although
Xnot for compiling.
X
X	Thus, the Vforth system tends to generate code in-line for those
Xwords whose definitions are (1) short and (2) position independent, and
Xto thread (via "jsb"s) to those routine which are not. Here at HP we have
Xobserved a 4-5 times speed increase in speed over JHU forth. Because the
Xincrease was sufficient for our needs, no code tuning was done; if you
Xfind a good "tune", please send it along to us!
X
X	The I/O system is very bare-bones indeed. The words "input" and
X"output" will take the next word in the input stream and open it as a file,
Xthen use it for input or output (respectively). There is a "stack" of units
Xfor both input and output, so both may be nested. An "abort" will restore
XI/O to the console, but will not close the file descriptors--I'm not yet
Xsure whether this is a feature or a bug. I/O is almost unbuffered on output,
Xand buffered to 1K blocks on input. The resultant amount of I/O traffic to
XUNIX does not slow things down enough for me to be interested in changing it.
X
X	Floating numbers are mostly used for fractional accuracy; no support
Xis provided for exponential numeric formats. INTERP recognizes a floating
Xpoint number as one with a decimal point. Thus, "23" would be a 32-bit
Xinteger, but "23.0" would be a floating point number. The classic use of
Xthe decimal point to mark double-word numbers is superseded in Vforth as
XALL integers are already 32 bits.
X
X					Andy Valencia
X					...!ucbvax!hpda!vandys
X
X
!RoNnIe!RaYgUn!
echo x - vforth.s
sed -e 's/^X//' > vforth.s << '!RoNnIe!RaYgUn!'
X#
X# Vforth--a 32 bit forth system using subroutine threading for
X#	increased speed.
X#
X#	By Andy Valencia, 1984
X#
X# Registers with fixed uses:
X#	PC - Since we're using direct threading, this operates as the actual
X#		execution vector for each instruction.
X#	SP - Maintains the return stack
X#	R11 - The operand stack
X#	R10 - Next open byte in the dictionary--"HERE"
X#	R9  - Index into current input line
X#	R8  - Points to last entry in the dictionary chain
X#
X
X#
X# These are the constants which are compiled into the executable code
X#
X	.set	jsb_header,0x9F16	# jsb *$...
X	.set	lit_header,0x8FD0	# pushl $...
X	.set	lit_tailer,0x7B
X	.set	rsb_header,0x5		# rsb
X	.set	Again_header,0x9F17	# jmp *$...
X	.set	Skipt,0x6128BD5		# tstl (r11)+; bnequ .+6
X
X#
X# These are the other constants
X#
X	.set	Recursive,1		# SFA bits: recursive function
X	.set	Smudged,2		#   SMUDGE bit
X	.set	Priority,4		#   IMMEDIATE
X	.set	Primitive,8		#   PRIMITIVE--is a code macro
X
X	.set	NL,10			# Newline
X	.set	Spc,32			# Space
X	.set	Tab,9			# Tab
X
X	.set	Mrkcolon,1		# For control structure matching
X	.set	Mrkif,2
X	.set	Mrkdo,3
X	.set	Mrkbegin,4
X	.set	Mrkwhile,5
X
X	.data	0
X
X	.word	0			# Procedure entry mask
Xgo1:	movl	$dictend,r10		# r10 is end of dictionary
X	movl	sp,sp_hold		# For resetting SP later
X	movl	*$latest,r8		# Setup R8 to end of dict.
Xabort:	movl	sp_hold,sp		# Start SP from its initial value
X	subl3	$80,sp,r11		# Leave 80 bytes for opstack
X	movl	r11,stacklim		# For underflow checking
X	movl	$inline,r9		# Set up input line as empty
X	clrb	(r9)
X	clrl	*$state			# Turn off compile mode
X	movl	$istk,isp		# Reset I/O system
X	clrl	istk
X	clrl	iunit
X	movl	$ostk,osp
X	cvtbl	$1,ostk
X	cvtbl	$1,ounit
X	jbr	interp			# Start up the interpretive loop
X
X#
X# Some data area
X#
Xsp_hold: .space 4			# Holds return stack base
Xstacklim: .space 4			# Holds bottom of stack
Xinline:	.space	1025			# Room for a block of input
Xwrd:	.space	81			#  and up to 80-char word
Xlatest:					# Last intrinsic word in dictionary
X	.long	interp1
X
X#
X# Pushdown list of input & output file descriptors
Xistk:	.long	0,0,0,0,0,0,0,0
Xisp:	.long	istk
Xideep:	.long	0
Xiunit:	.long	0
Xostk:	.long	1,1,1,1,1,1,1,1
Xosp:	.long	ostk
Xodeep:	.long	0
Xounit:	.long	1
X
X#
X# KLUDGE city! When we push down an input file, we have to save the buffer,
X#	otherwise the new input file will abuse it in various undesireable
X#	ways. So we make room for a save image of each input unit.
Xibufs:	.space	1024*8	# The input buffers
Xibufx:	.space	4*8	#  and the current position within them
X
X#
X# Open the given file for output; add it to the pushdown stack. Error
X#	if it can't be opened.
X#
Xoutfcb:	.long	3
Xoutname: .space	4
X	.long	0x201,0x1FF
Xoutopen:
X	movl	r0,outname
X	movl	$outfcb,ap
X	chmk	$5
X	bcs	outop1
X	movl	osp,r1
X	addl2	$4,r1
X	movl	r0,(r1)
X	movl	r0,ounit
X	movl	r1,osp
X	incl	odeep
X	rsb
Xoutop1:	movl	$outop2,r0	# Couldn't open--complain
X	jsb	prstr
X	jbr	abort
Xoutop2:	.asciz	" Could not open output file\n"
X
X#
X# Open the given file for input; add it to the pushdown stack. Error
X#	if it can't be opened.
X#
Xinfcb:	.long	3		# parms to do a OPEN for READ syscall
Xinname:	.space	4
X	.long	0,0x1FF
X
Xinopen:	movl	r0,inname	# Set up name for open
X	movl	$infcb,ap
X	chmk	$5
X	bcs	inop1
X
X				# Open successful, save previous buffer
X	movl	$256,r2		# R2 is the number of bytes to move
X	movl	ideep,r3
X	mull2	$1024,r3
X	addl2	$ibufs,r3	# R3 now points to our save location
X	movl	$inline,r1	# R1 points to the buffer to save
Xinop3:	movl	(r1)+,(r3)+	# Move the bytes
X	sobgtr	r2,inop3
X	movl	ideep,r3	# Now save the input index
X	movl	r9,ibufx[r3]
X	movl	$inline,r9	# Clear the input buffer
X	clrb	(r9)
X
X	movl	isp,r1		# Push down the old file descriptor
X	addl2	$4,r1
X	movl	r0,(r1)
X	movl	r0,iunit
X	movl	r1,isp
X	incl	ideep
X	rsb
Xinop1:	movl	$inop2,r0	# Bad open, complain & abort
X	jsb	prstr
X	jbr	abort
Xinop2:	.asciz	" Could not open input file.\n"
X
X#
X# ----Start of FORTH dictionary
X#
X
X#
X# over--copy second to new top
X#
Xover2:	.long	0,over1
X	.word	4,Primitive
X	.asciz	"over"
Xover1:	movl	4(r11),-(r11)
X	rsb
X
X#
X# abs,fabs--get absolute value
X#
Xabs2:	.long	over2,abs1,0
X	.asciz	"abs"
Xabs1:	tstl	(r11)
X	bgeq	abs3
X	mnegl	(r11),(r11)
Xabs3:	rsb
Xfabs2:	.long	abs2,fabs1,0
X	.asciz	"fabs"
Xfabs1:	tstf	(r11)
X	bgeq	abs3
X	mnegf	(r11),(r11)
X	rsb
X
X#
X# max,fmax--get maximum value
X#
Xmax2:	.long	fabs2,max1,0
X	.asciz	"max"
Xmax1:	movl	(r11)+,r0
X	cmpl	r0,(r11)
X	bleq	max3
X	movl	r0,(r11)
Xmax3:	rsb
Xfmax2:	.long	max2,fmax1,0
X	.asciz	"fmax"
Xfmax1:	movf	(r11)+,r0
X	cmpf	r0,(r11)
X	bleq	max3
X	movf	r0,(r11)
Xfmax3:	rsb
X
X#
X# min,fmin--get minimum value
X#
Xmin2:	.long	fmax2,min1,0
X	.asciz	"min"
Xmin1:	movl	(r11)+,r0
X	cmpl	r0,(r11)
X	bgeq	min3
X	movl	r0,(r11)
Xmin3:	rsb
Xfmin2:	.long	min2,fmin1,0
X	.asciz	"fmin"
Xfmin1:	movf	(r11)+,r0
X	cmpf	r0,(r11)
X	bgeq	min3
X	movf	r0,(r11)
Xfmin3:	rsb
X
X#
X# c@, c!--byte fetch/store operators
X#
Xcfet2:	.long	fmin2,cfet1
X	.word	6,Primitive
X	.asciz	"c@"
Xcfet1:	movl	(r11),r0
X	cvtbl	(r0),(r11)
X	rsb
Xcsto2:	.long	cfet2,csto1
X	.word	6,Primitive
X	.asciz	"c!"
Xcsto1:	movl	(r11)+,r0
X	cvtlb	(r11)+,(r0)
X	rsb
X
X#
X# negate & fnegate
X#
Xneg2:	.long	csto2,neg1
X	.word	3,Primitive
X	.asciz	"negate"
Xneg1:	mnegl	(r11),(r11)
X	rsb
Xfneg2:	.long	neg2,fneg1
X	.word	3,Primitive
X	.asciz	"fnegate"
Xfneg1:	mnegf	(r11),(r11)
X	rsb
X
X#
X# HERE--provide the address of the next open byte in the dictionary
X#
Xhere2:	.long	fneg2,here1
X	.word	3,Primitive
X	.asciz	"here"
Xhere1:	movl	r10,-(r11)
X	rsb
X
X#
X# "r>" & ">r"--move a word between op & return stacks
X#
Xto_r2:	.long	here2,to_r1
X	.word	2,Primitive
X	.asciz	">r"
Xto_r1:	pushl	(r11)+
X	rsb
Xfrom_r2:
X	.long	to_r2,from_r1
X	.word	3,Primitive
X	.asciz	"r>"
Xfrom_r1:
X	movl	(sp)+,-(r11)
X	rsb
X
X#
X# fill--fill an area of memory with a constant
X#
Xfill2:	.long	from_r2,fill1,0
X	.asciz	"fill"
Xfill1:	cvtlb	(r11)+,r0
X	movl	(r11)+,r1
X	movl	(r11)+,r2
Xfill3:	tstl	r1
X	beql	fill4
X	movb	r0,(r2)+
X	decl	r1
X	brb	fill3
Xfill4:	rsb
X
X#
X# pick--get a word in the stack
X#
Xpick2:	.long	fill2,pick1,0
X	.asciz	"pick"
Xpick1:	movl	(r11)+,r0
X	movl	(r11)[r0],-(r11)
X	rsb
X
X#
X# 'c,' & ','--push word to HERE
X#
Xcomma2:	.long	pick2,comma1
X	.word	3,Primitive
X	.asciz	","
Xcomma1:	movl	(r11)+,(r10)+
X	rsb
Xccomm2:	.long	comma2,ccomm1
X	.word	3,Primitive
X	.asciz	"c,"
Xccomm1:	cvtlb	(r11)+,(r10)+
X	rsb
X
X#
X# rot,-rot --the rotational operators
X#
Xrot2:	.long	ccomm2,rot1,0
X	.asciz	"rot"
Xrot1:	movl	(r11)+,r0
X	movl	(r11)+,r1
X	movl	(r11),r2
X	movl	r1,(r11)
X	movl	r0,-(r11)
X	movl	r2,-(r11)
X	rsb
Xdrot2:	.long	rot2,drot1,0
X	.asciz	"-rot"
Xdrot1:	movl	(r11)+,r0
X	movl	(r11)+,r1
X	movl	(r11),r2
X	movl	r0,(r11)
X	movl	r2,-(r11)
X	movl	r1,-(r11)
X	rsb
X
X#
X# allot--move the end of the dictionary forward a number of bytes
X#
Xallot2:	.long	drot2,allot1
X	.word	3,Primitive
X	.asciz	"allot"
Xallot1:	addl2	(r11)+,r10
X	rsb
X
X#
X# 2dup, 2swap--double-int stack operators
X#
Xtdup2:	.long	allot2,tdup1,0
X	.asciz	"2dup"
Xtdup1:	movl	(r11)+,r0
X	movl	(r11),r1
X	movl	r0,-(r11)
X	movl	r1,-(r11)
X	movl	r0,-(r11)
X	rsb
Xtswap2:	.long	tdup2,tswap1,0
X	.asciz	"2swap"
Xtswap1:	movl	(r11)+,r0
X	movl	(r11)+,r1
X	movl	(r11)+,r2
X	movl	(r11),r3
X	movl	r1,(r11)
X	movl	r0,-(r11)
X	movl	r3,-(r11)
X	movl	r2,-(r11)
X	rsb
X
X#
X# "("--handle forth comments
X#
Xcomm2:	.long	tswap2,comm1
X	.word	0,Priority
X	.asciz	"("
Xcomm1:	movb	(r9)+,r0	# Get next byte of input
X	cmpb	r0,0		# Get another buffer-full if hit end of cur.
X	beql	comm3
X	cmpb	r0,$10		# End comment on newline or close paren
X	beql	comm4
X	cmpb	r0,$41
X	bneq	comm1
Xcomm4:	rsb
Xcomm3:	jsb	getlin		# Get another buffer
X	brb	comm1
X
X#
X# "abort"--calls the forth abort code
X#
Xabo2:	.long	comm2,abo1,0
X	.asciz	"abort"
Xabo1:	jbr	abort
X
X#
X# "halt"--cause forth to exit
X#
Xhalt3:	.long	1,0
Xhalt2:	.long	abo2,halt1,0
X	.asciz	"halt"
Xexit:
Xhalt1:	movl	$halt3,ap
X	chmk	$1
X
X#
X# "outpop"--do for the output list what EOF does for the input list;
X#	close the current output file & pop back a level
X#
Xoutp4:	.long	1
Xoutp3:	.space	4
Xoutp2:	.long	halt2,outp1,0
X	.asciz	"outpop"
Xoutp1:	movl	osp,r0		# Get the stack pointer to R0
X	cmpl	r0,$ostk	# Don't pop off end of stack
X	beql	outp5
X	movl	ounit,outp3	# Close the current unit
X	movl	outp4,ap
X	chmk	$6
X	movl	osp,r0
X	subl2	$4,r0		# Move back a position
X	movl	(r0),ounit	#  and set output to that file descriptor
X	movl	r0,osp
X	decl	odeep		# Decrement nesting count
Xoutp5:	rsb
X
X#
X# "output"--open the named output file & make it the new output unit
X#
Xout2:	.long	outp2,out1,0
X	.asciz	"output"
Xout1:	jsb	getw
X	movl	$wrd,r0
X	jsb	outopen
X	rsb
X
X#
X# "input"--open the named file & make it the new input unit
X#
Xinp2:	.long	out2,inp1,0
X	.asciz	"input"
Xinp1:	jsb	getw		# Get the name of the file
X	movl	$wrd,r0
X	jsb	inopen
X	rsb
X
X#
X# Push logical constants to stack
X#
Xfalse2:	.long	inp2,false1
X	.word	2,Primitive
X	.asciz	"false"
Xfalse1:	clrl	-(r11)
X	rsb
Xtrue2:	.long	false2,true1
X	.word	4,Primitive
X	.asciz	"true"
Xtrue1:	cvtbl	$-1,-(r11)
X	rsb
X
X#
X# the logical operators. Note that they serve for both logical and
X#	bitwise purposes, as "true" is defined as -1.
X#
Xlor2:	.long	true2,lor1
X	.word	3,Primitive
X	.asciz	"or"
Xlor1:	bisl2	(r11)+,(r11)
X	rsb
Xland2:	.long	lor2,land1,0
X	.asciz	"and"
Xland1:	bitl	(r11)+,(r11)
X	bneq	land3
X	clrl	(r11)
X	rsb
Xland3:	cvtbl	$-1,(r11)
X	rsb
X
X#
X# the floating relational operators
X#
Xfeq2:	.long	land2,feq1,0
X	.asciz	"f="
Xfeq1:	cmpf	(r11)+,(r11)
X	beql	feq3
X	clrl	(r11)
X	rsb
Xfeq3:	cvtbl	$-1,(r11)
X	rsb
Xfgt2:	.long	feq2,fgt1,0	# Greater than
X	.asciz	"f>"
Xfgt1:	cmpf	(r11)+,(r11)
X	blss	fgt3
X	clrl	(r11)
X	rsb
Xfgt3:	cvtbl	$-1,(r11)
X	rsb
Xflt2:	.long	fgt2,flt1,0	# Less than
X	.asciz	"f<"
Xflt1:	cmpf	(r11)+,(r11)
X	bgtr	flt3
X	clrl	(r11)
X	rsb
Xflt3:	cvtbl	$-1,(r11)
X	rsb
X
X#
X# the relational operators
X#
Xeq2:	.long	flt2,eq1,0
X	.asciz	"="
Xeq1:	cmpl	(r11)+,(r11)
X	beql	eq3
X	clrl	(r11)
X	rsb
Xeq3:	cvtbl	$-1,(r11)
X	rsb
Xgt2:	.long	eq2,gt1,0	# Greater than
X	.asciz	">"
Xgt1:	cmpl	(r11)+,(r11)
X	blss	gt3
X	clrl	(r11)
X	rsb
Xgt3:	cvtbl	$-1,(r11)
X	rsb
Xlt2:	.long	gt2,lt1,0	# Less than
X	.asciz	"<"
Xlt1:	cmpl	(r11)+,(r11)
X	bgtr	lt3
X	clrl	(r11)
X	rsb
Xlt3:	cvtbl	$-1,(r11)
X	rsb
X
X#
X# drop,2drop--get rid of top item(s)
X#
Xtdrop2:	.long	lt2,tdrop1
X	.word	3,Primitive
X	.asciz	"2drop"
Xtdrop1:	addl2	$8,r11
X	rsb
Xdrop2:	.long	tdrop2,drop1
X	.word	3,Primitive
X	.asciz	"drop"
Xdrop1:	movl	(r11)+,r0
X	rsb
X
X#
X# swap--exchange top & second
X#
Xswap2:	.long	drop2,swap1
X	.word	12,Primitive
X	.asciz	"swap"
Xswap1:	movl	(r11)+,r0
X	movl	(r11),r1
X	movl	r0,(r11)
X	movl	r1,-(r11)
X	rsb
X
X#
X# dup--duplicate top
X#
Xdup2:	.long	swap2,dup1
X	.word	3,Primitive
X	.asciz	"dup"
Xdup1:	movl	(r11),-(r11)
X	rsb
X
X#
X# "if"--conditional control structure
X#
Xif2:	.long	dup2,if1
X	.word	0,Priority
X	.asciz	"if"
Xif1:	movl	$0x6128BD5,(r10)+	# tstl (r11)+; bneq .+6
X	movw	$0x9F17,(r10)+		# jmp *$...
X	movl	r10,-(r11)
X	addl2	$4,r10
X	movl	$Mrkif,-(r11)		# Mark the control structure
X	rsb
X
X#
X# "else"
X#
Xelse2:	.long	if2,else1
X	.word	0,Priority
X	.asciz	"else"
Xelse1:	cmpl	$Mrkif,(r11)+		# Check for matching 'if'
X	bneq	else3
X	movw	$0x9F17,(r10)+		# jmp *$...
X	movl	r10,r0
X	addl2	$4,r10			# Leave room for the jump address
X	movl	r10,*(r11)+		# Have 'false' branch here
X	movl	r0,-(r11)		# Put our fill-in addr.
X	movl	$Mrkif,-(r11)		#  and put back the marker
X	rsb
Xelse3:	movl	$else4,r0		# Complain
X	jsb	prstr
X	jbr	abort
Xelse4:	.asciz	" 'else' does not match an 'if'\n"
X
X#
X# endif--finish off the conditional
X#
Xendif2:	.long	else2,endif1
X	.word	0,Priority
X	.asciz	"endif"
Xendif1:	cmpl	(r11)+,$Mrkif		# Check match
X	bneq	endif3
X	movl	r10,*(r11)+
X	rsb
Xendif3:	movl	$endif4,r0		# Complain on no match
X	jsb	prstr
X	jbr	abort
Xendif4:	.asciz	" 'endif' does not match 'else'/'if'\n"
X
X#
X# begin--start of all looping conditionals
X#
Xbeg2:	.long	endif2,beg1
X	.word	0,Priority
X	.asciz	"begin"
Xbeg1:	movl	r10,-(r11)		# Save current address
X	cvtbl	$Mrkbegin,-(r11)	#  and control structure marker
X	rsb
X
X#
X# "while".."repeat" looping construct
X#
Xwhile4:	.asciz	"'while' does not match a 'begin'\n"
Xwhile2:	.long	beg2,while1
X	.word	0,Priority
X	.asciz	"while"
Xwhile1:	cmpl	$Mrkbegin,(r11)+	# Check match
X	bneq	while3
X	movl	$0x6128BD5,(r10)+	# tstl (r11)+; bequ *$<forward>
X	movw	$0x9F17,(r10)+
X	movl	r10,-(r11)		# Mark where to plug in
X	addl2	$4,r10			# Leave room for the patch
X	movl	$Mrkwhile,-(r11)
X	rsb
Xwhile3:	movl	$while4,r0		# Bad match, complain
X	jsb	prstr
X	jbr	abort
X
Xrep4:	.asciz	"'repeat' does not match a 'while'\n"
Xrep2:	.long	while2,rep1
X	.word	0,Priority
X	.asciz	"repeat"
Xrep1:	cmpl	$Mrkwhile,(r11)+	# Check match
X	bneq	rep3
X	movl	(r11)+,r0		# Save where to patch
X	movw	$0x9F17,(r10)+		# jmp *$<back>
X	movl	(r11)+,(r10)+
X	movl	r10,(r0)		# Backpatch
X	rsb
Xrep3:	movl	$rep4,r0		# Complain
X	jsb	prstr
X	jbr	abort
X
X#
X# again--unconditional back branch
X#
Xagain4:	.asciz	"'again' does not match with a 'begin'\n"
Xagain2:	.long	rep2,again1
X	.word	0,Priority
X	.asciz	"again"
Xagain1:	cmpl	$Mrkbegin,(r11)+	# verify match of control structures
X	bnequ	again3
X	movw	$Again_header,(r10)+	# compile in back branch
X	movl	(r11)+,(r10)+
X	rsb
Xagain3:	movl	$again4,r0		# Complain
X	jsb	prstr
X	jbr	abort
X
X#
X# until--loop until condition becomes true
X#
Xuntil4:	.asciz	"'until' doesn not match a 'begin'\n"
Xuntil2:	.long	again2,until1
X	.word	0,Priority
X	.asciz	"until"
Xuntil1:	cmpl	$Mrkbegin,(r11)+	# Verify match
X	bnequ	until3
X	movl	$Skipt,(r10)+		# Branch over backbranch if true
X	movw	$Again_header,(r10)+	# compile in backbranch
X	movl	(r11)+,(r10)+
X	rsb
Xuntil3:	movl	$until4,r0		# Complain
X	jsb	prstr
X	jbr	abort
X
X#
X# leave--setup innermost loop so it will exit at next iteration
X#
Xleave2:	.long	until2,leave1
X	.word	4,Primitive
X	.asciz	"leave"
Xleave1:	movl	(sp),4(sp)
X	rsb
X
X#
X# "k"--return index of third loop
X#
Xk_idx2:	.long	leave2,k_idx1
X	.word	4,Primitive
X	.asciz	"k"
Xk_idx1:	movl	20(sp),-(r11)
X	rsb
X
X#
X# "j"--return index of second loop
X#
Xj_idx2:	.long	k_idx2,j_idx1
X	.word	4,Primitive
X	.asciz	"j"
Xj_idx1:	movl	12(sp),-(r11)
X	rsb
X
X#
X# "i"--return index of innermost loop
X#
Xi_idx2:	.long	j_idx2,i_idx1
X	.word	4,Primitive
X	.asciz	"i"
Xi_idx1:	movl	4(sp),-(r11)
X	rsb
X
X#
X# "do"--start a loop
X#
X	.set	Do1,0xD07E8BD0	# movl (r11)+,-(sp); movl (r11)+,-(sp)
X	.set	Do2,0x7E8B
X
X	.set	Do3,0xD0508ED0	# movl (sp)+,r0; movl (sp)+,r1
X	.set	Do4,0x51D1518E	#   cmpl r1,r0; blss .+6
X	.set	Do5,0x17061950	#   jmp *$<forward>
X	.set	Do6,0x9F
X
X	.set	Do7,0xD07E51D0	# movl r1,-(sp); movl r1,-(sp)
X	.set	Do8,0x7E50
X
Xdo2:	.long	i_idx2,do1
X	.word	0,Priority
X	.asciz	"do"
Xdo1:	movl	$Do1,(r10)+
X	movw	$Do2,(r10)+
X	movl	r10,-(r11)	# Save current pos. for back branch
X	movl	$Do3,(r10)+
X	movl	$Do4,(r10)+
X	movl	$Do5,(r10)+
X	movb	$Do6,(r10)+
X	movl	r10,-(r11)	# Save this loc for fill-in as forward branch
X	addl2	$4,r10
X	movl	$Do7,(r10)+
X	movw	$Do8,(r10)+
X
X	movl	$Mrkdo,-(r11)	# Flag our control structure
X	rsb
X
X#
X# loop--branch back to the opening "DO"
X#
X	.set	Loop1,0x1704AED6	# incl 4(sp); jmp *$<back>
X	.set	Loop2,0x9F
Xloop3:	.asciz	"'loop' does not match a 'do'\n"
Xloop2:	.long	do2,loop1
X	.word	0,Priority
X	.asciz	"loop"
Xloop1:	cmpl	$Mrkdo,(r11)+	# Check for match of control structures
X	bnequ	loop4
X	movl	(r11)+,r0	# Keep where to fill in forward branch addr.
X	movl	$Loop1,(r10)+	# Build code to increment loop
X	movb	$Loop2,(r10)+
X	movl	(r11)+,(r10)+
X	movl	r10,(r0)	# Fill in this location as loop exit addr.
X	rsb
Xloop4:	movl	$loop3,r0	# Bad match--complain
X	jsb	prstr
X	jbr	abort
X
X#
X# +loop--like loop, but add by the top item instead of 1
X#
X	.set	Loop1,0x4AE8BC0		# incl 4(sp); jmp *$<back>
X	.set	Loop2,0x9F17
Xpoop3:	.asciz	"'+loop' does not match a 'do'\n"
Xpoop2:	.long	loop2,poop1
X	.word	0,Priority
X	.asciz	"+loop"
Xpoop1:	cmpl	$Mrkdo,(r11)+	# Check for match of control structures
X	bnequ	poop4
X	movl	(r11)+,r0	# Keep where to fill in forward branch addr.
X	movl	$Loop1,(r10)+	# Build code to increment loop
X	movw	$Loop2,(r10)+
X	movl	(r11)+,(r10)+
X	movl	r10,(r0)	# Fill in this location as loop exit addr.
X	rsb
Xpoop4:	movl	$poop3,r0	# Bad match--complain
X	jsb	prstr
X	jbr	abort
X
X#
X# "@"--fetch the contents of the addressed word
X#
Xfetch2:	.long	poop2,fetch1
X	.word	4,Primitive
X	.asciz	"@"
Xfetch1:	movl	*(r11),(r11)
X	rsb
X
X#
X# "!"--store the word (second) to address (top)
X#
Xstore2:	.long	fetch2,store1
X	.word	6,Primitive
X	.asciz	"!"
Xstore1:	movl	(r11)+,r0
X	movl	(r11)+,(r0)
X	rsb
X
X#
X# "variable"--build a variable
X#
X	.set	Var1,0x8FD0		# movl $<addr>,-(r11)
X	.set	Var2,0x7B
Xvar2:	.long	store2,var1,0
X	.asciz	"variable"
Xvar1:	jsb	getw			# Build the header
X	movl	r8,r2			# Add this word to the chain
X	movl	r10,r8
X	movl	r2,(r10)+
X	movl	r10,r0			# Save this position (PFA)
X	clrl	(r10)+
X	cvtbw	$7,(r10)+		# SFP = 7
X	cvtbw	$Primitive,(r10)+	# SFA = "primitive"
X	movl	$wrd,r1			# Now copy the name in
Xvar3:	movb	(r1)+,(r10)
X	tstb	(r10)+
X	bnequ	var3
X	movl	r10,(r0)		# Update the PFA
X	movw	$Var1,(r10)+		# Our in-line code
X	addl3	$6,r10,(r10)+
X	movb	$Var2,(r10)+
X	movb	$rsb_header,(r10)+
X	clrl	(r10)+			# The first word of space (= 0)
X	rsb
X
X#
X# "constant"--build a constant value
X#
Xconst2:	.long	var2,const1,0
X	.asciz	"constant"
Xconst1:	jsb	getw			# Build the header
X	movl	r8,r2			# Add this word to the chain
X	movl	r10,r8
X	movl	r2,(r10)+
X	movl	r10,r0			# Save this position (PFA)
X	clrl	(r10)+
X	cvtbw	$7,(r10)+		# SFP = 7
X	cvtbw	$Primitive,(r10)+	# SFA = "primitive"
X	movl	$wrd,r1			# Now copy the name in
Xconst3:	movb	(r1)+,(r10)
X	tstb	(r10)+
X	bnequ	const3
X	movl	r10,(r0)		# Update the PFA
X	movw	$Var1,(r10)+		# Our in-line code
X	movl	(r11)+,(r10)+		# the value to push
X	movb	$Var2,(r10)+
X	movb	$rsb_header,(r10)+
X	rsb
X
X
X#
X# ":"--start a colon definition
X#
Xcolon2:	.long	const2,colon1,0
X	.asciz	":"
Xcolon1:	cvtbl	$1,state		# Set our state to "compile"
X	jsb	getw			# Get the name of the new word
X	movl	r8,r2			# Add this word to the chain
X	movl	r10,r8
X	movl	r2,(r10)+
X	movl	r10,r0			# Save this position (PFA)
X	clrl	(r10)+
X	clrw	(r10)+			# SFP = 0
X	cvtbw	$Smudged,(r10)+		# SFA = "smudged"
X	movl	$wrd,r1			# Now copy the name in
Xcolon3:	movb	(r1)+,(r10)
X	tstb	(r10)+
X	bnequ	colon3
X	movl	r10,(r0)		# Finally, update the PFA
X	movl	$Mrkcolon,-(r11)	# and leave our mark on the stack
X	rsb
X
X#
X# ";"--end compile mode
X#
Xsemi4:	.asciz	"; not matched to ':'\n"
Xsemi2:	.long	colon2,semi1
X	.word	0,Priority
X	.asciz	";"
Xsemi1:	clrl	state			# Reset compile state
X	cmpl	$Mrkcolon,(r11)+	# Check the mark
X	beql	semi3			#  Uh-oh, bad match
X	movl	$semi4,r0		# Complain
X	jsb	prstr
X	rsb
Xsemi3:	clrw	10(r8)		# All OK, so clear the smudge
X	movb	$rsb_header,(r10)+ # Add the closing RSB
X	rsb
X
X#
X# "mod"--get remainder of division
X#
Xmod2:	.long	semi2,mod1,0
X	.asciz	"mod"
Xmod1:	movl	(r11)+,r0
X	movl	(r11),r2
X	clrl	r3
X	ediv	r0,r2,r2,(r11)
X	rsb
X
X#
X# "/"--divide second by top
X#
Xdiv2:	.long	mod2,div1
X	.word	3,Primitive
X	.asciz	"/"
Xdiv1:	divl2	(r11)+,(r11)
X	rsb
X
X#
X# "*"--multiply top two items on stack
X#
Xmul2:	.long	div2,mul1
X	.word	3,Primitive
X	.asciz	"*"
Xmul1:	mull2	(r11)+,(r11)
X	rsb
X
X#
X# "-"--subtract top two integers, push result
X#
Xminus2:	.long	mul2,minus1
X	.word	3,Primitive
X	.asciz	"-"
Xminus1:	subl2	(r11)+,(r11)
X	rsb
X
X#
X# "f+"--add floating
X#
Xfplus2:	.long	minus2,fplus1
X	.word	3,Primitive
X	.asciz	"f+"
Xfplus1:	addf2	(r11)+,(r11)
X	rsb
X
X#
X# "f-"--subtract floating
X#
Xfminus2:
X	.long	fplus2,fminus1
X	.word	3,Primitive
X	.asciz	"f-"
Xfminus1:
X	subf2	(r11)+,(r11)
X	rsb
X
X#
X# "f*"--multiply floating
X#
Xfmul2:	.long	fminus2,fmul1
X	.word	3,Primitive
X	.asciz	"f*"
Xfmul1:	mulf2	(r11)+,(r11)
X	rsb
X
X#
X# "f/"--divide floating
X#
Xfdiv2:	.long	fmul2,fdiv1
X	.word	3,Primitive
X	.asciz	"f/"
Xfdiv1:	divf2	(r11)+,(r11)
X	rsb
X
X#
X# "i->f"--convert int to float
X#
Xi2f2:	.long	fdiv2,i2f1
X	.word	3,Primitive
X	.asciz	"i->f"
Xi2f1:	cvtlf	(r11),(r11)
X	rsb
X
X#
X# "f->i"--convert float to int
X#
Xf2i2:	.long	i2f2,f2i1
X	.word	3,Primitive
X	.asciz	"f->i"
Xf2i1:	cvtfl	(r11),(r11)
X	rsb
X
X#
X# "+"--add top two integers, push result back to stack
X#
Xplus2:	.long	f2i2,plus1
X	.word	3,Primitive
X	.asciz	"+"
Xplus1:	addl2	(r11)+,(r11)
X	rsb
X
X#
X# emit--print the specified character
X#
Xemit5:	.space	1
Xemit3:	.long	3
Xemit4:	.space	4
X	.long	emit5,1
Xemit2:	.long	plus2,emit1,0
X	.asciz	"emit"
Xemit1:	cvtlb	(r11)+,emit5		# Put the desired char into the buffer
X	movl	$emit3,ap		# Print the buffer
X	movl	ounit,emit4
X	chmk	$4
X	rsb
X
X#
X# cr--print newline
X#
Xcr5:	.asciz	"\n"
Xcr3:	.long	3
Xcr4:	.space	4
X	.long	cr5,1
Xcr2:	.long	emit2,cr1,0
X	.asciz	"cr"
Xcr1:	movl	$cr3,ap
X	movl	ounit,cr4
X	chmk	$4
X	rsb
X
X#
X# "f."--print a floating point number
X#
Xfprbuf:	.space	10			# Output buffer for fractional part
X
Xfprn2:	.long	cr2,fprn1,0
X	.asciz	"f."
Xfprn1:	cvtfl	(r11),-(r11)		# Dup the number for "."
X	jsb	prnum1
X	movl	$fprbuf,r3		# R3 points to buffer position
X	movf	(r11)+,r0		# Get the number
X	cvtfl	r0,r1			# Get the integer part
X	cvtlf	r1,r1
X	subf2	r1,r0			# And take it off the number
X	movb	$'.,(r3)+		# The decimal point
X	cvtbl	$6,r4			# We always print 6 places
X
Xfprn3:	mulf2	$0F10.0,r0		# Get the next digit
X	cvtfl	r0,r1			# R1 is the next digit
X	cvtlf	r1,r5			# Take this digit off the number
X	subf2	r5,r0
X	cvtlb	r1,r1			# Turn it into the ASCII byte
X	addb3	$'0,r1,(r3)+
X	sobgtr	r4,fprn3		# Loop 6 times
X
X	clrb	(r3)
X	movl	$fprbuf,r0		# Now print it
X	jsb	prstr
X
X	rsb
X
X#
X# ." --if compiling, generate code to print a string, otherwise just
X#	print the string
X#
Xdotqbuf:
X	.space	133
Xdotq2:	.long	fprn2,dotq1
X	.word	0,Priority
X	.asciz	".\""
Xdotq1:	movl	$dotqbuf,r1
X	cmpb	(r9),$32	# Skip char if it's the separating blank
X	bneq	dotq7
X	incl	r9
Xdotq7:	movb	(r9)+,r0	# get the next char of the string
X	cmpb	$'",r0		# End string on newline or '"'
X	beql	dotq4
X	cmpb	$10,r0
X	beql	dotq4
X	tstb	r0		# At end of current input buffer?
X	beql	dotq5
X	movb	r0,(r1)+	#  No. Add this char to our output line
X	brb	dotq7
Xdotq5:	jsb	getlin		#  Yes. Get another buffer
X	brb	dotq7
X
Xdotq4:	clrb	(r1)		# Make the resulting string NULL-terminated
X	movl	$dotqbuf,r0	# Point R0 to head of this string
X	tstl	*$state		# Check state
X	beql	dotq3
X
X	movw	$jsb_header,(r10)+ # Compile in reference to (.")
X	movl	$pdotq1,(r10)+
Xdotq6:	movb	(r0)+,(r10)+	# Copy in the string
X	bneq	dotq6
X	rsb
X
Xdotq3:	jsb	prstr		# Print the string
X	rsb
X
X#
X# (.")--run-time code to print a string
X#
Xpdotq2:	.long	dotq2,pdotq1,0
X	.asciz	"(.\")"
Xpdotq1:	movl	(sp)+,r0	# Get the address of our return loc.
X	jsb	prstr		# Print the string
X	pushl	r2		# Return to addr following string
X	rsb
X
X#
X# "."--pop and print the top number on the stack
X#
X	.space	14			# Null-terminated string buffer
Xprnbuf:	.byte	0
Xprnum2:	.long	pdotq2,prnum1,0
X	.asciz	"."
Xprnum1:	movl	base,r5			# Get the base
X	movl	(r11)+,r0		# R0 holds the number
X	movl	$prnbuf,r1		# R1 points to the char positions
X	movl	r0,r2			# Keep a copy to do the sign
X	tstl	r0			# Negate if negative
X	bgeq	prnum3
X	mnegl	r0,r0
Xprnum3:	divl3	r5,r0,r3		# R3 holds new number
X	mull3	r5,r3,r4		# Calculate remainder the hard way
X	subl3	r4,r0,r4
X	cmpl	r4,$9			# See if it's a HEX digit
X	bleq	prnu5
X	addb3	$('A-10),r4,-(r1)
X	brb	prnu6
Xprnu5:	addb3	$'0,r4,-(r1)		# Put it in as the next digit
Xprnu6:	movl	r3,r0			# Update number
X	tstl	r0
X	bnequ	prnum3
X	tstl	r2			# Now check sign
X	bgeq	prnum4
X	movb	$'-,-(r1)
Xprnum4:	movl	r1,r0			# print the number
X	jsb	prstr
X	rsb
X
X#
X# sin & cos (and the corresponding fsin & fcos)
X#
Xsintab:
X    .long 0, 174, 348, 523, 697, 871, 1045, 1218, 1391, 1564, 1736
X    .long 1908, 2079, 2249, 2419, 2588, 2756, 2923, 3090, 3255, 3420
X    .long 3583, 3746, 3907, 4067, 4226, 4383, 4539, 4694, 4848, 5000
X    .long 5150, 5299, 5446, 5591, 5735, 5877, 6018, 6156, 6293, 6427
X    .long 6560, 6691, 6819, 6946, 7071, 7193, 7313, 7431, 7547, 7660
X    .long 7771, 7880, 7986, 8090, 8191, 8290, 8386, 8480, 8571, 8660
X    .long 8746, 8829, 8910, 8987, 9063, 9135, 9205, 9271, 9335, 9396
X    .long 9455, 9510, 9563, 9612, 9659, 9702, 9743, 9781, 9816, 9848
X    .long 9876, 9902, 9925, 9945, 9961, 9975, 9986, 9993, 9998, 10000
X
Xsin2:	.long	prnum2,sin1,0
X	.asciz	"sin"
Xsin1:	movl	(r11)+,r0		# Get angle
X	clrl	r1			# Negative quadrant flag
Xsin3:	tstl	r0			# Fold negative angles
X	bgeq	sin4
X	addl2	$360,r0
X	brb	sin3
Xsin4:	cmpl	r0,$360			# Fold angles > 360
X	blss	sin5
X	subl2	$360,r0
X	brb	sin4
Xsin5:	cmpl	r0,$181			# Flag & fold negative quadrant vals
X	blss	sin6
X	movb	$-1,r1
X	subl3	r0,$360,r0
Xsin6:	cmpl	r0,$91			# Fold equivalent 2nd quadrant
X	blss	sin7
X	subl3	r0,$180,r0
Xsin7:	movl	sintab[r0],r0		# Get the value
X	tstl	r1			# Negate if needed
X	beql	sin8
X	mnegl	r0,r0
Xsin8:	movl	r0,-(r11)		# Push result
X	rsb
X
Xcos2:	.long	sin2,cos1,0
X	.asciz	"cos"
Xcos1:	subl3	(r11),$90,(r11)		# sin(90-a) = cos(a)
X	jsb	sin1
X	rsb
X
Xfsin2:	.long	cos2,fsin1,0
X	.asciz	"fsin"
Xfsin1:	cvtfl	(r11),(r11)		# Change to int & call sin
X	jsb	sin1
X	cvtlf	(r11),r0
X	divf3	$0F10000.0,r0,(r11)	# Scale down to true float
X	rsb
X
Xfcos2:	.long	fsin2,fcos1,0
X	.asciz	"fcos"
Xfcos1:	cvtfl	(r11),(r11)		# Change to int & call sin
X	jsb	cos1
X	cvtlf	(r11),r0
X	divf3	$0F10000.0,r0,(r11)	# Scale down to true float
X	rsb
X
X#
X# decimal--set FORTH's base to decimal
X#
Xdecim2:	.long	fcos2,decim1,0
X	.asciz	"decimal"
Xdecim1:	cvtbl	$10,base
X	rsb
X
X#
X# hex--set FORTH's base to hexadecimal
X#
Xhex2:	.long	decim2,hex1,0
X	.asciz	"hex"
Xhex1:	cvtbl	$16,base
X	rsb
X
X#
X# BASE variable--holds the current base
X#
Xbase2:	.long	hex2,base1,0
X	.asciz	"base"
Xbase1:	movl	$base,-(r11)
X	rsb
Xbase:	.long	10
X
X#
X# STATE variable--0=interp, 1=compiling
X#
Xstate2:	.long	base2,state1,0
X	.asciz	"state"
Xstate1:	movl	$state,-(r11)
X	rsb
Xstate:	.long	0
X
X#
X# isdig--return whether the first character in the current word is
X#	a numeric digit (watch out for HEX!)
X#
Xisdig:	movb	(r7),r3			# Put the char in question into R3
X	cmpb	r3,$48			# Check for 0..9
X	blss	isdig1
X	cmpb	r3,$58
X	blss	isdig2
X	movl	r6,r4			# The base comes into us in R6
X	cmpl	r4,$11			# For higher bases, check A..?
X	blss	isdig1
X	addl2	$54,r4			# Change the base into the highest char
X	cmpb	r3,$97			# Map a..? to A..?
X	blss	isdig3
X	subb2	$32,r3
Xisdig3:	cmpb	r3,$65			# Check against 'A'
X	blss	isdig1
X	cmpb	r4,r3			# Check against highest char
X	blss	isdig1
X	brb	isdig2
X
Xisdig1:	clrb	r3			# KLUDGE to return NZ
X	decb	r3
X	rsb
X
Xisdig2:	clrb	r3			# Likewise for Z
X	tstb	r3
X	rsb
X
Xinterp6: .asciz	" ?Stack empty\n"
Xinterp1:
X	.long	state2,interp,0
X	.asciz	"interp"
Xinterp:	cmpl	r11,stacklim		# Check for underflow
X	bleq	interp5
X	movl	$interp6,r0		# Underflowed. Complain & abort
X	jsb	prstr
X	jbr	abort
Xinterp5:
X	jsb	getw			# Get next word
X	jsb	lookup			# In the dictionary?
X	bneq	cknum			#  No, see if it's a number
X	tstb	state			# Yes, either compile or execute
X	bneq	interp2
Xinterp4:
X	jsb	(r0)			# execute via its address
X	brb	interp
Xinterp2:
X	bitl	$Priority,r1		# See if it's immediate
X	jnequ	interp4
X	bitl	$Primitive,r1		# See if it generates in-line code
X	bnequ	interp7
X	movw	$jsb_header,(r10)+	# compile it with a "jsb" header
X	movl	r0,(r10)+
X	jbr	interp 
Xinterp7:
X	cvtwl	8(r2),r1		# Get number of bytes in def.
Xinterp8:
X	movb	(r0)+,(r10)+		# Copy bytes of insructions
X	decl	r1			# See if done
X	bnequ	interp8
X	jbr	interp
X
Xsign:	.space	1			# Flags the sign
Xcknum:	movl	$wrd,r7			# R7 is our index to the line
X	clrb	sign			# Take care of negative #'s here
X	cmpb	(r7),$'-
X	bneq	cknu1
X	movb	$-1,sign
X	incl	r7
Xcknu1:	movl	base,r6			# Keep base in R6
X	jsb	isdig			# Is this a number?
X	jneq	badwrd			#  No, complain
X
X	clrl	r1
Xckn1:	cvtbl	(r7)+,r0		# Loop. Get next digit
X	subl2	$'0,r0
X	cmpl	r0,$10			# Fix things up for HEX
X	blss	ckn2
X	subl2	$17,r0
X	cmpl	r0,$6
X	blss	ckn8			# Turn R0 into the hex value
X	subl2	$32,r0
Xckn8:	addl2	$10,r0
Xckn2:	mull2	r6,r1			# Scale up R1, add in R0
X	addl2	r0,r1
X	jsb	isdig			# Loop if have more chars
X	jeql	ckn1
X
X	cmpb	$46,(r7)+		# If has decimal point, is floating pt.
X	bneq	ckn4
X	cvtlf	r1,r1
X	movf	$0F0.1,r0		# R0 is our scaling factor
Xckn5:	jsb	isdig			# See if more digits
X	bneq	ckn6
X	subb3	$48,(r7)+,r2		# Get next digit, convert to float num
X	cvtbf	r2,r2
X	mulf2	r0,r2			# Scale by current factor
X	addf2	r2,r1			# Add it in to the current number
X	divf2	$0F10.0,r0		# Move our factor down one place
X	brb	ckn5
Xckn6:	tstb	sign			# Do negation if needed
X	beql	cknu2
X	mnegf	r1,r1
X	brb	cknu2
X
Xckn4:	tstb	sign			# negate if it started with '-'
X	beql	cknu2
X	mnegl	r1,r1
X
Xcknu2:	tstb	*$state			# Compile or push this number
X	jneq	ckn3
X	movl	r1,-(r11)
X	jbr	interp
Xckn3:	movw	$lit_header,(r10)+	# pushl $...
X	movl	r1,(r10)+
X	movb	$lit_tailer,(r10)+
X	jbr	interp
X
X#
X# badwrd--print the offending word, then call abort to restart the
X#	interpreter.
X#
Xdunno:	.asciz	": not found\n"
Xbadwrd:	movl	$wrd,r0			# First print the offending word
X	jsb	prstr
X	movl	$dunno,r0		# then, ": not found"
X	jsb	prstr
X	jbr	abort
X
X#
X# prstr--print the null-terminated string pointed to by r0 on STDOUT
X#
Xwrprm:	.long	3			# Parm block for WRITE syscall
Xwrunit:	.space	4	# Output unit
Xwradr:	.space	4	# BufAddr
Xwrcnt:	.space	4	# Nbytes
X
Xprstr:	movl	ounit,wrunit		# Set the output descriptor
X	clrl	r1			# Count the bytes -> R1
X	movl	r0,wradr
Xprst1:	tstb	(r0)+
X	jeql	prst2
X	incl	r1
X	jbr	prst1
Xprst2:	movl	r0,r2			# Make next open addr. available in R2
X	movl	r1,wrcnt
X	movl	$wrprm,ap		# Now do the syscall
X	chmk	$4
X	rsb
X
X#
X# lookup--take the current word in "wrd" and see if it's in the dictionary
X#	chain. If it is, return with address in R0 and Z# otherwise
X#	return with NZ. If it is found, R1 will contain the SF.
X#
Xlookup:	movl	$wrd,r0			# R0 -> word
X	movl	r8,r1			# R1 -> next entry to check against
Xlook1:	addl3	$12,r1,r2		# R2 -> cur entry's name
X	movl	r0,r3			# R3 -> our word
X	bitw	$Smudged,10(r1)		# Smudged?
X	bnequ	look3
X
Xlook2:	cmpb	(r3)+,(r2)		# Compare the names
X	bnequ	look3			#  they didn't match
X	tstb	(r2)+			# They did; at end of names?
X	bnequ	look2			# No, keep going
X
X	movl	4(r1),r0		# We have a match. R0 -> entry
X	movl	r1,r2			# R2 -> top of entry
X	cvtwl	10(r1),r1		# R1 = (SFA)
X	clrb	r3			# Return Z
X	tstb	r3
X	rsb
Xlook3:	movl	(r1),r1			# Move to next entry
X	tstl	r1
X	bnequ	look1
X	clrb	r0			# No match, return NZ
X	decb	r0
X	rsb
X
X#
X# iswhite--return whether the character pointed to by R9 is a white
X#	space character
X#
Xiswhite:
X	movb	(r9),r3			# Keep this char in register
X	cmpb	$Tab,r3		# Tab
X	jeql	iswh1
X	cmpb	$Spc,r3		# Space
X	jeql	iswh1
X	cmpb	$NL,r3		# Newline
X	jeql	iswh1
X	tstb	r3		# NULL
Xiswh1:	rsb
X
X#
X# getlin--read another line of input from the current input file descriptor.
X#	Note that we do some fancy things here to allow either a file or a TTY
X#	to be read equivalently (and with reasonable efficiency). Namely,
X#	installing NULLS at the end of buffers, and reading (potentially) a
X#	full disk block from the input file descriptor.
X#
Xrdprm:	.long	3
Xrdunit:	.space	4
X	.long	inline,1024
Xprompt:	.asciz	"> "
Xgetlin:	movl	iunit,r0		# Get the input unit, put it in the
X	movl	r0,rdunit		#  the read area, prompt if ==0
X	tstl	r0
X	bneq	getl2
X	movl	$prompt,r0
X	jsb	prstr
Xgetl2:	movl	$rdprm,ap		# Read a block
X	chmk	$3
X	tstl	r0			# Test for EOF
X	jeql	getl1
X	clrb	inline(r0)		# Terminate the buffer with NULL
X	movl	$inline,r9		# Set the input line pointer
X	rsb
X
Xgetl1:	decl	ideep		# Decrement nesting depth count
X	movl	$256,r2		# R2 is the number of bytes to move
X	movl	ideep,r0
X	mull2	$1024,r0
X	addl2	$ibufs,r0	# R0 now points to our save location
X	movl	$inline,r1	# R1 points to the buffer to restore
Xgetl3:	movl	(r0)+,(r1)+	# Move the bytes
X	sobgtr	r2,getl3
X	movl	ideep,r0	# Now save the input index
X	movl	ibufx[r0],r9
X
X	movl	iunit,outp3		# EOF--Close the unit
X	movl	$outp4,ap
X	chmk	$6
X	movl	isp,r0			# If we're not at top, pop item
X	cmpl	r0,$istk
X	jeql	exit			# If at top, forth exits
X	subl2	$4,r0
X	movl	r0,isp
X	movl	(r0),iunit
X	rsb				# Return with the restored input buffer
X
X#
X# getw--get the next word in the current input line. If there are no
X#	more words in this line, get another from the input
X#
Xgetw:	jsb	iswhite			# Skip initial white space
X	bnequ	getw1
X	tstb	(r9)+			# Is white. If NULL, need new line
X	bnequ	getw
X	jsb	getlin
X	brb	getw
Xgetw1:	movl	$wrd,r0			# Found word. Copy into "wrd"
Xgetw2:	movb	(r9)+,(r0)+
Xgetw4:	jsb	iswhite
X	bnequ	getw2
X	tstb	(r9)			# Read new buffer if at end
X	bneq	getw5
X	pushl	r0			# Save R0, then call "getlin"
X	jsb	getlin
X	movl	(sp)+,r0
X	brb	getw4
Xgetw5:	clrb	(r0)			# add NULL at end of word
X	rsb
Xdictend:
X	.space	30000			# Dictionary space
!RoNnIe!RaYgUn!
exit