[net.sources] Reposting - part 8 of 8 - Princeton FORTH v2.0 for the VAX

wls@astrovax.UUCP (William L. Sebok) (07/13/84)

Part 8 of 8

This is a reposting of Princeton Forth v2.0, due to the fact that there were
so many complaints of, or problems attributable to, files being lost or mangled
on the net.  There are 8 parts. A size and checksum is now included the
beginning of each part.  Part 8 has several bug fixes:
	1) a colon had been omitted from  ./vaxforth/makefile.4.1
	2) several error handlers in the initialization code in
	   ./vaxforth/forth3.S were faulty and caused core dumps.
	3) A bug in the 4.1BSD section of the above code caused the invocation
	   of one of these error handlers.
--------
  This is a 32 bit public domain implementation of Forth that has been written
for a VAX running under 4.1 or 4.2 BSD UNIX.  It has been running now for
about two years at the Astrophysics Dept. at Princeton University and is used
for image processing.  It follows the 79-standards except: 1) entries on the
parameter stack are 32 bits wide,  2) addresses are 32 bits (rather than the
demanded 16 bits) wide, 3) Certain escape sequences beginning with a backslash
are recognized in the printing word  ." ......"

  Some extensions to the 79-standard are: 1) A character string stack, with a
full set of string operators. This also make manipulation of Unix file names
infinitely easier,  2) A floating point stack, and 3) A set of Unix interface
words.

  Colon definitions are compiled as a series of bsbb, bsbw, or jsb instructions
(the shortest one that will reach) rather than as  list of pointers.  The ICODE
operator can be used instead of the ICODE operator for short definitions.  When
a word defined by the ICODE operator is compiled its code is stuffed in-line
rather than referenced.  Number references are compiled as the shortest of the
many possible instructions to push that number onto the stack.

Dearchive this package in a directory called forth.  Edit the makefile to
point to the directory it is in.  Convert the file ./vaxforth/forth.blk.txt
to a forth screen file ./vaxforth/forth.blk  with the provided utility utf :
	utf forth.blk.txt forth.blk

Princeton Univ. Observatory
Peyton Hall, Rm. 129
Princeton, NJ 08544
Phone: (609)452-3586
Uucp: {allegra,akgua,burl,cbosgd,decvax,ihnp4,noao,vax135}!astrovax!wls

Part 8 of 8	file with parts before and after "Cut here" lines removed:
	size = 35132 bytes	Checksum = 2525620
-----------Cut here and extract with sh not csh---------------
mkdir ./vaxforth
/bin/echo 'Extracting ./vaxforth/forth3.S'
sed 's/^X//' <<'//go.sysin dd *' >./vaxforth/forth3.S
X/* ================================================================ */

X/*  Dictionary Headers */

	.byte	8f-0f
9:	.word	9b-fdc1
9:	.set	fdc1,9b
	.long	INL+IM+06425151410	/* ASSEMBLER */
0:	moval	asmdic,context(%u)
8:	rsb

	.byte	8f-0f
9:	.word	9b-fdc6
9:	.set	fdc6,9b
	.long	INL+IM+04121107450	/* FORTH */
0:	moval	fthdic,context(%u)
8:	rsb

X/*    Vocabulary Operations ----------------------------------- */

9:	.word	9b-fdc6
9:	.set	fdc6,9b
	.long	02435107460	/* FORGET (truncate dictionary chain) */
forget:	bsbw	tick
	movl	current(%u),context(%u)
	movl	current(%u),r0
	cmpl	(%s),-8(r0)	/*  trying to forget below FENCE? */
	bgtru	0f
	movl	$E.FENCE,r0
	jbr	abort

0:	subl3	$10,(%s)+,r1	/* back up dict pointer */
	movl	r1,%h
	tstw	-(%h)		/* short link? */
	bneq	1f		/* yes */
	tstl	-(%h)		/* if not, skip long link */
1:	bitb	$INL,(r1)	/* was it in-line definition */
	beql	2f		/* no */
	decl	%h		/* if so, skip in-line length */
2:	movl	$16,r1		/* init count to 16 threads */
3:	movl	(r0),r2		/* get 1st defin. in thread */
4:	cmpl	r2,%h		/* compare against forgetting point */
	blssu	6f		/* if it doesn't stick beyond go to nxt thread*/
	movzwl	-(r2),r3	/* get short link */
	beql	5f		/* is it short link? */
	subl2	r3,r2		/* yes */
	bneq	4b		/* is it end of chain? */
	brb	6f
5:	movl	-(r2),r2	/* get long link */
	bneq	4b		/* end of chain? */
6:	movl	r2,(r0)+	/* replace truncated thread */
	sobgtr	r1,3b		/* go to next thread */
	rsb

9:	.word	9b-fdc6
9:	.set	fdc6,9b
	.long	01004147520		/* VOCABULARY */
	bsbw	create			/* compile entry */
	bisb2	$IM,*head(%u)		/* make immediate */
	addl3	$72,%h,(%h)+		/* set fence to be right here */
	movl	context(%u),(%h)+	/* set link to context vocabulary */
	movc5	$0,(%h),$0,$64,(%h)	/* clear room for 16 threads */
	movl	r3,%h
	bsbw	semcod
vocab:	addl3	(%r)+,$8,context(%u)
	rsb

X/* ================================================================ */

X/*   Double Integer Operators (An Extension Word Set) */

	.byte	8f-0f
9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	INL+020202020720	/* 2! */
0:	movl	(%s)+,r0
	movq	(%s)+,(r0)
8:	rsb

	.byte	8f-0f
9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	INL+020202000320	/* 2@ */
0:	movl	(%s)+,r0
	movq	(r0)+,-(%s)
8:	rsb

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	011470741710		/* 2CONSTANT */
	bsbw	create
	movq	(%s)+,(%h)+
	bsbw	semcod
	movq	*(%r)+,-(%s)
	rsb

	.byte	8f-0f
9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	INL+010075102350	/* 2DROP */
0:	addl2	$8,%s
8:	rsb

	.byte	8f-0f
9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	INL+020101242340	/* 2DUP */
0:	movq	(%s),-(%s)
8:	rsb

	.byte	8f-0f
9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	INL+011025307750	/* 2OVER */
0:	movq	8(%s),-(%s)
8:	rsb

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	020120751340		/* 2ROT */
	movq	16(%s),-(%s)
	movl	%s,r0
	addl2	$32,%s
	movq	-(r0),-(%s)
