valencia@vger.UUCP (05/28/85)
#
# Vforth--a 32 bit forth system using subroutine threading for
# increased speed.
#
# By Andy Valencia, 1984
#
# Registers with fixed uses:
# PC - Since we're using direct threading, this operates as the actual
# execution vector for each instruction.
# SP - Maintains the return stack
# R11 - The operand stack
# R10 - Next open byte in the dictionary--"HERE"
# R9 - Index into current input line
# R8 - Points to last entry in the dictionary chain
#
#
# These are the constants which are compiled into the executable code
#
.set jsb_header,0x9F16 # jsb *$...
.set lit_header,0x8FD0 # pushl $...
.set lit_tailer,0x7B
.set rsb_header,0x5 # rsb
.set Again_header,0x9F17 # jmp *$...
.set Skipt,0x6128BD5 # tstl (r11)+; bnequ .+6
#
# These are the other constants
#
.set Recursive,1 # SFA bits: recursive function
.set Smudged,2 # SMUDGE bit
.set Priority,4 # IMMEDIATE
.set Primitive,8 # PRIMITIVE--is a code macro
.set NL,10 # Newline
.set Spc,32 # Space
.set Tab,9 # Tab
.set Mrkcolon,1 # For control structure matching
.set Mrkif,2
.set Mrkdo,3
.set Mrkbegin,4
.set Mrkwhile,5
.text 0
.globl go
go:
.word 0 # Procedure entry mask
go1: movl $dictend,r10 # r10 is end of dictionary
movl sp,sp_hold # For resetting SP later
movl *$latest,r8 # Setup R8 to end of dict.
abort: movl sp_hold,sp # Start SP from its initial value
subl3 $80,sp,r11 # Leave 80 bytes for opstack
movl r11,stacklim # For underflow checking
movl $inline,r9 # Set up input line as empty
clrb (r9)
clrl *$state # Turn off compile mode
movl $istk,isp # Reset I/O system
clrl istk
clrl iunit
movl $ostk,osp
cvtbl $1,ostk
cvtbl $1,ounit
jbr interp # Start up the interpretive loop
#
# Some data area
#
sp_hold: .space 4 # Holds return stack base
stacklim: .space 4 # Holds bottom of stack
inline: .space 1025 # Room for a block of input
wrd: .space 81 # and up to 80-char word
latest: # Last intrinsic word in dictionary
.long interp1
#
# Pushdown list of input & output file descriptors
istk: .long 0,0,0,0,0,0,0,0
isp: .long istk
ideep: .long 0
iunit: .long 0
ostk: .long 1,1,1,1,1,1,1,1
osp: .long ostk
odeep: .long 0
ounit: .long 1
#
# KLUDGE city! When we push down an input file, we have to save the buffer,
# otherwise the new input file will abuse it in various undesireable
# ways. So we make room for a save image of each input unit.
ibufs: .space 1024*8 # The input buffers
ibufx: .space 4*8 # and the current position within them
#
# Open the given file for output; add it to the pushdown stack. Error
# if it can't be opened.
#
outfcb: .long 3
outname: .space 4
.long 0x201,0x1FF
outopen:
movl r0,outname
movl $outfcb,ap
chmk $5
bcs outop1
movl osp,r1
addl2 $4,r1
movl r0,(r1)
movl r0,ounit
movl r1,osp
incl odeep
rsb
outop1: movl $outop2,r0 # Couldn't open--complain
jsb prstr
jbr abort
outop2: .asciz " Could not open output file\n"
#
# Open the given file for input; add it to the pushdown stack. Error
# if it can't be opened.
#
infcb: .long 3 # parms to do a OPEN for READ syscall
inname: .space 4
.long 0,0x1FF
inopen: movl r0,inname # Set up name for open
movl $infcb,ap
chmk $5
bcs inop1
# Open successful, save previous buffer
movl $256,r2 # R2 is the number of bytes to move
movl ideep,r3
mull2 $1024,r3
addl2 $ibufs,r3 # R3 now points to our save location
movl $inline,r1 # R1 points to the buffer to save
inop3: movl (r1)+,(r3)+ # Move the bytes
sobgtr r2,inop3
movl ideep,r3 # Now save the input index
movl r9,ibufx[r3]
movl $inline,r9 # Clear the input buffer
clrb (r9)
movl isp,r1 # Push down the old file descriptor
addl2 $4,r1
movl r0,(r1)
movl r0,iunit
movl r1,isp
incl ideep
rsb
inop1: movl $inop2,r0 # Bad open, complain & abort
jsb prstr
jbr abort
inop2: .asciz " Could not open input file.\n"
#
# ----Start of FORTH dictionary
#
#
# over--copy second to new top
#
.align 2
over2: .long 0,over1
.word 4,Primitive
.asciz "over"
over1: movl 4(r11),-(r11)
rsb
#
# abs,fabs--get absolute value
#
.align 2
abs2: .long over2,abs1,0
.asciz "abs"
abs1: tstl (r11)
bgeq abs3
mnegl (r11),(r11)
abs3: rsb
.align 2
fabs2: .long abs2,fabs1,0
.asciz "fabs"
fabs1: tstf (r11)
bgeq abs3
mnegf (r11),(r11)
rsb
#
# max,fmax--get maximum value
#
.align 2
max2: .long fabs2,max1,0
.asciz "max"
max1: movl (r11)+,r0
cmpl r0,(r11)
bleq max3
movl r0,(r11)
max3: rsb
.align 2
fmax2: .long max2,fmax1,0
.asciz "fmax"
fmax1: movf (r11)+,r0
cmpf r0,(r11)
bleq max3
movf r0,(r11)
fmax3: rsb
#
# min,fmin--get minimum value
#
.align 2
min2: .long fmax2,min1,0
.asciz "min"
min1: movl (r11)+,r0
cmpl r0,(r11)
bgeq min3
movl r0,(r11)
min3: rsb
.align 2
fmin2: .long min2,fmin1,0
.asciz "fmin"
fmin1: movf (r11)+,r0
cmpf r0,(r11)
bgeq min3
movf r0,(r11)
fmin3: rsb
#
# c@, c!--byte fetch/store operators
#
.align 2
cfet2: .long fmin2,cfet1
.word 6,Primitive
.asciz "c@"
cfet1: movl (r11),r0
cvtbl (r0),(r11)
rsb
.align 2
csto2: .long cfet2,csto1
.word 6,Primitive
.asciz "c!"
csto1: movl (r11)+,r0
cvtlb (r11)+,(r0)
rsb
#
# negate & fnegate
#
.align 2
neg2: .long csto2,neg1
.word 3,Primitive
.asciz "negate"
neg1: mnegl (r11),(r11)
rsb
.align 2
fneg2: .long neg2,fneg1
.word 3,Primitive
.asciz "fnegate"
fneg1: mnegf (r11),(r11)
rsb
#
# HERE--provide the address of the next open byte in the dictionary
#
.align 2
here2: .long fneg2,here1
.word 3,Primitive
.asciz "here"
here1: movl r10,-(r11)
rsb
#
# "r>" & ">r"--move a word between op & return stacks
#
.align 2
to_r2: .long here2,to_r1
.word 2,Primitive
.asciz ">r"
to_r1: pushl (r11)+
rsb
.align 2
from_r2:
.long to_r2,from_r1
.word 3,Primitive
.asciz "r>"
from_r1:
movl (sp)+,-(r11)
rsb
#
# fill--fill an area of memory with a constant
#
.align 2
fill2: .long from_r2,fill1,0
.asciz "fill"
fill1: cvtlb (r11)+,r0
movl (r11)+,r1
movl (r11)+,r2
fill3: movb r0,(r2)+
sobgtr r1,fill3
fill4: rsb
#
# pick--get a word in the stack
#
.align 2
pick2: .long fill2,pick1,0
.asciz "pick"
pick1: movl (r11)+,r0
movl (r11)[r0],-(r11)
rsb
#
# 'c,' & ','--push word to HERE
#
.align 2
comma2: .long pick2,comma1
.word 3,Primitive
.asciz ","
comma1: movl (r11)+,(r10)+
rsb
.align 2
ccomm2: .long comma2,ccomm1
.word 3,Primitive
.asciz "c,"
ccomm1: cvtlb (r11)+,(r10)+
rsb
#
# rot,-rot --the rotational operators
#
.align 2
rot2: .long ccomm2,rot1,0
.asciz "rot"
rot1: movl (r11)+,r0
movl (r11)+,r1
movl (r11),r2
movl r1,(r11)
movl r0,-(r11)
movl r2,-(r11)
rsb
.align 2
drot2: .long rot2,drot1,0
.asciz "-rot"
drot1: movl (r11)+,r0
movl (r11)+,r1
movl (r11),r2
movl r0,(r11)
movl r2,-(r11)
movl r1,-(r11)
rsb
#
# allot--move the end of the dictionary forward a number of bytes
#
.align 2
allot2: .long drot2,allot1
.word 3,Primitive
.asciz "allot"
allot1: addl2 (r11)+,r10
rsb
#
# 2dup, 2swap--double-int stack operators
#
.align 2
tdup2: .long allot2,tdup1,0
.asciz "2dup"
tdup1: movl (r11)+,r0
movl (r11),r1
movl r0,-(r11)
movl r1,-(r11)
movl r0,-(r11)
rsb
.align 2
tswap2: .long tdup2,tswap1,0
.asciz "2swap"
tswap1: movl (r11)+,r0
movl (r11)+,r1
movl (r11)+,r2
movl (r11),r3
movl r1,(r11)
movl r0,-(r11)
movl r3,-(r11)
movl r2,-(r11)
rsb
#
# "("--handle forth comments
#
.align 2
comm2: .long tswap2,comm1
.word 0,Priority
.asciz "("
comm1: movb (r9)+,r0 # Get next byte of input
cmpb r0,0 # Get another buffer-full if hit end of cur.
beql comm3
cmpb r0,$10 # End comment on newline or close paren
beql comm4
cmpb r0,$41
bneq comm1
comm4: rsb
comm3: jsb getlin # Get another buffer
brb comm1
#
# "abort"--calls the forth abort code
#
.align 2
abo2: .long comm2,abo1,0
.asciz "abort"
abo1: jbr abort
#
# "halt"--cause forth to exit
#
.align 2
halt3: .long 1,0
halt2: .long abo2,halt1,0
.asciz "halt"
exit:
halt1: movl $halt3,ap
chmk $1
#
# "outpop"--do for the output list what EOF does for the input list;
# close the current output file & pop back a level
#
.align 2
outp4: .long 1
outp3: .space 4
outp2: .long halt2,outp1,0
.asciz "outpop"
outp1: movl osp,r0 # Get the stack pointer to R0
cmpl r0,$ostk # Don't pop off end of stack
beql outp5
movl ounit,outp3 # Close the current unit
movl outp4,ap
chmk $6
movl osp,r0
subl2 $4,r0 # Move back a position
movl (r0),ounit # and set output to that file descriptor
movl r0,osp
decl odeep # Decrement nesting count
outp5: rsb
#
# "output"--open the named output file & make it the new output unit
#
.align 2
out2: .long outp2,out1,0
.asciz "output"
out1: jsb getw
movl $wrd,r0
jsb outopen
rsb
#
# "input"--open the named file & make it the new input unit
#
.align 2
inp2: .long out2,inp1,0
.asciz "input"
inp1: jsb getw # Get the name of the file
movl $wrd,r0
jsb inopen
rsb
#
# Push logical constants to stack
#
.align 2
false2: .long inp2,false1
.word 2,Primitive
.asciz "false"
false1: clrl -(r11)
rsb
.align 2
true2: .long false2,true1
.word 4,Primitive
.asciz "true"
true1: cvtbl $-1,-(r11)
rsb
#
# the logical operators. Note that they serve for both logical and
# bitwise purposes, as "true" is defined as -1.
#
.align 2
lor2: .long true2,lor1
.word 3,Primitive
.asciz "or"
lor1: bisl2 (r11)+,(r11)
rsb
.align 2
land2: .long lor2,land1
.word 6,Primitive
.asciz "and"
land1: mcoml (r11)+,r0
bicl2 r0,(r11)
rsb
#
# the floating relational operators
#
.align 2
feq2: .long land2,feq1,0
.asciz "f="
feq1: cmpf (r11)+,(r11)
beql feq3
clrl (r11)
rsb
feq3: cvtbl $-1,(r11)
rsb
.align 2
fgt2: .long feq2,fgt1,0 # Greater than
.asciz "f>"
fgt1: cmpf (r11)+,(r11)
blss fgt3
clrl (r11)
rsb
fgt3: cvtbl $-1,(r11)
rsb
.align 2
flt2: .long fgt2,flt1,0 # Less than
.asciz "f<"
flt1: cmpf (r11)+,(r11)
bgtr flt3
clrl (r11)
rsb
flt3: cvtbl $-1,(r11)
rsb
#
# the relational operators
#
.align 2
eq2: .long flt2,eq1,0
.asciz "="
eq1: cmpl (r11)+,(r11)
beql eq3
clrl (r11)
rsb
eq3: cvtbl $-1,(r11)
rsb
.align 2
gt2: .long eq2,gt1,0 # Greater than
.asciz ">"
gt1: cmpl (r11)+,(r11)
blss gt3
clrl (r11)
rsb
gt3: cvtbl $-1,(r11)
rsb
.align 2
lt2: .long gt2,lt1,0 # Less than
.asciz "<"
lt1: cmpl (r11)+,(r11)
bgtr lt3
clrl (r11)
rsb
lt3: cvtbl $-1,(r11)
rsb
#
# drop,2drop--get rid of top item(s)
#
.align 2
tdrop2: .long lt2,tdrop1
.word 3,Primitive
.asciz "2drop"
tdrop1: addl2 $8,r11
rsb
.align 2
drop2: .long tdrop2,drop1
.word 3,Primitive
.asciz "drop"
drop1: movl (r11)+,r0
rsb
#
# swap--exchange top & second
#
.align 2
swap2: .long drop2,swap1
.word 12,Primitive
.asciz "swap"
swap1: movl (r11)+,r0
movl (r11),r1
movl r0,(r11)
movl r1,-(r11)
rsb
#
# dup--duplicate top
#
.align 2
dup2: .long swap2,dup1
.word 3,Primitive
.asciz "dup"
dup1: movl (r11),-(r11)
rsb
#
# "if"--conditional control structure
#
.align 2
if2: .long dup2,if1
.word 0,Priority
.asciz "if"
if1: movl $0x6128BD5,(r10)+ # tstl (r11)+; bneq .+6
movw $0x9F17,(r10)+ # jmp *$...
movl r10,-(r11)
addl2 $4,r10
movl $Mrkif,-(r11) # Mark the control structure
rsb
#
# "else"
#
.align 2
else2: .long if2,else1
.word 0,Priority
.asciz "else"
else1: cmpl $Mrkif,(r11)+ # Check for matching 'if'
bneq else3
movw $0x9F17,(r10)+ # jmp *$...
movl r10,r0
addl2 $4,r10 # Leave room for the jump address
movl r10,*(r11)+ # Have 'false' branch here
movl r0,-(r11) # Put our fill-in addr.
movl $Mrkif,-(r11) # and put back the marker
rsb
else3: movl $else4,r0 # Complain
jsb prstr
jbr abort
else4: .asciz " 'else' does not match an 'if'\n"
#
# endif--finish off the conditional
#
.align 2
endif2: .long else2,endif1
.word 0,Priority
.asciz "endif"
endif1: cmpl (r11)+,$Mrkif # Check match
bneq endif3
movl r10,*(r11)+
rsb
endif3: movl $endif4,r0 # Complain on no match
jsb prstr
jbr abort
endif4: .asciz " 'endif' does not match 'else'/'if'\n"
#
# begin--start of all looping conditionals
#
.align 2
beg2: .long endif2,beg1
.word 0,Priority
.asciz "begin"
beg1: movl r10,-(r11) # Save current address
cvtbl $Mrkbegin,-(r11) # and control structure marker
rsb
#
# "while".."repeat" looping construct
#
while4: .asciz "'while' does not match a 'begin'\n"
.align 2
while2: .long beg2,while1
.word 0,Priority
.asciz "while"
while1: cmpl $Mrkbegin,(r11)+ # Check match
bneq while3
movl $0x6128BD5,(r10)+ # tstl (r11)+; bequ *$<forward>
movw $0x9F17,(r10)+
movl r10,-(r11) # Mark where to plug in
addl2 $4,r10 # Leave room for the patch
movl $Mrkwhile,-(r11)
rsb
while3: movl $while4,r0 # Bad match, complain
jsb prstr
jbr abort
rep4: .asciz "'repeat' does not match a 'while'\n"
.align 2
rep2: .long while2,rep1
.word 0,Priority
.asciz "repeat"
rep1: cmpl $Mrkwhile,(r11)+ # Check match
bneq rep3
movl (r11)+,r0 # Save where to patch
movw $0x9F17,(r10)+ # jmp *$<back>
movl (r11)+,(r10)+
movl r10,(r0) # Backpatch
rsb
rep3: movl $rep4,r0 # Complain
jsb prstr
jbr abort
#
# again--unconditional back branch
#
again4: .asciz "'again' does not match with a 'begin'\n"
.align 2
again2: .long rep2,again1
.word 0,Priority
.asciz "again"
again1: cmpl $Mrkbegin,(r11)+ # verify match of control structures
bnequ again3
movw $Again_header,(r10)+ # compile in back branch
movl (r11)+,(r10)+
rsb
again3: movl $again4,r0 # Complain
jsb prstr
jbr abort
#
# until--loop until condition becomes true
#
until4: .asciz "'until' doesn not match a 'begin'\n"
.align 2
until2: .long again2,until1
.word 0,Priority
.asciz "until"
until1: cmpl $Mrkbegin,(r11)+ # Verify match
bnequ until3
movl $Skipt,(r10)+ # Branch over backbranch if true
movw $Again_header,(r10)+ # compile in backbranch
movl (r11)+,(r10)+
rsb
until3: movl $until4,r0 # Complain
jsb prstr
jbr abort
#
# leave--setup innermost loop so it will exit at next iteration
#
.align 2
leave2: .long until2,leave1
.word 4,Primitive
.asciz "leave"
leave1: movl (sp),4(sp)
rsb
#
# "k"--return index of third loop
#
.align 2
k_idx2: .long leave2,k_idx1
.word 4,Primitive
.asciz "k"
k_idx1: movl 20(sp),-(r11)
rsb
#
# "j"--return index of second loop
#
.align 2
j_idx2: .long k_idx2,j_idx1
.word 4,Primitive
.asciz "j"
j_idx1: movl 12(sp),-(r11)
rsb
#
# "i"--return index of innermost loop
#
.align 2
i_idx2: .long j_idx2,i_idx1
.word 4,Primitive
.asciz "i"
i_idx1: movl 4(sp),-(r11)
rsb
#
# "do"--start a loop
#
.set Do1,0xD07E8BD0 # movl (r11)+,-(sp); movl (r11)+,-(sp)
.set Do2,0x7E8B
.set Do3,0xD0508ED0 # movl (sp)+,r0; movl (sp)+,r1
.set Do4,0x51D1518E # cmpl r1,r0; blss .+6
.set Do5,0x17061950 # jmp *$<forward>
.set Do6,0x9F
.set Do7,0xD07E51D0 # movl r1,-(sp); movl r1,-(sp)
.set Do8,0x7E50
.align 2
do2: .long i_idx2,do1
.word 0,Priority
.asciz "do"
do1: movl $Do1,(r10)+
movw $Do2,(r10)+
movl r10,-(r11) # Save current pos. for back branch
movl $Do3,(r10)+
movl $Do4,(r10)+
movl $Do5,(r10)+
movb $Do6,(r10)+
movl r10,-(r11) # Save this loc for fill-in as forward branch
addl2 $4,r10
movl $Do7,(r10)+
movw $Do8,(r10)+
movl $Mrkdo,-(r11) # Flag our control structure
rsb
#
# loop--branch back to the opening "DO"
#
.set Loop1,0x1704AED6 # incl 4(sp); jmp *$<back>
.set Loop2,0x9F
loop3: .asciz "'loop' does not match a 'do'\n"
.align 2
loop2: .long do2,loop1
.word 0,Priority
.asciz "loop"
loop1: cmpl $Mrkdo,(r11)+ # Check for match of control structures
bnequ loop4
movl (r11)+,r0 # Keep where to fill in forward branch addr.
movl $Loop1,(r10)+ # Build code to increment loop
movb $Loop2,(r10)+
movl (r11)+,(r10)+
movl r10,(r0) # Fill in this location as loop exit addr.
rsb
loop4: movl $loop3,r0 # Bad match--complain
jsb prstr
jbr abort
#
# +loop--like loop, but add by the top item instead of 1
#
.set Loop1,0x4AE8BC0 # incl 4(sp); jmp *$<back>
.set Loop2,0x9F17
poop3: .asciz "'+loop' does not match a 'do'\n"
.align 2
poop2: .long loop2,poop1
.word 0,Priority
.asciz "+loop"
poop1: cmpl $Mrkdo,(r11)+ # Check for match of control structures
bnequ poop4
movl (r11)+,r0 # Keep where to fill in forward branch addr.
movl $Loop1,(r10)+ # Build code to increment loop
movw $Loop2,(r10)+
movl (r11)+,(r10)+
movl r10,(r0) # Fill in this location as loop exit addr.
rsb
poop4: movl $poop3,r0 # Bad match--complain
jsb prstr
jbr abort
#
# "@"--fetch the contents of the addressed word
#
.align 2
fetch2: .long poop2,fetch1
.word 4,Primitive
.asciz "@"
fetch1: movl *(r11),(r11)
rsb
#
# "!"--store the word (second) to address (top)
#
.align 2
store2: .long fetch2,store1
.word 6,Primitive
.asciz "!"
store1: movl (r11)+,r0
movl (r11)+,(r0)
rsb
#
# "variable"--build a variable
#
.set Var1,0x8FD0 # movl $<addr>,-(r11)
.set Var2,0x7B
.align 2
var2: .long store2,var1,0
.asciz "variable"
var1: addl2 $3,r10 # Longword-align the entry
bicl2 $3,r10
jsb getw # Build the header
movl r8,r2 # Add this word to the chain
movl r10,r8
movl r2,(r10)+
movl r10,r0 # Save this position (PFA)
clrl (r10)+
cvtbw $7,(r10)+ # SFP = 7
cvtbw $Primitive,(r10)+ # SFA = "primitive"
movl $wrd,r1 # Now copy the name in
var3: movb (r1)+,(r10)
tstb (r10)+
bnequ var3
movl r10,(r0) # Update the PFA
movw $Var1,(r10)+ # Our in-line code
addl3 $6,r10,(r10)+
movb $Var2,(r10)+
movb $rsb_header,(r10)+
clrl (r10)+ # The first word of space (= 0)
rsb
#
# "constant"--build a constant value
#
.align 2
const2: .long var2,const1,0
.asciz "constant"
const1: jsb getw # Build the header
movl r8,r2 # Add this word to the chain
movl r10,r8
movl r2,(r10)+
movl r10,r0 # Save this position (PFA)
clrl (r10)+
cvtbw $7,(r10)+ # SFP = 7
cvtbw $Primitive,(r10)+ # SFA = "primitive"
movl $wrd,r1 # Now copy the name in
const3: movb (r1)+,(r10)
tstb (r10)+
bnequ const3
movl r10,(r0) # Update the PFA
movw $Var1,(r10)+ # Our in-line code
movl (r11)+,(r10)+ # the value to push
movb $Var2,(r10)+
movb $rsb_header,(r10)+
rsb
#
# ":"--start a colon definition
#
.align 2
colon2: .long const2,colon1,0
.asciz ":"
colon1: cvtbl $1,state # Set our state to "compile"
jsb getw # Get the name of the new word
movl r8,r2 # Add this word to the chain
movl r10,r8
movl r2,(r10)+
movl r10,r0 # Save this position (PFA)
clrl (r10)+
clrw (r10)+ # SFP = 0
cvtbw $Smudged,(r10)+ # SFA = "smudged"
movl $wrd,r1 # Now copy the name in
colon3: movb (r1)+,(r10)
tstb (r10)+
bnequ colon3
movl r10,(r0) # Finally, update the PFA
movl $Mrkcolon,-(r11) # and leave our mark on the stack
rsb
#
# ";"--end compile mode
#
semi4: .asciz "; not matched to ':'\n"
.align 2
semi2: .long colon2,semi1
.word 0,Priority
.asciz ";"
semi1: clrl state # Reset compile state
cmpl $Mrkcolon,(r11)+ # Check the mark
beql semi3 # Uh-oh, bad match
movl $semi4,r0 # Complain
jsb prstr
rsb
semi3: clrw 10(r8) # All OK, so clear the smudge
movb $rsb_header,(r10)+ # Add the closing RSB
rsb
#
# "mod"--get remainder of division
#
.align 2
mod2: .long semi2,mod1,0
.asciz "mod"
mod1: movl (r11)+,r0
movl (r11),r2
clrl r3
ediv r0,r2,r2,(r11)
rsb
#
# ">>"--shift second number right by top number of bits, push result
#
.align 2
ashr2: .long mod2,ashr1
.word 7,Primitive
.asciz ">>"
ashr1: mnegl (r11)+,r0
ashl r0,(r11),(r11)
rsb
#
# "<<"--shift second number left by top number of bits, push result
#
.align 2
ashl2: .long ashr2,ashl1
.word 7,Primitive
.asciz "<<"
ashl1: cvtlb (r11)+,r0
ashl r0,(r11),(r11)
rsb
#
# "/"--divide second by top
#
.align 2
div2: .long ashl2,div1
.word 3,Primitive
.asciz "/"
div1: divl2 (r11)+,(r11)
rsb
#
# "*"--multiply top two items on stack
#
.align 2
mul2: .long div2,mul1
.word 3,Primitive
.asciz "*"
mul1: mull2 (r11)+,(r11)
rsb
#
# "-"--subtract top two integers, push result
#
.align 2
minus2: .long mul2,minus1
.word 3,Primitive
.asciz "-"
minus1: subl2 (r11)+,(r11)
rsb
#
# "f+"--add floating
#
.align 2
fplus2: .long minus2,fplus1
.word 3,Primitive
.asciz "f+"
fplus1: addf2 (r11)+,(r11)
rsb
#
# "f-"--subtract floating
#
.align 2
fminus2:
.long fplus2,fminus1
.word 3,Primitive
.asciz "f-"
fminus1:
subf2 (r11)+,(r11)
rsb
#
# "f*"--multiply floating
#
.align 2
fmul2: .long fminus2,fmul1
.word 3,Primitive
.asciz "f*"
fmul1: mulf2 (r11)+,(r11)
rsb
#
# "f/"--divide floating
#
.align 2
fdiv2: .long fmul2,fdiv1
.word 3,Primitive
.asciz "f/"
fdiv1: divf2 (r11)+,(r11)
rsb
#
# "i->f"--convert int to float
#
.align 2
i2f2: .long fdiv2,i2f1
.word 3,Primitive
.asciz "i->f"
i2f1: cvtlf (r11),(r11)
rsb
#
# "f->i"--convert float to int
#
.align 2
f2i2: .long i2f2,f2i1
.word 3,Primitive
.asciz "f->i"
f2i1: cvtfl (r11),(r11)
rsb
#
# "+"--add top two integers, push result back to stack
#
.align 2
plus2: .long f2i2,plus1
.word 3,Primitive
.asciz "+"
plus1: addl2 (r11)+,(r11)
rsb
#
# emit--print the specified character
#
emit5: .space 1
.align 2
emit3: .long 3
emit4: .space 4
.long emit5,1
emit2: .long plus2,emit1,0
.asciz "emit"
emit1: cvtlb (r11)+,emit5 # Put the desired char into the buffer
movl $emit3,ap # Print the buffer
movl ounit,emit4
chmk $4
rsb
#
# cr--print newline
#
cr5: .asciz "\n"
.align 2
cr3: .long 3
cr4: .space 4
.long cr5,1
cr2: .long emit2,cr1,0
.asciz "cr"
cr1: movl $cr3,ap
movl ounit,cr4
chmk $4
rsb
#
# "f."--print a floating point number
#
fprbuf: .space 10 # Output buffer for fractional part
.align 2
fprn2: .long cr2,fprn1,0
.asciz "f."
fprn1: movf (r11),r2 # Handle negative numbers
cmpf r2,$0F0.0 # If it's negative...
bgeq fprn9
movl $fprbuf,r0 # Print a '-'
movl r0,r1
movb $'-,(r1)+
clrb (r1)
jsb prstr
mnegf (r11),(r11) # And negate it
fprn9: cvtfl (r11),-(r11) # Dup the number for "."
jsb prnum1
movl $fprbuf,r3 # R3 points to buffer position
movf (r11)+,r0 # Get the number
cvtfl r0,r1 # Get the integer part
cvtlf r1,r1
subf2 r1,r0 # And take it off the number
movb $'.,(r3)+ # The decimal point
cvtbl $6,r4 # We always print 6 places
fprn3: mulf2 $0F10.0,r0 # Get the next digit
cvtfl r0,r1 # R1 is the next digit
cvtlf r1,r5 # Take this digit off the number
subf2 r5,r0
cvtlb r1,r1 # Turn it into the ASCII byte
addb3 $'0,r1,(r3)+
sobgtr r4,fprn3 # Loop 6 times
clrb (r3)
movl $fprbuf,r0 # Now print it
jsb prstr
rsb
#
# ." --if compiling, generate code to print a string, otherwise just
# print the string
#
dotqbuf:
.space 133
.align 2
dotq2: .long fprn2,dotq1
.word 0,Priority
.asciz ".\""
dotq1: movl $dotqbuf,r1
cmpb (r9),$32 # Skip char if it's the separating blank
bneq dotq7
incl r9
dotq7: movb (r9)+,r0 # get the next char of the string
cmpb $'",r0 # End string on newline or '"'
beql dotq4
cmpb $10,r0
beql dotq4
tstb r0 # At end of current input buffer?
beql dotq5
movb r0,(r1)+ # No. Add this char to our output line
brb dotq7
dotq5: jsb getlin # Yes. Get another buffer
brb dotq7
dotq4: clrb (r1) # Make the resulting string NULL-terminated
movl $dotqbuf,r0 # Point R0 to head of this string
tstl *$state # Check state
beql dotq3
movw $jsb_header,(r10)+ # Compile in reference to (.")
movl $pdotq1,(r10)+
dotq6: movb (r0)+,(r10)+ # Copy in the string
bneq dotq6
rsb
dotq3: jsb prstr # Print the string
rsb
#
# (.")--run-time code to print a string
#
.align 2
pdotq2: .long dotq2,pdotq1,0
.asciz "(.\")"
pdotq1: movl (sp)+,r0 # Get the address of our return loc.
jsb prstr # Print the string
pushl r2 # Return to addr following string
rsb
#
# "."--pop and print the top number on the stack
#
.space 14 # Null-terminated string buffer
prnbuf: .byte 0
.align 2
prnum2: .long pdotq2,prnum1,0
.asciz "."
prnum1: movl base,r5 # Get the base
movl (r11)+,r0 # R0 holds the number
movl $prnbuf,r1 # R1 points to the char positions
movl r0,r2 # Keep a copy to do the sign
tstl r0 # Negate if negative
bgeq prnum3
mnegl r0,r0
prnum3: divl3 r5,r0,r3 # R3 holds new number
mull3 r5,r3,r4 # Calculate remainder the hard way
subl3 r4,r0,r4
cmpl r4,$9 # See if it's a HEX digit
bleq prnu5
addb3 $('A-10),r4,-(r1)
brb prnu6
prnu5: addb3 $'0,r4,-(r1) # Put it in as the next digit
prnu6: movl r3,r0 # Update number
tstl r0
bnequ prnum3
tstl r2 # Now check sign
bgeq prnum4
movb $'-,-(r1)
prnum4: movl r1,r0 # print the number
jsb prstr
rsb
#
# sin & cos (and the corresponding fsin & fcos)
#
.align 2
sintab:
.long 0, 174, 348, 523, 697, 871, 1045, 1218, 1391, 1564, 1736
.long 1908, 2079, 2249, 2419, 2588, 2756, 2923, 3090, 3255, 3420
.long 3583, 3746, 3907, 4067, 4226, 4383, 4539, 4694, 4848, 5000
.long 5150, 5299, 5446, 5591, 5735, 5877, 6018, 6156, 6293, 6427
.long 6560, 6691, 6819, 6946, 7071, 7193, 7313, 7431, 7547, 7660
.long 7771, 7880, 7986, 8090, 8191, 8290, 8386, 8480, 8571, 8660
.long 8746, 8829, 8910, 8987, 9063, 9135, 9205, 9271, 9335, 9396
.long 9455, 9510, 9563, 9612, 9659, 9702, 9743, 9781, 9816, 9848
.long 9876, 9902, 9925, 9945, 9961, 9975, 9986, 9993, 9998, 10000
.align 2
sin2: .long prnum2,sin1,0
.asciz "sin"
sin1: movl (r11)+,r0 # Get angle
clrl r1 # Negative quadrant flag
sin3: tstl r0 # Fold negative angles
bgeq sin4
addl2 $360,r0
brb sin3
sin4: cmpl r0,$360 # Fold angles > 360
blss sin5
subl2 $360,r0
brb sin4
sin5: cmpl r0,$181 # Flag & fold negative quadrant vals
blss sin6
movb $-1,r1
subl3 r0,$360,r0
sin6: cmpl r0,$91 # Fold equivalent 2nd quadrant
blss sin7
subl3 r0,$180,r0
sin7: movl sintab[r0],r0 # Get the value
tstl r1 # Negate if needed
beql sin8
mnegl r0,r0
sin8: movl r0,-(r11) # Push result
rsb
.align 2
cos2: .long sin2,cos1,0
.asciz "cos"
cos1: subl3 (r11),$90,(r11) # sin(90-a) = cos(a)
jsb sin1
rsb
.align 2
fsin2: .long cos2,fsin1,0
.asciz "fsin"
fsin1: cvtfl (r11),(r11) # Change to int & call sin
jsb sin1
cvtlf (r11),r0
divf3 $0F10000.0,r0,(r11) # Scale down to true float
rsb
.align 2
fcos2: .long fsin2,fcos1,0
.asciz "fcos"
fcos1: cvtfl (r11),(r11) # Change to int & call sin
jsb cos1
cvtlf (r11),r0
divf3 $0F10000.0,r0,(r11) # Scale down to true float
rsb
#
# decimal--set FORTH's base to decimal
#
.align 2
decim2: .long fcos2,decim1,0
.asciz "decimal"
decim1: cvtbl $10,base
rsb
#
# hex--set FORTH's base to hexadecimal
#
.align 2
hex2: .long decim2,hex1,0
.asciz "hex"
hex1: cvtbl $16,base
rsb
#
# BASE variable--holds the current base
#
.align 2
base2: .long hex2,base1,0
.asciz "base"
base1: movl $base,-(r11)
rsb
base: .long 10
#
# STATE variable--0=interp, 1=compiling
#
.align 2
state2: .long base2,state1,0
.asciz "state"
state1: movl $state,-(r11)
rsb
state: .long 0
#
# isdig--return whether the first character in the current word is
# a numeric digit (watch out for HEX!)
#
isdig: movb (r7),r3 # Put the char in question into R3
cmpb r3,$48 # Check for 0..9
blss isdig1
cmpb r3,$58
blss isdig2
movl r6,r4 # The base comes into us in R6
cmpl r4,$11 # For higher bases, check A..?
blss isdig1
addl2 $54,r4 # Change the base into the highest char
cmpb r3,$97 # Map a..? to A..?
blss isdig3
subb2 $32,r3
isdig3: cmpb r3,$65 # Check against 'A'
blss isdig1
cmpb r4,r3 # Check against highest char
blss isdig1
brb isdig2
isdig1: clrb r3 # KLUDGE to return NZ
decb r3
rsb
isdig2: clrb r3 # Likewise for Z
tstb r3
rsb
interp6: .asciz " ?Stack empty\n"
.align 2
interp1:
.long state2,interp,0
.asciz "interp"
interp: cmpl r11,stacklim # Check for underflow
bleq interp5
movl $interp6,r0 # Underflowed. Complain & abort
jsb prstr
jbr abort
interp5:
jsb getw # Get next word
jsb lookup # In the dictionary?
bneq cknum # No, see if it's a number
tstb state # Yes, either compile or execute
bneq interp2
interp4:
jsb (r0) # execute via its address
brb interp
interp2:
bitl $Priority,r1 # See if it's immediate
jnequ interp4
bitl $Primitive,r1 # See if it generates in-line code
bnequ interp7
movw $jsb_header,(r10)+ # compile it with a "jsb" header
movl r0,(r10)+
jbr interp
interp7:
cvtwl 8(r2),r1 # Get number of bytes in def.
interp8:
movb (r0)+,(r10)+ # Copy bytes of insructions
decl r1 # See if done
bnequ interp8
jbr interp
sign: .space 1 # Flags the sign
cknum: movl $wrd,r7 # R7 is our index to the line
clrb sign # Take care of negative #'s here
cmpb (r7),$'-
bneq cknu1
movb $-1,sign
incl r7
cknu1: movl base,r6 # Keep base in R6
jsb isdig # Is this a number?
jneq badwrd # No, complain
clrl r1
ckn1: cvtbl (r7)+,r0 # Loop. Get next digit
subl2 $'0,r0
cmpl r0,$10 # Fix things up for HEX
blss ckn2
subl2 $17,r0
cmpl r0,$6
blss ckn8 # Turn R0 into the hex value
subl2 $32,r0
ckn8: addl2 $10,r0
ckn2: mull2 r6,r1 # Scale up R1, add in R0
addl2 r0,r1
jsb isdig # Loop if have more chars
jeql ckn1
cmpb $46,(r7) # If has decimal point, is floating pt.
bneq ckn4
incl r7 # It does, move to first digit
cvtlf r1,r1
movf $0F0.1,r0 # R0 is our scaling factor
ckn5: jsb isdig # See if more digits
bneq ckn6
subb3 $48,(r7)+,r2 # Get next digit, convert to float num
cvtbf r2,r2
mulf2 r0,r2 # Scale by current factor
addf2 r2,r1 # Add it in to the current number
divf2 $0F10.0,r0 # Move our factor down one place
brb ckn5
ckn6: tstb sign # Do negation if needed
beql cknu2
mnegf r1,r1
brb cknu2
ckn4: tstb (r7) # Make sure there's no trailing junk
jneq badwrd # Bad number. Don't need to restore
# R9 because ABORT does it anyway
tstb sign # negate if it started with '-'
beql cknu2
mnegl r1,r1
cknu2: tstb *$state # Compile or push this number
jneq ckn3
movl r1,-(r11)
jbr interp
ckn3: movw $lit_header,(r10)+ # pushl $...
movl r1,(r10)+
movb $lit_tailer,(r10)+
jbr interp
#
# badwrd--print the offending word, then call abort to restart the
# interpreter.
#
dunno: .asciz ": not found\n"
badwrd: movl $wrd,r0 # First print the offending word
jsb prstr
movl $dunno,r0 # then, ": not found"
jsb prstr
jbr abort
#
# prstr--print the null-terminated string pointed to by r0 on STDOUT
#
wrprm: .long 3 # Parm block for WRITE syscall
wrunit: .space 4 # Output unit
wradr: .space 4 # BufAddr
wrcnt: .space 4 # Nbytes
prstr: movl ounit,wrunit # Set the output descriptor
clrl r1 # Count the bytes -> R1
movl r0,wradr
prst1: tstb (r0)+
jeql prst2
incl r1
jbr prst1
prst2: movl r0,r2 # Make next open addr. available in R2
movl r1,wrcnt
movl $wrprm,ap # Now do the syscall
chmk $4
rsb
#
# lookup--take the current word in "wrd" and see if it's in the dictionary
# chain. If it is, return with address in R0 and Z# otherwise
# return with NZ. If it is found, R1 will contain the SF.
#
lookup: movl $wrd,r0 # R0 -> word
movl r8,r1 # R1 -> next entry to check against
look1: addl3 $12,r1,r2 # R2 -> cur entry's name
movl r0,r3 # R3 -> our word
bitw $Smudged,10(r1) # Smudged?
bnequ look3
look2: cmpb (r3)+,(r2) # Compare the names
bnequ look3 # they didn't match
tstb (r2)+ # They did; at end of names?
bnequ look2 # No, keep going
movl 4(r1),r0 # We have a match. R0 -> entry
movl r1,r2 # R2 -> top of entry
cvtwl 10(r1),r1 # R1 = (SFA)
clrb r3 # Return Z
tstb r3
rsb
look3: movl (r1),r1 # Move to next entry
tstl r1
bnequ look1
clrb r0 # No match, return NZ
decb r0
rsb
#
# iswhite--return whether the character pointed to by R9 is a white
# space character
#
iswhite:
movb (r9),r3 # Keep this char in register
cmpb $Tab,r3 # Tab
beql iswh1
cmpb $Spc,r3 # Space
beql iswh1
cmpb $NL,r3 # Newline
beql iswh1
tstb r3 # NULL
iswh1: rsb
#
# getlin--read another line of input from the current input file descriptor.
# Note that we do some fancy things here to allow either a file or a TTY
# to be read equivalently (and with reasonable efficiency). Namely,
# installing NULLS at the end of buffers, and reading (potentially) a
# full disk block from the input file descriptor.
#
rdprm: .long 3
rdunit: .space 4
.long inline,1024
prompt: .asciz "> "
getlin: movl iunit,r0 # Get the input unit, put it in the
movl r0,rdunit # the read area, prompt if ==0
tstl r0
bneq getl2
movl $prompt,r0
jsb prstr
getl2: movl $rdprm,ap # Read a block
chmk $3
tstl r0 # Test for EOF
jeql getl1
clrb inline(r0) # Terminate the buffer with NULL
movl $inline,r9 # Set the input line pointer
rsb
getl1: decl ideep # Decrement nesting depth count
movl $256,r2 # R2 is the number of bytes to move
movl ideep,r0
mull2 $1024,r0
addl2 $ibufs,r0 # R0 now points to our save location
movl $inline,r1 # R1 points to the buffer to restore
getl3: movl (r0)+,(r1)+ # Move the bytes
sobgtr r2,getl3
movl ideep,r0 # Now save the input index
movl ibufx[r0],r9
movl iunit,outp3 # EOF--Close the unit
movl $outp4,ap
chmk $6
movl isp,r0 # If we're not at top, pop item
cmpl r0,$istk
jeql exit # If at top, forth exits
subl2 $4,r0
movl r0,isp
movl (r0),iunit
rsb # Return with the restored input buffer
#
# getw--get the next word in the current input line. If there are no
# more words in this line, get another from the input
#
getw: jsb iswhite # Skip initial white space
bnequ getw1
tstb (r9)+ # Is white. If NULL, need new line
bnequ getw
jsb getlin
brb getw
getw1: movl $wrd,r0 # Found word. Copy into "wrd"
getw2: movb (r9)+,(r0)+
getw4: jsb iswhite
bnequ getw2
tstb (r9) # Read new buffer if at end
bneq getw5
pushl r0 # Save R0, then call "getlin"
jsb getlin
movl (sp)+,r0
brb getw4
getw5: clrb (r0) # add NULL at end of word
rsb
.comm dictend,500000 # Dictionary space