UNIX FORTH for the PDP11 (part 3 of 7)
lwt1 at aplvax.UUCP
lwt1 at aplvax.UUCP
Sat Jun 9 05:56:03 AEST 1984
Here is part 3 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - prim.as
cat >prim.as <<'+E+O+F'
/ Copyright 1984 by The Johns Hopkins University/Applied Physics Lab.
/ Free non-commercial distribution is *encouraged*, provided that:
/
/ 1. This copyright notice is included in any distribution, and
/ 2. You let us know that you're using it.
/
/ Please notify:
/
/ Lloyd W. Taylor
/ JHU/Applied Physics Lab
/ Johns Hopkins Road
/ Laurel, MD 20707
/ (301) 953-5000
/
/ Usenet: ... seismo!umcp-cs!aplvax!lwt1
/
/
/ Unix-FORTH was developed under NASA contract NAS5-27000 for the
/ Hopkins Ultraviolet Telescope, a March 1986 Space Shuttle mission. (we
/ hope to take a peek at Halley's comet!)
/
/ Written entirely by Wizard-In-Residence John R. Hayes.
/
/ * Unix is a trademark of Bell Labs.
/
/
/ FORTH PDP-11 inner interpreter and code primitives
/
iar =r4
psp =r5
nl =012 / newline
tab =011 / tab
EOF =-1 / end of file
BLKSIZE=512. / disk block size
/ start-up code
mov $pstack,psp / TEST
mov $dict,DP
mov $16.,BASE / base is hex
mov $quit-6,INITVOCAB
mov $quit+4,iar / point to high level QUIT code
jmp *(iar)+
/ parameter stack
.=.+256. / 256 byte stack TEST
pstack:
/ text input buffer
inbuf: .=.+120. / 120 characters
/ (:) Code for next is thing at bottom of dictionary
.byte 3; <(:)>
.byte 0,0 / end of dictionary
next: jmp *(iar)+
/ The code for call is compiled in-line for colon definitions.
/
/ call: jsr iar,*$next
/
/ (;)
.byte 3; <(;)>
next-6
return: mov (sp)+,iar
jmp *(iar)+
/
/ This is tricky code. All words defined by VARIABLE, CONSTANT, or
/ <BUILDS .. DOES> words will have similar code fields. Therefore the
/ code for (VARIABLE), (CONSTANT), and (DOES>) is shown below.
/ Code compiled by VARIABLE will be:
/ jsr iar,*$var
/ (VARIABLE)
.byte 12; <(VA>
return-6
var: mov iar,-(psp)
mov (sp)+,iar
jmp *(iar)+
/ (CONSTANT)
.byte 12; <(CO>
var-6
con: mov (iar),-(psp)
mov (sp)+,iar
jmp *(iar)+
/ (DOES>)
.byte 7; <(DO>
con-6
pdoes: mov (iar)+,r0
mov iar,-(psp)
mov r0,iar
jmp *(iar)+
/ branching primitives
/ (LITERAL)
.byte 11; <(LI>
pdoes-6
lit: mov (iar)+,-(psp)
jmp *(iar)+
/ BRANCH
.byte 6; <BRA>
lit-6
branch: mov (iar),iar
jmp *(iar)+
/ ?BRANCH
.byte 7; <?BR>
branch-6
zbranch:
mov (psp)+,r0
beq branch
add $2,iar
jmp *(iar)+
/ EXECUTE
.byte 7; <EXE>
zbranch-6
execute:
jmp *(psp)+
/ FORTH-83 do loops
/ (DO)
.byte 4; <(DO>
execute-6
pdo: mov (psp)+,r1
mov (psp)+,r0
add $100000,r0 / limit' := limit + 8000
mov r0,-(sp)
sub r0,r1 / imit' := init - limit'
mov r1,-(sp)
jmp *(iar)+
/ (LOOP)
.byte 6; <(LO>
pdo-6
ploop: inc (sp)
bvs exitloop
mov (iar),iar / loop back
jmp *(iar)+
exitloop:
add $4,sp / pop return stack
add $2,iar / skip loop address
jmp *(iar)+
/ (+LOOP)
.byte 7; <(+L>
ploop-6
pploop: add (psp)+,(sp)
bvs exitloop
mov (iar),iar / loop back
jmp *(iar)+
/ I
.byte 1; <I >
pploop-6
i: mov (sp),r0
add 2(sp),r0 / i := i' + limit'
mov r0,-(psp)
jmp *(iar)+
/ J
.byte 1; <J >
i-6
j: mov 4(sp),r0
add 6(sp),r0
mov r0,-(psp)
jmp *(iar)+
/ (LEAVE)
.byte 7; <(LE>
j-6
pleave: add $4,sp / pop return stack
mov (iar),iar / branch past loop
jmp *(iar)+
/ basic unix system interface routines
/ buffer for holding indirect system calls
sysbuf: .byte 0,0 / trap instruction
.byte 0,0 / argument 1
.byte 0,0 / argument 2
.byte 0,0 / argument 3
/ I/O buffer and control variables
block: .=.+BLKSIZE; .even
size: .byte 0,0 / size in bytes
index: .byte 0,0 / current offset into block
fd: .byte -1,-1 / file descriptor of file this block belongs to
/ file position table: each slot has a 32 bit file offset. file descriptor
/ is index into table. There are 15 slots.
filepos:
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
/ subroutine getc: handles all input and does buffering
/ input: file descriptor in r0
/ output: character or EOF in r0
/ side effects: r0 and r1
getc: cmp r0,fd / is this file in buffer?
beq 0f / if so, do not need to seek
mov r0,fd / save new fd in buffer descriptor
mov size,index / indicate that buffer is empty
mov $104423,sysbuf / move lseek trap instruction to sysbuf
asl r0; asl r0 / multiply by 4 to index into table
mov filepos(r0),sysbuf+2 / high offset word
mov filepos+2(r0),sysbuf+4 / low offset word
clr sysbuf+6 / offset from beginning of file
mov fd,r0 / file descriptor in r0
sys 0;sysbuf / seek sytem call
mov fd,r0 / restore fd since call destroyed r0,r1
0: mov r2,-(sp) / save r2
mov *$index,r2 / r2 is index
cmp r2,*$size
blt 1f / if there is still data in buffer, use it
sys 3;block;BLKSIZE / read up to BLKSIZE bytes
bcs 2f / branch if error
mov r0,*$size / save size of block
beq 2f / branch if eof
clr r2 / reset index
1: movb block(r2),r0 / get next character
bic $17400,r0 / mask off high byte
inc r2
mov r2,*$index / update index
mov fd,r2 / reuse r2 to hold file descriptor
asl r2; asl r2 / multiply by 4 to index into table
add $1,filepos+2(r2) / add one to current file position
adc filepos(r2)
br 3f
2: mov $EOF,r0 / return EOF on error condition
3: mov (sp)+,r2 / restore r2
rts pc
/ OPEN ( addr[string] mode --- fd )
.byte 4; <OPE>
pleave-6
open: mov $104405,sysbuf / move trap 5 instruction to indir area
mov (psp)+,sysbuf+4 / mode
mov (psp),sysbuf+2 / addr[filename]
sys 0;sysbuf
bcc 1f
mov $-1,(psp) / error, negative file descriptor returned
br 2f
1: mov r0,(psp) / return file descriptor
asl r0; asl r0 / multiply by 4 to index into table
clr filepos(r0) / initialize file position to zero
clr filepos+2(r0)
2: jmp *(iar)+
/ CREAT ( addr[string] pmode --- fd/-1 )
.byte 5; <CRE>
open-6
creat: mov $104410,sysbuf / move trap 8 instruction to indir area
mov (psp)+,sysbuf+4 / move mode
mov (psp),sysbuf+2 / move address of file name
sys 0;sysbuf / creat system call
bcc 1f
mov $-1,(psp) / error, negative file descriptor returned
br 2f
1: mov r0,(psp) / return file descriptor
asl r0; asl r0 / multiply by 4 to index into position table
clr filepos(r0) / initialize file position to zero
clr filepos+2(r0)
2: jmp *(iar)+
/ CLOSE ( fd --- )
.byte 5; <CLO>
creat-6
close: mov $104406,sysbuf / move trap 6 instruction to indir area
mov (psp)+,r0 / file descriptor
sys 0;sysbuf
jmp *(iar)+
/ KEY ( fd --- char/EOF )
.byte 3; <KEY>
close-6
key: mov (psp),r0 / file descriptor
jsr pc,getc / get next character
mov r0,(psp) / return character
jmp *(iar)+
/ FEXPECT ( fd addr count --- actcount)
.byte 7; <FEX>
key-6
fexpect:
mov 2(psp),r2 / buffer address
mov (psp)+,r3 / count
beq 3f / do nothing if count is zero
1: mov 2(psp),r0 / file descriptor
jsr pc,getc / get next character
cmp r0,$EOF
beq 3f / leave loop on EOF
cmpb r0,$tab
bne 2f
movb $040,r0 / change tabs to blanks
2: movb r0,(r2)+ / save character
cmpb r0,$nl
beq 3f / leave loop on newline
sob r3,1b / decrement count and continue if non-zero
3: sub (psp)+,r2 / compute actual number of characters read
mov r2,(psp) / return actual number
jmp *(iar)+
/ READ ( fd addr count --- actcount ) ( like expect )
/ ( that tabs are not stripped and newlines are )
/ ( not significant. )
.byte 4; <REA>
fexpect-6
read: mov 2(psp),r2 / buffer address
mov (psp)+,r3 / count
beq 3f / do nothing if count is zero
1: mov 2(psp),r0 / file descriptor
jsr pc,getc / get next character
cmp r0,$EOF
beq 3f / leave loop on EOF
movb r0,(r2)+ / save character
sob r3,1b / decrement count and continue if non-zero
3: sub (psp)+,r2 / compute actual number of characters read
mov r2,(psp) / return actual number
jmp *(iar)+
/ WRITE ( addr count fd --- actcount )
.byte 5; <WRI>
read-6
write: mov $104404,sysbuf / move trap 4 instruction to indir area
mov (psp)+,r0 / file descriptor
mov (psp)+,sysbuf+4 / count
mov (psp),sysbuf+2 / address
sys 0; sysbuf / indirect system call
bcc 1f
mov $-1,r0 / error flag
1: mov r0,(psp) / return actual count )
jmp *(iar)+
/ SEEK ( fd offsetl offseth --- )
.byte 4; <SEE>
write-6
seek: mov 4(psp),r0 / file descriptor
cmp r0,fd / if seek on currently buffered file
bne 1f
mov $-1,fd / flag buffer as invalid
1: asl r0; asl r0 / multiply by 4 to index into file pos. table
mov (psp),filepos(r0) / high offset into file position table
mov 2(psp),filepos+2(r0) / low offset into file position table
mov $104423,sysbuf / move seek trap instruction to sysbuf
mov (psp)+,sysbuf+2 / move high offset
mov (psp)+,sysbuf+4 / move low offset
clr sysbuf+6 / offset from beginning of file
mov (psp)+,r0 / file descriptor in r0
sys 0;sysbuf / seek
jmp *(iar)+
/ TERMINATE
.byte 11; <TER>
seek-6
terminate:
clr r0 / return good status
sys 1
jmp *(iar)+ / this should not be executed TEST
/ high level utilities written in assembly language for speed
/ (FIND) ( addr[name] addr[vocab] --- 0 <or> nfa )
.byte 6; <(FI>
terminate-6
pfind: mov (psp)+,r0
beq 3f / empty vocabulary?
mov (psp),r3
mov (r3)+,r2 / name ls
mov (r3),r3 / name ms
1: mov (r0),r1
bic $200,r1 / clear immediate bit
cmp r1,r2 / compare ls
bne 2f
cmp 2(r0),r3 / compare ms
beq 3f
2: mov 4(r0),r0 / next link
bne 1b / zero link?
3: mov r0,(psp)
jmp *(iar)+
/ WORD ( del --- addr )
.byte 4; <WOR>
pfind-6
word: mov (psp),r0 / delimiter
mov *$IN,r1 / >IN
add $inbuf,r1
mov *$DP,r2 / HERE
mov r2,(psp) / return HERE
1: cmpb r0,(r1)+ / skip delimiters
beq 1b
dec r1 / back up one
mov r1,r3
2: cmpb r0,(r3) / delimiter?
beq 3f
cmpb $nl,(r3) / newline?
beq 3f
inc r3 / skip until end of word
br 2b
3: sub r1,r3 / r3 has length
movb r3,(r2)+ / save count
beq 5f / skip if eol
4: movb (r1)+,(r2)+ / move characters to here
sob r3,4b
5: cmpb $nl,(r1) / if not newline
beq 6f
inc r1 / skip delimiter
6: sub $inbuf,r1
mov r1,*$IN / update >IN scanner
movb $040,(r2) / put blank at end of word
jmp *(iar)+
/ FORTH nucleus primitives
/ !
.byte 1; <! >
word-6
store: mov (psp)+,r0
mov (psp)+,(r0)
jmp *(iar)+
/ !SP
.byte 3; <!SP>
store-6
storesp:
mov (psp),psp
jmp *(iar)+
/ +
.byte 1; <+ >
storesp-6
plus: add (psp)+,(psp)
jmp *(iar)+
/ +!
.byte 2; <+! >
plus-6
plusstore:
mov (psp)+,r0
add (psp)+,(r0)
jmp *(iar)+
/ -
.byte 1; <- >
plusstore-6
minus: sub (psp)+,(psp)
jmp *(iar)+
/ -1
.byte 2; <-1 >
minus-6
minusone:
mov $-1,-(psp)
jmp *(iar)+
/ 0
.byte 1; <0 >
minusone-6
zero: clr -(psp)
jmp *(iar)+
/ 0<
.byte 2; <0< >
zero-6
zeroless:
clr r0
tst (psp)
bpl 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ 0=
.byte 2; <0= >
zeroless-6
zeroeq: clr r0
tst (psp)
bne 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ 1
.byte 1; <1 >
zeroeq-6
one: mov $1,-(psp)
jmp *(iar)+
/ 1+
.byte 2; <1+ >
one-6
oneplus:
inc (psp)
jmp *(iar)+
/ 1-
.byte 2; <1- >
oneplus-6
oneminus:
dec (psp)
jmp *(iar)+
/ 2
.byte 1; <2 >
oneminus-6
two: mov $2,-(psp)
jmp *(iar)+
/ 2+
.byte 2; <2+ >
two-6
twoplus:
add $2,(psp)
jmp *(iar)+
/ 2-
.byte 2; <2- >
twoplus-6
twominus:
sub $2,(psp)
jmp *(iar)+
/ 2*
.byte 2; <2* >
twominus-6
twostar:
asl (psp)
jmp *(iar)+
/ 2/
.byte 2; <2/ >
twostar-6
twoslash:
asr (psp)
jmp *(iar)+
/ <
.byte 1; << >
twoslash-6
less: clr r0
cmp (psp)+,(psp)
ble 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ =
.byte 1; <= >
less-6
equal: clr r0
cmp (psp)+,(psp)
bne 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ >
.byte 1; <\> >
equal-6
greater:
clr r0
cmp (psp)+,(psp)
bge 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ >R
.byte 2; <\>R >
greater-6
tor: mov (psp)+,-(sp)
jmp *(iar)+
/ @
.byte 1; <@ >
tor-6
at: mov *(psp),(psp)
jmp *(iar)+
/ @SP
.byte 3; <@SP>
at-6
atsp: mov psp,r1
mov r1,-(psp)
jmp *(iar)+
/ AND
.byte 3; <AND>
atsp-6
and: mov (psp)+,r0
com r0 / there is no direct and in PDP-11 assembly lang.
bic r0,(psp)
jmp *(iar)+
/ C!
.byte 2; <C! >
and-6
cstore: mov (psp)+,r0
mov (psp)+,r1
movb r1,(r0)
jmp *(iar)+
/ C@
.byte 2; <C@ >
cstore-6
cat: movb *(psp),r0
bic $177400,r0
mov r0,(psp)
jmp *(iar)+
/ CMOVE ( src dest ucount --- )
.byte 5; <CMO>
cat-6
cmove: mov (psp)+,r2
beq 2f
mov (psp)+,r0 / destination
mov (psp)+,r1 / source
1: movb (r1)+,(r0)+
sob r2,1b
br 3f
2: add $4,psp / pop two stack args
3: jmp *(iar)+
/ D+
.byte 2; <D+ >
cmove-6
dplus: mov (psp)+,r0
add (psp)+,2(psp)
adc (psp)
add r0,(psp)
jmp *(iar)+
/ DNEGATE
.byte 7; <DNE>
dplus-6
dnegate:
com (psp)
com 2(psp)
add $1,2(psp)
adc (psp)
jmp *(iar)+
/ DROP
.byte 4; <DRO>
dnegate-6
drop: add $2,psp
jmp *(iar)+
/ DUP
.byte 3; <DUP>
drop-6
dup: mov (psp),-(psp)
jmp *(iar)+
/ M*
.byte 2; <M* >
dup-6
mstar: mov (psp),r0
mul 2(psp),r0
mov r1,2(psp) / low result
mov r0,(psp) / high result
jmp *(iar)+
/ M/
.byte 2; <M/ >
mstar-6
mslash: mov (psp)+,r2 / r2 has divisor
mov (psp),r0 / r0 has high dividend
mov 2(psp),r1 / r1 has low dividend
mov r2,r3
xor r0,r3 / r3 has sign
div r2,r0 / divide by r2
tst r3
bpl 1f / skip if sign is not negative
tst r1
beq 1f / skip if remainder is zero
dec r0 / subtract one from quotient
add r2,r1 / add divisor to remainder
1: mov r1,2(psp) / remainder
mov r0,(psp) / quotient
jmp *(iar)+
/ NEGATE
.byte 6; <NEG>
mslash-6
negate: neg (psp)
jmp *(iar)+
/ NOT
.byte 3; <NOT>
negate-6
not: com (psp)
jmp *(iar)+
/ OR
.byte 2; <OR >
not-6
or: bis (psp)+,(psp)
jmp *(iar)+
/ OVER
.byte 4; <OVE>
or-6
over: mov 2(psp),-(psp)
jmp *(iar)+
/ R>
.byte 2; <R\> >
over-6
fromr: mov (sp)+,-(psp)
jmp *(iar)+
/ R@
.byte 2; <R@ >
fromr-6
rat: mov (sp),-(psp)
jmp *(iar)+
/ ROT
.byte 3; <ROT>
rat-6
rot: mov 4(psp),r0
mov 2(psp),4(psp)
mov (psp),2(psp)
mov r0,(psp)
jmp *(iar)+
/ ROTATE ( word nbits --- word' )
.byte 6; <ROT>
rot-6
rotate: mov (psp)+,r1 / loop counter
bic $0177760,r1 / mask off all but lower four bits
beq 3f
mov (psp),r0
1: tst r0 / test sign bit; clear carry
bpl 2f
sec / set carry
2: rol r0 / rotate
sob r1,1b
mov r0,(psp)
3: jmp *(iar)+
/ SWAP
.byte 4; <SWA>
rotate-6
swap: mov 2(psp),r0
mov (psp),2(psp)
mov r0,(psp)
jmp *(iar)+
/ UM*
.byte 3; <UM*>
swap-6
umstar: clr r0
mov $20,r1 / r1 := 16
mov (psp),r2
mov 2(psp),r3 / multiplier
ror r3 / get ls bit
1: bcc 2f
add r2,r0 / accumulate
2: ror r0 / shift carry into r0
ror r3 / shift into r3; get ls bit
sob r1,1b
mov r3,2(psp) / save ls word
mov r0,(psp) / save ms word
jmp *(iar)+
/ UM/ ( dl dh divisor --- rem quot )
/ dividend is 31 bits
.byte 3; <UM/>
umstar-6
umslash:
mov $20,r0 / 16 bits
mov (psp)+,r1 / divisor
mov (psp),r2 / ms word
mov 2(psp),r3 / ls word
1: asl r3
rol r2
cmp r1,r2
bhi 2f
sub r1,r2
inc r3
2: sob r0,1b
mov r2,2(psp) / remainder
mov r3,(psp) / quotient
jmp *(iar)+
/ U<
.byte 2; <U< >
umslash-6
uless: clr r0
cmp (psp)+,(psp)
blos 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ U>
.byte 2; <U\> >
uless-6
ugreater:
clr r0
cmp (psp)+,(psp)
bhis 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ XOR
.byte 3; <XOR>
ugreater-6
exor: mov (psp)+,r0
xor r0,(psp)
jmp *(iar)+
+E+O+F
More information about the Comp.sources.unix
mailing list