peter@baylor.UUCP (Peter da Silva) (08/19/85)
The following is a port of John James' FIG-FORTH for the PDP-11 to UNIX and
the as assembler (with m4). I have had half a dozen requests for this from
people wanting to port it to the 68000, so here it is.
Notes:
" foo" -> addr len
Leaves address and length of the string "foo" on the stack.
You can only have one such in immediate mode, since it uses PAD.
fload addr len ->
Loads UNIX text file. This is the preferred method of
loading text, though a screens file "screens" is supported. The
screens filename can be changed, and it is only opened when
accessed.
User, TIB, and the disk buffers are allocated on the system stack.
You can use SBRK to allocate more memory.
A large number of system calls are supprted.
The error messages are internal, and are extended by the presence
of all the UNIX errno messages.
The commented source is mine. The uncommented source is mostly what
I got from FIG. The person who typed it in didn't bother with the
comments.
key, emit, etc use the fd in the byte uvars "stdin", "stdout",
and "stderr". I have added a few other uvars as needed.
QUIT is highly idiosyncratic, using a prompt instead of "OK",
mainly because I didn't want to bother with raw mode. It
also uses the uvar "(null)" to determine the end of input.
INTR puts you into a prompt where you can cold- or warm- start
with 'q' or 'w'... 'q' should do nothing, but something is
broken because it crashes. anything else drops you out of FORTH.
If anybody actually uses this thing as released, and wants some
additional support code (for example shell escapes), drop me
a line...
----- forth.s ------
/ The following is (c) by and provided courtesy of the Forth Interest Group.
/ And may be distributed so long as this notice is included.
/ Any commented code is (c)1984 by and provided courtesy of Peter da Silva,
/ and may be further distributed so long as this notice is included.
/ If you want any support, send me a description of the problem and
/ I'll do my best, which will depend on how long it is since I've looked
/ at the code. Anything major will require monetary recompense.
/ -- Peter da Silva, ...!{baylor,kitty,hyd-ptd}!peter
/ USmail: 13102 Fallsview #5005, Houston, TX 77077
/ MaBell: (713) 497-4372
define(eis,0)
w=r2
u=r3
ip=r4
s=r5
rp=sp
link=0
keylen = 0100 / size of key input buffer
sysorig: / Local initialisation code.
mov (sp)+,argc+2 / get hold of the args area: argc
mov sp,argv+2 / argv
mov sp,r0
tst -(sp)
1: tst (r0)+ / look for end of argv
bne 1b
mov r0,envp+2 / environment
mov sp,aendbuf
add $-1028.*3,sp / allocate disk buffers
mov sp,adskbuf
add $-256.,sp / allocate tbuf
mov sp,atbuf
add $-keylen,sp / allocate key buffer
mov sp,akeybuf
add $-0100,sp / allocate user space
mov sp,aup / and put it into the user pointer
add $-0200,sp / allocate return stack space
mov sp,ar0 / and save a pointer to it
add $-256.,sp / allocate tib
mov sp,atib / and save a pointer to it
mov sp,as0 / stack pointer is at tib
sys 48.;2;intr / catch interrupts
jmp origin
.data / Forth must go in data segment
/
/ macros
/
/ Note: local labels 8 and 9 are used by the 'head' macro,
/ and local labels 6 and 7 are used by the 'string' macro.
/
/ head(length_byte,name,name_hibyte,internal_label,code_addr)
/
/ Notes:
/ length_byte is the length of the name or'ed with
/ 0200 or 0300 if it is immediate.
/ name should be empty (,,) for 1-byte names. odd-length
/ names should be truncated to an even length
/ name_hibyte should be empty for even length names
/ code_addr should be empty for primitives.
/
/ string(text)
/
/divert(-1)
/
/changequote({,})
/define(link,8)
/define(link2,9)
/define(link1,9)
/define(head,{/
/ : $2{}substr($3,1,1)
undefine({link2})define({link2},link)dnl
undefine({link})define({link},link1)dnl
undefine({link1})define({link1},link2)dnl
link1: .byte $1 / length
ifelse($2,,/,<{$2}>) / name
ifelse($3,,.byte 240,.byte $3|128.) / hibyte
ifelse($6,,link()b,$6) / link
$4: ifelse($5,,.+2,$5)}) / cfa
/define(next,{mov (ip)+,w
jmp *(w)+})
/define(string,{.byte 7f-6f
6: <$1>
7: .even})
/divert
/
/ start-up table
origin: jmp cent /0
jmp went /4
/
acpu: 11 /8
arev: 13 /10
aflink: task-10 /12
backsp: 10 /14
aup: 0 / filled in at origin
as0: 0 / ditto
ar0: 0 / ditto
atib: 0 / ditto
awidth: 37
awarn: 0
afence: xdp
adp: xdp
avlink: xxvoc
adskbuf:0 / ditto
aendbuf:0 / ditto
0
0
/
/ nucleus
/
head(203,li,'t,lit,,0)
mov (ip)+,-(s)
next
/
head(207,execut,'e,exec)
mov (s)+,w
jmp *(w)+
/
head(206,branch,,bran)
add (ip),ip
next
/
head(207,0branc,'h,zbran)
tst (s)+
bne 1f
add (ip),ip
next
1: add $2,ip
next
/
head(206,(loop),,xloop)
inc (rp)
cmp (rp),2(rp)
bpl 1f / was bge 1f.
add (ip),ip
next
1: add $4,rp
add $2,ip
next
/
head(207,{{(+loop}},{{')}},xploo)
add (s),(rp)
tst (s)+
blt 2f
cmp 2(rp),(rp)
bmi 1f / was ble 1f
beq 1f
add (ip),ip
next
1: add $4,rp
add $2,ip
next
2: cmp (rp),2(rp)
bmi 1b / was ble 1f
beq 1f
add (ip),ip
next
/
head(204,(do),,xdo)
mov 2(s),-(rp)
mov (s),-(rp)
add $4,s
next
/
head(201,,'i,i)
mov (rp),-(s)
next
/
head(205,digi,'t,digit)
cmp 2(s),$141 / allow for lower case
blt 1f
sub $40,2(s)
1: sub $60,2(s)
cmp 2(s),$11
ble 1f
sub $7,2(s)
cmp 2(s),$12
blt 2f
1: tst 2(s)
blt 2f
cmp 2(s),(s)
bge 2f
mov $1,(s)
next
2: add $2,s
clr (s)
next
/
head(206,(find),,pfind)
mov (s)+,r0 / r0 is test
mov (s)+,r1 / r1 is target
mov r5,-(rp) / r5 is ...
mov r4,-(rp) / r4 is ...
mov r3,-(rp) / r3 is ...
clr -(rp) / top of stack is ... scratch
mov (r1),r2
bic $100200,r2 / r2 -> length & first byte of target
/
fcomp:
fast:
mov (r0),r3 / r3 is length and first byte of test
bic $100300,r3
cmp r2,r3 / compare
beq nofast
xmatch: tst (r0)+ / fail, search for end of word
bpl xmatch
tst (r0) / is there a nextlink ?
beq failed
mov (r0),r0 / yes, indirect
br fcomp / and try again
/ length and first byte match...
nofast: mov (r0),(rp) / save length of test...
mov r1,r5 / r5 is pointer to target
br nofst1 / enter loop in middle!!!! damn.
mloop: tst (r5)+ / get Next 2 bytes
mov (r5),r4 / r4 is Next 2 bytes of target
mov (r0),r3 / r3 is Next 2 bytes of test
bic $100000,r3 / with the high bit cleared
cmp r3,r4 / if they differ
bne xmatch / go back and skip name
nofst1: bit $100000,(r0)+ / check for end of name
beq mloop / nope, compare Next 2 bytes^
mov (rp)+,r2 / recover r2 = length,
mov (rp)+,r3 / r3,
mov (rp)+,r4 / r4,
mov (rp)+,r5 / r5.
add $4,r0 / skip to pfa
mov r0,-(s) / and push it
bic $177400,r2 / dump high byte of test length
mov r2,-(s) / and push it
mov $1,-(s) / along with a 'true'
next
failed: tst (rp)+ / failed: scratch length
mov (rp)+,r3 / recover r3,
mov (rp)+,r4 / r4,
mov (rp)+,r5 / r5.
clr -(s) / push a false
next
/
head(207,enclos,'e,encl)
cmpb (s),$40 / is it a space?
beq encl1 / if so, use the alternate enclose
mov (s),r0
mov 2(s),r1
sub $4,s
1: cmpb (r1)+,r0
beq 1b
sub $1,r1
mov r1,4(s)
2: tstb (r1)
beq 4f
cmpb (r1)+,r0
bne 2b
mov r1,(s)
sub $1,r1
3: mov r1,2(s)
mov 6(s),r1
sub r1,(s)
sub r1,2(s)
sub r1,4(s)
next
4: mov r1,(s)
cmp r1,4(s)
bne 3b
add $1,r1
br 3b
/
encl1: mov 2(s),r1 / special version for white space...
sub $4,s
1: movb (r1)+,r0
bic $177400,r0
cmp r0,$40 / space
beq 1b
cmp r0,$10 / backspace
beq 1b
cmp r0,$11 / tab
beq 1b
cmp r0,$12 / newline
beq 1b
cmp r0,$13 / vtab
beq 1b
cmp r0,$14 / ff
beq 1b
cmp r0,$15 / cr
beq 1b
sub $1,r1
mov r1,4(s)
2: tstb (r1)
beq 4f
movb (r1)+,r0
bic $177400,r0
cmp r0,$40 / space
beq 5f
cmp r0,$10 / backspace
beq 5f
cmp r0,$11 / tab
beq 5f
cmp r0,$12 / newline
beq 5f
cmp r0,$13 / vtab
beq 5f
cmp r0,$14 / ff
beq 5f
cmp r0,$15 / cr
beq 5f
br 2b
5: mov r1,(s)
sub $1,r1
3: mov r1,2(s)
mov 6(s),r1
sub r1,(s)
sub r1,2(s)
sub r1,4(s)
next
4: mov r1,(s)
cmp r1,4(s)
bne 3b
add $1,r1
br 3b
/
head(204,emit,,emit,docol)
pemit;zequ;zbran;1f-.
stdout;cat;two;equal;zbran;2f-.
lit;-1;exit
2: two;stdout;cstor
perror;quit
1: one;out;pstor
semis
/
head(203,ke,'y,key,docol)
pkey;zequ;zbran;1f-.
errno;at;lit;42.;equal;zbran;2f-.
one;feof;store;lit;10.
bran;1f-.
2: perror;abort
1: dup;lit;10.;equal;zbran;1f-.
zero;out;store
1: semis
/
head(211,?termina,'l,qterm,docol)
pqter
semis
/
head(202,cr,,cr,docol)
lit
12
emit
zero;out;store
semis
/
head(205,cmov,'e,cmove)
tst (s)
beq 2f
mov 2(s),r0
mov 4(s),r1
mov (s),r2
1: movb (r1)+,(r0)+
sob r2,1b
2: add $6,s
next
/
head(206,-cmove,,dcmove)
tst (s)
beq 2f
mov 2(s),r0
add (s),r0
mov 4(s),r1
add (s),r1
mov (s),r2
1: movb -(r1),-(r0)
sob r2,1b
2: add $6, s
next
/
head(202,u*,,ustar)
jsr pc,umult
next
umult:
mov (s)+,r2
mov $20,-(rp)
clr r0
clr r1
2: rol r1
rol r0
rol r2
bcc 1f
add (s),r1
adc r0
1: dec (rp)
bne 2b
mov r1,(s)
mov r0,-(s)
tst (rp)+
rts pc
/
head(202,u/,,uslas)
jsr pc,udiv
next
udiv:
mov (s)+,r2
mov (s)+,r0
mov (s)+,r1
mov $20,-(s)
1: asl r1
rol r0
beq 2f
sub r2,r0
inc r1
bcc 2f
add r2,r0
dec r1
2: dec (s)
bne 1b
tst (s)+
mov r0,-(s)
mov r1,-(s)
rts pc
/
head(203,an,'d,and)
com (s)
bic (s)+,(s)
next
/
head(202,or,,or)
bis (s)+,(s)
next
/
head(203,xo,'r,fxor)
ifelse(eis,1,
{
mov (s)+,r0
xor r0,(s)
},{
mov (s),-(rp)
bic 2(s),(rp)
bic (s)+,(s)
bis (rp)+,(s)
})
next
/
head(204,swab,,fswab)
swab (s)
next
/
head(203,sp,'@,spat)
mov s,r1
mov r1,-(s)
next
/
head(203,rp,'@,rpat)
mov rp,-(s)
next
/
head(203,sp,'!,spsto)
mov 6(u),s
next
/
head(203,rp,'!,rpsto)
mov origin+24,rp
next
/
head(202,;s,,semis)
mov (rp)+,ip
next
/
head(205,leav,'e,leave)
mov (rp),2(rp)
next
/
head(206,setjmp,,setjmp)/ addr -> 0; later -> n
mov (s)+,r0 / get buffer address
mov ip,(r0)+ / save ip
mov s,(r0)+ / sp
mov rp,(r0)+ / rp
clr -(s) / return 0
next
/
head(207,longjm,'p,longjmp)/ val addr -> *; setjmp returns val
mov (s)+,r0 / get buffer address
mov (s)+,r1 / save val
mov (r0)+,ip / recover ip
mov (r0)+,s / sp
mov (r0)+,rp / rp
mov r1,-(s) / return val
next
/
head(202,\>r,,tor)
mov (s)+,-(rp)
next
/
head(202,r\>,,fromr)
mov (rp)+,-(s)
next
/
head(201,,'r,r)
mov (rp),-(s)
next
/
head(202,0=,,zequ)
tst (s)
beq 1f
clr (s)
br 2f
1: mov $1,(s)
2: next
/
head(202,0<,,zless)
tst (s)
bmi 1f
clr (s)
br 2f
1: mov $1,(s)
2: next
/
head(201,,'+,plus)
add (s)+,(s)
next
/
head(202,d+,,dplus)
add 2(s),6(s)
adc 4(s)
add (s),4(s)
add $4,s
next
/
head(205,minu,'s,minus)
neg (s)
next
/
head(206,dminus,,dminu)
neg (s)
neg 2(s)
sbc (s)
next
/
head(204,over,,over)
mov 2(s),-(s)
next
/
head(204,drop,,drop)
add $2,s
next
/
head(204,swap,,swap)
mov 2(s),r1
mov (s),2(s)
mov r1,(s)
next
/
head(203,du,'p,dup)
mov (s),-(s)
next
/
head(202,+!,,pstor)
add 2(s),*(s)
add $4,s
next
/
head(206,toggle,,toggl)
mov 2(s),-(s)
movb *(s),(s)
mov (s),-(rp)
bic 2(s),(rp)
bic (s)+,(s)
bis (rp)+,(s)
mov 2(s),-(s)
movb 2(s),*(s)
add $6,s
next
/
head(201,,'@,at)
mov *(s),(s)
next
/
head(202,c@,,cat)
movb *(s),r1
bic $177400,r1
mov r1,(s)
next
/
head(201,,'!,store)
mov 2(s),*(s)
add $4,s
next
/
head(202,c!,,cstor)
movb 2(s),*(s)
add $4,s
next
/
/ pre-compiled forth section
/
head(301,,':,colon,docol)
qexec
scsp
curr
at
cont
store
creat
rbrac
pscod
docol: mov ip,-(rp)
mov w,ip
next
/
head(301,,';,semi,docol)
qcsp
comp
semis
smudg
lbrac
semis
/
head(210,constant,,con,docol)
creat
smudg
comma
pscod
docon: mov (w),-(s)
next
/
head(210,variable,,var,docol)
con
pscod
dovar: mov w,-(s)
next
/
head(204,user,,user,docol)
con
pscod
douse: mov (w),-(s)
add u,(s)
next
/
/ constants
/
head(201,,'0,zero,docon)
0
/
head(201,,'1,one,docon)
1
/
head(201,,'2,two,docon)
2
/
head(201,,'3,three,docon)
3
/
head(202,bl,,bl,docon)
40
/
head(203,c/,'l,cl,docon)
100
/
head(205,b/bu,'f,bbuf,docon)
1024.
/
head(205,b/sc,'r,bscr,docon)
1
/
head(207,+origi,'n,porig,docol)
lit
origin
plus
semis
/
/ user variables
/
head(202,s0,,szero,douse)
6
/
head(202,r0,,rzero,douse)
10
/
head(203,ti,'b,tib,douse)
12
/
head(205,widt,'h,width,douse)
14
/
head(207,warnin,'g,warn,douse)
16
/
head(205,fenc,'e,fence,douse)
20
/
head(202,dp,,dp,douse)
22
/
head(210,voc-{{link}},,vocl,douse)
24
/
head(205,firs,'t,first,douse)
26
/
head(205,limi,'t,limit,douse)
30
/
head(203,bl,'k,blk,douse)
36
/
head(202,in,,in,douse)
40
/
head(203,ou,'t,out,douse)
42
/
head(203,sc,'r,scr,douse)
44
/
head(206,offset,,ofset,douse)
46
/
head(207,contex,'t,cont,douse)
50
/
head(207,curren,'t,curr,douse)
52
/
head(205,stat,'e,state,douse)
54
/
head(204,base,,base,douse)
56
/
head(203,dp,'l,dpl,douse)
60
/
head(203,fl,'d,fld,douse)
62
/
head(203,cs,'p,csp,douse)
64
/
head(202,{{r#}},,rnum,douse)
66
/
head(203,hl,'d,hld,douse)
70
/
head(203,us,'e,use,douse)
72
/
head(204,prev,,prev,douse)
74
/
head(206,(null),,pnull,douse)
76
/
/ end of user area
/
head(202,1+,,onep)
inc (s)
next
/
head(202,2+,,twop)
add $2,(s)
next
/
head(202,1-,,onem)
dec (s)
next
/
head(202,2/,,twod)
asr (s)
next
/
head(202,2*,,twot)
asl (s)
next
/
head(204,here,,here,docol)
dp
at
semis
/
head(205,allo,'t,allot,docol)
dp
pstor
semis
/
head(201,,'{{,}},comma,docol)
here
store
two
allot
semis
/
head(201,,'-,fsub)
sub (s)+,(s)
next
/
head(201,,'=,equal)
cmp 2(s),(s)+
beq 1f
clr (s)
br 2f
1: mov $1,(s)
2: next
/
head(201,,'<,less)
cmp 2(s),(s)+
bmi 1f / was blt
clr (s)
br 2f
1: mov $1,(s)
2: next
/
head(201,,'>,great)
cmp 2(s),(s)+
bmi 1f
beq 1f
mov $1,(s)
br 2f
1: clr (s)
2: next
/
head(202,u<,,uless)
cmp 2(s),(s)+
blo 1f
clr (s)
br 2f
1: mov $1,(s)
2: next
/
head(202,u\>,,ugt)
cmp 2(s),(s)+
bhi 1f
clr (s)
br 2f
1: mov $1,(s)
2: next
/
head(203,ro,'t,rot)
mov (s),r0
mov 4(s),(s)
mov 2(s),4(s)
mov r0,2(s)
next
/
head(205,unde,'r,under)
mov 2(s),r0
mov (s),2(s)
mov (s),-(s)
mov r0,2(s)
next
/
head(205,spac,'e,space,docol)
lit
40
emit
semis
/
head(204,-dup,,ddup)
tst (s)
beq 1f
mov (s),-(s)
1: next
/
head(210,traverse,,trav,docol)
swap
1: over
plus
lit
177
over
cat
less
zbran
1b-.
swap
drop
semis
/
head(206,latest,,lates,docol)
curr
at
at
semis
/
head(203,lf,'a,lfa,docol)
lit
4
fsub
semis
/
head(203,cf,'a,cfa,docol)
two
fsub
semis
/
head(203,nf,'a,nfa,docol)
lit
5
fsub
lit
-1
trav
semis
/
head(203,pf,'a,pfa,docol)
one
trav
lit
5
plus
semis
/
head(204,!csp,,scsp,docol)
spat
csp
store
semis
/
head(206,?error,,qerr,docol)
swap
zbran
1f-.
error
bran
2f-.
1: drop
2: semis
/
head(205,?com,'p,qcomp,docol)
state
at
zequ
lit
21
qerr
semis
/
head(205,?exe,'c,qexec,docol)
state
at
lit
22
qerr
semis
/
head(206,?pairs,,qpair,docol)
fsub
lit
23
qerr
semis
/
head(204,?csp,,qcsp,docol)
spat
csp
at
fsub
lit
24
qerr
semis
/
head(210,?loading,,qload,docol)
blk
at
zequ
lit
26
qerr
semis
/
head(207,compil,'e,comp,docol)
qcomp
fromr
dup
twop
tor
at
comma
semis
/
head(301,,'[,lbrac,docol)
zero
state
store
semis
/
head(201,,'],rbrac,docol)
lit
300
state
store
semis
/
head(206,smudge,,smudg,docol)
lates
lit
40
toggl
semis
/
head(203,he,'x,hex,docol)
lit
20
base
store
semis
/
head(207,decima,'l,decim,docol)
lit
12
base
store
semis
/
head(205,octa,'l,octal,docol)
lit
10
base
store
semis
/
head(207,{{(;code}},{{')}},pscod,docol)
fromr
lates
pfa
cfa
store
semis
/
head(207,<build,'s,build,docol)
zero
con
semis
/
head(205,does,'>,does,docol)
fromr
lates
pfa
store
pscod
dodoe: mov ip,-(rp)
mov (w)+,ip
mov w,-(s)
next
/
head(205,coun,'t,count,docol)
dup
onep
swap
cat
semis
/
head(206,strlen,,strlen,docol)
dup
1: dup;cat;zbran;2f-.
onep;bran;1b-.
2: swap;fsub
semis
/
head(204,puts,,puts,docol)
dup;strlen;type
semis
/
head(204,type,,type,docol)
dup;out;pstor
stdout;at;write;zbran;1f-.
drop
1: semis
/
/ ddup
/ zbran
/ xxl2-.
/ over
/ plus
/ swap
/ xdo
/xxl1: i
/ cat
/ emit
/ xloop
/ xxl1-.
/ bran
/ xxl3-.
/xxl2: drop
/xxl3: semis
/
/
head(206,=cells,,ecell,docol)
dup
one
and
plus
semis
/
head(211,-trailin,'g,dtrai,docol)
dup
zero
xdo
1: over
over
plus
one
fsub
cat
bl
fsub
zbran
2f-.
leave
bran
3f-.
2: one
fsub
3: xloop
1b-.
semis
/
head(202,{{,"}},,commaq,docol)
lit;34.
word
here
cat
onep
ecell
allot
semis
/
head(204,(."),,pdotq,docol)
r
count
dup
onep
ecell
fromr
plus
tor
type
semis
/
head(302,.",,dotq,docol)
state
at
zbran
1f-.
comp
pdotq
commaq
bran
2f-.
1: lit;34.
word
here
count
type
2: semis
/
head(203,{{("}},{{')}},pqot,docol)
r;count
dup;onep;ecell
fromr;plus;tor
semis
/
head(301,,'",qot,docol)
state
at
zbran
1f-.
comp
pqot
commaq
bran
2f-.
1: lit;34.
word
here
pad
over
cat
onep
cmove
pad
count
2: semis
/
head(203,{{,c}},{{'"}},ccommaq,docol)
lit;34.;word
here;count; dup;tor; here;swap; cmove
zero; here;r;plus; cstor
fromr;onep; ecell; allot
semis
/
head(204,(c"),,pcqot,docol)
r;count
two;plus;ecell
fromr;plus;tor
semis
/
head(302,c",,cqot,docol)
lit
34.
state
at
zbran
1f-.
comp
pcqot
word
zero
here
count
plus
cstor
here
cat
two
plus
ecell
allot
bran
2f-.
1: word
here;count; pad;swap; cmove
zero; here;cat; pad;plus; cstor
pad
2: semis
/
head(206,?align,,qalig,docol)
here
one
and
allot
semis
/
head(206,expect,,expec,docol) / addr len ->
over;rot;rot / addr addr len
over;plus;swap;xdo
1: drop
key;dup;lit;10.;equal;zbran;2f-.
drop;i
leave;bran;3f-.
2: i;cstor;i;onep
3: xloop;1b-.
zero;over;cstor;onep;zero;swap;cstor
semis
/ over;tor / save addr / addr len
/ stdin;at;read;zbran;1f-. / real_len
/ ddup;zequ;zbran;3f-. / zero bytes read?
/ one;feof;store;one / yes, set feof
/3: fromr;plus;one;fsub / real_len+addr-1 (eat LF)
/ zero;over;cstor / = 0
/ zero;swap;onep;cstor / real_len+addr = 0
/ bran;2f-.
/1: zero;r;cstor / fail, return null string
/ zero;fromr;onep;cstor
/ perror / and print an error message
/2: semis
/
head(205,quer,'y,query,docol)
tib
at
lit
256.
expec
zero
in
store
semis
/
head(301,,0,null,docol)
/
/ long version for small buffers
/
/ blk
/ at
/ zbran
/ xxj2-.
/ one
/ blk
/ pstor
/ zero
/ in
/ store
/ blk
/ at
/ bscr
/ mod
/ zequ
/ zbran
/ xxj1-.
/ qexec
/ fromr
/ drop
/xxj1: bran
/ xxj4-.
/xxj2: one
/ pnull
/ store
/xxj4: semis
/
/ short version for 1k buffers
/
blk
at
zbran
1f-.
qexec
1: one
pnull
store
semis
/
head(204,fill,,fill,docol)
swap
tor
over
cstor
dup
onep
fromr
one
fsub
cmove
semis
/
head(205,eras,'e,erase,docol)
zero
fill
semis
/
head(206,blanks,,blank,docol)
bl
fill
semis
/
head(204,hold,,hold,docol)
lit
-1
hld
pstor
hld
at
cstor
semis
/
head(203,pa,'d,pad,docol)
here
lit
104
plus
semis
/
head(210,(number),,pnumb,docol)
1: onep
dup
tor
cat
base
at
digit
zbran
2f-.
swap
base
at
ustar
drop
rot
base
at
ustar
dplus
dpl
at
onep
zbran
3f-.
one
dpl
pstor
3: fromr
bran
1b-.
2: fromr
semis
/
head(206,number,,numb,docol)
zero
zero
rot
dup
onep
cat
lit
55
equal
dup
tor
plus
lit
-1
1: dpl
store
pnumb
dup
cat
bl
fsub
zbran
2f-.
dup
cat
lit
56
fsub
zero
qerr
zero
bran
1b-.
2: drop
fromr
zbran
1f-.
dminu
1: semis
/
head(205,-fin,'d,dfind,docol)
bl
word
icase;at;zbran;1f-.
here
count
lower
1: here
cont
at
at
pfind
dup
zequ
zbran
1f-.
drop
here
lates
pfind
1: semis
/
head(205,lowe,'r,lower,docol)
over
plus
swap
xdo
2: i
cat
lit
100
great
i
cat
lit
133
uless
and
zbran
1f-.
i
lit
40
toggl
1: xloop
2b-.
semis
/
head(207,{{(abort}},{{')}},pabor,docol)
abort
semis
/
head(205,erro,'r,error,docol)
dup;tor
warn
at
zless
zbran;1f-.
pabor
1: tib;at;in;at;type
pdotq
string(? )
mess
pdotq
string(... )
tib;at;in;at;plus;puts
cr
fromr;zequ;zbran;1f-.
contin;at;zbran;1f-.
semis
/
1: spsto
in
at
blk
keybuf;two;plus;lit;4;erase / keybuf 2 + 4 erase ( empty key buffer )
at
quit
semis
/
head(203,id,'.,iddot,docol)
pad
lit
40
lit
137
fill
dup
pfa
lfa
over
fsub
pad
swap
cmove
pad
count
lit
37
and
type
space
semis
/
head(206,create,,creat,docol)
dfind;zbran;1f-.
drop
uniq;at;zbran;2f-.
nfa;iddot
lit;4;mess
bran;1f-.
2: drop
1: /
here;dup;cat;width;at;min;onep;allot
qalig
dup;lit;240;toggl
here;one;fsub
lit;200;toggl
lates;comma
curr;at;store
here;twop;comma
semis
/
head(311,[compile,'],bcomp,docol)
dfind
zequ
zero
qerr
drop
cfa
comma
semis
/
head(307,litera,'l,liter,docol)
state
at
zbran
1f-.
comp
lit
comma
1: semis
/
head(310,dliteral,,dlite,docol)
state
at
zbran
1f-.
swap
liter
liter
1: semis
/
head(206,?stack,,qstac,docol)
szero
at
two
fsub
spat
uless
one
qerr
spat
here
lit
200
plus
uless
two
qerr
semis
/
head(211,interpre,'t,inter,docol)
1: dfind
zbran;4f-.
state
at
less
zbran;2f-.
cfa
comma
bran;3f-.
2: cfa
exec
3: qstac
bran;2f-.
4: here
numb
dpl
at
onep
zbran;3f-.
dlite
bran;4f-.
3: drop
liter
4: qstac
2: pnull
at
zbran;1b-.
zero
pnull
store
semis
/
head(211,immediat,'e,immed,docol)
lates
lit
100
toggl
semis
/
head(212,vocabulary,,vocab,docol)
build
lit
120201
comma
curr
at
cfa
comma
here
vocl
at
comma
vocl
store
does
dovoc: twop
cont
store
semis
/
head(213,definition,'s,defin,docol)
cont
at
curr
store
semis
/
head(301,,{{'(}},paren,docol)
lit
51
word
semis
/
head(206,prompt,,pmpt,docol)
out;at;zbran;1f-.
cr
1: spat;szero;at;fsub;minus;ddup;zbran;1f-.
pdotq
string(<)
twod;zero;dotr
1: base;at;lit;10.;equal;zequ;zbran;2f-.
spat;szero;at;fsub;zequ;zbran;3f-. / anything on the stack?
pdotq
string({{<}}) / no, brocket
3: pdotq
string({{:}}) / add a colon
base;at;dup;tor;decim;zero;dotr
fromr;base;store
2: pdotq
string({{\> }})
state
at
zbran
1f-.
two
spacs
1: semis
/
head(204,quit,,quit,docol)
zero
pnull
store
zero
blk
store
lbrac
zero;stdin;store / fix stdin ...
stdout;at;two;great;zbran;1f-. / and, if it's bad, ...
one;stdout;store / ... stdout
1: lit;22.;porig;at;tib;store / ... and tib
ftime;at;zbran;1f-.
zero;ftime;store
argv;tor
3: / begin
fromr;twop;dup;tor;at;ddup
zbran;1f-.
dup;strlen;fload
bran;3b-.
fromr;drop
/ pqot
/ s t r i n g(FORTHINIT)
/ getenv;zbran;1f-.
/ tib;store
/ rpsto;inter
1: rpsto
pmpt
query
inter
feof;at;zbran;2f-.
ieof;at;zbran;3f-.
pdotq
string(Use "bye" or "exit" to leave FORTH)
cr
zero;feof;store
bran;2f-.
3: bye
2: bran
1b-.
/
head(205,abor,'t,abort,docol)
spsto
decim
pdotq
string({SWT FIG-Forth Version 1.3 (UNIX)})
cr
forth
defin
quit
/
/ cold and warm starts
/
rtt=000006
1: <{ Interrupt: }>
2: .even;0
3:
intr:
mov r0,-(sp) / save regs in case
mov r1,-(sp)
mov r2,-(sp)
mov r3,-(sp)
mov r4,-(sp)
mov r5,-(sp)
sys 48.;2;intr / reset signal
mov $1,r0
sys 4.;1b;2b-1b / print 'Interrupt: '
mov $0,r0
sys 3.;2b;3b-2b / read command:
cmpb 2b,$'C / C: cold
beq cent
cmpb 2b,$'c
beq cent
cmpb 2b,$'W / W: warm
beq went
cmpb 2b,$'w
beq went
cmpb 2b,$'Q / Q: quit
beq qent
cmpb 2b,$'q
beq qent
cmpb 2b,$'/
bne int_ex
mov (sp)+,r5
mov (sp)+,r4
mov (sp)+,r3
mov (sp)+,r2
mov (sp)+,r1
mov (sp)+,r0
rtt
int_ex: mov $-1,r0 / else exit
sys 1.
/
qent: mov $quit+2,r4 / starts at 'quit'
jmp rpsto+2 / with an empty rstack
/
head(204,cold,,cold)
cent:
mov origin+14,forth+6
mov origin+20,u
mov origin+42,r0
mov origin+44,r1
1: clr (r0)+
cmp r0,r1
blt 1b
clr 42(u)
clr 46(u)
mov origin+42,72(u)
mov origin+42,74(u)
mov $30,r1
br w2
went:
mov $12,r1
w2: mov $origin+22,r5
mov origin+20,r0
clr 76(u)/ *** 10 mar 82 *** (null)
add $6,r0
add r5,r1
1: mov (r5)+,(r0)+
cmp r5,r1
blt 1b
mov origin+24,rp
mov $go,ip
next
/
go: spsto
decim
forth
defin
abort
0
0
0
/
head(204,argc,,argc,docon)
0
/
head(204,argv,,argv,docon)
0
/
head(204,envp,,envp,docon)
0
/
head(204,s-\>d,,stod)
clr -(s)
tst 2(s)
bpl 1f
dec (s)
1: next
/
head(203,ab,'s,abs,docol)
dup
zless
zbran
1f-.
minus
1: semis
/
head(204,dabs,,dabs,docol)
dup
zless
zbran
1f-.
dminu
1: semis
/
head(203,mi,'n,min,docol)
over
over
great
zbran
1f-.
swap
1: drop
semis
/
head(203,ma,'x,max,docol)
over
over
less
zbran
1f-.
swap
1: drop
semis
/
head(202,m*,,mstar)
ifelse(eis,1,
{
mov (s)+,r0
mul (s),r0
mov r1,(s)
mov r0,-(s)
next
},{
mov 2(s),-(rp)
bpl 1f
neg 2(s)
1: tst (s)
bpl 2f
neg (rp)
neg (s)
2: jsr pc,umult
tst (rp)+
bpl 3f
com (s)
com 2(s)
add $1,2(s)
adc (s)
3: next
})
/
head(202,m/,,mslas)
ifelse(eis,1,
{
mov 2(s),r0
mov 4(s),r1
div (s)+,r0
mov r1,2(s)
mov r0,(s)
next
},{
mov 2(s),-(rp)
bne 5f
inc (rp)
5: mov (rp),-(rp)
bpl 1f
com 2(s)
com 4(s)
add $1,4(s)
adc 2(s)
1: tst (s)
bpl 2f
neg (rp)
neg (s)
2: jsr pc,udiv
tst (rp)+
bpl 3f
neg (s)
3: tst (rp)+
bpl 4f
neg 2(s)
4: next
})
/
head(201,,'*,star,docol)
mstar
drop
semis
/
head(204,/mod,,slmod,docol)
tor
stod
fromr
mslas
semis
/
head(201,,'/,slash,docol)
slmod
swap
drop
semis
/
head(203,mo,'d,mod,docol)
slmod
drop
semis
/
head(205,*/mo,'d,ssmod,docol)
tor
mstar
fromr
mslas
semis
/
head(202,*/,,ssla,docol)
ssmod
swap
drop
semis
/
head(205,m/mo,'d,msmod,docol)
tor
zero
r
uslas
fromr
swap
tor
uslas
fromr
semis
/
/ miscellaneous higher levels
/
/
head(301,,047,tick,docol)
dfind
zequ
zero
qerr
drop
liter
semis
/
head(206,forget,,forge,docol)
curr
at
cont
at
fsub
lit
30
qerr
tick
dup
fence
at
uless
lit
25
qerr
dup
nfa
dp
store
lfa
at
cont
at
store
semis
/
head(204,back,,back,docol)
here
fsub
comma
semis
/
head(305,begi,'n,begin,docol)
qcomp
here
one
semis
/
head(305,endi,'f,endif,docol)
qcomp
two
qpair
here
over
fsub
swap
store
semis
/
head(304,then,,then,docol)
endif
semis
/
head(302,do,,do,docol)
comp
xdo
here
lit
3
semis
/
head(304,loop,,loop,docol)
lit
3
qpair
comp
xloop
back
semis
/
head(305,+loo,'p,ploop,docol)
lit
3
qpair
comp
xploo
back
semis
/
head(305,unti,'l,until,docol)
one
qpair
comp
zbran
back
semis
/
head(303,en,'d,end,docol)
until
semis
/
head(305,agai,'n,again,docol)
one
qpair
comp
bran
back
semis
/
head(306,repeat,,repeat,docol)
tor
tor
again
fromr
fromr
two
fsub
endif
semis
/
head(302,if,,if,docol)
comp
zbran
here
zero
comma
two
semis
/
head(304,else,,else,docol)
two
qpair
comp
bran
here
zero
comma
swap
two
endif
two
semis
/
head(305,whil,'e,while,docol)
if
twop
semis
/
/
head(206,spaces,,spacs,docol)
zero
max
ddup
zbran
2f-.
zero
xdo
1: space
xloop
1b-.
2: semis
/
head(202,<{{#}},,bdigs,docol)
pad
hld
store
semis
/
head(202,{{#}}\>,,edigs,docol)
drop
drop
hld
at
pad
over
fsub
semis
/
head(204,sign,,sign,docol)
rot
zless
zbran
1f-.
lit
55
hold
1: semis
/
head(201,,'{{#}},dig,docol)
base
at
msmod
rot
lit
11
over
less
zbran
1f-.
lit
7
plus
1: lit
60
plus
hold
semis
/
head(202,{{#}}s,,digs,docol)
1: dig
over
over
or
zequ
zbran
1b-.
semis
/
head(203,d.,'r,ddotr,docol)
tor
swap
over
dabs
bdigs
digs
sign
edigs
fromr
over
fsub
spacs
type
semis
/
head(202,.r,,dotr,docol)
tor
stod
fromr
ddotr
semis
/
head(202,d.,,ddot,docol)
zero
ddotr
space
semis
/
head(201,,'.,dot,docol)
stod
ddot
semis
/
head(201,,277,quest,docol)
at
dot
semis
/
head(202,u.,,udot,docol)
zero
ddot
semis
/
/ utility section
head(205,vlis,'t,vlist,docol)
lit
200
out
store
cont
at
at
1: out
at
lit
100
great
zbran
2f-.
cr
zero
out
store
2: dup
iddot
space
pfa
lfa
at
dup
zequ
qterm
or
zbran
1b-.
drop
semis
/
/
/ installation-dependent section (terminal, disk i/o, and traps)
/
.even
/
head(206,(emit),,pemit)
mov s,1f
mov stdout+2,r0
sys 4.
1: 0
1
bcc 1f
mov r0,errno+2
clr (s)
br 2f
1: mov $1,(s)
2: next
/
head(206,keybuf,,keybuf,dovar)
akeybuf:0
keyptr: 0
keyend: 0
/
head(205,{{(key}},{{')}},pkey)
cmp keyptr,keyend / any characters waiting?
beq 1f / if
keyloop:mov akeybuf,r0 / get buffer
add keyptr,r0 / add offset
clr -(s) / push
movb (r0),(s) / value
inc keyptr / point to nxt char
mov $1,-(s) / return success
br 2f / else
1: mov akeybuf,3f / keybuf, keylen,
mov stdin+2,r0 / fildes
sys 3. / read
3: 0
keylen
bec 3f / if an error
mov r0,errno+2 / record type
clr -(s) / return error
br 2f / else
3: tst r0 / anything read?
bne 1f / if not
mov $42.,errno+2 / end of file.
clr -(s) / return error
br 2f / else
1: mov r0,keyend / save length
clr keyptr / reset pointer
br keyloop / and try again
2: next / return
/
head(213,{{(?terminal}},{{')}},pqter)
mov $0,-(s)
next
/
head(203,by,'e,bye,docol)
zero;exit
/
head(204,exit,,exit)
mov (s)+,r0
sys 1
/
/ UNIX disk i/o
/
head(206,(open),,popen) / addr mode -> {0|fd 1}
mov (s)+,1f
mov (s)+,2f
sys 5.
2: 0
1: 0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov $1,-(s)
2: next
/
head(204,open,,open,docol) / addr len mode -> {fd 1|0}
tor;dup;tor / save mode, len
tbuf;swap;cmove / move name to tbuf
zero;tbuf;fromr;plus;cstor / add null
tbuf;fromr;popen
semis
/
head(207,{{(creat}},{{')}},pcret)/ addr mode -> {0|fd 1}
mov (s)+,1f
mov (s)+,2f
sys 8.
2: 0
1: 0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov $1,-(s)
2: next
/
head(205,crea,'t,cret,docol) / addr len mode -> {fd 1|0}
tor;dup;tor / save mode, len
tbuf;swap;cmove / move name to tbuf
zero;tbuf;fromr;plus;cstor / add null
tbuf;fromr;pcret
semis
/
head(205,clos,'e,close) / fd -> flag
mov (s)+,r0
sys 6.
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov $1,-(s)
2: next
/
head(204,tbuf,,tbuf,docon)
atbuf: xdp
/
head(205,lsee,'k,lseek) / lo hi fd -> flag
mov (s)+,r0
mov (s)+,1f
mov (s)+,2f
sys 19.
1: 0
2: 0
0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov $1,-(s)
2: next
/
head(204,read,,read) / addr bytes fd -> {bytes 1|0}
mov (s)+,r0 / fd
mov (s)+,2f / addr
mov (s)+,1f / length
sys 3. / read
1: 0 / to be addr
2: 0 / to be length
bec 1f / if succeeds, skip, else
mov r0,errno+2 / save errno
clr -(s) / return false
br 2f
1: mov r0,-(s) / success, return len
mov $1,-(s) / and true
2: next
/
head(205,writ,'e,write)/ addr bytes fd -> {bytes 1|0}
mov (s)+,r0
mov (s)+,2f
mov (s)+,1f
sys 4.
1: 0
2: 0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov $1,-(s)
2: next
/
/ Other UNIX system calls
/
head(203,br,'k,brk)
mov (s),abreak
mov (s)+,1f
sys 17.
1: xbreak
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov $1,-(s)
2: next
/
head(204,sbrk,,sbrk,docol)
break;at;plus;brk
next
/
head(205,brea,'k,break,dovar)
abreak: xbreak
/
head(207,{{(indir}},{{')}},pindir) / r0 r1 addr -> {r0 r1 1|0}
mov (s)+,1f
mov (s)+,r1
mov (s)+,r0
sys 0.
1: 0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov r1,-(s)
mov $1,-(s)
2: next
/
head(205,indi,'r,indir,docol) / args call r0 r1 -> args call {r0 r1 1|0}
spat;lit;4;plus;pindir
semis
/
head(204,fork,,fork)
sys 2.
br child
parent: bec 1f
mov r0,errno+2
mov $-1.,-(s)
br 2f
1: mov r0,-(s)
2: next
child: mov $0,-(s)
next
/
head(205,exec,'e,xece) / name argv envp -> ERROR
mov (s)+,3f
mov (s)+,2f
mov (s)+,1f
sys 59.
1: 0
2: 0
3: 0
mov r0,errno+2
next
/
head(204,wait,,wait) / wait -> {pid stat 1|0}
sys 7.
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov r1,-(s)
mov $1,-(s)
2: next
/
head(204,exec,,xec,docol)
envp;xece
semis
/
head(206,signal,,signal) / addr sig -> {addr 1|0}
mov (s)+,1f
mov (s)+,2f
sys 48.
1: 0
2: 0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov $1,-(s)
2: next
/
head(204,time,,time) / -> t.0 t.1
sys 13.
mov r1,-(s)
mov r0,-(s)
next
/
head(205,alar,'m,alarm) / t -> old.t
mov (s)+,r0
sys 27.
mov r0,-(s)
next
/
head(207,{{(chdir}},{{')}},pcd) / name -> t/f
mov (s)+,1f
sys 12.
1: 0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov $1,-(s)
2: next
/
head(204,udup,,udup) / fd -> {fd 1|0}
mov (s)+,r0
bic $0100,r0
sys 41.
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov $1,-(s)
2: next
/
head(205,udup,'2,udup2) / fd ofd -> 1|0
mov (s)+,r0
bis $0100,r0
mov (s)+,r1
sys 41.
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov $1,-(s)
2: next
/
head(206,getpid,,getpid) / -> pid
sys 20.
mov r0,-(s)
next
/
head(206,getuid,,getuid) / -> euid uid
sys 24.
mov r1,-(s)
mov r0,-(s)
next
/
head(206,getgid,,getgid) / -> egid gid
sys 47.
mov r1,-(s)
mov r0,-(s)
next
/
head(204,kill,,kill) / pid sig -> 1|0
mov (s)+,1f
mov (s)+,r0
sys 37.
1: 0
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov $1,-(s)
2: next
/
head(204,nice,,nice) / niceness -> 1|0
mov (s)+,r0
sys 34.
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov $1,-(s)
2: next
/
head(205,paus,'e,pause)
sys 29.
next
/
head(204,pipe,,pipe) / -> {rfd wfd 1|0}
sys 42.
bec 1f
mov r0,errno+2
clr -(s)
br 2f
1: mov r0,-(s)
mov r1,-(s)
mov $1,-(s)
2: next
/
head(206,unique,,uniq,dovar)
1
/
head(206,contin,,contin,dovar)
0
/
head(205,errn,'o,errno,dovar)
0
/
head(204,feof,,feof,dovar)
0
/
head(204,2dup,,twodup,docol)
over;over;semis
/
head(205,matc,'h,match,docol)
1: dup
zbran;4f-.
tor;over;cat;over;cat;equal;fromr;swap
zbran;2f-.;onem;rot;onep;rot;onep;rot;bran;3f-.
2: drop;drop;drop;zero;semis
3: bran;1b-.
4: drop;drop;drop;one
semis
/
head(204,scan,,scan,docol)
1: dup;at
zbran;3f-.
tor;twodup;i;at;swap;match;zbran;2f-.
drop;drop;fromr;at;one;semis
2: fromr;twop
bran;1b-.
3: drop;drop;drop;zero
semis
/
head(206,getenv,,getenv,docol)
envp;scan;zbran;3f-.
1: dup;cat;zequ;over;cat;lit;61.;equal;or;zequ;zbran;2f-.
onep;bran;1b-.
2: onep;one
bran;4f-.
3: zero
4: semis
/
head(205,ftim,'e,ftime,dovar)
1
/
head(205,stdi,'n,stdin,dovar)
0
/
head(206,stdout,,stdout,dovar)
1
/
head(206,stderr,,stderr,dovar)
2
/
head(209,ignoreeo,'f,ieof,dovar)
0
/
head(212,ignorecase,,icase,dovar)
1
/
head(209,{{(message}},{{')}},mesg,docol)
dup;plus
errtab;plus;at;count;type
semis
/
head(207,messag,'e,mess,docol)
lit;36.;plus;mesg
semis
/
head(206,perror,,perror,docol)
here;count;type;space;errno;at;mesg
semis
/
head(207,ferrta,'b,fertab,docon)
aferrtab
/
head(206,errtab,,errtab,dovar)
E0 ;E1 ;E2 ;E3 ;E4 ;E5 ;E6 ;E7 ;E8 ;E9
E10;E11;E12;E13;E14;E15;E16;E17;E18;E19
E20;E21;E22;E23;E24;E25;E26;E27;E28;E29
E30;E31;E32;E33;E34;E35
aferrtab: F0 ;F1 ;F2 ;F3
F4 ;F5 ;F6 ;F7 ;F8 ;F9 ;F10;F11;F12;F13
F14;F15;F16;F17;F18;F19;F20;F21;F22;F23
F24;F25;F26;F27;F28;F29;F30;F31;0
E0: string(Error 0)
E1: string(Not owner)
E2: string(No such file or directory)
E3: string(No such process)
E4: string(Interrupted system call)
E5: string(I/O Error)
E6: string(No such device or address)
E7: string(Arg list too long)
E8: string(Exec format error)
E9: string(Bad file number)
E10: string(No children)
E11: string(No more processes)
E12: string(Not enough core)
E13: string(Permission denied)
E14: string(Bad address)
E15: string(Block device required)
E16: string(Mount device busy)
E17: string(File exists)
E18: string(Cross device {{link}})
E19: string(No such device)
E20: string(Not a directory)
E21: string(Is a directory)
E22: string(Invalid argument)
E23: string(File table overflow)
E24: string(Too many open files)
E25: string(Not a typewriter)
E26: string(Text file busy)
E27: string(File too large)
E28: string(No space left on device)
E29: string(Illegal seek)
E30: string(Read only file system)
E31: string(Too many {{link}}s)
E32: string(Broken pipe)
E33: string(Math argument)
E34: string(Result too large)
E35: string(Unknown error)
F0: string(Undefined)
F1: string(Empty stack)
F2: string(Dictionary full)
F3: string(Bad address mode)
F4: string(Isn't unique)
F5=E35
F6: string(End of file) / 42.
F7: string(Full stack)
F8: string(Disk error!)
F9=E35
F10=E35
F11=E35
F12=E35
F13=E35
F14=E35
F15=E35
F16=E35
F17: string(Compilation only)
F18: string(Execution only)
F19: string(Conditionals not paired)
F20: string(Incomplete definition)
F21: string(In protected dictionary)
F22: string(Use only when loading)
F23=E35
F24: string(Declare vocabulary)
F25=E35
F26=E35
F27=E35
F28=E35
F29=E35
F30=E35
F31=E35
/
head(206,sallot,,sallot) / allocate n words on stack
mov (s)+,r0
asl r0
sub r0,s
/ Kludge stack limits down...
mov rp,r1
mov s,rp
mov r0,-(rp)
sys 33.; E35; 0
add r0, rp / make room for as much again.
mov r0,-(rp)
sys 33.; E35; 0
mov r1,rp
next
/
head(205,floa,'d,fload,docol) /: fload ( name -> )
zero;open;zbran;1f-. / 0 open if
stdin;at;tor;tib;at;tor;in;at;tor/ stdin @ >R tib @ >R in @ >R
keybuf / keybuf
dup;at;tor;two;plus / dup @ >R 2 +
dup;at;tor;two;plus / dup @ >R 2 +
at;tor / @ >R
stdin;store;zero;in;store / stdin ! 0 in !
lit;keylen;sallot / keylen sallot
spat;keybuf;store / sp@ keybuf !
keybuf;two;plus;lit;4;erase / keybuf 2 + 4 erase ( empty key buffer )
lit;128.;sallot;spat;tib;store / 128 sallot sp@ tib !
2: query;inter / begin query interpret
feof;at;zbran;2b-. / feof @ until
zero;feof;store;lit;-128.;sallot / 0 feof ! -128 sallot
lit;-keylen;sallot / -keylen sallot
stdin;at;close;drop / stdin @ close drop
fromr;keybuf;lit;4;plus;store / R> keybuf 4 + !
fromr;keybuf;two;plus;store / R> keybuf 2 + !
fromr;keybuf;store / R> keybuf !
fromr;in;store;fromr;tib;store / R> in ! R> tib !
fromr;stdin;store / R> stdin !
bran;2f-. / else
1: perror / perror
2: semis / then ;
/
/ FORTH disk I/O
/
head(204,word,,word,docol) / moved here because
blk;at;zbran;1f-. / it accesses the disk
blk;at;block;bran;2f-.
1: tib;at
2: in;at;plus
swap;encl
here;lit;42;blank
in;pstor
over;fsub;tor
r;here;cstor
plus;here;onep;fromr;cmove
semis
/
/ disk i/o - ( section common to all systems )
/
head(204,+buf,,pbuf,docol)
bbuf;lit;4;plus;plus
dup;limit;at;equal;zbran;1f-.
drop;first;at
1: dup;prev;at;fsub
semis
/
head(206,update,,updat,docol)
prev;at;at;lit;100000;or
prev;at;store
semis
/
head(215,empty-buffer,'s,mtbuf,docol)
first;at;limit;at;over;fsub;erase
semis
/
head(205,flus,'h,flush,docol)
limit;at;first;at;xdo
1: i;at;zless;zbran;2f-.
i;twop;i;at;lit;77777;and;zero;rw
2: bbuf;lit;4;plus
xploo;1b-.
mtbuf
semis
/
head(206,buffer,,buffe,docol)
use;at;dup;tor
1: pbuf;zbran;1b-.
use;store;r;at;zless;zbran;1f-.
r;twop;r;at;lit;77777;and;zero;rw
1: r;store;r;prev;store;fromr;twop
semis
/
head(205,bloc,'k,block,docol)
ofset;at;plus;tor
prev;at;dup;at;lit;077777;and;r;fsub;zbran;3f-.
1: pbuf;zequ;zbran;2f-.
drop;r;buffe;dup;r;one;rw;two;fsub
2: dup;at;lit;077777;and;r;fsub;zequ;zbran;1b-.
dup;prev;store
3: fromr;drop
twop
semis
/
head(206,(line),,pline,docol)
tor;cl;bbuf;ssmod;fromr;bscr;star;plus;block;plus;cl
semis
/
head(205,.lin,'e,dline,docol)
pline;dtrai;type
semis
/
head(204,load,,load,docol)
blk;at;tor
in;at;tor
zero;in;store
bscr;star;blk;store
inter
fromr;in;store
fromr;blk;store
semis
/
head(303,--,'>,arrow,docol)
qload
zero;in;store
bscr;blk;at;over;mod;fsub;blk;pstor
semis
/
/ utility section
/
head(204,list,,list,docol)
decim
dup;scr;store
pdotq
string({screen })
dot;cr
lit;20;zero;xdo
2: i;three;dotr;space;i;scr;at;dline;cr
xloop;2b-.
cr
semis
/
head(205,inde,'x,findex,docol)
onep;swap;xdo
2: i;three;dotr;space;zero;i;dline;cr
xloop;2b-.
semis
/
head(213,disk-origi,'n,dorig,dovar)
1
/
head(212,block-read,,bread,docol)/ addr block#...
dorig;at;fsub / don't waste block 0
bbuf;ustar / lo hi
scrf;at;lseek;zbran;1f-. / if can seek there
bbuf;scrf;at;read;zbran;1f-. / read.
bbuf;less;zbran;3f-. / if at EOF,
lit;42.;errno;store;zero / error
bran;2f-. / else
3: one / if succeeds, return 1
bran;2f-. / else
1: zero / return 0
2: semis / fi
/
head(213,block-writ,'e,bwrit,docol)/ addr block#...
dorig;at;fsub / don't waste block 0
bbuf;ustar / lo hi
scrf;at;lseek;zbran;1f-. / if can seek there
bbuf;scrf;at;write;zbran;1f-. / read.
drop;one / if succeeds, return 1
bran;2f-. / else
1: zero / return 0
2: semis / fi
/
head(203,r/,'w,rw,docol)
setio;zequ;zbran;1f-. / setio 0= if
perror;abort / perror abort
1: dup;one;equal;zbran;1f-. / then dup 1 = if
drop;bread;zequ;zbran;2f-. / drop block-read 0= if
perror;abort / perror abort
2: bran;3f-. / then else
1: zequ;zbran;4f-. / 0= if
bwrit;zequ;zbran;5f-. / block-write 0= if
perror;abort / perror abort
5: / then
4: / then
3: semis / then ;
/
head(204,scrf,,scrf,dovar)
0
/
head(205,seti,'o,setio)
mov $1,-(s) / assume success
tst scrf+2 / if already open
bne 1f / skip rest
sys 5.;sname+2;2 / else try open
bec 3f / and if it fails, then
sys 8.;sname+2;0777 / try creat
bec 3f / and if it fails, then
mov r0,errno+2 / set error
clr (s) / zap return
br 1f / else one of them worked
3: mov r0,scrf+2 / so get the fd
1: next / and in any case return
/
head(205,snam,'e,sname,dovar)
<screens>
.byte 0
.even
0;0;0;0;0;0;0;0;0;0 / allow some extra space
0;0;0;0;0;0;0;0;0;0 / for the screen name
/
/ the following two definitions are not pure code, so they were
/ moved here, near the end of the dictionary.
/
head(305,;cod,'e,semic,docol)
/ create new data type with code routine written in assembly
qcsp
comp
pscod
lbrac
smudg
semis
/
head(305,fort,'h,forth,dodoe)
dovoc
120201
task-10
xxvoc: 0
/
head(204,task,,task,docol)
semis
/
/ stacks and buffers
/
.bss
xdp:
.=.+8096. / initially 8K allocated
xbreak:
--
Peter (Made in Australia) da Silva
UUCP: ...!shell!neuro1!{hyd-ptd,baylor,datafac}!peter
MCI: PDASILVA; CIS: 70216,1076