1:	movq	-(r0),-(%s)
	movq	-(r0),-(%s)
	rsb

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	010005351750		/* 2SWAP */
d.swap:	movq	(%s)+,r0
	movq	(%s),r2
	movq	r0,(%s)
	movq	r2,-(%s)
	rsb

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	04510053310		/* 2VARIABLE */
	bsbw	create
	clrq	(%h)+
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020202026420		/* D- */
dminus: movq	(%s)+,r0
	subl2	r1,4(%s)
	sbwc	r0,(%s)
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020202036420		/* D= */
	bsbw	dminus
	bsbw	dzeq
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020114100440		/* DABS */
dabs:	tstl	(%s)
	bgeq	1f
	bsbw	dnegate
1:	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020140046440		/* DMAX */
	movq	8(%s),-(%s)
	movq	8(%s),-(%s)
	bsbw	d.less
	tstl	(%s)+
	beql	1f
	movq	(%s)+,(%s)
	rsb
1:	addl2	$8,%s
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020070446440		/* DMIN */
	movq	8(%s),-(%s)
	movq	8(%s),-(%s)
	bsbw	d.less
	tstl	(%s)+
	bneq	1f
	movq	(%s)+,(%s)
	rsb
1:	addl2	$8,%s
	rsb

X/*                    Double operators not in Standard ---------- */

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020202065430		/* D+! (double sum into addr) */
	movl	(%s)+,r0
	addl2	(%s)+,(r0)+
	addl2	(%s)+,(r0)
	adwc	$0,-(r0)
	rsb

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	03044411760		/* 2SHIFT (shift double integer) */
	movl	(%s)+,r2
	movl	(%s)+,r1
	movl	(%s),r0
	ashq	r2,r0,r0
	movl	r0,(%s)
	movl	r1,-(%s)
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020024601040		/* DBLE (signed conversion to double) */
	clrl	-(%s)
	tstl	4(%s)
	bgeq	1f
	decl	(%s)
1:	rsb

X/* ================================================================ */

X/*   Numeric Output */

9:	.word	9b-fdcd
9:	.set	fdcd,9b
	.long	0020200351430		/* MSG  (A compiling word for chrs) */
	bsbw	create
	bsbw	semcod
fmsg:	bsbw	does
	bsbw	count
	brw	type

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	02414050150		/* SPACE (type a space) */
space:	bsbb	fmsg
	.byte	1,BLANK

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	020202011020		/* CR */
cr:	bsbb	fmsg
	.byte	1,NL

9:	.word	9b-fdc6
9:	.set	fdc6,9b
	.long	020202003020		/* FF (form feed) */
	bsbb	fmsg
	.byte	1,12

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	020060602440		/* BELL */
	bsbb	fmsg
	.byte	1,7

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	02414050160		/* SPACES */
spaces:	movl	(%s)+,r0
	bgtr	1f
	rsb
1:	addl3	%h,$PADOFF,r1
	movq	r0,-(%s)
	movc5	$0,(r1),$BLANK,r0,(r1)
	movl	typer(%u),r0
	jmp	*(r0)+

9:	.word	9b-fdc8
9:	.set	fdc8,9b
	.long	020020607440		/* HOLD */
hold:	decl	dbparen(%u)
	cvtlb	(%s)+,*dbparen(%u)
	rsb

	.byte	8f-0f
9:	.word	9b-fdc0
9:	.set	fdc0,9b
	.long	INL+020200200530		/* PAD */
0:	addl3	%h,$PADOFF,-(%s)
8:	rsb

	.byte	8f-0f
9:	.word	9b-fdcc
9:	.set	fdcc,9b
	.long	INL+020202021720	/* <# */
0:	addl3	%h,$PADOFF,dbparen(%u)
8:	rsb

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	020202037220		/* #> */
sharpls:
	addl3	%h,$PADOFF,(%s)+
	movl	dbparen(%u),(%s)
	subl2	(%s),-(%s)
2:	rsb

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	020070344540		/* SIGN */
sign:	tstl	(%s)+
	bgeq	2b
	movl	$'-,-(%s)
	brb	hold

9:	.word	9b-fdcd
9:	.set	fdcd,9b
	.long	02074667450	/* M/MOD  divide double by single */
m_mod:	movl	(%s)+,r3	/* get divisor */
	movl	(%s)+,r1	/* get high dividend */
	movl	(%s)+,r0	/* get low dividend */
	clrl	r2		/* super high dividend is zero */
	ashq	$1,r0,r0	/* move low part around */
	ediv	r3,r1,r2,r1	/* divide high part */
	ashq	$-1,r0,r0	/* move low part back */
	ediv	r3,r0,r1,r0	/* divide low part */
	ashl	$1,r1,r1	
	ashq	$-1,r1,r1	/* move high part back */
	movl	r1,-(%s)	/* low part of quotient */
	movl	r2,-(%s)	/* high part of quotient */
	movl	r0,-(%s)	/* remainder */
	rsb

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	020202020210		/* # (extract digit and cvt to char) */
sharp:	movl	base(%u),-(%s)
	bsbw	m_mod
	cmpl	(%s),$9
	bleq	1f
	addl2	$7,(%s)
1:	addl2	$'0,(%s)
	decl	dbparen(%u)
	cvtlb	(%s)+,*dbparen(%u)
	rsb

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	020202011620		/* #S (convert until done) */
sharpS:	bsbb	sharp
	movq	(%s),r0
	bneq	sharpS
	rsb

pr:	addl3	%h,$PADOFF,dbparen(%u)
	bsbb	sharpS
	bsbw	rot
	bsbw	sign
	brw	sharpls

9:	.word	9b-fdc8
9:	.set	fdc8,9b
	.long	020202467230		/* (.) */
dot0:	movl	(%s),-(%s)
	bsbw	abs
	clrl	-(%s)
	brb	pr

9:	.word	9b-fdce
9:	.set	fdce,9b
	.long	020202020210		/* . (print a number) */
dot:	bsbb	dot0
	bsbw	type
	brw	space

9:	.word	9b-fdcf
9:	.set	fdcf,9b
	.long	020202020310		/* ? (print number at address) */
	movl	*(%s)+,-(%s)
	brb	dot

9:	.word	9b-fdc8
9:	.set	fdc8,9b
	.long	020246712640		/* (U.) */
udot0:	clrl	-(%s)
	bsbw	swap
	clrl	-(%s)
	brb	pr

9:	.word	9b-fdc5
9:	.set	fdc5,9b
	.long	020202027120		/* U.  (print unsigned number) */
	bsbb	udot0
	bsbw	type
	brw	space

9:	.word	9b-fdc8
9:	.set	fdc8,9b
	.long	020246702240		/* (D.) */
d.dot0:	bsbw	swap
	movl	4(%s),-(%s)
	bsbw	dabs
	brb	pr

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020202027020		/* D. (print double integer) */
	bsbb	d.dot0
	bsbw	type
	brw	space

rdot:	subl3	(%s),(%r)+,-(%s)
	bsbw	spaces
	brw	type

