UNIX FORTH for the VAX (part 8 of 8)
lwt1 at aplvax.UUCP
lwt1 at aplvax.UUCP
Sat Jun 23 04:46:29 AEST 1984
Here is part 8 of 8 of the source for FORTH for the VAX.
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.
Have fun!
-John Hayes
Johns Hopkins University
Applied Physics Laboratory
... seismo!umcp-cs!aplvax!lwt1
---------------------------------- 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:
*
* John Hayes
* JHU/Applied Physics Lab
* Johns Hopkins Road
* Laurel, MD 20707
* (301) 953-5000 x8086
*
* 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.
*/
/*
* VAX-FORTH indirect threaded code inner interpreter
*/
.text
.word 0x0 /* entry mask */
/* start-up code */
movzwl $pstack,r8 /* initialize r8 */
movw $dict,DP /* initialize dictionary pointer */
movw $16,BASE /* base is hex */
movw $quit-8,INITVOCAB
movzwl $quit+2,r9 /* initialize r9 */
brw next
/* parameter stack */
.space 256
pstack:
/* text input buffer */
inbuf: .space 120
/* (:) */
.byte 3; .ascii "(:) "
.word 0 /* end of dictionary */
pcolon: .word call
call: movw r9,-(sp)
movw r0,r9
next: movzwl (r9)+,r0
movzwl (r0)+,r1
jmp (r1)
/* (;) */
.byte 3; .ascii "(;) "
.word pcolon-8
return: .word return+2
movzwl (sp)+,r9
movzwl (r9)+,r0 /* repetion of next code for speed */
movzwl (r0)+,r1
jmp (r1)
/* (VARIABLE) */
.byte 10; .ascii "(VARI"
.word return-8
var: .word var+2
movw r0,-(r8)
brw next
/* (CONSTANT) */
.byte 10; .ascii "(CONS"
.word var-8
con: .word con+2
movw (r0),-(r8)
brw next
/* (DOES>) */
.byte 7; .ascii "(DOES"
.word con-8
pdoes: .word pdoes+2
movw r9,-(sp)
movzwl (r0)+,r9
movw r0,-(r8)
brw next
/* (LITERAL) */
.byte 9; .ascii "(LITE"
.word pdoes-8
lit: .word lit+2
movw (r9)+,-(r8)
brw next
/* BRANCH */
.byte 6; .ascii "BRANC"
.word lit-8
branch: .word branch+2
1: movzwl (r9),r9
brw next
/* ?BRANCH */
.byte 7; .ascii "?BRAN"
.word branch-8
zbranch: .word zbranch+2
tstw (r8)+
beql 1b
addw2 $2,r9
brw next
/* EXECUTE */
.byte 7; .ascii "EXECU"
.word zbranch-8
execute: .word execute+2
movzwl (r8)+,r0
movzwl (r0)+,r1
jmp (r1)
/* (DO) */
.byte 4; .ascii "(DO) "
.word execute-8
pdo: .word pdo+2
addw3 2(r8),$0100000,r0
movw r0,-(sp)
subw3 r0,(r8)+,-(sp)
addw2 $2,r8
brw next
/* (LOOP) */
.byte 6; .ascii "(LOOP"
.word pdo-8
ploop: .word ploop+2
incw (sp)
bvc 1b
addl2 $4,sp
addw2 $2,r9
brw next
/* (+LOOP) */
.byte 7; .ascii "(+LOO"
.word ploop-8
pploop: .word pploop+2
addw2 (r8)+,(sp)
bvc 1b
addl2 $4,sp
addw2 $2,r9
brw next
/* I */
.byte 1; .ascii "I "
.word pploop-8
i: .word i+2
addw3 (sp),2(sp),-(r8)
brw next
/* J */
.byte 1; .ascii "J "
.word i-8
j: .word j+2
addw3 4(sp),6(sp),-(r8)
brw next
/* (LEAVE) */
.byte 7; .ascii "(LEAV"
.word j-8
pleave: .word pleave+2
addl2 $4,sp
movzwl (r9),r9
brw next
/* basic system interface */
/* I/O buffer and control variables */
block: .space 1024
size: .word 0 /* size in bytes */
indx: .word 0 /* current offset into block */
fd: .word 0 /* file descriptor of associated file*/
/* file position table: each slot has a 32 bit file ofsett. file des-
criptor is offset into table. There are 15 slots */
filepos:
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
.long 0
/* low level system calls */
_read: .word 0 /* entry mask */
chmk $3
bcc 1f
clrl r0 /* if error, length is zero */
1: ret
_write: .word 0 /* entry mask */
chmk $4
bcc 1f
mnegl $1,r0 /* return -1 on error */
1: ret
_lseek: .word 0 /* entry mask */
chmk $19
bcc 1f
clrl r0 /* return zero if error */
1: ret
_creat: .word 0 /* entry mask */
chmk $8
bcc 1f
mnegl $1,r0
1: ret
_open: .word 0 /* entry mask */
chmk $5
bcc 1f
mnegl $1,r0 /* return negative file descriptor on error */
1: ret
_close: .word 0 /* entry mask */
chmk $6
ret /* ignore errors */
_exit: .word 0 /* entry mask */
chmk $1 /* should never return */
halt
/* subroutine getc: handles all input and does buffering
input: file descriptor in r2
output: character of -1 in r0
side effects: r2, r3
*/
getc: cmpw r2,*$fd
beql 1f /* do seek if new fd is not same as old fd */
movw r2,*$fd
movw *$size,*$indx /* indicate that buffer is empty */
clrl -(sp) /* whence is start of file */
pushl *$filepos[r2] /* push file position */
pushl r2 /* push file descriptor */
calls $3,_lseek /* seek */
1: movzwl *$indx,r3 /* r3 has index */
cmpw r3,*$size
blss 2f /* read file if buffer is empty */
pushl $1024 /* push block size */
pushl $block /* push address of buffer */
pushl r2 /* push file descriptor */
calls $3,_read /* read */
movw r0,*$size /* save size */
clrl r3 /* reset index */
2: cmpw r3,*$size
beql 3f /* branch if end of file */
incl *$filepos[r2] /* update file position */
movzbl block(r3),r0 /* return character */
incw r3 /* update index */
brb 4f
3: movl $-1,r0 /* return -1 */
4: movw r3,*$indx /* save index */
rsb
/* FEXPECT ( fd addr count --- actcount ) */
.byte 7; .ascii "FEXPE"
.word pleave-8
fexpect: .word fexpect+2
movzwl 2(r8),r6 /* buffer address */
movzwl (r8)+,r7 /* count */
beql 3f /* do nothing if count is zero */
1: movzwl 2(r8),r2 /* file descriptor */
jsb *$getc /* get next character */
cmpb r0,$-1
beql 3f /* leave loop on -1 */
cmpb r0,$011
bneq 2f
movw $040,r0 /* change tabs to blanks */
2: movb r0,(r6)+ /* save character */
cmpb r0,$012
beql 3f /* leave loop on newline */
sobgtr r7,1b /* decrement counter and continue if non-zero */
3: subw2 (r8)+,r6 /* compute actual number of characters read */
movw r6,(r8) /* return actual number */
brw next
/* READ ( fd addr count --- actcount ) */
.byte 4; .ascii "READ "
.word fexpect-8
read: .word read+2
movzwl 2(r8),r4 /* buffer address */
movzwl (r8)+,r5 /* count */
beql 3f
1: movzwl 2(r8),r2 /* file descriptor */
jsb *$getc /* get next character */
cmpw r0,$-1
beql 3f /* leave loop on -1 */
movb r0,(r4)+ /* save character */
sobgtr r5,1b /* decrement count and continue if non-zero */
3: subw2 (r8)+,r4 /* compute actual number of characters read */
movw r4,(r8) /* return actual count */
brw next
/* WRITE ( addr count fd --- actcount ) */
.byte 5; .ascii "WRITE"
.word read-8
write: .word write+2
movzwl (r8)+,r0 /* file descriptor */
movzwl (r8)+,-(sp) /* stack count */
movzwl (r8),-(sp) /* stack address */
pushl r0 /* stack file descriptor */
calls $3,_write /* write */
movw r0,(r8) /* return actual count */
brw next
/* SEEK ( fd offsetl offseth --- ) */
.byte 4; .ascii "SEEK "
.word write-8
seek: .word seek+2
movw 2(r8),-(r8)
movl (r8)+,r0 /* offset */
addw2 $2,r8
movzwl (r8)+,r1 /* file descriptor */
cmpw r1,*$fd
bneq 1f
movw *$size,*$index /* if seeking buffered file, reset buffer */
1: movl r0,filepos[r1] /* save new position in position table */
clrl -(sp) /* whence is start of file */
pushl r0 /* offset */
pushl r1 /* fd */
calls $3,_lseek /* seek */
brw next
/* CREAT ( addr[string] pmode --- fd ) */
.byte 5; .ascii "CREAT"
.word seek-8
creat: .word creat+2
movzwl (r8)+,-(sp) /* stack protection mode */
movzwl (r8),-(sp) /* stack address of file name string */
calls $2,_creat /* creat system call */
movw r0,(r8) /* return file descriptor */
blss 1f /* skip if creation failed */
clrl filepos[r0] /* set file position to zero */
1: brw next
/* OPEN ( addr[strin] mode --- fd ) */
.byte 4; .ascii "OPEN "
.word creat-8
open: .word open+2
movzwl (r8)+,-(sp) /* stack mode */
movzwl (r8),-(sp) /* stack address of file name */
calls $2,_open /* open */
movw r0,(r8) /* return file descriptor */
blss 1f /* skip of open faled */
clrl filepos[r0] /* reset file positions */
1: brw next
/* CLOSE ( fd --- ) */
.byte 5; .ascii "CLOSE"
.word open-8
close: .word close+2
movzwl (r8)+,-(sp) /* stack file descriptor */
calls $1,_close /* close */
brw next
/* TERMINATE ( --- ) */
.byte 9; .ascii "TERMI"
.word close-8
terminate: .word terminate+2
clrl -(sp) /* return good status */
calls $1,_exit /* exit */
/* high level utilities written in assembly language for speed */
/* (FIND) ( addr[word] addr[vocab] --- 0 <or> nfa ) */
.byte 6; .ascii "(FIND"
.word terminate-8
pfind: .word pfind+2
movzwl (r8)+,r0
beql 3f
movzwl (r8),r1
movl (r1),r2
1: bicl3 $128,(r0),r3
cmpl r2,r3
bneq 2f
cmpw 4(r1),4(r0)
beql 3f
2: movzwl 6(r0),r0
bneq 1b
3: movw r0,(r8)
brw next
/* WORD */
.byte 4; .ascii "WORD "
.word pfind-8
word: .word word+2
clrl r1
addw3 $inbuf,*$IN,r1
skpc (r8),$1000,(r1)
movzwl (r8),r0
movzwl *$DP,r2
movw r2,(r8)
movzwl r1,r3
1: cmpb r0,(r3)
beql 2f
cmpb $012,(r3)
beql 2f
incw r3
brb 1b
2: subw2 r1,r3
movb r3,(r2)+
beql 4f
3: movb (r1)+,(r2)+
sobgtr r3,3b
4: cmpb $012,(r1)
beql 5f
incw r1
5: subw3 $inbuf,r1,*$IN
movb $040,(r2)
brw next
/* VAX-FORTH stack primitives */
/* ! */
.byte 1; .ascii "! "
.word word-8
store: .word store+2
movzwl (r8)+,r0
movw (r8)+,(r0)
brw next
/* !SP */
.byte 3; .ascii "!SP "
.word store-8
storesp: .word storesp+2
movzwl (r8),r8
brw next
/* + */
.byte 1; .ascii "+ "
.word storesp-8
plus: .word plus+2
addw2 (r8)+,(r8)
brw next
/* +! */
.byte 2; .ascii "+! "
.word plus-8
plusstore: .word plusstore+2
movzwl (r8)+,r0
addw2 (r8)+,(r0)
brw next
/* - */
.byte 1; .ascii "- "
.word plusstore-8
minus: .word minus+2
subw2 (r8)+,(r8)
brw next
/* -1 */
.byte 2; .ascii "-1 "
.word minus-8
minusone: .word minusone+2
movw $-1,-(r8)
brw next
/* 0 */
.byte 1; .ascii "0 "
.word minusone-8
zero: .word zero+2
clrw -(r8)
brw next
/* 0< */
.byte 2; .ascii "0< "
.word zero-8
zeroless: .word zeroless+2
clrw r0
tstw (r8)
bgeq 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* 0= */
.byte 2; .ascii "0= "
.word zeroless-8
zeroeq: .word zeroeq+2
clrw r0
tstw (r8)
bneq 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* 1 */
.byte 1; .ascii "1 "
.word zeroeq-8
one: .word one+2
movw $1,-(r8)
brw next
/* 1+ */
.byte 2; .ascii "1+ "
.word one-8
oneplus: .word oneplus+2
incw (r8)
brw next
/* 1- */
.byte 2; .ascii "1- "
.word oneplus-8
oneminus: .word oneminus+2
decw (r8)
brw next
/* 2 */
.byte 1; .ascii "2 "
.word oneminus-8
two: .word two+2
movw $2,-(r8)
brw next
/* 2+ */
.byte 2; .ascii "2+ "
.word two-8
twoplus: .word twoplus+2
addw2 $2,(r8)
brw next
/* 2- */
.byte 2; .ascii "2- "
.word twoplus-8
twominus: .word twominus+2
subw2 $2,(r8)
brw next
/* 2* */
.byte 2; .ascii "2* "
.word twominus-8
twostar: .word twostar+2
movw (r8),r0
ashl $1,r0,r0
movw r0,(r8)
brw next
/* 2/ */
.byte 2; .ascii "2/ "
.word twostar-8
twoslash: .word twoslash+2
cvtwl (r8),r0
ashl $-1,r0,r0
movw r0,(r8)
brw next
/* < */
.byte 1; .ascii "< "
.word twoslash-8
less: .word less+2
clrw r0
cmpw (r8)+,(r8)
bleq 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* = */
.byte 1; .ascii "= "
.word less-8
equal: .word equal+2
clrw r0
cmpw (r8)+,(r8)
bneq 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* > */
.byte 1; .ascii "> "
.word equal-8
greater: .word greater+2
clrw r0
cmpw (r8)+,(r8)
bgeq 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* >R */
.byte 2; .ascii ">R "
.word greater-8
tor: .word tor+2
movw (r8)+,-(sp)
brw next
/* @ */
.byte 1; .ascii "@ "
.word tor-8
at: .word at+2
movzwl (r8),r0
movw (r0),(r8)
brw next
/* @SP */
.byte 3; .ascii "@SP "
.word at-8
atsp: .word atsp+2
movw r8,r0
movw r0,-(r8)
brw next
/* AND */
.byte 3; .ascii "AND "
.word atsp-8
and: .word and+2
mcomw (r8)+,r0
bicw2 r0,(r8)
brw next
/* C! */
.byte 2; .ascii "C! "
.word and-8
cstore: .word cstore+2
movzwl (r8)+,r0
movb (r8)+,(r0)
incw r8
brw next
/* C@ */
.byte 2; .ascii "C@ "
.word cstore-8
cat: .word cat+2
movzwl (r8),r0
movzbw (r0),(r8)
brw next
/* CMOVE */
.byte 5; .ascii "CMOVE"
.word cat-8
cmove: .word cmove+2
movzwl (r8)+,r2
beql 2f
movzwl (r8),r0
movzwl 2(r8),r1
1: movb (r1)+,(r0)+
sobgtr r2,1b
2: addl2 $4,r8
brw next
/* D+ */
.byte 2; .ascii "D+ "
.word cmove-8
dplus: .word dplus+2
movw 2(r8),-(r8)
movw 8(r8),4(r8)
addl2 (r8)+,(r8)
movw (r8)+,2(r8)
brw next
/* DNEGATE */
.byte 7; .ascii "DNEGA"
.word dplus-8
dnegate: .word dnegate+2
movw 2(r8),-(r8)
mnegl (r8),(r8)
movw (r8)+,2(r8)
brw next
/* D< */
.byte 2; .ascii "D< "
.word dnegate-8
dless: .word dless+2
movw 2(r8),-(r8)
movw 8(r8),4(r8)
clrw r0
cmpl (r8)+,(r8)+
bleq 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* DROP */
.byte 4; .ascii "DROP "
.word dless-8
drop: .word drop+2
addw2 $2,r8
brw next
/* DUP */
.byte 3; .ascii "DUP "
.word drop-8
dup: .word dup+2
movw (r8),-(r8)
brw next
/* M* */
.byte 2; .ascii "M* "
.word dup-8
mstar: .word mstar+2
cvtwl (r8)+,r0
cvtwl (r8),r1
mull3 r0,r1,-(r8)
movw (r8)+,2(r8)
brw next
/* M/ */
.byte 2; .ascii "M/ "
.word mstar-8
mslash: .word mslash+2
cvtwl (r8),r0 /* divisor in r0 */
movw 4(r8),(r8)
clrl r2
movl (r8)+,r1
bgeq 1f
decl r2 /* signed quadword dividend in r1,r2 */
1: xorl3 r2,r0,r3 /* expected sign in r3 */
ediv r0,r1,r4,r5
tstl r3
bgeq 2f /* branch if sign not negative */
tstl r1
beql 2f /* branch if remainder is zero */
decl r4 /* subtract one from quotient */
addl2 r0,r5 /* add divisor to remainder */
2: movw r5,(r8) /* remainder */
movw r4,-(r8) /* quotient */
brw next
/* NEGATE */
.byte 6; .ascii "NEGAT"
.word mslash-8
negate: .word negate+2
mnegw (r8),(r8)
brw next
/* NOT */
.byte 3; .ascii "NOT "
.word negate-8
not: .word not+2
mcomw (r8),(r8)
brw next
/* OR */
.byte 2; .ascii "OR "
.word not-8
or: .word or+2
bisw2 (r8)+,(r8)
brw next
/* OVER */
.byte 4; .ascii "OVER "
.word or-8
over: .word over+2
movw 2(r8),-(r8)
brw next
/* R> */
.byte 2; .ascii "R> "
.word over-8
fromr: .word fromr+2
movw (sp)+,-(r8)
brw next
/* R@ */
.byte 2; .ascii "R@ "
.word fromr-8
rat: .word rat+2
movw (sp),-(r8)
brw next
/* ROT */
.byte 3; .ascii "ROT "
.word rat-8
rot: .word rot+2
movw 4(r8),r0
movw 2(r8),4(r8)
movw (r8),2(r8)
movw r0,(r8)
brw next
/* ROTATE */
.byte 6; .ascii "ROTAT"
.word rot-8
rotate: .word rotate+2
bicw3 $0177760,(r8),r0
movw 2(r8),(r8)
movl (r8),r1
addw2 $2,r8
rotl r0,r1,r1
movw r1,(r8)
brw next
/* SWAP */
.byte 4; .ascii "SWAP "
.word rotate-8
swap: .word swap+2
movw 2(r8),r0
movw (r8),2(r8)
movw r0,(r8)
brw next
/* U< */
.byte 2; .ascii "U< "
.word swap-8
uless: .word uless+2
clrw r0
cmpw (r8)+,(r8)
blequ 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* U> */
.byte 2; .ascii "U> "
.word uless-8
ugreater: .word ugreater+2
clrw r0
cmpw (r8)+,(r8)
bgequ 1f
movw $-1,r0
1: movw r0,(r8)
brw next
/* UM* */
.byte 3; .ascii "UM* "
.word ugreater-8
umstar: .word umstar+2
movzwl (r8)+,r0
movzwl (r8),r1
mull2 r1,r0
movl r0,-(r8)
movw (r8)+,2(r8)
brw next
/* UM/ */
.byte 3; .ascii "UM/ "
.word umstar-8
umslash: .word umslash+2
movzwl (r8),r2
movw 4(r8),(r8)
movl (r8)+,r3
clrl r4
ediv r2,r3,r0,r1
movw r1,(r8)
movw r0,-(r8)
brw next
/* XOR */
.byte 3; .ascii "XOR "
.word umslash-8
exor: .word exor+2
xorw2 (r8)+,(r8)
brw next
!E!O!F
More information about the Comp.sources.unix
mailing list