Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!uunet!husc6!hao!ames!sdcsvax!nosc!humu!uhmanoa!uhccux!lee
From: lee@uhccux.UUCP (Greg Lee)
Newsgroups: comp.sys.amiga
Subject: Re: Postscript Interpreter
Message-ID: <777@uhccux.UUCP>
Date: Fri, 4-Sep-87 14:10:16 EDT
Article-I.D.: uhccux.777
Posted: Fri Sep  4 14:10:16 1987
Date-Received: Sat, 5-Sep-87 18:47:10 EDT
References: <588@applix.UUCP>
Reply-To: {ihnp4,dcdwest,ucbvax}!sdcsvax!nosc!uhccux!lee
Organization: U. of Hawaii, Manoa (Honolulu)
Lines: 1405
Summary: Here is ps.a

I tried to mail to individuals who wanted a good copy of
this file, but can't get mail out.  As I should have noted before,
this source is for the MetaComco assembler.  To those who inquired about a
binary, I did post one several weeks ago to comp.binaries.amiga.
But I will email one to you as soon as I can find paths that work.

# This is a shell archive.  Remove anything before this line
# then unpack it by saving it in a file and typing "sh file"
# (Files unpacked will be owned by you and have default permissions).
# This archive contains the following files:
#	./ps.a
#
if `test ! -s ./ps.a`
then
echo "writing ./ps.a"
sed 's/^X//' > ./ps.a << '\Rogue\Monster\'
X*
X*	This program is in the public domain.	PostScript is a trademark
X*	of Adobe Systems.
X*		Greg Lee, July, 1987.
X*	U.S. mail: 562 Moore Hall, Dept. of Linguistics
X* INTERNET: lee@uhccux.uhcc.hawaii.edu
X* UUCP:	{ihnp4,dcdwest,ucbvax}!sdcsvax!nosc!uhccux!lee
X* BITNET:	lee%uhccux.uhcc.hawaii.edu@rutgers.edu
X*
X
X
X* link with ffpa.o
X	xref	FFPAFP
X* link with lmath.o
X	xref	lmulu
X	xref	ldivu
X	xref	ldivs
X* link with files.o
X	xref	readln
X	xref	runclose
X	xref	showreal
X	xref	show8x
X	xref	showdec
X	xref	newline
X	xref	getstr
X	xref	msg,longmsg
X	xref	ioinit
X	xref	endio
X* in control.o
X	xref	initloops
X	xref	_exec
X* in graphics.o
X	xref	initgr,endgr
X* in rmath.o
X	xref	_gsave,_grestore
X* in dict.o
X	xref	systemdict
X	xref	fdict,enddict
X	xref	.true,.false
X
X
X
X	xdef	reinterp
X
X	xdef	ihandle,ohandle
X	xdef	rastport,wbscreen
X	xdef	intuitionbase
X	xdef	graphicsbase
X	xdef	mathffpbase
X	xdef	mathtransbase
X
X
X
X
X	idnt	PS
X
X	section	one
X
X	include	"ps.h"
X
X
Xmath	macro
X	move.l	A6,-(SP)
X	move.l	mathffpbase,A6
X	jsr	_LVO\1(A6)
X	move.l	(SP)+,A6
X	endm
X
X
X	lref	Open,1
X	lref	Close,2
X	lref	Read,3
X	lref	Write,4
X	lref	Input,5
X	lref	Output,6
X	lref	DeleteFile,8
X	lref	IoErr,18
X	lref	LoadSeg,21
X	lref	UnLoadSeg,22
X	lref	IsInteractive,32
X
X	lref	SPFix,1
X	lref	SPFlt,2
X	lref	SPCmp,3
X	lref	SPTst,4
X	lref	SPAbs,5
X	lref	SPNeg,6
X	lref	SPAdd,7
X	lref	SPSub,8
X	lref	SPMul,9
X	lref	SPDiv,10
X
X
X
X_RTS		equ	%0100111001110101
X_JSR		equ	%0100111010111001	destination abs. long
X_JMP		equ	%0100111011111001	destination abs. long
X_MOVELD0	equ	%0010000000111100	source immediate long
X_MOVEVD0	equ	%0010000000111001	source abs. long
X_MOVEWD2	equ	%0011010000111100	source immediate word
X_MOVEVD2	equ	%0011010000111001	source abs. long
X
X
X
Xmain
X	move.l	SP,stacksave
X	bsr	ioinit
X	bsr	initgr
X
X
X* here on error to redo stack
Xmain1
X	bsr	_clear
X	bsr	dsclear
X
X* get more stuff to interpret
Xmain.in
X	bsr	getstr
X* (from here, A1 -> next stuff to interpret)
X
X
X* interpret next symbol
Xmain.next
X	bsr	skipsp
X	beq	main.in
X
X	pea	main.next
X	move.b	compilelevel,D3
X
X* if it's a number, push it
X	bsr	testnumber
X	beq	pushnum
X
X* name literal?
X	cmp.b	#'/',D0
X	beq	pushlit
X
X	cmp.b	#'(',D0
X	beq	pushstr
X
X	cmp.b	#'{',D0
X	beq	start_compile
X
X	cmp.b	#'}',D0
X	beq	end_compile
X
X	cmp.b	#'%',D0
X	beq	getstr
X
X* interpret a name
X	bsr	findsym
X	tst.l	D2
X	bpl	name.ok
Xsay_undefined
X	print	unknown
X	bra	reinterp
X
Xname.ok
X	move.b	compilelevel,D3
X	beq	no.dummies
X	cmp.w	#Dummy,D2
X	bne	no.dummies
X	bsr	vpush
X	lea	_exec,A0
X	move.l	A0,D0
X	bra	stowcall
X
Xno.dummies
X	cmp.w	#ICode,D2
X	bne	vpush
X
X	tst.b	D3
X	bne	stowcall
X
X	move.l	A1,-(SP)
X	move.l	D0,A0
X	jsr	(A0)
X	move.l	(SP)+,A1
X	rts
X
X* exit
Xsystem
X	bsr	endgr
X	bsr	endio
X	moveq	#0,D0
X	rts
X***********************
X
X	DEF	clear
X	lea	istacktop,A5
X	moveq	#Illegal,D0
X	move.l	D0,-(A5)
X	move.w	D0,-(A5)
X	rts
X
Xcountistack
X	moveq	#-1,D0
X	moveq	#Illegal,D2
X	move.l	A5,A0
X1$	addq.l	#1,D0
X	move.w	(A0),D1
X	addq.l	#6,A0
X	cmp.w	D1,D2
X	bne	1$
X	rts
X
X	
X	DEF	count
X	bsr	countistack
X	RETURN	Integer
X
Xindex1istack
X	bsr	popnum
X	addq.l	#1,D0
X	bgt	..ndxis
X	bra	iuflow
Xindexistack
X	bsr	popnum
X..ndxis
X	move.l	D0,D3
X	bmi	iuflow
X	bsr	countistack
X	cmp.l	D0,D3
X	bhi	iuflow
X	move.l	D3,D0
X	subq	#1,D0
X	mulu	#6,D0
X	move.l	A5,A2
X	add.l	D0,A2
X	rts
X
X	DEF	copy
X	bsr	indexistack
X	bra	2$
X1$	move.w	(A2)+,D2
X	move.l	(A2),D0
X	bsr	r.ipush
X	subq.l	#8,A2
X2$	dbra	D3,1$
X	rts
X
X	DEF	index
X	bsr	index1istack
X	move.w	(A2)+,D2
X	move.l	(A2)+,D0
X	bra	r.ipush
X
X	DEF	roll
X	bsr	popnum
X	move.l	D0,-(SP)
X	bsr	indexistack
X	move.l	(SP)+,D0
X	subq.l	#1,D3
X	bmi	2$
X	move.l	D3,D4
X1$	move.l	D4,D3
X	bsr	roll1
X	bne	1$
X2$	rts
Xroll1
X	tst.l	D0
X	beq	1$
X	bmi	rollm
X	bra	rollp
X1$	rts
X
Xrollp
X	subq.l	#1,D0
X	move.l	D0,-(SP)
X	move.l	A5,A0
X	move.l	A5,A1
X	move.w	(A0)+,-(SP)
X	move.l	(A0)+,-(SP)
X	bra	2$
X1$	move.w	(A0)+,(A1)+
X	move.l	(A0)+,(A1)+
X2$	dbra	D3,1$
X	move.l	(SP)+,D0
X	move.w	(SP)+,(A1)+
X	move.l	D0,(A1)
X	move.l	(SP)+,D0
X	rts
X
Xrollm
X	addq.l	#1,D0
X	move.l	D0,-(SP)
X	move.l	A2,A1
X	move.l	A2,A0
X	subq.l	#6,A0
X	move.w	(A2)+,-(SP)
X	move.l	(A2)+,-(SP)
X	bra	2$
X1$	move.w	(A0)+,(A1)+
X	move.l	(A0),(A1)
X	subq.l	#8,A0
X	subq.l	#8,A1
X2$	dbra	D3,1$
X	move.l	(SP)+,D0
X	move.w	(SP)+,(A1)+
X	move.l	D0,(A1)
X	move.l	(SP)+,D0
X	rts
X
Xdsclear
X	lea	dstacktop,A0
X	move.l	A0,dstack
X	moveq	#0,D0
X	move.w	D0,dstackcnt
X	lea	sstacktop,A0
X	move.l	A0,sstack
X	moveq	#0,D0
X	move.w	D0,sstackcnt
X	rts
X
X
Xstart_compile
X	addq.l	#1,A1
X	move.b	compilelevel,D0
X	move.w	D0,-(SP)
X	move.l	nextcode,A0
X	move.w	#ICode,D2
X	move.w	(SP),D0
X	tst.b	D0
X	beq	2$
X	add.l	#6+4+6+6,A0	allow for push & jmp if doing sub-proc
X2$	move.l	A0,D0
X* if doing sub-proc, this generates code to do the push
X	bsr	ipush
X	move.w	(SP),D0
X	addq.b	#1,D0
X	move.b	D0,compilelevel
X	move.w	(SP)+,D0
X	tst.b	D0
X	bne	3$
X	rts
X3$
X	move.w	#_JMP,D0
X	bsr	stowword
X	move.l	nextcode,A0
X	move.l	A0,-(SP)	where to put dest of jmp
X	moveq	#0,D0			leave room for dest of jmp
X	bsr	stowword
X	bsr	stowword
X
X	bsr	main.next		go compile the sub-procedure
X* should return to here when get matching '}'
X	move.l	(SP)+,A0	patch in dest of jmp
X	move.l	nextcode,(A0)
X	rts
X
X
Xend_compile
X	addq.l	#1,A1
X	move.b	compilelevel,D0
X	beq	2$				unmatched '}'
X	move.w	D0,-(SP)
X	move.w	#_RTS,D0
X	bsr	stowword
X	move.w	(SP)+,D0
X	subq.b	#1,D0
X	move.b	D0,compilelevel
X	beq	1$
X	addq.l	#4,SP	discard ret to main.next and ret to above
X1$	rts
X2$	print	rbrace
X	bra	reinterp
X
Xtestnumber
X	cmp.b	#'-',D0
X	beq	..endtestn
X	cmp.b	#'+',D0
X	beq	..endtestn
X	cmp.b	#'.',D0			(only if next is digit?)
X	beq	..endtestn
Xtestdig
X	cmp.b	#'0',D0			* is it a decimal digit?
X	bcs	..endtestn
X	cmp.b	#'9',D0
X	bhi	..endtestn
X	cmp.b	D0,D0
X..endtestn
X	rts
X
Xpushstr
X	addq.l	#1,A1
X	move.w	#1,parenlevel
X	move.l	farea,D0
X	btst	#0,D0
X	beq	1$
X	bsr	stowbyte
X	move.l	farea,D0
X1$
X	move.l	D0,-(SP)	place to put length
X	move.w	#String,D2
X	bsr	ipush
X
X	moveq	#0,D0
X	move.w	D0,-(SP)	count length
X	bsr	stowbyte	room for length
X	bsr	stowbyte
X
X..nextsbyte
X	addq.w	#1,(SP)
X	pea	..nextsbyte
X	move.b	(A1)+,D0
X	bne	2$
X	move.b	#10,D0
X	bsr	stowbyte
X	bra	getstr
X
X2$	cmp.b	#'(',D0
X	bne	3$
X	add.w	#1,parenlevel
X	bra	stowbyte
X
X3$	cmp.b	#')',D0
X	bne	4$
X	sub.w	#1,parenlevel
X	bne	stowbyte
X	addq.l	#4,SP	discard ret to ..nextsbyte
X
X	move.w	(SP)+,D0
X	subq.w	#1,D0	correct for ')' not stored
X	move.l	(SP)+,A0
X	move.w	D0,(A0)
X	rts
X
X4$	cmp.b	#'\',D0
X	bne	stowbyte
X	move.b	(A1)+,D0
X	beq	getstr
X	move.b	D0,D1
X
X	move.b	#10,D0
X	cmp.b	#'n',D1
X	beq	stowbyte
X
X	move.b	#13,D0
X	cmp.b	#'r',D1
X	beq	stowbyte
X
X	move.b	#9,D0
X	cmp.b	#'t',D1
X	beq	stowbyte
X
X	move.b	#8,D0
X	cmp.b	#'b',D1
X	beq	stowbyte
X
X	move.b	#12,D0
X	cmp.b	#'f',D1
X	beq	stowbyte
X
X	cmp.b	#'0',D1
X	bcs	..noct
X	cmp.b	#'7',D1
X	bhi	..noct
X	moveq	#0,D0
X	bsr	..isoct
X	bsr	..isoct
X	sub.b	#'0',D1
X	asl.b	#3,D0
X	add.b	D1,D0
X	bra	stowbyte
X
X..isoct
X	sub.b	#'0',D1
X	asl.b	#3,D0
X	add.b	D1,D0
X	move.b	(A1),D1
X	cmp.b	#'0',D1
X	bcs	1$
X	cmp.b	#'7',D1
X	bhi	1$
X	addq.l	#1,A1
X	rts
X1$	addq.l	#4,SP
X	bra	stowbyte
X
X..noct
X	move.b	D1,D0
X	cmp.b	#'\',D1
X	beq	stowbyte
X	cmp.b	#'(',D1
X	beq	stowbyte
X	cmp.b	#')',D1
X	beq	stowbyte
X	rts
X
X
Xpushlit
X	addq.l	#1,A1	past '/'
X	move.l	farea,A0	save to push
X	moveq	#0,D3		count
X	bsr	stowbyte	room for length
X1$	move.b	(A1)+,D0
X	bsr	testendchar
X	bne	2$
X	move.b	D3,(A0)
X	subq.l	#1,A1
X	move.l	A0,D0
X	move.w	#Name,D2
X	bra	ipush
X2$	bsr	stowbyte
X	addq.l	#1,D3
X	bra	1$
X
Xpushnum
X	moveq	#0,D1
X	move.l	D1,D2	neg flag
X	move.l	D1,D3	dec point flag
X	move.l	A1,A0
X	cmp.b	#'-',(A0)
X	bne	1$
X	move.b	(A1)+,D2
X1$	move.b	(A1)+,D0
X	bsr	testdig
X	bne	2$
X	sub.b	#'0',D0
X	ext.w	D0
X	ext.l	D0
X
X	move.l	D0,-(SP)
X	add.l	D1,D1
X	move.l	D1,D0
X	lsl.l	#2,D1
X	add.l	D0,D1
X	move.l	(SP)+,D0
X	add.l	D0,D1
X	bra	1$
X
X2$	tst.b	D3
X	beq	6$
X	cmp.b	#'E',D0
X	bne	realpush
X3$	move.b	(A1)+,D0
X	cmp.b	#'-',D0
X	bne	5$
X4$	move.b	(A1)+,D0
X5$	bsr	testdig
X	beq	4$
X	bra	realpush
X
X6$	cmp.b	#'E',D0
X	beq	3$
X	cmp.b	#'.',D0
X	bne	intpush
X	move.b	D0,D3
X	bra	1$
X
Xrealpush
X	subq.l	#1,A1
X	move.l	A1,-(SP)
X	jsr	FFPAFP
X	move.l	(SP)+,A1
X	bvs	1$
X	move.w	#Real,D2
X	move.l	D7,D0
X	bra	ipush
X1$	print	fperr
X	bra	reinterp
X
Xintpush
X	subq.l	#1,A1
X	move.b	D2,D3
X	move.w	#Integer,D2
X	move.l	D1,D0
X	tst.b	D3
X	beq	ipush
X	neg.l	D0
X
Xipush
X	move.b	compilelevel,D3
X	beq	r.ipush
X	bsr	stowmovel
X	bsr	stowmovew
X..iptype
X	lea	r.ipush,A0
X	move.l	A0,D0
X	bra	stowcall
X
Xvpush
X	tst.b	D3
X	beq	r.ipush
X	move.l	A2,D0	get address of value
X	addq.l	#2,D0
X	move.l	A2,-(SP)
X	bsr	stowmovev
X	move.l	(SP)+,D0	get address of type
X	bsr	stowmovevw
X	bra	..iptype
X
X	xdef	r.ipush
Xr.ipush
X*	move.l	istack,A5
X	move.l	D0,-(A5)
X	move.w	D2,-(A5)
X	cmp.l	#istackbot,A5
X	bhi	ipush.ok
X	print	overflow
Xreinterp
X	move.b	#0,compilelevel
X	bsr	initloops
X	bsr	runclose
X	move.l	stacksave,SP
X	bra	main1
X
Xipush.ok
X*	move.l	A5,istack
X	rts
X
X
X	xdef	ipop
Xipop
X	DEF	pop
X*	move.l	istack,A5
X	move.w	(A5)+,D2
X	cmp.w	#Illegal,D2
X	bne	..ippok
Xiuflow
X	print	underflow
X	bra	reinterp
X..ippok
X	move.l	(A5)+,D0
X*	move.l	A5,istack
X	rts
X
X	xdef	popnum
Xpopnum
X	bsr	ipop
X	cmp.w	#Integer,D2
X	beq	1$
X	cmp.w	#Real,D2
X	bne	type_mismatch
X	move.l	D1,-(SP)
X	math	SPFix
X	move.l	(SP)+,D1
X	move.w	#Integer,D2
X1$	rts
X
Xskipsp
X	move.b	(A1),D0
X	beq	2$
X	cmp.b	#10,D0
X	beq	1$
X	cmp.b	#' ',D0
X	bne	2$
X1$	addq.l	#1,A1
X	bra	skipsp
X2$	rts
X
Xtestendchar
X	tst.b	D0
X	beq	1$
X	cmp.b	#' ',D0
X	beq	1$
X	cmp.b	#10,D0
X	beq	1$
X	cmp.b	#'}',D0
X	beq	1$
X	cmp.b	#'{',D0
X	beq	1$
X	cmp.b	#')',D0
X	beq	1$
X	cmp.b	#'(',D0
X	beq	1$
X	cmp.b	#'/',D0
X	beq	1$
X	cmp.b	#'%',D0
X	beq	1$
X	cmp.b	#']',D0
X	beq	1$
X	cmp.b	#'[',D0
X	beq	1$
X	cmp.b	#'>',D0
X	beq	1$
X	cmp.b	#'<',D0
X1$	rts
X
X* A1 -> name to look for
X* return with A1 -> past name
X* D2 = -1 if not found, else D2 = type
X* D0 = value & A2 -> type of entry
Xfindsym
X	move.l	A1,A0
X	moveq	#0,D3
X	move.l	D3,D2
X
X1$	move.b	(A0)+,D0	get length in D3
X	bsr	testendchar
X	beq	2$
X	addq.l	#1,D3
X	bra	1$
X2$	tst.l	D3
X	bne	4$
X	cmp.b	#'[',D0
X	beq	3$
X	cmp.b	#']',D0
X	bne	.nonefound
X3$	moveq	#1,D3
X4$	bsr	allsym
X	tst.l	D2
X	bpl	5$
X	move.b	compilelevel,D1
X	bne	dummyentry
X5$	add.l	D3,A1
X	rts
X
Xallsym
X	move.w	dstackcnt,D1
X	move.l	dstack,A0
X1$	subq.w	#1,D1
X	bmi	2$
X	move.l	(A0)+,A2
X	addq.l	#2,A2
X	movem.l	A0/D1,-(SP)
X	moveq	#0,D2
X	bsr	nextsym
X	movem.l	(SP)+,A0/D1
X	tst.l	D2
X	bmi	1$
X	rts
X2$	moveq	#0,D2
X	lea	systemdict,A2
X
X* also called by dictsearch
Xnextsym
X	move.l	(A2)+,D0
X	beq	.nonefound
X	move.l	D0,A3	A3 -> name in dict
X	move.l	A1,A0	A0 -> name
X	move.l	D3,D1
X	move.w	(A2)+,D2	D2 = type
X	move.l	(A2)+,D0	D0 = value
X
X	cmp.b	(A3)+,D1	same length?
X	bne	nextsym
X
X	subq.l	#1,D1
X4$	cmp.b	(A3)+,(A0)+
X	dbne	D1,4$
X	bne	nextsym
X	subq.l	#6,A2
X	rts
X
X.nonefound
X	moveq	#-1,D2
X	rts
X
X* from above -- A1 -> name; D3 = length
Xdummyentry
X	move.l	A1,A0
X	add.l	D3,A0
X	move.l	A0,-(SP)
X	move.l	farea,A0	save for entry name
X	move.l	D3,D0
X	bsr	stowbyte	length
X	bra	2$
X1$	move.b	(A1)+,D0
X	bsr	stowbyte
X2$	dbra	D3,1$
X
X	lea	say_undefined,A1
X	move.l	A1,D0
X	move.l	#Dummy,D2
X	bsr	newentry
X	subq.l	#6,A0
X	move.l	A0,A2
X	bsr	vpush
X	lea	_exec,A0
X	move.l	#ICode,D2
X	move.l	A0,D0
X	move.l	(SP)+,A1
X	rts
X
X
X
X	DEF	begin
X	ARG	Dictionary
X	lea	dstackcnt,A0
X	cmp.w	#DstackSize,(A0)
X	beq	1$
X	addq.w	#1,(A0)
X	move.l	dstack,A0
X	move.l	D0,-(A0)
X	move.l	A0,dstack
X	rts
X1$	print	dstackov
X	bra	reinterp
X
X	DEF	end
X	lea	dstackcnt,A0
X	tst.w	(A0)
X	beq	1$
X	subq.w	#1,(A0)
X	move.l	dstack,A0
X	move.l	(A0)+,D0
X	move.l	A0,dstack
X	rts
X1$	print	dstackuv
X	bra	reinterp
X
X**********
X
X
Xstowbyte
X	move.l	farea,A2
X	move.b	D0,(A2)+
X	cmp.l	#endsarea,A2
X	bne	1$
X	print	areafull
X	bra	reinterp
X1$	move.l	A2,farea
X	rts
X
X* store instruction 'move.w <D0>,D2'
Xstowmovevw
X	move.l	D0,-(SP)
X	move.w	#_MOVEVD2,D0
X	bra	..stowi
X* store instruction 'move.w #<D2>,D2'
Xstowmovew
X	move.w	#_MOVEWD2,D0
X	bsr	stowword
X	move.w	D2,D0
X	bra	stowword
X* store instruction 'move.l <D0>,D0'
Xstowmovev
X	move.l	D0,-(SP)
X	move.w	#_MOVEVD0,D0
X	bra	..stowi
X* store instruction 'move.l #<D0>,D0'
Xstowmovel
X	move.l	D0,-(SP)
X	move.w	#_MOVELD0,D0
X	bra	..stowi
X* store instruction 'jsr <D0>'
Xstowcall
X	move.l	D0,-(SP)
X	move.w	#_JSR,D0	change to BSR?
X..stowi
X	bsr	stowword
X	move.l	(SP),D0
X	swap	D0
X	bsr	stowword
X	move.l	(SP)+,D0
X
Xstowword
X	move.l	nextcode,A2
X	move.w	D0,(A2)+
X	cmp.l	#endcode,A2
X	bls	1$
X	print	codefull
X	bra	reinterp
X1$	move.l	A2,nextcode
X	rts
X
Xstowlong
X	swap	D0
X	bsr	stowword
X	swap	D0
X	bra	stowword
X
X************************************
X
X	DEF	hex
X	bsr	ipop
X	bsr	show8x
X	move.l	A0,D0
X	RETURN	Name
X
X	DEF	quit
X	move.l	stacksave,SP
X	bsr	runclose
X	bra	system
X
X	DEF	cvs
X	ARG	String
X	move.l	D0,-(SP)
X	moveq	#-1,D0		flag this is a string conversion
X	bra	..prnt
X..cvs2
X* it better be long enough
X	move.l	(SP)+,A1
X	move.l	A1,D0
X* A0 -> name; A1 -> string
X	moveq	#0,D1
X	move.b	D1,(A1)+
X	move.b	(A0),D1
X1$	move.b	(A0)+,(A1)+
X	dbra	D1,1$
X	RETURN	String
X
X..pors
X	move.l	(SP)+,D0
X	bne	..cvs2
X	bsr	msg
X	bra	newline
X
X	DEF	print
X	ARG	String
X	move.l	D0,A0
X	moveq	#0,D3
X	move.w	(A0)+,D3
X	bra	longmsg
X
X
X	DEF	equalsprint
X	moveq	#0,D0	flag this is a print
X..prnt
X	move.l	D0,-(SP)
X	bsr	ipop
X	cmp.w	#Integer,D2
X	bne	2$
X	bsr	showdec
X	bra	..pors
X
X2$	cmp.w	#Name,D2
X	bne	3$
X	move.l	D0,A0
X	bra	..pors
X
X3$	cmp.w	#String,D2
X	bne	4$
X	move.l	D0,A0
X	move.l	(SP)+,D1
X	beq	30$
X	move.l	(SP)+,D1
X	bra	r.ipush	it's already a string -- should copy it?
X30$
X	moveq	#0,D3
X	move.w	(A0)+,D3
X	bsr	longmsg
X	bra	newline
X
X4$	cmp.w	#Boolean,D2
X	bne	6$
X	lea	.true,A0
X	tst.l	D0
X	bne	5$
X	lea	.false,A0
X5$	bra	..pors
X
X6$	cmp.w	#Real,D2
X	bne	7$
X	bsr	showreal
X	bra	..pors
X
X7$
X	lea	nsv,A0
X	bra	..pors
X
X
X	DEF	string
X	bsr	popnum
X	move.l	D0,D3
X	swap	D0
X	tst.w	D0
X	bne	2$
X
X	move.l	farea,D0
X	btst	#0,D0
X	beq	1$
X	bsr	stowbyte
X	move.l	farea,D0
X1$
X	move.l	D0,A2
X	add.l	D3,A2
X	addq.l	#2,A2
X	cmp.l	#endsarea,A2
X	bcs	3$
X2$	print	areafull
X	bra	reinterp
X3$	move.l	D0,A0
X	move.w	D3,(A0)
X	move.l	A2,farea
X	RETURN	String
X
X	DEF	dict
X	moveq	#-1,D4
X	bra	..arry
X
X	DEF	array
X	moveq	#0,D4
X..arry
X	bsr	popnum
X	move.l	nextcode,A2
X	move.l	A2,A0
X	move.w	D0,(A2)+
X	add.l	D0,D0		bytes -> words
X	move.l	D0,D1
X	add.l	D1,D0
X	add.l	D1,D0		length * 3
X	tst.l	D4
X	beq	1$
X	add.l	D1,D0
X	add.l	D1,D0		length * 5
X	addq.l	#4,D0	+1 for null at end
X	move.l	A2,A0
X	clr.w	(A2)+		current length is 0
X	clr.l	(A2)			flag end
X1$	add.l	D0,A2
X	cmp.l	#endcode,A2
X	bls	2$
X	ERR	codefull
X2$	move.l	A2,nextcode
X	move.l	A0,D0
X	tst.l	D4
X	bne	3$
X	RETURN	Array
X3$	RETURN	Dictionary
X
X	DEF	fontalloc
X	move.l	nextcode,A0
X	lea	12(A0),A2
X	cmp.l	#endcode,A2
X	bls	1$
X	ERR	codefull
X1$	move.l	A2,nextcode
X	rts
X
X
X	DEF	maxlength
X	bsr	ipop
X	move.l	D0,A0
X	subq.l	#2,A0
X	bra	..lngth
X
X	DEF	length
X	bsr	ipop
X	move.l	D0,A0
X	cmp.w	#String,D2
X	beq	..rlngth
X	cmp.w	#Array,D2
X	beq	..rlngth
X..lngth
X	cmp.w	#Dictionary,D2
X	bne	type_mismatch
X..rlngth
X	moveq	#0,D0
X	move.w	(A0),D0
X	move.w	#Integer,D2
X	bra	r.ipush
X
X
Xarrayref
X	bsr	popnum
X	move.l	D0,D1	the index
X	bsr	ipop
X	move.l	D0,A0	base of array
X	moveq	#0,D3
X	cmp.w	#Array,D2
X	beq	1$
X	cmp.w	#String,D2
X	bne	type_mismatch
X1$	move.w	(A0)+,D3
X	subq.l	#1,D3	length - 1 is max index
X	bmi	3$
X	cmp.l	D3,D1	past end?
X	bhi	3$
X	cmp.w	#Array,D2
X	beq	2$
X	add.l	D1,A0	ret not equal
X	rts
X2$	add.l	D1,D1	word reference
X	move.l	D1,D0
X	add.l	D1,D0	times 3
X	add.l	D1,D0
X	add.l	D0,A0	index to element
X	cmp.l	D0,D0
X	rts
X3$	print	arr_err
X	bra	reinterp
X
X
X	DEF	get
X	bsr	arrayref
X	bne	1$
X	move.w	(A0)+,D2	type
X	move.l	(A0),D0	value
X	bra	r.ipush
X1$	move.w	#Integer,D2
X	moveq	#0,D0
X	move.b	(A0),D0
X	bra	r.ipush
X
X	DEF	put
X	bsr	ipop
X	move.l	D0,-(SP)
X	move.w	D2,-(SP)
X	bsr	arrayref
X	bne	1$
X	move.w	(SP)+,(A0)+
X	move.l	(SP)+,(A0)
X	rts
X1$	move.w	(SP)+,D2
X	move.l	(SP)+,D0
X	cmp.w	#Integer,D2
X	bne	type_mismatch
X	move.b	D0,(A0)
X	rts
X
X	DEF	mark
X	moveq	#0,D0
X	RETURN	Mark
X
X	DEF	rbracket
X	moveq	#0,D3		count array elements
X1$	bsr	ipop
X	cmp.w	#Mark,D2
X	beq	2$
X	addq.l	#1,D3
X	move.l	D0,-(SP)
X	move.w	D2,-(SP)
X	bra	1$
X2$	move.l	nextcode,D0
X	move.w	#Array,D2
X	bsr	r.ipush
X	move.l	D3,D0
X	bsr	stowword
X	bra	4$
X
X3$	move.w	(SP)+,D0
X	bsr	stowword
X	move.l	(SP)+,D0
X	bsr	stowlong
X4$	dbra	D3,3$
X	rts
X
X
X	DEF	def
X	bsr	ipop
X	movem.l	D0/D2,-(SP)
X	ARG	Name
X	move.l	D0,A1	first check dict to see if old symbol
X	move.l	D0,-(SP)	save for name of new entry
X	bsr	alldictsearch
X	move.l	(SP)+,D0
X	tst.l	D2		found?
X	bmi	newentry1
X* replace old entry
X	movem.l	(SP)+,D0/D2
X*(perhaps change this so that when types don't match,
X* make old entry nameless and create new entry, to prevent
X* problem with previously compiled code)
X	move.w	D2,(A2)+	new type
X	move.l	D0,(A2)	new value
X	rts
X
X* called from findsym
Xnewentry
X	movem.l	D0/D2,-(SP)
X	move.l	A0,D0
X* make new entry
X* type & value on stack; D0 -> name
Xnewentry1
X	move.w	dstackcnt,D1
X	bne	4$
X	move.l	nextentry,A0
X	move.l	D0,(A0)+
X	movem.l	(SP)+,D0/D2
X	move.w	D2,(A0)+
X	move.l	D0,(A0)+
X	clr.l	(A0)
X	cmp.l	#enddict,A0
X	bhi	3$
X	move.l	A0,nextentry
X	rts
X3$	print	fulldict
X	bra	reinterp
X4$	move.l	dstack,A0
X	move.l	(A0),A0	address of dict -> current size
X	move.w	-(A0),D1	D1 = maxsize
X	addq.l	#2,A0	point at current size again
X	cmp.w	(A0),D1		if max <= current, no room
X	bls	3$
X	moveq	#0,D1		form address for new entry
X	move.w	(A0),D1
X	add.l	D1,D1		word
X	move.l	D1,D2	5 * new current size
X	add.l	D1,D1
X	add.l	D1,D1
X	add.l	D2,D1
X
X	addq.w	#1,(A0)+	new current size, & point to 1st entry
X	add.l	D1,A0		point to new entry
X	tst.l	(A0)			if not null, imp. error
X	bne	imp_error
X
X	move.l	D0,(A0)+
X	movem.l	(SP)+,D0/D2
X	move.w	D2,(A0)+
X	move.l	D0,(A0)+
X	clr.l	(A0)
X
X	rts
X
Xalldictsearch
X	move.l	dstack,A0
X	move.w	dstackcnt,D3
X1$	subq.w	#1,D3
X	bmi	3$
X	move.l	(A0)+,A2
X	addq.l	#2,A2	past current length
X	movem.l	D3/A0,-(SP)
X	bsr	dictsearch
X	movem.l	(SP)+,D3/A0
X	tst.l	D2
X*	bmi	1$	(it was a mistake to search past top dictionary)
X	rts
X3$	lea	systemdict,A2
X	xdef	dictsearch
X* A1 -> Name (bstr)
X* A2 -> dict
X* returns D2 = -1 if not found
X*	else	D2 = type
X*	D0 = value
X*	A2 -> type in entry
Xdictsearch
X	move.l	A1,-(SP)
X	moveq	#0,D3		len
X	move.l	D3,D2
X	move.b	(A1)+,D3
X	bsr	nextsym
X	move.l	(SP)+,A1
X	rts
X
X
X	DEF	exch
X	bsr	ipop
X	move.l	D0,D1
X	move.w	D2,D3
X	bsr	ipop
X	exg	D0,D1
X	exg	D2,D3
X	bsr	r.ipush
X	move.l	D1,D0
X	move.w	D3,D2
X	bra	r.ipush
X
X	DEF	dup
X	bsr	ipop
X	bsr	r.ipush
X	bra	r.ipush
X
X	DEF	true
X	moveq	#-1,D0
X	RETURN	Boolean
X
X	DEF	false
X	moveq	#0,D0
X	RETURN	Boolean
X
X	DEF	cvr
X	ARG	Integer
X	math	SPFlt
X	RETURN	Real
X
X	DEF	cvi
X	ARG	Real
X	math	SPFix
X	RETURN	Integer
X
X**************
X
X	DEF	save
X	lea	sstackcnt,A0
X	cmp.w	#SstackSize,(A0)
X	beq	1$
X	addq.w	#1,(A0)
X	move.l	sstack,A0
X	move.l	farea,-(A0)
X	move.l	nextentry,-(A0)
X	move.l	nextcode,-(A0)
X	move.l	A0,sstack
X	bsr	_gsave
X	moveq	#0,D0
X	RETURN	Save
X1$	print	sstkov
X	bra	reinterp
X
X	DEF	restore
X	ARG	Save
X	lea	sstackcnt,A0
X	tst.w	(A0)
X	beq	1$
X	subq.w	#1,(A0)
X	move.l	sstack,A0
X	move.l	(A0)+,nextcode
X	move.l	(A0)+,A1
X	clr.l	(A1)
X	move.l	A1,nextentry
X	move.l	(A0)+,farea
X	bra	_grestore
X1$	print	sstkuv
X	bra	reinterp
X
X
X****************
X
Ximp_error
X	print	imperr
X	bra	reinterp
X
X	xdef	type_mismatch
Xtype_mismatch
X	print	mismatch
X	bra	reinterp
X
X*****************************
X	section	three,bss
X
Xstacksave	ds.l	1
X
Xgraphicsbase	ds.l	1
Xintuitionbase	ds.l  1
Xmathffpbase	ds.l	1
Xmathtransbase	ds.l  1
X
Xwbscreen	ds.l	1
Xrastport	ds.l	1
X
Xohandle	ds.l	1
Xihandle	ds.l	1
X
X
Xcodearea	ds.w	CodeSize
Xendcode	ds.w	4
X
Xistack	ds.l	1
X		ds.b	12
Xistackbot	ds.b	6*IstackSize
Xistacktop	ds.l	1
X
Xdstackcnt	ds.w	1
Xdstack		ds.l	1
X		ds.b	8
Xdstackbot	ds.b	4*DstackSize
Xdstacktop	ds.l	1
X
X
Xsstackcnt	ds.w	1
Xsstack		ds.l	1
X		ds.b	12
Xsstackbot	ds.b	12*SstackSize
Xsstacktop	ds.l	1
X
Xfsarea		ds.b	SAreaSize
Xendsarea	ds.b	2
X
X	section two,data
X
Xfarea		dc.l	fsarea
Xnextentry	dc.l	fdict
Xnextcode	dc.l	codearea
Xcompilelevel	dc.w	0
Xparenlevel	dc.w	0
X
X
X	bstr	underflow,<stack underflow>
X	bstr	overflow,<stack overflow>
X	bstr	areafull,<string area is full>
X	bstr	mismatch,<type mismatch>
X	bstr	nsv,<--nostringval-->
X	bstr	fulldict,<dictionary is full>
X	bstr	codefull,<code area is full>
X	bstr	unknown,<unknown symbol>
X	bstr	rbrace,<unmatched right brace>
X	bstr	fperr,<floating point error>
X	bstr	arr_err,<bad array reference>
X	bstr	dstackov,<dict stack overflow>
X	bstr	dstackuv,<dict stack underflow>
X	bstr	imperr,<implementation error>
X	bstr	sstkov,<save stack overflow>
X	bstr	sstkuv,<save stack underflow>
X
X	end
X
\Rogue\Monster\
else
  echo "will not over write ./ps.a"
fi
if [ `wc -c ./ps.a | awk '{printf $1}'` -ne 19579 ]
then
echo `wc -c ./ps.a | awk '{print "Got " $1 ", Expected " 19579}'`
fi
echo "Finished archive 1 of 1"
# if you want to concatenate archives, remove anything after this line
exit