9:	.word	9b-fdce
9:	.set	fdce,9b
	.long	020202011220		/* .R  (right justified signed print) */
dotr:	pushl	(%s)+
	bsbw	dot0
	brb	rdot

9:	.word	9b-fdc5
9:	.set	fdc5,9b
	.long	020201127130		/* U.R (right justified unsigned dot) */
u.r:	pushl	(%s)+
	bsbw	udot0
	brb	rdot

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020201127030		/* D.R (right justified double dot) */
d.r:	pushl	(%s)+
	bsbw	d.dot0
	brb	rdot

9:	.word	9b-fdcd
9:	.set	fdcd,9b
	.long	04405112210		/* -TRAILING (delete trailing blanks) */
mtrail:	movl	(%s)+,r0
	bleq	2f
	addl3	(%s),r0,r1
1:	cmpb	-(r1),$BLANK
	bneq	2f
	sobgtr	r0,1b
2:	movl	r0,-(%s)
	rsb

9:	.word	9b-fdcc
9:	.set	fdcc,9b
	.long	020024704440		/* LINE */
line:	cvtwl	$64,-(%s)
	cvtwl	$1024,-(%s)
	bsbw	tmdvmod
	addl2	scr(%u),(%s)
	bsbw	block
	addl2	(%s)+,(%s)
	rsb

9:	.word	9b-fdcc
9:	.set	fdcc,9b
	.long	020121144440		/* LIST */
list:	movl	(%s)+,scr(%u)
	clrl	-(%r)
1:	bsbw	cr
	movl	(%r),-(%s)
	movl	$3,-(%s)
	bsbw	dotr
	bsbw	space
	movl	(%r),-(%s)
	bsbb	line
	cvtwl	$LNSIZ,-(%s)
	bsbw	mtrail
	bsbw	s.at
	bsbw	sdot
	acbl	$15,$1,(%r),1b
	tstl	(%r)+
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020100652440		/* DUMP */
dump:	clrl	-(%s)
	bsbw	do
1:	bsbw	cr
	movl	(%s),-(%s)
	movl	$12,-(%s)
	bsbw	u.r
	movl	$3,-(%s)
	bsbw	spaces
	addl3	$1,4(%r),-(%s)
	addl3	$4,(%r),-(%s)
	bsbw	min
	movl	(%r),-(%s)
	bsbw	do
2:	bsbw	space
	movl	*0(%s),-(%s)
	movl	$12,-(%s)
	bsbw	u.r
	addl2	$4,(%s)
	aobleq	4(%r),(%r),2b
	addl2	$8,%r
	acbl	4(%r),$4,(%r),1b
	addl2	$8,%r
	tstl	(%s)+
	rsb

X/* ============================================================ */

X/*  Editor Vocabulary (Small Resident Line Oriented Editor) */

	.set	LNSIZ,64	/* max size of edited line */
	.set	LLNSIZ,6	/* log2(LNSIZ) */

	.set	edc0,0
	.set	edc1,0
	.set	edc2,0
	.set	edc3,0
	.set	edc4,0
	.set	edc5,0
	.set	edc6,0
	.set	edc7,0
	.set	edc8,0
	.set	edc9,0
	.set	edca,0
	.set	edcb,0
	.set	edcc,0
	.set	edcd,0
	.set	edce,0
	.set	edcf,0

ehold:	movl	(%s),-(%s)
	bsbw	line
	cvtbl	$LNSIZ,-(%s)
	bsbw	s.at
	rsb

9:	.word	9b-edc8
9:	.set	edc8,9b
	.long	020202020210		/*  (  */
	bsbw	paren
	movl	%h,-(%s)
	bsbw	spush
	rsb

9:	.word	9b-edc4
9:	.set	edc4,9b
	.long	020202020110		/* T  (type out line) */
	bsbw	cr
	movl	$2,-(%s)
	bsbw	spaces
	bsbb	ehold
	bsbw	sdup
	bsbw	sdot
	rsb

9:	.word	9b-edc2
9:	.set	edc2,9b
	.long	020202020110		/* R  (replace line) */
e.r:	bsbw	line
	cvtbl	$LNSIZ,-(%s)
	bsbw	s.stor
	bsbw	update
	rsb

9:	.word	9b-edc4
9:	.set	edc4,9b
	.long	020202020010		/* D  (delete line) */
	bsbb	ehold
	movl	(%s),-(%s)
	bsbw	line
	movl	(%s)+,r0
	subl3	(%s)+,$15,r1
	bleq	1f
	ashl	$LLNSIZ,r1,r1
	movc3	r1,LNSIZ(r0),(r0)
1:	movl	$15,-(%s)
	bsbw	line
	movc5	$0,(%h),$BLANK,$LNSIZ,*(%s)+
	bsbw	update
	rsb
	
9:	.word	9b-edc9
9:	.set	edc9,9b
	.long	020202020010		/* I  ( Insert line) */
	incl	(%s)
	movl	(%s),-(%s)
	bsbw	line
	movl	(%s)+,r0
	subl3	(%s),$15,r1
	bleq	1f
	ashl	$LLNSIZ,r1,r1
	movc3	r1,(r0),LNSIZ(r0)
1:	bsbb	e.r
	rsb

9:	.word	9b-edcc
9:	.set	edcc,9b
	.long	020202020010		/* L  (List current block) */
	movl	scr(%u),-(%s)
	movl	(%s),-(%s)
	bsbw	dot
	bsbw	list
	rsb

9:	.word	9b-edc3
9:	.set	edc3,9b
	.long	020145007440		/* COPY (one disk block to another) */
	movl	(%s)+,-(%r)
	bsbw	block
	movl	(%s)+,r0
	movl	(%r)+,(link1+locat)(r0)
	bsbw	update
	rsb


9:	.word	9b-fdc5
9:	.set	fdc5,9b
ednam:	.long	IM+07520442060		/* EDITOR */
	jsb	*$vocab
	.long	hinit,fthdic
edic:	.long	edc0,edc1,edc2,edc3,edc4,edc5,edc6,edc7
	.long	edc8,edc9,edca,edcb,edcc,edcd,edce,edcf

X/* ========================================================================== */

X/* << System Call Interface >> */
unxerr:	movl	_errno,r0
	jbr	uerror

un1err:	tstl	r0
	blss	1f
	clrl	errno(%u)
	rsb
