simlab <@CSNET-RELAY.ARPA,@ucsc.csnet (Simlab Class):simlab@ucsc (02/02/85)
This release of VFORTH has a bug fix in the "f." word, and
a change to "fill". My previous posting was only marginally successful
(many systems never received it), so I am posting in its entirety, rather
than with diff's. This FORTH is my original creation, and uses
subroutine-threading and in-line code generation to improve performance.
It is written in VAX assembly code, and runs on BSD 4.2. Moving it to
other versions of VAX UNIX shouldn't be too bad, but otherwise you might
as well forget it.
Faster than BASIC, and structured, too!
Andy Valencia
...!{ucbvax,fortune}!hpda!vandys
: This is a shar archieve. Extract with sh, not csh.
: The rest of this file will extract:
: Makefile glossary vforth.doc vforth.s
echo extracting - Makefile
sed 's/^X//' > Makefile << '/*EOF'
Xvforth: vforth.s
X as -o vforth vforth.s
X chmod a+x vforth
/*EOF
echo extracting - glossary
sed 's/^X//' > glossary << '/*EOF'
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.
X
/*EOF
echo extracting - vforth.doc
sed 's/^X//' > vforth.doc << '/*EOF'
X
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
X
/*EOF
echo extracting - vforth.s
sed 's/^X//' > vforth.s << '/*EOF'
X
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: movb r0,(r2)+
X sobgtr r1,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: movf (r11),r2 # Handle negative numbers
X cmpf r2,$0F0.0 # If it's negative...
X bgeq fprn9
X movl $fprbuf,r0 # Print a '-'
X movl r0,r1
X movb $'-,(r1)+
X clrb (r1)
X jsb prstr
X mnegf (r11),(r11) # And negate it
Xfprn9: 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
X
/*EOF