UNIX FORTH for the PDP11 (part 4 of 7)
lwt1 at aplvax.UUCP
lwt1 at aplvax.UUCP
Sat Jun 9 05:56:18 AEST 1984
Here is part 4 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 - 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; <TIB>
exor-6
tib: jsr iar,*$con
inbuf
/ SP0
.byte 3; <SP0>
tib-6
sp0: jsr iar,*$con
pstack
/ DP0
.byte 3; <DP0>
sp0-6
dp0: jsr iar,*$con
dict
/ WRN
.byte 3; <WRN>
dp0-6
wrn: jsr iar,*$var
.byte -1,-1
/ DP
.byte 2; <DP >
wrn-6
dp: jsr iar,*$var
DP: .byte 0,0
/ >IN
.byte 3; <\>IN>
dp-6
in: jsr iar,*$var
IN: .byte 0,0
/ STATE
.byte 5; <STA>
in-6
state: jsr iar,*$var
.byte 0,0
/ BASE
.byte 4; <BAS>
state-6
base: jsr iar,*$var
BASE: .byte 0,0
/ INITVOCAB ( intial vocabulary - will be FORTH )
.byte 11; <INI>
base-6
initvocab:
jsr iar,*$var
INITVOCAB: .byte 0,0
/ CONTXT ( context vocabulary )
.byte 6; <CON>
initvocab-6
context:
jsr iar,*$var
INITVOCAB
/ CURRENT ( current vocabulary )
.byte 7; <CUR>
context-6
current:
jsr iar,*$var
INITVOCAB
/ CLUE
.byte 4; <CLU>
current-6
clue: jsr iar,*$var
.byte 0,0
/ STDIN
.byte 5; <STD>
clue-6
stdin: jsr iar,*$con
.byte 0,0
/ STDOUT
.byte 6; <STD>
stdin-6
stdout: jsr iar,*$con
.byte 1,0
/ EOL
.byte 3; <EOL>
stdout-6
eol: jsr iar,*$con
.byte 12,0
/ TRUE
.byte 4; <TRU>
eol-6
true: jsr iar,*$con
.byte -1,-1
/ FALSE
.byte 5; <FAL>
true-6
false: jsr iar,*$con
.byte 0,0
/ Code extensions
/ ?DUP
.byte 4; <?DU>
false-6
qdup: jsr iar,*$next
dup; zbranch; 1f; dup; 1: return
/ -ROT
.byte 4; <-RO>
qdup-6
mrot: jsr iar,*$next
rot; rot; return
/ *
.byte 1; <* >
mrot-6
star: jsr iar,*$next
umstar; drop; return
/ 2DUP
.byte 4; <2DU>
star-6
twodup: jsr iar,*$next
over; over; return
/ S->D
.byte 4; <S-\>>
twodup-6
stod: jsr iar,*$next
dup; zeroless; return
/ +-
.byte 2; <+- >
stod-6
plusminus:
jsr iar,*$next
zeroless; zbranch; 1f; negate; 1: return
/ D+-
.byte 3; <D+->
plusminus-6
dplusminus:
jsr iar,*$next
zeroless; zbranch; 1f; dnegate; 1: return
/ ABS
.byte 3; <ABS>
dplusminus-6
abs: jsr iar,*$next
dup; plusminus; return
/ DABS
.byte 4; <DAB>
abs-6
dabs: jsr iar,*$next
dup; dplusminus; return
/ 2DROP
.byte 5; <2DR>
dabs-6
twodrop:
jsr iar,*$next
drop; drop; return
/ UM*M ( ul uh mul --- ul' uh' )
.byte 4; <UM*>
twodrop-6
umstarm:
jsr iar,*$next
swap; over; umstar; drop; tor; umstar; zero; fromr; dplus; return
/ M/MMOD
.byte 6; <M/M>
umstarm-6
mslashmmod:
jsr iar,*$next
tor; zero; rat; umslash; fromr; swap; tor; umslash; fromr; return
/ FILL
.byte 4; <FIL>
mslashmmod-6
fill: jsr iar,*$next
mrot; qdup; zbranch; 2f
over; plus; swap; pdo; 1: dup; i; cstore; ploop; 1b; branch; 3f
2: drop
3: drop; return
/ TOGGLE
.byte 6; <TOG>
fill-6
toggle: jsr iar,*$next
over; at; exor; swap; store; return
/ <>
.byte 2; <<\> >
toggle-6
nequal: jsr iar,*$next
equal; not; return
/ MAX
.byte 3; <MAX>
nequal-6
max: jsr iar,*$next
twodup; less; zbranch; 1f; swap; 1: drop; return
/ HEX
.byte 3; <HEX>
max-6
hex: jsr iar,*$next
lit; .byte 16.,0; base; store; return
/ DECIMAL
.byte 7; <DEC>
hex-6
decimal:
jsr iar,*$next
lit; .byte 10.,0; base; store; return
/ OCTAL
.byte 5; <OCT>
decimal-6
octal: jsr iar,*$next
lit; .byte 8.,0; base; store; return
/ 2! ( n1 n2 addr --- )
.byte 2; <2! >
octal-6
twostore:
jsr iar,*$next
swap; over; store; twoplus; store; return
/ Compiling words
/ HERE
.byte 4; <HER>
twostore-6
here: jsr iar,*$next
dp; at; return
/ PAD
.byte 3; <PAD>
here-6
pad: jsr iar,*$next
here; lit; .byte 80.,0; plus; return
/ LATEST
.byte 6; <LAT>
pad-6
latest: jsr iar,*$next
current; at; at; return
/ ALLOT
.byte 5; <ALL>
latest-6
allot: jsr iar,*$next
dp; plusstore; return
/ ,
.byte 1; <, >
allot-6
comma: jsr iar,*$next
here; store; two; allot; return
/ IMMEDIATE
.byte 11; <IMM>
comma-6
immediate:
jsr iar,*$next
latest; lit; .byte 200,0; toggle; return
/ SMUDGE
.byte 6; <SMU>
immediate-6
smudge: jsr iar,*$next
latest; lit; .byte 100,0; toggle; return
/ COMPILE
.byte 7; <COM>
smudge-6
compile:
jsr iar,*$next
fromr; dup; at; comma; two; plus; tor; return
/ IF
.byte 202; <IF > / immediate word
compile-6
if: jsr iar,*$next
compile; zbranch; here; two; allot; return
/ THEN
.byte 204; <THE>
if-6
then: jsr iar,*$next
here; swap; store; return
/ ELSE
.byte 204; <ELS>
then-6
else: jsr iar,*$next
compile; branch; here; two; allot; here; rot; store; return
/ BEGIN
.byte 205; <BEG>
else-6
begin: jsr iar,*$next
here; return
/ UNTIL
.byte 205; <UNT>
begin-6
until: jsr iar,*$next
compile; zbranch; comma; return
/ AGAIN
.byte 205; <AGA>
until-6
again: jsr iar,*$next
compile; branch; comma; return
/ WHILE
.byte 205; <WHI>
again-6
while: jsr iar,*$next
compile; zbranch; here; two; allot; return
/ REPEAT
.byte 206; <REP>
while-6
repeat: jsr iar,*$next
compile; branch; swap; comma; here; swap; store; return
/ DO
.byte 202; <DO >
repeat-6
do: jsr iar,*$next
compile; pdo; clue; at; zero; clue; store; here; return
/ LOOP
.byte 204; <LOO>
do-6
loop: jsr iar,*$next
compile; ploop; comma; clue; at; qdup; zbranch; 1f
here; swap; store
1: clue; store; return
/ +LOOP
.byte 205; <+LO>
loop-6
plusloop:
jsr iar,*$next
compile; pploop; comma; clue; at; qdup; zbranch; 1f
here; swap; store
1: clue; store; return
/ LEAVE
.byte 205; <LEA>
plusloop-6
leave: jsr iar,*$next
compile; pleave; here; clue; store; two; allot; return
/ [
.byte 201; <[ >
leave-6
lbracket:
jsr iar,*$next
zero; state; store; return
/ ]
.byte 1; <] >
lbracket-6
rbracket:
jsr iar,*$next
one; state; store; return
/ (
.byte 201; <( >
rbracket-6
paren: jsr iar,*$next
lit; .byte 051,0; word; drop; return
/ I/O words
/ TYPE ( addr count --- )
.byte 4; <TYP>
paren-6
type: jsr iar,*$next
stdout; write; drop; return
/ EMIT ( chr --- )
.byte 4; <EMI>
type-6
emit: jsr iar,*$next
atsp; one; type; drop; return
/ CR
.byte 2; <CR >
emit-6
cr: jsr iar,*$next
eol; emit; return
/ FQUERY ( fd --- actcount )
.byte 6; <FQU>
cr-6
fquery: jsr iar,*$next
zero; in; store;
tib; lit; .byte 120.,0; fexpect; return
/ COUNT
.byte 5; <COU>
fquery-6
count: jsr iar,*$next
dup; oneplus; swap; cat; return
/ ALIGN
.byte 5; <ALI>
count-6
align: jsr iar,*$next
oneplus; twoslash; twostar; return
/ (.")
.byte 4; <(.">
align-6
pdotquote:
jsr iar,*$next
fromr; count; twodup; type; plus; align; tor; return
/ ,WORD
.byte 5; <,WO>
pdotquote-6
commaword:
jsr iar,*$next
word; cat; oneplus; align; allot; return
/ ."
.byte 202; <." >
commaword-6
dotquote:
jsr iar,*$next
compile; pdotquote; lit; .byte 42,0; commaword; return
/ SPACE
.byte 5; <SPA>
dotquote-6
space: jsr iar,*$next
lit; .byte 40,0; emit; return
/ SPACES
.byte 6; <SPA>
space-6
spaces: jsr iar,*$next
qdup; zbranch; 2f
zero; pdo; 1: space; ploop; 1b
2: return
/ STRING ( adr[counted_string] --- adr[string] )
.byte 6; <STR>
spaces-6
string: jsr iar,*$next
count; dup; tor; pad; swap; cmove; zero; pad; fromr; plus;
cstore; pad; return
/ " ( --- adr[string] )
.byte 1; <" >
string-6
quote: jsr iar,*$next
lit; .byte 042,0; word; string; return
/ ("") ( --- adr[string] )
.byte 4; <("">
quote-6
pdquote:
jsr iar,*$next
fromr; dup; count; plus; align; tor; string; return
/ ""
.byte 202; <"" >
pdquote-6
dquote: jsr iar,*$next
compile; pdquote; lit; .byte 042,0; commaword; return;
/ Defining words
/ CFIELD
.byte 6; <CFI>
dquote-6
cfield: jsr iar,*$next
lit; .byte 6,0; plus; return
/ NFIELD
.byte 6; <NFI>
cfield-6
nfield: jsr iar,*$next
lit; .byte 6,0; minus; return
/ -IMM ( nfa --- cfa n )
.byte 4; <-IM>
nfield-6
notimm: jsr iar,*$next
dup; cfield; minusone; rot; cat; lit; .byte 0200,0; and
zbranch; 1f; negate; 1: return
/ FIND ( addr[name] --- addr2 n )
.byte 4; <FIN>
notimm-6
find: jsr iar,*$next
dup; context; at; at; pfind
qdup; zbranch; 1f; swap; drop; notimm; branch; 3f
1: dup; latest; pfind
qdup; zbranch; 2f; swap; drop; notimm; branch; 3f
2: zero
3: return
/ '
.byte 1; <' >
find-6
tic: jsr iar,*$next
here; lit; .byte 4,0; lit; .byte 40,0; fill
lit; .byte 40,0; word
find; zeroeq; zbranch; 1f; drop; zero; 1: return
/ HEADER
.byte 6; <HEA>
tic-6
header: jsr iar,*$next
tic; zbranch; 1f
wrn; at; zbranch; 1f
here; count; type
pdotquote; .byte 15; < isn't unique>; .even; cr
1: here; lit; .byte 4,0; allot; latest; comma; current; at; store;
return
/ CALL
.byte 4; <CAL>
header-6
call: jsr iar,*$next
lit; .byte 037,9; comma; return
/ :
.byte 1; <: >
call-6
colon: jsr iar,*$next
current; at; context; store;
header; call; compile; next; rbracket; smudge; return
/ ;
.byte 201; <; >
colon-6
semicolon:
jsr iar,*$next
compile; return; smudge; zero; state; store; return
/ VARIABLE
.byte 10; <VAR>
semicolon-6
variable:
jsr iar,*$next
header; call; compile; var; zero; comma; return
/ CONSTANT
.byte 10; <CON>
variable-6
constant:
jsr iar,*$next
header; call; compile; con; comma; return
/ 2VARIABLE
.byte 11; <2VA>
constant-6
twovar: jsr iar,*$next
variable; zero; comma; return
/ DOES>
.byte 5; <DOE>
twovar-6
does: jsr iar,*$next
fromr; latest; cfield; lit; .byte 4,0; plus; store; return
/ CREATE
.byte 6; <CRE>
does-6
create: jsr iar,*$next
header; call; compile; pdoes; zero; comma; does; return
/ VOCABULARY
.byte 12; <VOC>
create-6
vocabulary:
jsr iar,*$next
create; here; twoplus; comma; latest; comma
does; at; context; store; return
/ DEFINITIONS
.byte 13; <DEF>
vocabulary-6
definitions:
jsr iar,*$next
context; at; current; store; return
/ FORTH FORTH vocabulary
.byte 205; <FOR>
definitions-6
forth: jsr iar,*$next
initvocab; context; store; return
/ numeric output words
/ HLD
.byte 3; <HLD>
forth-6
hld: jsr iar,*$var
.byte 0,0
/ HOLD
.byte 4; <HOL>
hld-6
hold: jsr iar,*$next
minusone; hld; plusstore; hld; at; cstore; return
/ <#
.byte 2; <<# >
hold-6
lnum: jsr iar,*$next
pad; hld; store; return
/ #>
.byte 2; <#\> >
lnum-6
gnum: jsr iar,*$next
twodrop; hld; at; pad; over; minus; return
/ SIGN
.byte 4; <SIG>
gnum-6
sign: jsr iar,*$next
zeroless; zbranch; 1f; lit; .byte 055,0; hold; 1: return
/ #
.byte 1; <# >
sign-6
num: jsr iar,*$next
base; at; mslashmmod; rot; lit; .byte 11,0; over; less
zbranch; 1f; lit; .byte 7,0; plus; 1:
lit; .byte 060,0; plus; hold; return
/ #S
.byte 2; <#S >
num-6
nums: jsr iar,*$next
1: num; twodup; or; zeroeq; zbranch; 1b; return
/ D.R
.byte 3; <D.R>
nums-6
ddotr: jsr iar,*$next
tor; swap; over; dabs; lnum; nums; rot; sign; gnum;
fromr; over; minus; zero; max; spaces; type; return
/ ZEROES
.byte 6; <ZER>
ddotr-6
zeroes: jsr iar,*$next
zero; max; qdup; zbranch; 2f; zero; pdo; 1:
lit; .byte 060,0; emit; ploop; 1b
2: return
/ D.LZ
.byte 4; <D.L>
zeroes-6
ddotlz: jsr iar,*$next
tor; swap; over; dabs; lnum; nums; rot; sign; gnum
fromr; over; minus; zeroes; type; return
/ D.
.byte 2; <D. >
ddotlz-6
ddot: jsr iar,*$next
zero; ddotr; space; return
/ .R
.byte 2; <.R >
ddot-6
dotr: jsr iar,*$next
tor; stod; fromr; ddotr; return
/ .
.byte 1; <. >
dotr-6
dot: jsr iar,*$next
stod; ddot; return
/ U.R
.byte 3; <U.R>
dot-6
udotr: jsr iar,*$next
zero; swap; ddotr; return
/ U.LZ
.byte 4; <U.L>
udotr-6
udotlz: jsr iar,*$next
zero; swap; ddotlz; return
/ utilities
/ [COMPILE]
.byte 211; <[CO>
udotlz-6
bcompile:
jsr iar,*$next
tic; comma; return
/ DUMP ( addr bytes --- )
.byte 4; <DUM>
bcompile-6
dump: jsr iar,*$next
cr; over; plus; swap; pdo; 1:
i; lit; .byte 4,0; udotlz; pdotquote; .byte 1; <:>; .even
space
i; lit; .byte 8,0; plus; i; pdo; 2:
i; cat; two; udotlz; space; ploop; 2b
i; lit; .byte 8,0; plus; i; pdo; 3:
i; cat; dup; lit; .byte 040,0; less;
over; lit; .byte 177,0; equal; or
zbranch; 4f; drop; lit; .byte 056,0; 4:
emit; ploop; 3b
cr; lit; .byte 8,0; pploop; 1b
return
/ operating system support words
/ DIGIT ( char --- n true <or> false )
.byte 5; <DIG>
dump-6
digit: jsr iar,*$next
lit; .byte 60,0; minus
dup; lit; .byte 11,0; greater; over; lit; .byte 21,0; less; and
zbranch; 1f
drop; false; branch; 4f
1: dup; lit; .byte 11,0; ugreater; zbranch; 2f
lit; .byte 7,0; minus
2: dup; base; at; oneminus; ugreater; zbranch; 3f
drop; false; branch; 4f
3: true
4: return
/ CONVERT ( dl dh addr1 --- dl' dh' addr2 )
.byte 7; <CON>
digit-6
convert:
jsr iar,*$next
tor; 1:
fromr; oneplus; dup; tor; cat; digit;
zbranch; 2f; tor; base; at; umstarm; fromr; zero; dplus
branch; 1b
2: fromr; return
/ NUMBER ( ADDR --- N TRUE <OR> FALSE )
.byte 6; <NUM>
convert-6
number: jsr iar,*$next
dup; oneplus; cat; lit; .byte 055,0; equal; dup; tor; minus
zero; zero; rot; convert
cat; lit; .byte 040,0; equal; zbranch; 1f
drop; fromr; plusminus; true; branch; 2f
1: twodrop; fromr; drop; false
2: return
/ ?STACK ( --- T/F ) ( returns true if stack underflow )
.byte 6; <?ST>
number-6
qstack: jsr iar,*$next
atsp; sp0; greater; return
/ CHUCKBUF ( chuck rest of input buffer )
.byte 10; <CHU>
qstack-6
chuckbuf:
jsr iar,*$next
tib; in; at; plus
1: dup; cat; eol; nequal; zbranch; 2f; oneplus
branch; 1b
2: tib; minus; in; store; return
/ ENDINTERP ( --- ) ( flush reset of input buffer )
.byte 11; <END>
chuckbuf-6
endinterp:
jsr iar,*$next
sp0; storesp; / reset stack pointer
chuckbuf; return
/ INTERPRET
.byte 11; <INT>
endinterp-6
interpret:
jsr iar,*$next
1: here; lit; .byte 4,0; lit; .byte 040,0; fill
lit; .byte 040,0; word; cat; zbranch; 9f
here; find; qdup; zbranch; 4f
state; at; plus
zbranch; 2f; execute; branch; 3f; 2: comma; 3:
branch; 7f
4: number; zbranch; 6f
state; at; zbranch; 5f; compile; lit; comma; 5:
branch; 7f
6: here; count; type; pdotquote; .byte 2; < ?>; .even; cr
endinterp
7: qstack; zbranch; 8f; pdotquote; .byte 14; < Stack empty>; .even; cr
endinterp; 8:
branch; 1b;
9: return
/ FLOAD ( adr[string] --- )
.byte 5; <FLO>
interpret-6
fload: jsr iar,*$next
zero; open; dup; zeroless; zbranch; 0f
drop; pdotquote; .byte 13; < can't open>; .even; cr; branch; 3f
0: tor
1: rat; fquery; zbranch; 2f; interpret; branch; 1b
2: fromr; close; chuckbuf
3: return
/ QUIT
.byte 4; <QUI>
fload-6
quit: jsr iar,*$next
zero; state; store; sp0; storesp
cr; pdotquote; .byte 23.; <unix-FORTH, version 1.0>; .even
1: cr; stdin; fquery; zbranch; 3f
interpret
state; at; zeroeq; zbranch; 2f; pdotquote; .byte 3; < OK>;
.even
2: branch; 1b
3: cr; terminate; return
/ the reset of the dictionary
dict: .=.+20000. / TEST
+E+O+F
More information about the Comp.sources.unix
mailing list