1:	movl	_errno,errno(%u)
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	011474601660	/* $CLOSE */
s_close:
	pushl	(%s)+
	calls	$1,_close
	brb	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	07025007650	/* $OPEN */
	pushl	(%s)
	pushal	1(%c)
	bsbw	sdrop
	calls	$2,_open
	movl	r0,(%s)
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	0425101670	/* $CREATE */
s_create:
	pushl	(%s)
	pushal	1(%c)
	bsbw	sdrop
	calls	$2,_creat
	movl	r0,(%s)
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	02004251250	/* $READ */
s_read:	movl	(%s)+,r1
	pushl	(%s)+
	pushl	(%s)
	pushl	r1
	calls	$3,_read
	movl	r0,(%s)
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	012045113660	/* $WRITE */
s_write:
	movl	(%s)+,r1
	pushl	(%s)+
	pushl	(%s)
	pushl	r1
	calls	$3,_write
	movl	r0,(%s)
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	012014744660	/* $IOCTL */
s_ioctl:
	movq	(%s)+,r0
	pushl	(%s)		/* buf */
	pushl	r1		/* code */
	pushl	r0		/* descr */
	calls	$3,_ioctl
	movl	r0,(%s)
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	04460712670	/* $UNLINK */
s_unlink:
	pushal	1(%c)
	bsbw	sdrop
	calls	$1,_unlink
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	07464401660	/* $CHMOD */
s_chmod:
	pushl	(%s)+
	pushal	1(%c)
	bsbw	sdrop
	calls	$2,_chmod
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020200201630	/* $CD */
	pushal	1(%c)
	bsbw	sdrop
	calls	$1,_chdir
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020101242240	/* $DUP */
	pushl	(%s)
	calls	$1,_dup
	movl	r0,(%s)
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	05424251650	/* $SEEK */
s_seek:
	movl	(%s)+,r1
	pushl	(%s)+
	pushl	(%s)
	pushl	r1
	calls	$3,_lseek
	movl	r0,(%s)	
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	02425146260	/* $LSEEK */
s_lseek:
	movl	(%s)+,r1
	pushl	(%s)+
	tstl	(%s)+
	pushl	(%s)+
	pushl	r1
	calls	$3,_lseek
	movl	r0,-(%s)	
	clrl	-(%s)
	bgeq	1f
	decl	(%s)
1:	brw	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	03470246270	/* $LENGTH */
	movl	(%s)+,r0
	clrl	-(%s)
	movl	$2,-(%s)
	movl	r0,-(%s)
	jbr	s_seek		/* seek to end of file and return length */

X/* keeping chmk here because I want to keep feature that the child
   receives its parent's uid */
9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	05510743250	/* $FORK */
	pushl	$0
	movl	sp,ap
#ifdef BSD4_2
	chmk	$SYS_fork
#else
	chmk	$fork
#endif
	jcs	1f
	clrl	errno(%u)
	brb	2f
1:
	movl	_errno,errno(%u)
2:
	tstl	(%r)+
	movl	r0,-(%s)
	movl	r1,-(%s)
	rsb

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	01425402650	/* $EXEC */
	addl3	$2,(%s),r6	/* get counter (1st two args are prog name) */
	pushl	$0		/* provide stopper for end of arg list */
	movl	%c,(%s)		/* args are stacked on string stack */
1:	addl3	$1,(%s),-(%r)
	bsbw	sdown		/* go to next one below */
	sobgtr	r6,1b		/* loop */
	movl	(%r)+,r0	/* retrieve last argument */
	pushl	envir		/* add environment string */
	pushal	4(%r)		/* add arg list */
	pushl	r0		/* add routine name */
	pushl	$3
	movl	%r,ap
#ifdef BSD4_2
	chmk 	$SYS_execve
#else
	chmk 	$exece
#endif
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	012044053650	/* $WAIT */
	clrl	-(%s)
	pushl	%s
	calls	$1,_wait
	movl	r0,-(%s)
	jbr	un1err

X/*  Calling Sequence:  ---  out in */

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	02500450250	/* $PIPE */
	clrq	-(%s)
	pushl	%s
	calls	$1,_pipe
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	06060445650	/* $KILL */
s_kill:	pushl	(%s)+
	pushl	(%s)+
	calls	$2,_kill
	jbr	un1err

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	012045402650	/* $EXIT */
s_exit:	pushl	(%s)+
	calls	$2,__exit

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	010120243670	/* $GETPID */
s_getpid:
	calls	$0,_getpid
	movl	r0,-(%s)
	jbr	un1err
X/* ========================================================================== */


X/*   FORTH `WAIT' routine (relict of stand-alone FORTH multi-tasking). */

X/*     Under UNIX this routine merely switches between co-processes. */

#ifdef	COPROCESS
c_wait:	movl	%u,r0		/* get reference u pointer */
1:	movl	-(%u),%u	/*  get next u */
	tstl	(%u)		/*  is he awake? */
	bneq	1b		/*  no, try next guy. */

	cmpl	r0,%u		/* same as current process? */
	beql	2f		/* yes, no need for context switch. */

	pushl	0x0f00		/* save registers (s,h,c,f) */
	movl	%r,rsav(%u)	/* save r */

	movl	%u,*$owner	/* flag new guy as in control. */
	movl	rsav(%u),%r	/* recall r */
	popr	0x0f00		/* restore registers (s,h,c,f) */
2:	rsb
#endif

9:	.word	9b-fdcf
9:	.set	fdcf,9b
	.long	011024713450	/* OWNER  is the co-process in control */
	moval	owner,-(%s)
	rsb

X/* =============================================================== */

X/*  Words to access User area fields */

udef:	addl3	%u,*(%r)+,-(%s)
	rsb

9:	.word	9b-fdc7
9:	.set	fdc7,9b
	.long	020202012620	/* 'U */
	movl	%u,-(%s)
	rsb

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	020120741140	/* RBOT */
	jsb	*$udef
	.long	rbot

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	020120741140	/* SBOT */
	jsb	*$udef
	.long	sbot

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	011025014550	/* TYPER */
	jsb	*$udef
	.long	typer

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	011025014560	/* TYPER0 */
	jsb	*$udef
	.long	typer0

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	02420042560	/* READER */
	jsb	*$udef
	.long	reader

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	02420042570	/* READER0 */
	jsb	*$udef
	.long	reader0

9:	.word	9b-fdc8
9:	.set	fdc8,9b
	.long	020020042440	/* HEAD */
	jsb	*$udef
	.long	head

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	0425100450	/* DAREA */
	jsb	*$udef
	.long	darea

#ifdef	COPROCESS
9:	.word	9b-fdcc
9:	.set	fdcc,9b
	.long	012070541450	/* LCKNT */
	jsb	*$udef
	.long	lcknt
#endif

9:	.word	9b-fdce
9:	.set	fdce,9b
	.long	020014746340	/* >LOC */
	jsb	*$udef
	.long	floc

