UNIX FORTH for the VAX (part 7 of 8)
lwt1 at aplvax.UUCP
lwt1 at aplvax.UUCP
Sat Jun 23 04:45:46 AEST 1984
Here is part 7 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 - os.as
cat >os.as <<'!E!O!F'
/*
FORTH operating system in assembler format
System variables and constants
The upper case labels are so that assembly language routines can refer
to the values of these variables
*/
/* TIB */
.byte 3; .ascii "TIB "
.word exor-8
tib: .word con+2
.word inbuf
/* SP0 */
.byte 3; .ascii "SP0 "
.word tib-8
sp0: .word con+2
.word pstack
/* DP0 */
.byte 3; .ascii "DP0 "
.word sp0-8
dp0: .word con+2
.word dict
/* WRN */
.byte 3; .ascii "WRN "
.word dp0-8
wrn: .word var+2
.word -1
/* DP */
.byte 2; .ascii "DP "
.word wrn-8
dp: .word var+2
DP: .word 0
/* >IN */
.byte 3; .ascii ">IN "
.word dp-8
in: .word var+2
IN: .word 0
/* STATE */
.byte 5; .ascii "STATE"
.word in-8
state: .word var+2
.word 0
/* BASE */
.byte 4; .ascii "BASE "
.word state-8
base: .word var+2
BASE: .word 0
/* INITVOCAB ( intial vocabulary - will be FORTH ) */
.byte 11; .ascii "INITV"
.word base-8
initvocab: .word var+2
INITVOCAB: .word 0
/* CONTXT ( context vocabulary ) */
.byte 6; .ascii "CONTX"
.word initvocab-8
context: .word var+2
.word INITVOCAB
/* CURRENT ( current vocabulary ) */
.byte 7; .ascii "CURRE"
.word context-8
current: .word var+2
.word INITVOCAB
/* CLUE */
.byte 4; .ascii "CLUE "
.word current-8
clue: .word var+2
.word 0
/* STDIN */
.byte 5; .ascii "STDIN"
.word clue-8
stdin: .word con+2
.word 0
/* STDOUT */
.byte 6; .ascii "STDOU"
.word stdin-8
stdout: .word con+2
.word 1
/* EOL */
.byte 3; .ascii "EOL "
.word stdout-8
eol: .word con+2
.word 012
/* TRUE */
.byte 4; .ascii "TRUE "
.word eol-8
true: .word con+2
.word -1
/* FALSE */
.byte 5; .ascii "FALSE"
.word true-8
false: .word con+2
.word 0
/* Code extensions */
/* ?DUP */
.byte 4; .ascii "?DUP "
.word false-8
qdup: .word call
.word dup, zbranch, 1f, dup; 1: .word return
/* -ROT */
.byte 4; .ascii "-ROT "
.word qdup-8
mrot: .word call
.word rot, rot, return
/* * */
.byte 1; .ascii "* "
.word mrot-8
star: .word call
.word umstar, drop, return
/* 2DUP */
.byte 4; .ascii "2DUP "
.word star-8
twodup: .word call
.word over, over, return
/* S->D */
.byte 4; .ascii "S->D "
.word twodup-8
stod: .word call
.word dup, zeroless, return
/* +- */
.byte 2; .ascii "+- "
.word stod-8
plusminus: .word call
.word zeroless, zbranch, 1f, negate; 1: .word return
/* D+- */
.byte 3; .ascii "D+- "
.word plusminus-8
dplusminus: .word call
.word zeroless, zbranch, 1f, dnegate; 1: .word return
/* ABS */
.byte 3; .ascii "ABS "
.word dplusminus-8
abs: .word call
.word dup, plusminus, return
/* DABS */
.byte 4; .ascii "DABS "
.word abs-8
dabs: .word call
.word dup, dplusminus, return
/* 2DROP */
.byte 5; .ascii "2DROP"
.word dabs-8
twodrop: .word call
.word drop, drop, return
/* UM*M ( ul uh mul --- ul' uh' ) */
.byte 4; .ascii "UM*M "
.word twodrop-8
umstarm: .word call
.word swap, over, umstar, drop, tor, umstar, zero, fromr, dplus
.word return
/* M/MMOD */
.byte 6; .ascii "M/MMO"
.word umstarm-8
mslashmmod: .word call
.word tor, zero, rat, umslash, fromr, swap, tor, umslash, fromr
.word return
/* FILL */
.byte 4; .ascii "FILL "
.word mslashmmod-8
fill: .word call
.word mrot, qdup, zbranch, 2f
.word over, plus, swap, pdo; 1:
.word dup, i, cstore, ploop, 1b, branch, 3f
2: .word drop
3: .word drop, return
/* TOGGLE */
.byte 6; .ascii "TOGGL"
.word fill-8
toggle: .word call
.word over, at, exor, swap, store, return
/* <> */
.byte 2; .ascii "<> "
.word toggle-8
nequal: .word call
.word equal, not, return
/* MAX */
.byte 3; .ascii "MAX "
.word nequal-8
max: .word call
.word twodup, less, zbranch, 1f, swap; 1: .word drop, return
/* HEX */
.byte 3; .ascii "HEX "
.word max-8
hex: .word call
.word lit, 16, base, store, return
/* DECIMAL */
.byte 7; .ascii "DECIM"
.word hex-8
decimal: .word call
.word lit, 10, base, store, return
/* OCTAL */
.byte 5; .ascii "OCTAL"
.word decimal-8
octal: .word call
.word lit, 8, base, store, return
/* 2! ( n1 n2 addr --- ) */
.byte 2; .ascii "2! "
.word octal-8
twostore: .word call
.word swap, over, store, twoplus, store, return
/* Compiling words */
/* HERE */
.byte 4; .ascii "HERE "
.word twostore-8
here: .word call
.word dp, at, return
/* PAD */
.byte 3; .ascii "PAD "
.word here-8
pad: .word call
.word here, lit, 80, plus, return
/* LATEST */
.byte 6; .ascii "LATES"
.word pad-8
latest: .word call
.word current, at, at, return
/* ALLOT */
.byte 5; .ascii "ALLOT"
.word latest-8
allot: .word call
.word dp, plusstore, return
/* , */
.byte 1; .ascii ", "
.word allot-8
comma: .word call
.word here, store, two, allot, return
/* IMMEDIATE */
.byte 9; .ascii "IMMED"
.word comma-8
immediate: .word call
.word latest, lit, 0200, toggle, return
/* SMUDGE */
.byte 6; .ascii "SMUDG"
.word immediate-8
smudge: .word call
.word latest, lit, 0100, toggle, return
/* COMPILE */
.byte 7; .ascii "COMPI"
.word smudge-8
compile: .word call
.word fromr, dup, at, comma, two, plus, tor, return
/* IF */
.byte 2+128; .ascii "IF "
.word compile-8
if: .word call
.word compile, zbranch, here, two, allot, return
/* THEN */
.byte 4+128; .ascii "THEN "
.word if-8
then: .word call
.word here, swap, store, return
/* ELSE */
.byte 4+128; .ascii "ELSE "
.word then-8
else: .word call
.word compile, branch, here, two, allot, here, rot, store, return
/* BEGIN */
.byte 5+128; .ascii "BEGIN"
.word else-8
begin: .word call
.word here, return
/* UNTIL */
.byte 5+128; .ascii "UNTIL"
.word begin-8
until: .word call
.word compile, zbranch, comma, return
/* AGAIN */
.byte 5+128; .ascii "AGAIN"
.word until-8
again: .word call
.word compile, branch, comma, return
/* WHILE */
.byte 5+128; .ascii "WHILE"
.word again-8
while: .word call
.word compile, zbranch, here, two, allot, return
/* REPEAT */
.byte 6+128; .ascii "REPEA"
.word while-8
repeat: .word call
.word compile, branch, swap, comma, here, swap, store, return
/* DO */
.byte 2+128; .ascii "DO "
.word repeat-8
do: .word call
.word compile, pdo, clue, at, zero, clue, store, here, return
/* LOOP */
.byte 4+128; .ascii "LOOP "
.word do-8
loop: .word call
.word compile, ploop, comma, clue, at, qdup, zbranch, 1f
.word here, swap, store
1: .word clue, store, return
/* +LOOP */
.byte 5+128; .ascii "+LOOP"
.word loop-8
plusloop: .word call
.word compile, pploop, comma, clue, at, qdup, zbranch, 1f
.word here, swap, store
1: .word clue, store, return
/* LEAVE */
.byte 5+128; .ascii "LEAVE"
.word plusloop-8
leave: .word call
.word compile, pleave, here, clue, store, two, allot, return
/* [ */
.byte 1+128; .ascii "[ "
.word leave-8
lbracket: .word call
.word zero, state, store, return
/* ] */
.byte 1; .ascii "] "
.word lbracket-8
rbracket: .word call
.word one, state, store, return
/* ( */
.byte 1+128; .ascii "( "
.word rbracket-8
paren: .word call
.word lit, 051, word, drop, return
/* I/O words */
/* TYPE ( addr count --- ) */
.byte 4; .ascii "TYPE "
.word paren-8
type: .word call
.word stdout, write, drop, return
/* EMIT ( chr --- ) */
.byte 4; .ascii "EMIT "
.word type-8
emit: .word call
.word atsp, one, type, drop, return
/* CR */
.byte 2; .ascii "CR "
.word emit-8
cr: .word call
.word eol, emit, return
/* FQUERY ( fd --- actcount ) */
.byte 6; .ascii "FQUER"
.word cr-8
fquery: .word call
.word zero, in, store
.word tib, lit, 120, fexpect, return
/* COUNT */
.byte 5; .ascii "COUNT"
.word fquery-8
count: .word call
.word dup, oneplus, swap, cat, return
/* (.") */
.byte 4; .ascii "(.\") "
.word count-8
pdotquote: .word call
.word fromr, count, twodup, type, plus, tor, return
/* ,WORD */
.byte 5; .ascii "WORD"
.word pdotquote-8
commaword: .word call
.word word, cat, oneplus, allot, return
/* ." */
.byte 2+128; .ascii ".\" "
.word commaword-8
dotquote: .word call
.word compile, pdotquote, lit, 042, commaword, return
/* SPACE */
.byte 5; .ascii "SPACE"
.word dotquote-8
space: .word call
.word lit, 040, emit, return
/* SPACES */
.byte 6; .ascii "SPACE"
.word space-8
spaces: .word call
.word zero, max, qdup, zbranch, 2f
.word zero, pdo; 1: .word space, ploop, 1b
2: .word return
/* STRING ( adr[counted_string] --- adr[string] ) */
.byte 6; .ascii "STRIN"
.word spaces-8
string: .word call
.word count, dup, tor, pad, swap, cmove, zero, pad, fromr, plus
.word cstore, pad, return
/* " ( --- adr[string] ) */
.byte 1; .ascii "\" "
.word string-8
quote: .word call
.word lit, 042, word, string, return
/* ("") ( --- adr[string] ) */
.byte 4; .ascii "(\"\") "
.word quote-8
pdquote: .word call
.word fromr, dup, count, plus, tor, string, return
/* "" */
.byte 2; .ascii "\"\" "
.word pdquote-8
dquote: .word call
.word compile, pdquote, lit, 042, commaword, return
/* Defining words */
/* CFIELD */
.byte 6; .ascii "CFIEL"
.word dquote-8
cfield: .word call
.word lit, 8, plus, return
/* NFIELD */
.byte 6; .ascii "NFIEL"
.word cfield-8
nfield: .word call
.word lit, 8, minus, return
/* -IMM ( nfa --- cfa n ) */
.byte 4; .ascii "-IMM "
.word nfield-8
notimm: .word call
.word dup, cfield, minusone, rot, cat, lit, 0200, and
.word zbranch, 1f, negate; 1: .word return
/* FIND ( addr[name] --- addr2 n ) */
.byte 4; .ascii "FIND "
.word notimm-8
find: .word call
.word dup, context, at, at, pfind
.word qdup, zbranch, 1f, swap, drop, notimm, branch, 3f
1: .word dup, latest, pfind
.word qdup, zbranch, 2f, swap, drop, notimm, branch, 3f
2: .word zero
3: .word return
/* ' */
.byte 1; .ascii "' "
.word find-8
tic: .word call
.word here, lit, 6, lit, 040, fill
.word lit, 040, word
.word find, zeroeq, zbranch, 1f, drop, zero; 1: .word return
/* HEADER */
.byte 6; .ascii "HEADE"
.word tic-8
cheader: .word call
.word tic, zbranch, 1f
.word wrn, at, zbranch, 1f
.word here, count, type
.word pdotquote; .byte 13; .ascii " isn't unique"
.word cr
1: .word here, lit, 6, allot, latest, comma, current, at, store
.word return
/* : */
.byte 1; .ascii ": "
.word cheader-8
colon: .word call
.word current, at, context, store
.word cheader, compile, call, rbracket, smudge, return
/* ; */
.byte 1+128; .ascii "; "
.word colon-8
semicolon: .word call
.word compile, return, smudge, zero, state, store, return
/* VARIABLE */
.byte 8; .ascii "VARIA"
.word semicolon-8
variable: .word call
.word cheader, compile, var+2, zero, comma, return
/* CONSTANT */
.byte 8; .ascii "CONST"
.word variable-8
constant: .word call
.word cheader, compile, con+2, comma, return
/* 2VARIABLE */
.byte 9; .ascii "2VARI"
.word constant-8
twovar: .word call
.word variable, zero, comma, return
/* DOES> */
.byte 5; .ascii "DOES>"
.word twovar-8
does: .word call
.word fromr, latest, cfield, twoplus, store, return
/* CREATE */
.byte 6; .ascii "CREAT"
.word does-8
create: .word call
.word cheader, compile, pdoes+2, zero, comma, does, return
/* VOCABULARY */
.byte 10; .ascii "VOCAB"
.word create-8
vocabulary: .word call
.word create, here, twoplus, comma, latest, comma
.word does, at, context, store, return
/* DEFINITIONS */
.byte 11; .ascii "DEFIN"
.word vocabulary-8
definitions: .word call
.word context, at, current, store, return
/* FORTH FORTH vocabulary */
.byte 5+128; .ascii "FORTH"
.word definitions-8
forth: .word call
.word initvocab, context, store, return
/* numeric output words */
/* HLD */
.byte 3; .ascii "HLD "
.word forth-8
hld: .word var+2
.word 0
/* HOLD */
.byte 4; .ascii "HOLD "
.word hld-8
hold: .word call
.word minusone, hld, plusstore, hld, at, cstore, return
/* <# */
.byte 2; .ascii "<# "
.word hold-8
lnum: .word call
.word pad, hld, store, return
/* #> */
.byte 2; .ascii "#> "
.word lnum-8
gnum: .word call
.word twodrop, hld, at, pad, over, minus, return
/* SIGN */
.byte 4; .ascii "SIGN "
.word gnum-8
sign: .word call
.word zeroless, zbranch, 1f, lit, 055, hold; 1: .word return
/* # */
.byte 1; .ascii "# "
.word sign-8
num: .word call
.word base, at, mslashmmod, rot, lit, 011, over, less
.word zbranch, 1f, lit, 7, plus; 1:
.word lit, 060, plus, hold, return
/* #S */
.byte 2; .ascii "#S "
.word num-8
nums: .word call
1: .word num, twodup, or, zeroeq, zbranch, 1b, return
/* D.R */
.byte 3; .ascii "D.R "
.word nums-8
ddotr: .word call
.word tor, swap, over, dabs, lnum, nums, rot, sign, gnum
.word fromr, over, minus, spaces, type, return
/* ZEROES */
.byte 6; .ascii "ZEROE"
.word ddotr-8
zeroes: .word call
.word zero, max, qdup, zbranch, 2f, zero, pdo; 1:
.word lit, 060, emit, ploop, 1b
2: .word return
/* D.LZ */
.byte 4; .ascii "D.LZ "
.word zeroes-8
ddotlz: .word call
.word tor, swap, over, dabs, lnum, nums, rot, sign, gnum
.word fromr, over, minus, zeroes, type, return
/* D. */
.byte 2; .ascii "D. "
.word ddotlz-8
ddot: .word call
.word zero, ddotr, space, return
/* .R */
.byte 2; .ascii ".R "
.word ddot-8
dotr: .word call
.word tor, stod, fromr, ddotr, return
/* . */
.byte 1; .ascii ". "
.word dotr-8
dot: .word call
.word stod, ddot, return
/* U.R */
.byte 3; .ascii "U.R "
.word dot-8
udotr: .word call
.word zero, swap, ddotr, return
/* U.LZ */
.byte 4; .ascii "U.LZ "
.word udotr-8
udotlz: .word call
.word zero, swap, ddotlz, return
/* utilities */
/* [COMPILE] */
.byte 9+128; .ascii "[COMP"
.word udotlz-8
bcompile: .word call
.word tic, comma, return
/* DUMP ( addr bytes --- ) */
.byte 4; .ascii "DUMP "
.word bcompile-8
dump: .word call
.word cr, over, plus, swap, pdo; 1:
.word i, lit, 4, udotlz, pdotquote; .byte 1; .ascii ":"
.word space
.word i, lit, 8, plus, i, pdo; 2:
.word i, cat, two, udotlz, space, ploop, 2b
.word i, lit, 8, plus, i, pdo; 3:
.word i, cat, dup, lit, 040, less
.word over, lit, 0177, equal, or
.word zbranch, 4f, drop, lit, 056; 4:
.word emit, ploop, 3b
.word cr, lit, 8, pploop, 1b
.word return
/* operating system support words */
/* DIGIT ( char --- n true <or> false ) */
.byte 5; .ascii "DIGIT"
.word dump-8
digit: .word call
.word lit, 060, minus
.word dup, lit, 9, greater, over, lit, 17, less, and
.word zbranch, 1f
.word drop, false, branch, 4f
1: .word dup, lit, 9, ugreater, zbranch, 2f
.word lit, 7, minus
2: .word dup, base, at, oneminus, ugreater, zbranch, 3f
.word drop, false, branch, 4f
3: .word true
4: .word return
/* CONVERT ( dl dh addr1 --- dl' dh' addr2 ) */
.byte 7; .ascii "CONVE"
.word digit-8
convert: .word call
.word tor; 1:
.word fromr, oneplus, dup, tor, cat, digit
.word zbranch, 2f, tor, base, at, umstarm, fromr, zero, dplus
.word branch, 1b
2: .word fromr, return
/* NUMBER ( ADDR --- N TRUE <OR> FALSE ) */
.byte 6; .ascii "NUMBE"
.word convert-8
number: .word call
.word dup, oneplus, cat, lit, 055, equal, dup, tor, minus
.word zero, zero, rot, convert
.word cat, lit, 040, equal, zbranch, 1f
.word drop, fromr, plusminus, true, branch, 2f
1: .word twodrop, fromr, drop, false
2: .word return
/* ?STACK ( --- T/F ) ( returns true if stack underflow ) */
.byte 6; .ascii "?STAC"
.word number-8
qstack: .word call
.word atsp, sp0, greater, return
/* CHUCKBUF ( chuck rest of input buffer ) */
.byte 8; .ascii "CHUCK"
.word qstack-8
chuckbuf: .word call
.word tib, in, at, plus
1: .word dup, cat, eol, nequal, zbranch, 2f, oneplus
.word branch, 1b
2: .word tib, minus, in, store, return
/* ENDINTERP ( --- ) ( flush reset of input buffer ) */
.byte 9; .ascii "ENDIN"
.word chuckbuf-8
endinterp: .word call
.word sp0, storesp /* reset stack pointer */
.word chuckbuf, return
/* INTERPRET */
.byte 9; .ascii "INTER"
.word endinterp-8
interpret: .word call
1: .word here, lit, 6, lit, 040, fill
.word lit, 040, word, cat, zbranch, 9f
.word here, find, qdup, zbranch, 4f
.word state, at, plus
.word zbranch, 2f, execute, branch, 3f; 2: .word comma; 3:
.word branch, 7f
4: .word number, zbranch, 6f
.word state, at, zbranch, 5f, compile, lit, comma; 5:
.word branch, 7f
6: .word here, count, type, pdotquote; .byte 2; .ascii " ?"
.word cr,endinterp
7: .word qstack, zbranch, 8f, pdotquote
.byte 12; .ascii " Stack empty"; .word cr, endinterp; 8:
.word branch, 1b
9: .word return
/* FLOAD ( adr[string] --- ) */
.byte 5; .ascii "FLOAD"
.word interpret-8
fload: .word call
.word zero, open, dup, zeroless, zbranch, 0f
.word drop, pdotquote; .byte 11; .ascii " can't open"
.word cr, branch, 3f
0: .word tor
1: .word rat, fquery, zbranch, 2f, interpret, branch, 1b
2: .word fromr, close, chuckbuf
3: .word return
/* QUIT */
.byte 4; .ascii "QUIT "
.word fload-8
quit: .word call
.word zero, state, store, sp0, storesp
.word cr, pdotquote; .byte 21; .ascii "VAX FORTH version 1.0"
1: .word cr, stdin, fquery, zbranch, 3f
.word interpret
.word state, at, zeroeq, zbranch, 2f, pdotquote
.byte 3; .ascii " OK"
2: .word branch, 1b
3: .word cr, terminate, return
/* the rest of the dictionary */
dict: .space 20000
!E!O!F
More information about the Comp.sources.unix
mailing list