rminnich@udel.UUCP (08/31/87)
Sorry to hit the net with this but i cannot mail to the author- my mailer is unhelpful. The PostScript interpreter recently posted is missing the include file 'ps.h'. Anybody got this and can mail it to me? Thanks, ron -- Ron Minnich
lee@uhccux.UUCP (09/01/87)
Sorry I forgot to include ps.h. Here it is. I don't know how to reach me
on the net, but one of these might work:
* UUCP: {ihnp4,seismo,ucbvax,dcdwest}!sdcsvax!nosc!uhccux!lee
* ARPA: uhccux!lee@nosc.MIL
File ps.h follows:
* header for ps modules
lref macro
_LVO\1 equ -6*(\2+4)
endm
call macro
jsr _LVO\1(A6)
endm
print macro
lea \1,A0
bsr msg
endm
ERR macro
lea \1,A0
bsr msg
bra reinterp
endm
DEF macro
xdef _\1
_\1
endm
ARG macro
cmp.w #\1,(A5)+
bne type_mismatch
move.l (A5)+,D0
endm
RETURN macro
move.w #\1,D2
bra r.ipush
endm
bstr macro
\1 dc.b 1$-*-1
dc.b '\2',10
1$
endm
cnttype set -1
newtype macro
\1 equ cnttype
cnttype set cnttype+1
endm
newtype Illegal
newtype ICode
newtype Integer
newtype Name
newtype String
newtype Boolean
newtype Real
newtype FontID
newtype Array
newtype Mark
newtype Dictionary
newtype Save
newtype Dummy
newtype File
PointFive equ $80000040
OnePoint equ $80000041
ThreePoint equ $C0000042
FourPoint equ $80000043
HiRes equ 1
NumColors equ 16
InterAct equ 1
NumPlanes equ 4
PstackSize equ 20
IstackSize equ 100
DstackSize equ 20
SstackSize equ 10
SAreaSize equ 3000
SizeDict equ 100
CodeSize equ 5000scott@applix.UUCP (Scott Evernden) (09/04/87)
The recent source of the "ps" PostScript Interpreter, recently posted, seems to be missing the 0s, 1s, and 5s in file "ps.a". So far, it's been quite a puzzle, but I give up. Did anyone receive this file properly? - scott
lee@uhccux.UUCP (Greg Lee) (09/04/87)
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
exitdillon@CORY.BERKELEY.EDU.UUCP (09/06/87)
>The recent source of the "ps" PostScript Interpreter, recently >posted, seems to be missing the 0s, 1s, and 5s in file "ps.a". Same here. I gave up assembling it. Otherwise, It looks like quite an accomplishment being completely written in assembly. -Matt