9:	.word	9b-fdc4
9:	.set	fdc4,9b
	.long	020200610030	/* DPL */
	jsb	*$udef
	.long	dpl

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	020201101530	/* SCR */
	jsb	*$udef
	.long	scr

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	020025140440	/* BASE */
	jsb	*$udef
	.long	base

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	02520707470	/* CONTEXT */
	jsb	*$udef
	.long	context

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	02511112470	/* CURRENT */
	jsb	*$udef
	.long	current

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	02520052150	/* STATE */
	jsb	*$udef
	.long	state

9:	.word	9b-fdce
9:	.set	fdce,9b
	.long	020200704730	/* >IN */
	jsb	*$udef
	.long	in

9:	.word	9b-fdc2
9:	.set	fdc2,9b
	.long	020200546030	/* BLK */
	jsb	*$udef
	.long	blk

9:	.word	9b-fdcd
9:	.set	fdcd,9b
	.long	012410351460	/* MSGBUF */
	jsb	*$udef
	.long	msgbuf

9:	.word	9b-fdcd
9:	.set	fdcd,9b
	.long	012410351470	/* MSGBUF0 */
	jsb	*$udef
	.long	msgbuf0

9:	.word	9b-fdc8
9:	.set	fdc8,9b
	.long	020202024620	/* () */
	jsb	*$udef
	.long	dbparen

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	012074111550	/* SSBOT */
	jsb	*$udef
	.long	ssbot

9:	.word	9b-fdc6
9:	.set	fdc6,9b
	.long	012074111450	/* FSBOT */
	jsb	*$udef
	.long	fsbot

9:	.word	9b-fdc5
9:	.set	fdc5,9b
	.long	07471111050	/* ERRNO */
	jsb	*$udef
	.long	errno

9:	.word	9b-fdc3
9:	.set	fdc3,9b
	.long	0470344560	/* SIGNAL */
	jsb	*$udef
	.long	quitadd
X/* ---------------------------------------------------------------------- */

X/*    Messages (Permanent) */

msgstr:	.word	(msg0-msgs)
	.word	(msg1-msgs)
	.word	(msg2-msgs)
	.word	(msg3-msgs)
	.word	(msg4-msgs)
	.word	(msg5-msgs)
	.word	(msg6-msgs)
	.word	(msg7-msgs)
	.word	(msg8-msgs)
	.word	(msg9-msgs)
	.word	(msg10-msgs)
	.word	(msg11-msgs)
	.word	(msg12-msgs)
	.word	(msg13-msgs)
	.word	(msg14-msgs)
	.word	(msg15-msgs)
	.word	(msg16-msgs)
	.word	(msg17-msgs)
	.word	(msg18-msgs)
	.word	(msg19-msgs)
	.word	(msg20-msgs)
	.word	(msg21-msgs)
	.word	(msg22-msgs)
	.word	(msg23-msgs)
	.word	(msg24-msgs)
	.word	(msg25-msgs)
	.word	(msg26-msgs)
	.word	(msg27-msgs)
	.word	(msg28-msgs)
	.word	(msg29-msgs)
	.word	(msg30-msgs)
	.word	(msg31-msgs)
	.word	(msg32-msgs)
	.word	(msg33-msgs)
	.word	(msg34-msgs)
	.word	(msg35-msgs)
	.word	(msg36-msgs)
	.word	(msg37-msgs)
	.word	(msg38-msgs)
	.word	(msg39-msgs)
	.word	(msg40-msgs)
	.word	(msg41-msgs)
	.word	(msg42-msgs)
	.word	(msg43-msgs)
	.word	(msg44-msgs)
	.word	(msg45-msgs)
	.word	(msg46-msgs)
	.word	(msg47-msgs)
	.word	(msg48-msgs)
	.word	(msg49-msgs)
	.word	(msg50-msgs)
	.word	(msg51-msgs)
	.word	(msg52-msgs)
	.word	(msg53-msgs)
	.word	(msg54-msgs)
	.word	(msg55-msgs)
	.word	(msg56-msgs)
	.word	(msg57-msgs)
	.word	(msg58-msgs)
msglen:
	.byte	(msg1-msg0)
	.byte	(msg2-msg1)
	.byte	(msg3-msg2)
	.byte	(msg4-msg3)
	.byte	(msg5-msg4)
	.byte	(msg6-msg5)
	.byte	(msg7-msg6)
	.byte	(msg8-msg7)
	.byte	(msg9-msg8)
	.byte	(msg10-msg9)
	.byte	(msg11-msg10)
	.byte	(msg12-msg11)
	.byte	(msg13-msg12)
	.byte	(msg14-msg13)
	.byte	(msg15-msg14)
	.byte	(msg16-msg15)
	.byte	(msg17-msg16)
	.byte	(msg18-msg17)
	.byte	(msg19-msg18)
	.byte	(msg20-msg19)
	.byte	(msg21-msg20)
	.byte	(msg22-msg21)
	.byte	(msg23-msg22)
	.byte	(msg24-msg23)
	.byte	(msg25-msg24)
	.byte	(msg26-msg25)
	.byte	(msg27-msg26)
	.byte	(msg28-msg27)
	.byte	(msg29-msg28)
	.byte	(msg30-msg29)
	.byte	(msg31-msg30)
	.byte	(msg32-msg31)
	.byte	(msg33-msg32)
	.byte	(msg34-msg33)
	.byte	(msg35-msg34)
	.byte	(msg36-msg35)
	.byte	(msg37-msg36)
	.byte	(msg38-msg37)
	.byte	(msg39-msg38)
	.byte	(msg40-msg39)
	.byte	(msg41-msg40)
	.byte	(msg42-msg41)
	.byte	(msg43-msg42)
	.byte	(msg44-msg43)
	.byte	(msg45-msg44)
	.byte	(msg46-msg45)
	.byte	(msg47-msg46)
	.byte	(msg48-msg47)
	.byte	(msg49-msg48)
	.byte	(msg50-msg49)
	.byte	(msg51-msg50)
	.byte	(msg52-msg51)
	.byte	(msg53-msg52)
	.byte	(msg54-msg53)
	.byte	(msg55-msg54)
	.byte	(msg56-msg55)
	.byte	(msg57-msg56)
	.byte	(msg58-msg57)
	.byte	(msg59-msg58)

X/* =============================================================== */

X/*   Impure Code Region */

X.data
	.long	hinit-4,0	/* FORTH vocab head */	/* fence and link */
fthdic:	.long	fdc0,fdc1,fdc2,fdc3,fdc4,fdc5,fdc6,fdc7
	.long	fdc8,fdc9,fdca,fdcb,fdcc,fdcd,fdce,fdcf

	.long	hinit-4,fthdic	/* ASSEMBLER vocab head */ /* fence and link */
asmdic:	.long	adc0,adc1,adc2,adc3,adc4,adc5,adc6,adc7
	.long	adc8,adc9,adca,adcb,adcc,adcd,adce,adcf

owner:	.long	user	/* co-process currently in control */
utop:	.long	0	/* top of available memory. */
envir:	.long	0	/* location of environment */

X/*  terminal control block */
	.word	0,0,0
	.word	0,0,0
	.byte	0	/* input channel number */
	.byte	0xff	/* mung flag */
	.long	unxin
tty:	.long	unxout
	.long	1

sbreak:	.long	0	/* current size of memory */
msgfil:	.long	0	/* file descriptor for message file */
trpad0:	.space	60	/* location of latest trap */
trpadd:	.space	20

X/*   Disk Block cross reference table */

dtabl:	.space	Blktab		/* reserve space for disk table */

X/* 	Primary user area ------------------------------------------- */

	.long	user	/* link to next task in circular chain */
user:	.long	0	/* 0 if task active, not 0 if inactive */
	.long	0	/* RSAV save r */
	.long	0	/* RBOT	bottom of return stack. */
	.long	0	/* SBOT	bottom of parameter stack. */
	.long	tty	/* TYPER  points to device used in TYPE command */
	.long	tty	/* 0TYPER points to device used in 0TYPE command. */
	.long	tty	/* READER points to device used in EXPECT command. */
	.long	tty	/* 0READER  used to reset READER. */
	.long	0	/* HEAD	points to most recently compiled word. */
	.long	dtabl	/* DAREA points to area which describes disk buffers */
	.long	1	/* LCKNT count of times disk buffer is kept locked. */
	.long	0	/* >LOC	pointer to location being compiled in file. */
	.long	0	/* DPL	characteristics of last number interpreted by */
			/*   CONVERT  low byte contains decimal digit count */
			/*	      high byte contains flags. */
	.long	0	/* SCR	block being manipulated by editor */
	.long	10	/* BASE	used in number conversions */
	.long	fthdic	/* CONTEXT   vocabulary used for searches. */
	.long	fthdic	/* CURRENT vocabulary in which new Words are compiled*/
	.long	0	/* STATE ==0 if execute, !=0 if compile */
	.long	0	/* >IN	char pointer in line being interpreted */
	.long	3	/* BLK	block being currently interpreted */
			/*   if= 0 then input from keyboard. */
			/*   if > CHANBOT then BLK-CHANBOT is file descriptor */
			/*     (kluge to permit interpretation of files). */
	.long	0	/* MSGBUF	message buffer for terminal I/O */
	.long	0	/* 0MSGBUF	cell used to reset MSGBUF. */
	.long	0	/* ()		used for graphics and number output */
	.long	0	/* SSBOT	  string stack bottom */
	.long	0	/* FSBOT	  bottom of floating point stack */
	.long	0	/* ERRNO    unix error number */
	.long	0	/* QUITADD  intercept forth QUIT (like a Unix signal).*/

hinit:			/* dictionary starts here */

X/* 	Initialization Code given control when Forth is first entered. */
X/* 	(this code goes away when Forth is running). */
strtup:
	movl	%r,utop		/* tell where our top of memory is. */
	movl	(%r),r3		/* get number of arguments */
	moval	8(%r)[r3],envir	/* save location of environment string */

X/*    Analyse command string */

	addl3	$8,%r,r2	/* get beginning of arg list */
	decl	r3
	bleq	endarg		/* quit if no arguments */

parstring:			/* interpret `argv' */
	movl	(r2)+,r0	/* get arg */
	cmpb	(r0)+,$'-	/* is it `-' flag? */
	beql	checksym	/* yes */

	decl	r0		/* back up pointer */
	movl	r0,b.nam	/* use it for default BLOCK file. */
	brb	nxtarg

checksym:
	mnegl	$1,r4		/* init counter */
1:	incl	r4
	movl	symtab[r4],r1	/* get pointer to symbol */
	bneq	2f
	brw	9f		/* if none match then trouble */
2:	cmpb	(r0),(r1)+	/* this char match? */
	bneq	1b		/* no, try next symbol. */
	tstb	(r0)+		/* if yes, is this end of strings? */
	bneq	2b		/* no, try next chars. */

	pushl	argtab[r4]
	rsb			/* execute operation. */

nxtarg:	sobgtr	r3,parstring	/* get next argument */
endarg:	jbr	endrgs		/* skip over stuff */

X/*   -w		Open block file for update */

d.w:	movl	$2,b.mod
	jbr	nxtarg

X/*   -l		Suppress automatic loading of block 3. */

d.l:	clrl	(user+blk)
	jbr	nxtarg

X/*   -buf n	Use n buffers (default 7) */

d.buf:	bsbw	cnvoct
	movl	r0,nbuf
	jbr	nxtarg

X/*   -top n	Use address n as top of memory. */

d.top:	bsbw	cnvoct
	movl	r0,utop
	movl	r0,%r		/* make stack grow down from here */
	jbr	nxtarg

X/*   -s		Disable Signal Trapping */

d.nhp:	clrl	hupp
	jbr	nxtarg

symtab:	.long	sm1,sm2,sm3,sm4,sm5,0
argtab:	.long	d.w,d.l,d.buf,d.top,d.nhp
sm1:	.asciz	"w"
sm2:	.asciz	"l"
sm3:	.asciz	"buf"
sm4:	.asciz	"top"
sm5:	.asciz	"s"

X/*   subroutine returns octal arg in r0 */

cnvoct:	decl	r3		/* dec argument count */
	beql	9f
	movl	(r2)+,r1
	clrl	r0
1:	movb	(r1)+,r4
	beql	2f		/* quit if done */
	subl2	$'0,r4
	blss	9f
	cmpb	r4,$7
	bgtr	9f		/* valid digits between 0 and 7 */
	ashl	$3,r0,r0
	addl2	r4,r0
	brb	1b
2:	rsb

1:	.ascii	"Error in Arguments!!!\n"
2:
9:
argerr:	pushl	$(2b-1b)
	pushal	1b
	pushl	$2
	moval	_write,r0
	calls	$3,(r0)
	pushl	$1
	moval	__exit,r0
	calls	$1,(r0)
endrgs:

X/*         initialize BLOCK buffers */

bfset:	movl	nbuf,r2		/* set number of buffers */
	moval	user,%u		/* set u */
	movl	darea(%u),r4	/* get disk area */
	movl	r4,(r4)
	movl	r4,4(r4)	/* init link to link to itself */
	movl	r2,bufs(r4)	/* save number of buffers */
	movl	$1,n.blktab(r4)	/* set initially 1 block file */
	movl	r4,r1
	bicl2	$3,%r		/* align stack */

1:	clrl	-(%r)		/* clr hard link pointer */
	clrl	-(%r)		/* clr backward link */
	clrl	-(%r)		/* clr forward link */
	insque	(%r),(r1)	/* insert buffer in queue */
	movl	%r,link0(r1)	/* set hard link */
	movl	%r,r1		/* save for next link */
	mnegl	$1,-(%r)	/* set location to be undefined */
	clrl	-(%r)		/* clr ownership mark */
	clrl	-(%r)		/* clr update flag and lock count */
	movl	$(BUFLEN/4),r0	/* skip over buffer */
2:	clrl	-(%r)
	sobgtr	r0,2b
	sobgtr	r2,1b

	movl	$((TBUFSIZ+3)/4),r0	/* allocate terminal buffer */
0:	clrl	-(%r)
	sobgtr	r0,0b

	movl	%r,msgbuf(%u)	/* init msg buffer address */
	movl	%r,msgbuf0(%u)	/* init msg buffer reset */

	movl	%r,rbot(%u)	/* init r stack bottom */

	movl	$(RSTKSZ/4),r0	/* allocate RSTKSZ word for r stack */
0:	clrl	-(%r)
	sobgtr	r0,0b

	movl	%r,ssbot(%u)	/* set string stack bottom */
	movl	%r,%c		/* set string stack pointer */

	movl	$(STRSTKSZ/4),r0	/* allocate STRSTKSZ for string stack */
1:	clrl	-(%r)
	sobgtr	r0,1b
	movl	%r,fsbot(%u)	/* set floating point stack bottom */

	movl	$(FSTKSZ/4),r0
2:	clrl	-(%r)
	sobgtr	r0,2b

	movl	%r,sbot(%u)	/* set s stack bottom */
	movl	%r,%s
	bicl3	$017777,%r,r0	/* to nearest byte boundary */
0:	clrl	-(%r)
	cmpl	%r,r0		/* clear stack */
	bgtru	0b
	movl	rbot(%u),%r	/* recall return stack top */

X/*          Open initial BLOCK file. */

	pushl	b.mod
	pushl	b.nam
	moval	_open,r0
	calls	$2,(r0)		/* open block file */
	tstl	r0
	bgeq	5f
	brb	1f

0:	.byte	1f-0b-1
	.ascii	"BLOCK file cannot be Opened!!!\n"
1:
	moval	0b,-(%s)
	moval	spush,r0
	jsb	(r0)
	moval	sdot,r0
	jsb	(r0)
	movl	$1,-(%s)
	moval	s_exit,r0
	jmp	(r0)
5:
	movb	r0,f.blktab(r4)		/* save file descriptor. */

X/* 	  find block number of last block. */

opnblk:	clrl	-(%s)	
	movl	$2,-(%s)
	movl	r0,-(%s)
	moval	s_seek,r0
	jsb	(r0)		/* find last block number */
	ashl	$-10,(%s)+,r0
	decl	r0
	movl	r0,e.blktab(r4)	/* place in table */

X/*   Create and Open Message File in /tmp directory */

crtfil: moval	s_getpid,r0
	jsb	(r0)			/*get process id (to make name unique)*/
	bicl3	$0xffff0000,(%s)+,r0
	cvtlp	r0,$5,msgpck		/* convert to packed decimal */
	cvtps	$5,msgpck,$6,msgpid	/* convert to decimal */

#ifdef BSD4_2
	pushl	$0600
	pushl	$03002		/* O_CREAT|O_TRUNC|O_RDWR */
	pushal	msgnam
	moval	_open,r0
	calls	$3,(r0)		/* open and create file */
	tstl	r0
	jlss	1f
#else
	pushl	$0600
	pushal	msgnam
	moval	_creat,r0
	calls	$2,(r0)		/* create file */
	tstl	r0
	jlss	1f

	pushl	r0
	moval	_close,r0
	calls	$1,(r0)

	pushl	$2
	pushal	msgnam
	moval	_open,r0
	calls	$2,(r0)		/* reopen for update */
	tstl	r0
	jlss	1f
#endif
	movl	r0,msgfil	/* save file descriptor */

	pushal	msgnam
	moval	_unlink,r0
	calls	$1,(r0)			/* make entry anonymous */
	brb	wrtmsg

0:	.byte	1f-0b-1
	.ascii	"Unable to Create Message File!!\n"
1:	moval	0b,-(%s)
	moval	spush,r0
	jsb	(r0)
	moval	sdot,r0
	jsb	(r0)
	movl	$1,-(%s)
	moval	s_exit,r0
	jmp	(r0)

wrtmsg:
	moval	msgs,-(%s)
	movl	$(e.msgs-msgs),-(%s)
	movl	msgfil,-(%s)
	moval	s_write,r0
	jsb	(r0)
	tstl	(%s)+

X/*   Get Terminal Modes */

	moval	tty,r4

	moval	s.arg(r4),-(%s)
	movl	$TIOCGETP,-(%s)
	cvtbl	rchan(r4),-(%s)
	moval	s_ioctl,r0
	jsb	(r0)
	tstl	(%s)+

	movc3	$12,s.arg(r4),is.arg(r4)

#ifdef	FPROMPT
	bisw2	$FPROMPT,(is.mode+tty)	/* make FORTH mode default */
#endif

X/*   Set Signals */

	blbc	hupp,0f
	moval	hup,r0
	jsb	(r0)
0:

X/*   Initialize Registers and invoke go-loop */

	movl	fsbot(%u),%f	/* init floating point stack */
	movl	ssbot(%u),%c	/* init string stack */
	moval	hinit,%h	/* init dictionary pointer */
	pushal	quit		/* quit after system is loaded */
	pushl	$0
	pushl	$0
	pushl	$0
	pushal	goloop
	rsb

fthblk:	.asciz	FBLK		/* default block file */

msgnam:	.ascii	"/tmp/"
msgnm0:	.ascii	"ForthMsg"	/* name of Message File */
msgpid:	.ascii	"XXXXXX"	/* cell into which pid number is placed */
	.word	0
msgpck:	.long	0

hupp:	.long	1	/* Enable/disable signal trapping */
nbuf:	.long	NBUF	/* number of buffers */

X/* arg list for block file open */
b.nam:	.long	fthblk	/* pointer to name of block */
b.mod:	.long	0	/* open mode for block file */

X/*   Initialization of Message File. */

msgs:
msg0:	.ascii	"\n"
msg1:	.ascii	" Uncompleted Control Structure!!!"
msg2:	.ascii	" ?"
msg3:	.ascii	" Stack Empty!"
msg4:	.ascii	" Dictionary Full!"
msg5:	.ascii	" Return Stack Overflow!!!"
msg6:	.ascii	" All Buffers Locked !!!"
msg7:	.ascii	" Undefined Block Number !!!"
msg8:	.ascii	" Attempt to Overflow Dictionary!!!"
msg9:	.ascii	" Attempt to FORGET below Vocab. FENCE!!!"
msg10:	.ascii	" String Stack Empty!"
msg11:	.ascii	" Bad String on String Stack!"
msg12:	.ascii	" String Stack Overflow!"
msg13:	.ascii	" Floating Point Stack Empty!"
msg14:	.ascii	" Floating Point Stack Overflow!"
msg15:	.ascii	" Ran off end of Line!"
msg16:	.ascii	" Undefined UNIX Error!!!"
msg17:	.ascii	" Uerr - Permission Violation!!!"
msg18:	.ascii	" Uerr - No Such File!!!"
msg19:	.ascii	" Uerr - No Such Process!!!"
msg20:	.ascii	" Uerr - Interrupted System Call!!!"
msg21:	.ascii	" Uerr - I/O Error!!!"
msg22:	.ascii	" Uerr - No Such Device or Out of Bounds!!!"
msg23:	.ascii	" Uerr - Argument List too Long!!!"
msg24:	.ascii	" Uerr - Unexecutable File!!!"
msg25:	.ascii	" Uerr - File Unopened or Write Protected!!!"
msg26:	.ascii	" Uerr - No Subprocesses on which to Wait!!!"
msg27:	.ascii	" Uerr - Process Table is Full!!!"
msg28:	.ascii	" Uerr - Request for too much Memory!!!"
msg29:	.ascii	" Uerr - File Permission Denied!!!"
msg30:	.ascii	" Uerr - Illegal Address passed to Driver!!!"
msg31:	.ascii	" Uerr - Block Device is Required!!!"
msg32:	.ascii	" Uerr - Device is Busy!!!"
msg33:	.ascii	" Uerr - File Already Exists!!!"
msg34:	.ascii	" Uerr - Attempt to Link to file on another Device!!!"
msg35:	.ascii	" Uerr - Innapropriate I/O!!!"
msg36:	.ascii	" Uerr - Not a Directory!!!"
msg37:	.ascii	" Uerr - Attempt to Write on a Directory!!!"
msg38:	.ascii	" Uerr - Invalid Argument in System Call!!!"
msg39:	.ascii	" Uerr - System File Table Full!!!"
msg40:	.ascii	" Uerr - Too Many Open Files!!!"
msg41:	.ascii	" Uerr - Invalid stty or gtty Call !!!"
msg42:	.ascii	" Uerr - Text File Busy!!!"
msg43:	.ascii	" Uerr - File too Large!!!"
msg44:	.ascii	" Uerr - No Space Left on Device!!!"
msg45:	.ascii	" Uerr - Seek issued on Inappropriate Device!!!"
msg46:	.ascii	" Uerr - Attempt to Write on Read/Only Device!!!"
msg47:	.ascii	" Uerr - Too Many Links to File!!!"
msg48:	.ascii	" Uerr - Write on Broken Pipe!!!"
msg49:	.ascii	" Floating Point or Arithmetic Trap!!!"
msg50:	.ascii	" Undefined Message!"
msg51:	.ascii	" Undefined Message!"
msg52:	.ascii	" Undefined Message!"
msg53:	.ascii	" Undefined Message!"
msg54:	.ascii	" Illegal Instruction!"
msg55:	.ascii	" Illegal (protected) Address!!!"
msg56:	.ascii	" Illegal (out of range) Address!!!"
msg57:	.ascii	" Bad System Call arguments!!!"
msg58:	.ascii	" Write on Broken Pipe!!!"
msg59:
e.msgs:
X.data
//go.sysin dd *
made=TRUE
if [ $made = TRUE ]; then
	/bin/chmod 644 ./vaxforth/forth3.S
	/bin/echo -n '	'; /bin/ls -ld ./vaxforth/forth3.S
fi
/bin/echo 'Extracting ./vaxforth/makefile'
sed 's/^X//' <<'//go.sysin dd *' >./vaxforth/makefile
ARGS= -DBSD4_2 # -DFPROMPT=0100000
FDIR=\"/usr/src/forth/\"
FBLK=\"/usr/src/forth/vaxforth/forth.blk\"
INSDIR=/usr/local

forth:	forth.o
	ld -o forth forth.o -lc

forth.o:	forth.i
	as -d2 -o forth.o forth.i

forth.s:	forth1.S forth2.S forth3.S
	cat forth1.S forth2.S forth3.S >forth.s

forth.i:	forth.s
	/lib/cpp -DFDIR=${FDIR} -DFBLK=${FBLK} ${ARGS} forth.s >forth.i

clean:
	rm -f forth.s forth.i forth.o forth OUT

install:	forth
	cp forth ${INSDIR}
//go.sysin dd *
made=TRUE
if [ $made = TRUE ]; then
	/bin/chmod 644 ./vaxforth/makefile
	/bin/echo -n '	'; /bin/ls -ld ./vaxforth/makefile
fi
/bin/echo 'Extracting ./vaxforth/makefile.4.1'
sed 's/^X//' <<'//go.sysin dd *' >./vaxforth/makefile.4.1
ARGS= # -DFPROMPT=0100000
FDIR=\"/usr/src/forth/\"
FBLK=\"/usr/src/forth/vaxforth/forth.blk\"
INSDIR=/usr/local

forth:	forth.o
	ld -o forth forth.o -lc

forth.o:	forth.i /usr/include/sys.s
	as -d2 -o forth.o /usr/include/sys.s forth.i

forth.i:	forth.s
	/lib/cpp -DFDIR=${FDIR} -DFBLK=${FBLK} ${ARGS} forth.s >forth.i

forth.s:	forth1.S forth2.S forth3.S
	cat forth1.S forth2.S forth3.S >forth.s

clean:
	rm -f forth.s forth.i forth.o forth OUT

install:	forth
	cp forth ${INSDIR}
//go.sysin dd *
made=TRUE
if [ $made = TRUE ]; then
	/bin/chmod 664 ./vaxforth/makefile.4.1
	/bin/echo -n '	'; /bin/ls -ld ./vaxforth/makefile.4.1
fi
made=TRUE
if [ $made = TRUE ]; then
	/bin/chmod 755 ./vaxforth
	/bin/echo -n '	'; /bin/ls -ld ./vaxforth
fi
made=TRUE
if [ $made = TRUE ]; then
	/bin/chmod 755 .
	/bin/echo -n '	'; /bin/ls -ld .
fi
exit
----Cut here. If this line isn't here something is missing-----------
-- 
Bill Sebok			Princeton University, Astrophysics
{allegra,akgua,burl,cbosgd,decvax,ihnp4,noao,princeton,vax135}!astrovax!wls