lee@uhccux.UUCP (Greg Lee) (08/28/87)
# 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:
# ./gothic-g
# ./graphics.a
# ./letters
# ./lmath.a
# ./palette
# ./prg
# ./ps.a
#
if `test ! -s ./gothic-g`
then
echo "writing ./gothic-g"
sed 's/^X//' > ./gothic-g << '\Rogue\Monster\'
X
X2 pencolor
Xsave
X/gg {
X -5 3 moveto -5 -6 lineto -7 -7 lineto -6 -7 lineto
X -4 -8 lineto -3 -9 lineto -2 -8 lineto 0 -7 lineto
X 3 -6 lineto
X
X -4 2 moveto -4 -7 lineto -2 -8 lineto
X
X -3 3 moveto -3 -6 lineto -1 -7 lineto 0 -7 lineto
X
X -5 3 moveto -3 3 lineto 0 4 lineto 2 5 lineto 3 4 lineto
X 5 3 lineto 7 3 lineto 5 2 lineto 5 -10 lineto
X 4 -13 lineto 2 -15 lineto 0 -16 lineto -1 -15 lineto
X -3 -14 lineto -5 -14 lineto
X
X 1 4 moveto 4 2 lineto 4 -10 lineto
X
X 1 -15 moveto -1 -14 lineto -2 -14 lineto
X
X 0 4 moveto 1 3 lineto 3 2 lineto 3 -8 lineto
X 4 -11 lineto 4 -13 lineto
X
X 2 -15 moveto 1 -14 lineto -1 -13 lineto -3 -13 lineto
X -5 -14 lineto
X
X } def
X
X50 180 translate
X
X gg stroke
X
X10 {
X 50 0 translate 1.2 1.2 scale gg stroke
X } repeat
X
Xrestore
X
\Rogue\Monster\
else
echo "will not over write ./gothic-g"
fi
if [ `wc -c ./gothic-g | awk '{printf $1}'` -ne 786 ]
then
echo `wc -c ./gothic-g | awk '{print "Got " $1 ", Expected " 786}'`
fi
if `test ! -s ./graphics.a`
then
echo "writing ./graphics.a"
sed 's/^X//' > ./graphics.a << '\Rogue\Monster\'
X
X xref graphicsbase
X xref rastport
X xref viewport
X xref type_mismatch
X xref msg
X xref reinterp
X
X xref ipop
X xref r.ipush
X xref popnum
X xref dictsearch
X
X xref popxy,poprxy
X xref _showg,_scaleg,_lengthg
X xref xadvance
X
X xref checklwidth,xywidth
X
X section one
X
X include "ps.h"
X
X
X lref ClearScreen,4
X lref TextLength,5
X lref Text,6
X lref SetFont,7
X lref OpenFont,8
X lref CloseFont,9
X lref Move,36
X lref Draw,37
X lref AreaMove,38
X lref AreaDraw,39
X lref AreaEnd,40
X lref InitArea,43
X lref SetRGB4,44
X lref RectFill,47
X lref WritePixel,50
X lref Flood,51
X lref SetAPen,53
X lref SetBPen,54
X lref SetDrMd,55
X lref InitTmpRas,74
X lref AllocRaster,78
X lref FreeRaster,79
X lref GetRGB4,93
X
X
Xgraphics macro
X move.l A6,-(SP)
X move.l graphicsbase,A6
X move.l rastport,A1
X jsr _LVO\1(A6)
X move.l (SP)+,A6
X endm
X
Xgraph macro
X move.l A6,-(SP)
X move.l graphicsbase,A6
X jsr _LVO\1(A6)
X move.l (SP)+,A6
X endm
X
X
X
X xref mathffpbase
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
Xmathb macro
X move.l mathffpbase,A6
X endm
X
Xmaths macro
X jsr _LVO\1(A6)
X endm
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
XAreaSize equ 500
X
XPenMask equ NumColors-1
X ifne HiRes
XMaxY equ 399
X endc
X ifeq HiRes
XMaxY equ 199
X endc
X
X*************************
X
X xdef initgr
Xinitgr
X move.l rastport,A1
X
X move.l #640,D0
X move.l #MaxY+1,D1
X move.l A1,-(SP)
X graph AllocRaster
X move.l D0,rasterpt
X
X move.l (SP),A1
X lea tmpras,A0
X move.l A0,$0C(A1)
X move.l D0,A1
X move.l #640*(MaxY+1),D0
X graph InitTmpRas
X
X move.l (SP)+,A1
X lea areasptrn,A0
X move.l A0,$08(A1)
X move.b #2,$1D(A1) 4 words
X
X lea areainfo,A0
X move.l A0,$10(A1)
X lea areabuffer,A1
X move.l #AreaSize,D0
X graph InitArea
X
X lea pstacktop,A0
X move.l A0,pstack
X clr.w pstackcnt
X clr.w (A0)+
X lea pathbuffer,A1
X move.l A1,(A0)
X clr.w pointcnt
X move.l A1,nextpoint
X
X moveq #1,D0
X graphics SetAPen
X moveq #0,D0
X graphics SetBPen
X moveq #1,D0
X graphics SetDrMd
X
X rts
X
X
X xdef endgr
Xendgr
X move.l rasterpt,A0
X move.l #640,D0
X move.l #MaxY+1,D1
X graphics FreeRaster
X move.l rastport,A1
X clr.l $08(A1)
X clr.l $0C(A1)
X clr.l $10(A1)
X rts
X
Xrasterpt dc.l 0
X
X
X
X DEF stringwidth
X move.b resfontflag,D0
X bne _lengthg
X ARG String
X move.l D0,A0
X moveq #0,D0
X move.w (A0)+,D0
X graphics TextLength
X math SPFlt dx
X move.w #Real,D2
X bsr r.ipush
X moveq #0,D0 dy = 0
X bra r.ipush
X
X
X DEF show
X ARG String
X move.l D0,-(SP)
X bsr movehere
X move.l (SP)+,D0
X
X move.l D0,A0
X move.b resfontflag,D0
X bne showresfont
X
X movem.l currdevpoint,D0/D1
X graphics Move
X
X move.l rastport,A1
X move.w $24(A1),-(SP)
X moveq #0,D0
X move.w (A0)+,D0
X graphics Text
X move.l rastport,A1
X moveq #0,D0
X move.w $24(A1),D0
X move.w (SP)+,D1
X sub.w D1,D0
X bsr xadvance
X movem.l D0-D3,bpath
X movem.l D0-D3,currdevpoint
X rts
X
Xshowresfont
X move.l A0,D0
X move.w #String,D2
X bsr r.ipush
X bra _showg
X
Xnewpoint
X moveq #0,D4
X move.w #MaxY,D4
X cmp.l D4,D1
X ble 1$
X move.l D4,D1
X1$ tst.l D1
X bpl 2$
X clr.l D1
X2$ move.w #639,D4
X cmp.l D4,D0
X ble 3$
X move.l D4,D0
X3$ tst.l D0
X bpl 4$
X clr.l D0
X4$ rts
X
X DEF newpath
X move.l pstack,A0
X move.w (A0)+,pointcnt
X move.l (A0),nextpoint
X move.b #0,strokepathflag
X rts
X
X xdef ggsave
Xggsave
X lea pstackcnt,A0
X cmp.w #PstackSize,(A0)
X beq 1$
X addq.w #1,(A0)
X move.l pstack,A0
X move.l currfont,-(A0)
X move.l graylevel,-(A0)
X move.l linecap,-(A0)
X move.l nextpoint,-(A0) must be pushed next last
X move.w pointcnt,-(A0) must be pushed last
X move.l A0,pstack
X rts
X1$ ERR psov
X
X xdef ggrestore
Xggrestore
X lea pstackcnt,A0
X tst.w (A0)
X beq 1$
X subq.w #1,(A0)
X move.l pstack,A0
X move.w (A0)+,pointcnt
X move.l (A0)+,nextpoint
X move.l (A0)+,linecap
X move.l (A0)+,D0
X move.l (A0)+,currfont
X move.l A0,pstack
X bsr resetgray
X move.l currfont,D0
X bra resetfont
X1$ ERR psuv
X
X
X
Xc_moveto equ 1
Xc_lineto equ 2
Xc_closepath equ 3
X
Xappendpoint
X lea pointcnt,A0
X cmp.w #AreaSize,(A0)
X beq pointprob
X addq.w #1,(A0)
X move.l nextpoint,A0
X move.w D0,(A0)+
X move.l D2,(A0)+
X move.l D3,(A0)+
X move.l A0,nextpoint
X rts
Xpointprob
X ERR pntsov
X
X DEF rmoveto
X bsr poprxy
X bra ymoveto
X
X DEF moveto
X bsr popxy
X xdef ymoveto
Xymoveto
X movem.l D0-D3,bpath
X movem.l D0-D3,currdevpoint
X moveq #c_moveto,D0
X bra appendpoint
X
Xmovehere
X movem.l currdevpoint,D0-D3
X
X xdef xmoveto
Xxmoveto
X bsr newpoint
X movem.l D0-D3,bpath
X movem.l D0-D3,currdevpoint
X graphics Move
X rts
X
X DEF rlineto
X bsr poprxy
X bra ylineto
X
X
X DEF lineto
X bsr popxy
X xdef ylineto
Xylineto
X tst.w pointcnt
X bne 1$
X movem.l D0-D3,-(SP)
X movem.l currdevpoint,D0-D3
X bsr ymoveto
X movem.l (SP)+,D0-D3
X1$
X movem.l D0-D3,currdevpoint
X moveq #c_lineto,D0
X bra appendpoint
X
X xdef xclosepath
Xxclosepath
X movem.l bpath,D0-D3
X movem.l D0-D3,currdevpoint
X
X xdef xlineto
Xxlineto
X bsr arlineto
X beq xxlineto
X rts
Xxxlineto
X bsr newpoint
X graphics Draw
X rts
X
X DEF closepath
X movem.l bpath,D0-D3
X movem.l D0-D3,currdevpoint
X moveq #c_closepath,D0
X bra appendpoint
X
X
X DEF pixel
X* graphics WritePixel
X* rts
X bsr movehere
X move.l rastport,A1
X move.l 4(A1),A0 A0 -> bitmap
X move.w $26(A1),D1 D1 = cp_y
X mulu (A0),D1 cp_y * bytes per row
X moveq #0,D0
X move.w $24(A1),D0 cp_x
X move.l D0,D2
X lsr.l #3,D0 byte offset for x
X add.l D0,D1 byte address of pixel
X and.l #7,D2 bit offset
X moveq #7,D0
X sub D2,D0
X move.b $19(A1),D3 pen color
X
X move.l 8(A0),A1 base address of first screen
X btst #0,D3
X beq 1$
X bsr 2$
X1$ move.l 12(A0),A1 base address of second screen
X btst #1,D3
X beq 3$
X2$ add.l D1,A1
X bset D0,(A1)
X3$ rts
X
X**debug
X ifd DEBUG2
XpushA0
X movem.l D0-D7/A1-A6,-(SP)
X move.l A0,D0
X move.w #Integer,D2
X bsr r.ipush
X movem.l (SP)+,D0-D7/A1-A6
X rts
X endc
X
Xxpixel
X**debug
X ifd DEBUG2
X move.l D0,A0
X bsr pushA0
X move.l D1,A0
X bsr pushA0
X move.l D2,A0
X bsr pushA0
X endc
X
X tst.b D2
X beq 3$
X tst.l D1
X bmi 3$
X tst.l D0
X bmi 3$
X cmp.l #639,D0
X bhi 3$
X cmp.l #MaxY,D1
X bhi 3$
X
X mulu (A5),D1 cp_y * bytes per row
X move.l D2,A1 save pencolor
X move.l D0,D2
X lsr.l #3,D0 byte offset for x
X add.l D0,D1 byte address of pixel
X and.l #7,D2 bit offset
X moveq #7,D0
X sub D2,D0
X move.l A1,D2 pen color
X
X move.l 8(A5),A1 base address of first screen
X btst #0,D2
X beq 1$
X bsr 2$
X1$ move.l 12(A5),A1 base address of second screen
X btst #1,D2
X
X ifne HiRes
X beq 10$
X bsr 2$
X10$
X move.l 16(A5),A1
X btst #2,D2
X endc
X
X beq 3$
X2$ add.l D1,A1
X bset D0,(A1)
X3$ rts
X
X
X
Xarlineto
X movem.l oldx,A0/A1 starting real coord
X movem.l D2/D3,oldx ending real coord - save for next time
X tst.l vint
X beq 900$ 0 vint means use Amiga line drawer
X* now draw antirasterized line from (A0,A1) to (D2,D3)
X* (y-axis is still inverted)
X movem.l D5-D7/A2-A6,-(SP)
X* D2,D3,A0,A1,A6
X move.l A0,D4
X move.l A1,D5
X* update cp
X graphics Move
X* set A6 for short math calls
X mathb
X
X* D2(ex),D3(ey),D4(sx),D5(sy),A6(mbase)
X
X move.l D5,D0
X move.l D3,D1
X maths SPCmp
X bcs 4$
X exg D2,D4
X exg D3,D5
X4$
X
X move.l D2,D0
X move.l D4,D1
X maths SPSub ex - sx
X move.l D0,D6
X
X move.l D3,D0
X move.l D5,D1
X maths SPSub ey - sy
X move.l D0,D7
X
X* D2(ex),D3(ey),D4(sx),D5(sy),D6(dx),D7(dy)
X
X* move.l D7,D0
X and.b #$7F,D0
X move.l D6,D1
X and.b #$7F,D1
X maths SPCmp if abs(dy) >= abs(dx), exchange
X bcs 10$
X exg D2,D3
X exg D4,D5
X exg D6,D7
X moveq #-1,D3 set exchange flag
X bra 11$
X10$
X moveq #0,D3
X11$
X
X move.l D4,D0
X move.l #PointFive,D1
X maths SPAdd
X maths SPFix
X move.l D0,A2 A2 = rx = round(sx)
X* D2(ex),D3(flag),D4(sx),D5(sy),D6(dx),D7(dy)
X* A2(rx),A4(abs dx)
X
X
X
X* move.l A2,D0 count = trunc(abs(ex - rx)) + 1
X maths SPFlt
X move.l D0,D1
X move.l D2,D0
X maths SPSub ex - flt(rx)
X and.b #$7F,D0
X* round not in original
X move.l #PointFive,D1
X maths SPAdd
X maths SPFix
X addq.l #1,D0
X move.l D0,A4
X
X move.l D3,D2 move flag
X
X move.l D7,D0
X move.l D6,D1
X beq 800$
X maths SPDiv
X move.l D0,A5 A5 = slope = (ey - sy)/(ex - sx)
X* D2(flag),D3(n.u.),D4(sx),D5(sy),D6(dx),D7(dy),A2(rx),A4(cnt),A5(slope),A6
X
X move.l A2,D0
X maths SPFlt
X move.l D4,D1
X maths SPSub rx - sx
X move.l A5,D1
X maths SPMul times slope
X* abs ??
X move.l D5,D1
X maths SPAdd plus sy
X move.l D0,D3 D3 = aux
X
X* round ??
X maths SPFix
X move.l D0,A3 A3 = ry
X
X move.l A5,D0
X and.b #$7F,D0
X move.l vint,D5
X move.l D5,D1
X maths SPMul
X move.l D0,D4 D4 = dint = abs(slope) * vint
X* D2(flag),D3(aux),D4(dint),D5(vint),D6(dx),D7(dy)
X* A2(rx),A3(ry),A4(cnt),A5(n.u.),A6
X
X move.l A3,D0
X maths SPFlt
X move.l D0,D1
X move.l D3,D0
X maths SPSub aux - ry
X move.l D5,D1
X maths SPMul times vint
X move.l D0,D3 D3 = lint
X* D2(flag),D3(lint),D4(dint),D5(vint),D6(dx),D7(dy)
X* A2(rx),A3(ry),A4(cnt),A5(n.u.),A6
X
X tst.w D2
X bpl 20$
X exg A2,A3
X exg D6,D7
X20$
X
X move.l D6,D1 dx -> +-1
X moveq #0,D0
X maths SPCmp
X bne 22$
X moveq #1,D0
X22$
X move.l D0,D6
X
X* move.l D7,D0 dy -> -+1
X* moveq #0,D1
X* maths SPCmp
X* bne 24$
X* moveq #-1,D0
X*24$
X* move.l D0,D7
X
X move.l rastport,A0
X move.l 4(A0),A5 bitmap
X
X move.l #MaxY,D0 uninvert y-axis
X move.l A3,D1
X sub.l D1,D0
X move.l D0,A3
X
X
X* D0 (pass x)
X* D1 (pass y)
X* D2 flag dy > dx and pass pencolor
X* D3 lint
X* D4 dint
X* D5 vint
X* D6 sign dx
X*** D7 sign dy (n.u. now)
X* A0
X* A1 (temp)
X* A2 rx
X* A3 ry
X* A4 cnt
X* A5 bitmap
X* A6 mathffpbase
X
X**debug
X ifd DEBUG1
X move.l A4,SAVECNT
X move.l A2,SAVERX
X move.l A3,SAVERY
X move.l D6,SAVESDX
X move.l D7,SAVESDY
X move.l D3,SAVELINT
X move.l D4,SAVEDINT
X endc
X
X100$
X subq.l #1,A4
X move.l A4,D0
X bmi 800$
X
X swap D2 save exchange flag
X
X move.l D5,D0
X move.l D3,D1
X maths SPSub vint - lint
X bsr pixreg
X
X bsr xpixel pixel(rx,ry,rint)
X
X move.l D3,D0
X bsr pixreg
X
X swap D2
X tst.w D2
X bpl 110$
X add.l D6,D0 lx = rx + 1
X bra 111$
X110$
X* add.l D7,D1 ly = ry + 1
X subq.l #1,D1
X111$
X swap D2
X
X bsr xpixel pixel(lx,ly,lint)
X
X swap D2
X
X move.l D3,D0
X move.l D4,D1
X maths SPAdd
X move.l D0,D3 lint = lint + dint
X
X move.l D5,D1
X maths SPCmp
X bcs 200$ not if lint < vint
X
X tst.w D2
X bmi 120$
X* add.l D7,A3 ry = ry + sign(dy)
X subq.l #1,A3
X bra 130$
X120$
X add.l D6,A2 rx = rx + sign(dx)
X130$
X
X
X move.l D3,D0
X move.l D5,D1
X maths SPSub
X move.l D0,D3 lint = lint - vint
X
X200$
X tst.w D2
X bmi 220$
X add.l D6,A2 rx = rx + 1
X bra 100$
X220$
X* add.l D7,A3
X subq.l #1,A3
X bra 100$
X
X
X800$
X movem.l (SP)+,D5-D7/A2-A6
X
X**debug
X ifd DEBUG1
X move.w #Integer,D2
X move.l SAVECNT,D0
X bsr r.ipush
X move.l SAVERX,D0
X bsr r.ipush
X move.l SAVERY,D0
X bsr r.ipush
X move.l SAVESDX,D0
X bsr r.ipush
X move.l SAVESDY,D0
X bsr r.ipush
X move.w #Real,D2
X move.l SAVELINT,D0
X bsr r.ipush
X move.l SAVEDINT,D0
X bsr r.ipush
X endc
X
X moveq #1,D0 signal line is drawn
X900$
X rts
X
X**debug
X ifd DEBUG1
XSAVECNT dc.l 0
XSAVERX dc.l 0
XSAVERY dc.l 0
XSAVESDX dc.l 0
XSAVESDY dc.l 0
XSAVELINT dc.l 0
XSAVEDINT dc.l 0
X endc
X
Xpixreg
X move.l #FourPoint,D1
X maths SPMul
X maths SPFix
X cmp.b #4,D0
X bne 2$
X moveq #3,D0
X2$ move.w D0,D2
X move.l A2,D0
X move.l A3,D1
X* tst.l D7
X* bmi 1$
X* addq.l #1,D1
X1$ rts
X
X
X DEF greyline
X bsr pop01
X move.l D0,vint
X rts
X
Xpop01
X bsr ipop
X move.l #OnePoint,D1
X cmp.w #Real,D2
X beq 1$
X cmp.w #Integer,D2
X bne type_mismatch
X tst.l D0
X beq 2$
X subq.l #1,D0
X bne range01
X move.l D1,D0
X1$ tst.b D0
X bmi range01
X move.l D0,D2
X math SPCmp
X bgt range01
X move.l D2,D0
X2$ rts
X
Xrange01
X ERR out01
X
Xvint dc.l 0
Xbpath dc.l 0,0
Xoldx dc.l 0,0
Xcurrdevpoint dc.l 0,0,0,0
X
X DEF currentgray
X move.l graylevel,D0
X RETURN Real
X
X
X DEF setgray
X bsr pop01
Xresetgray
X move.l D0,graylevel
X lea areasptrn,A0
X tst.l D0
X beq 2$
X move.l #FourPoint,D1
X math SPMul
X math SPFix
X moveq #3,D1
X cmp.l D1,D0
X bls 1$
X move.l D1,D0
X1$ add.l D0,D0
X add.l D0,D0
X add.l D0,D0
X lea areaptrn,A0
X add.l D0,A0
X2$ move.l rastport,A1
X move.l A0,8(A1)
X rts
X
X
X DEF flood
X bsr popxy
X bsr newpoint
X moveq #0,D2
X move.l rastport,A1
X move.b $19(A1),$1B(A1)
X graphics Flood
X rts
X
X DEF fill
X lea strokepathflag,A0
X move.b (A0),D0
X move.b #0,(A0)
X tst.b D0
X bne _stroke
X moveq #-1,D0
X bra ..strk
X
X DEF strokepath
X move.b #1,strokepathflag
X rts
X
X DEF stroke
X moveq #0,D0
X bsr checklwidth does line have width?
X..strk
X movem.l D5-D7/A2-A4,-(SP)
X move.l D0,D7
X
X moveq #-1,D0
X move.l D0,buttremember
X move.l D0,ibuttremember
X move.l D0,buttbegin
X move.l D0,ibuttbegin
X move.l D0,a_linecap
X
X move.l pstack,A0
X move.w (A0)+,D0 pointcount at last newpath
X move.l (A0),A2 nextpoint at last newpath
X
X move.w pointcnt,D5
X sub.w D0,D5
X* lea pathbuffer,A2
X
X1$ subq.w #1,D5
X bmi 100$
X move.w (A2)+,D6
X move.l (A2)+,D2
X move.l D2,D0
X math SPFix
X move.l D0,A3
X
X move.l (A2)+,D3
X move.l D3,D0
X math SPFix
X move.l #MaxY,D1
X sub.l D0,D1
X move.l A3,D0
X
X tst.l D7
X bmi 4$
X bne 6$
X cmp.b #c_moveto,D6
X bne 2$
X bsr xmoveto
X bra 1$
X2$
X* cmp.b #c_lineto,D6
X* bne 1$
X bsr xlineto
X3$ bra 1$
X
X4$ cmp.b #c_moveto,D6
X bne 5$
X graphics AreaMove
X bra 1$
X5$
X* cmp.b #c_lineto,D6
X* bne 1$
X graphics AreaDraw
X bra 1$
X
X6$ cmp.b #c_moveto,D6
X bne 7$
X movem.l D0-D3,arsource
X
X* put caps on ends of last subpath
X bsr dolinecaps
X
X moveq #-1,D0
X move.l D0,buttremember
X move.l D0,ibuttremember
X move.l D0,buttbegin
X move.l D0,ibuttbegin
X move.l D0,a_linecap
X bra 1$
X
X* draw thick stroke by filling
X7$
X* cmp.b #c_lineto,D6
X* bne 1$
X lea ardest,A4
X movem.l D0-D3,(A4)
X lea arsource,A3
X
X* sub.l (A3),D0
X* bpl 71$
X* neg.l D0
X*71$
X* sub.l 4(A3),D1
X* bpl 72$
X* neg.l D1
X*72$
X* add.l D1,D0
X* cmp.l #4,D0
X* blt 1$
X
X* rmath routine calculates sides of right triangle whose
X* hypotenuse is perpendicular to this stroke and is
X* 1/2 linewidth in length -- returns x-side in D2, y-side in D3
X* also y in D0, x in D1 in device coordinates for x and y axes, resp.
X bsr xywidth
X movem.l D0/D1,deltayx
X movem.l buttremember,D0/D1
X tst.l D0
X bpl 8$
X* 1st corner at beginning of subpath
X movem.l (A3),D0/D1
X
X lea a_linecap,A0
X movem.l D0-D3,(A0)
X movem.l deltayx,D0/D1
X movem.l D0/D1,16(A0)
X movem.l (A0),D0/D1
X
X sub.l D2,D0
X sub.l D3,D1
X movem.l D0/D1,buttbegin
X8$ movem.l D0/D1,-(SP) save to close rectangle at end
X bsr qamove
X
X move.l buttremember,D0
X bmi 9$
X* connect 2nd corner of last stroke to 1st corner of this one
X movem.l (A3),D0/D1
X sub.l D2,D0
X sub.l D3,D1
X bsr qadraw
X
X9$
X* 2nd corner
X movem.l (A4),D0/D1
X
X lea b_linecap,A0
X movem.l D0-D3,(A0)
X movem.l deltayx,D0/D1
X movem.l D0/D1,16(A0)
X movem.l (A0),D0/D1
X
X sub.l D2,D0
X sub.l D3,D1
X movem.l D0/D1,buttremember
X bsr qadraw
X
X cmp.b #c_closepath,D6
X bne 10$
X* signal don't do linecaps
X moveq #-1,D0
X move.l D0,a_linecap
X
X* connect 2nd corner to 1st corner of stroke at
X* beginning of subpath
X movem.l buttbegin,D0/D1
X tst.l D0
X bmi 10$
X bsr qadraw
X movem.l ibuttbegin,D0/D1
X tst.l D0
X bmi 10$
X bsr qadraw
X
X10$
X* 3rd corner
X movem.l ibuttremember,D0/D1
X movem.l D0/D1,-(SP)
X
X movem.l (A4),D0/D1
X add.l D2,D0
X add.l D3,D1
X movem.l D0/D1,ibuttremember
X* may want move here instead of interior line
X bsr qadraw
X
X* 4th corner
X movem.l (A3),D0/D1
X add.l D2,D0
X add.l D3,D1
X lea ibuttbegin,A0
X tst.l (A0)
X bpl 11$
X movem.l D0/D1,(A0)
X11$
X bsr qadraw
X
X* connect 4th corner to 3rd corner of last stroke
X movem.l (SP)+,D0/D1
X tst.l D0
X bmi 12$
X bsr qadraw
X
X12$
X* close rectangle
X movem.l (SP)+,D0/D1
X bsr qadraw
X
X* fill it
X bsr qaend
X
X movem.l (A4),D0-D3 this destination will be next source
X movem.l D0-D3,(A3)
X bra 1$
X
X
X100$
X bsr dolinecaps
X move.l D7,D0
X movem.l (SP)+,D5-D7/A2-A4
X tst.l D0
X bpl _newpath
X graphics AreaEnd
X bra _newpath
X
X
Xqamove
X tst.b strokepathflag
X bne 1$
X move.l D2,D4
X or.l D3,D4
X beq 1$
X graphics AreaMove
X tst.l D0
X bmi pointprob
X rts
X1$ movem.l D2/D3,-(SP)
X bsr xmoveto
X movem.l (SP)+,D2/D3
X rts
X
Xqadraw
X move.l D2,D4
X or.l D3,D4
X beq 1$
X tst.b strokepathflag
X bne ..qnd
X graphics AreaDraw
X tst.l D0
X bmi pointprob
X1$ rts
X..qnd
X movem.l D2/D3,-(SP)
X bsr xxlineto
X movem.l (SP)+,D2/D3
X rts
X
Xqaend
X move.l D2,D4
X or.l D3,D4
X beq ..qnd
X tst.b strokepathflag
X bne 1$
X graphics AreaEnd
X1$ rts
X
X
Xdolinecaps
X movem.l D5/D6,-(SP)
X lea a_linecap,A3
X tst.l (A3)
X bmi 100$
X move.w linecap,D0
X beq 100$
X cmp.b #2,D0
X beq 100$ no round ones yet
X
X movem.l (A3),D0-D5
X move.l D4,D6
X
X bsr onecap
X moveq #-1,D0
X move.l D0,(A3) signal did it
X
X lea b_linecap,A3
X movem.l (A3),D0-D5
X move.l D4,D6
X
X add.l D5,D0
X sub.l D4,D1
X movem.l D0/D1,(A3)
X bsr onecap
X
X100$
X movem.l (SP)+,D5/D6
X rts
X
X
Xonecap
X
X movem.l (A3),D0-D3
X sub.l D2,D0
X sub.l D5,D0
X
X sub.l D3,D1
X add.l D6,D1
X
X movem.l D0/D1,-(SP)
X bsr qamove
X
X movem.l (A3),D0-D3
X sub.l D2,D0
X sub.l D3,D1
X bsr qadraw
X
X movem.l (A3),D0-D3
X add.l D2,D0
X add.l D3,D1
X bsr qadraw
X
X movem.l (A3),D0-D3
X add.l D2,D0
X sub.l D5,D0
X add.l D3,D1
X add.l D6,D1
X bsr qadraw
X
X movem.l (SP)+,D0/D1
X bsr qadraw
X
X bra qaend
X
X
X
X DEF setlinecap
X bsr popnum
X tst.l D0
X bmi type_mismatch
X cmp.l #2,D0
X bgt type_mismatch
X move.w D0,linecap
X rts
X
X DEF currentlinecap
X moveq #0,D0
X move.w linecap,D0
X RETURN Integer
X
X
X DEF setlinejoin
X bsr popnum
X tst.l D0
X bmi type_mismatch
X cmp.l #2,D0
X bgt type_mismatch
X move.w D0,linejoin
X rts
X
X DEF currentlinejoin
X moveq #0,D0
X move.w linejoin,D0
X RETURN Integer
X
X
Xarsource dc.l 0,0,0,0
Xardest dc.l 0,0,0,0
Xdeltayx dc.l 0,0
Xbuttremember dc.l 0,0
Xibuttremember dc.l 0,0
Xbuttbegin dc.l 0,0
Xibuttbegin dc.l 0,0
Xa_linecap dc.l 0,0,0,0,0,0
Xb_linecap dc.l 0,0,0,0,0,0
X
X
X
X DEF erasepage
X move.l rastport,A1
X move.l 8(A1),-(SP) save pattern
X moveq #0,D0
X move.b $19(A1),D0 save fgpen
X move.l D0,-(SP)
X move.b $1C(A1),D0 save draw mode
X move.l D0,-(SP)
X lea areasptrn,A0 solid pattern
X move.l A0,8(A1)
X
X moveq #0,D0
X graphics SetDrMd
X
X moveq #0,D0
X graphics SetAPen
X
X moveq #0,D0
X move.l D0,D1
X move.l #639,D2
X move.l #MaxY,D3
X
X move.l A1,-(SP)
X graphics RectFill
X move.l (SP)+,A1
X move.l (SP)+,D0 old mode
X move.l (SP)+,D2 old fg pen
X move.l (SP)+,8(A1) old pattern
X
X graphics SetDrMd
X move.l D2,D0
X graphics SetAPen
X rts
X
X* above substituted for following, since system
X* was corrupted by ClearScreen
X* lea $24(A1),A2
X* move.l (A2),-(SP) save currentpoint
X* clr.l (A2) home
X* graphics ClearScreen
X* move.l (SP)+,(A2)
X* rts
X
X DEF pencolor
X bsr popnum
X moveq #PenMask,D1
X and.l D1,D0
X graphics SetAPen
X rts
X
X DEF penbcolor
X bsr popnum
X moveq #PenMask,D1
X and.l D1,D0
X graphics SetBPen
X rts
X
X DEF penmode
X bsr popnum
X graphics SetDrMd
X rts
X
X DEF penpattern
X bsr popnum
X move.l rastport,A1
X move.w D0,$22(A1)
X rts
X
X DEF box
X bsr popxy
X bsr newpoint
X movem.l D0/D1,-(SP)
X bsr popxy
X bsr newpoint
X movem.l (SP)+,D2/D3
X
X cmp.l D2,D0
X bls 1$
X exg D0,D2
X1$ cmp.l D3,D1
X bls 2$
X exg D1,D3
X2$
X graphics RectFill
X rts
X
X
X DEF currentrgbcolor
X move.l viewport,A0
X move.l 4(A0),A0 colormap
X move.l rastport,A1
X moveq #0,D0
X move.b $19(A1),D0
X graphics GetRGB4
X move.l D0,D3
X move.w #Integer,D2
X moveq #%1111,D1
X lsr #8,D0
X and.l D1,D0
X bsr r.ipush
X move.l D3,D0
X lsr #4,D0
X and.l D1,D0
X bsr r.ipush
X move.l D3,D0
X and.l D1,D0
X bra r.ipush
X
X DEF setrgbcolor
X bsr popnum
X move.l D0,D3
X bsr popnum
X move.l D0,D4
X bsr popnum
X move.l D0,D1
X move.l D4,D2
X
X move.l viewport,A0
X move.l rastport,A1
X
X moveq #0,D0
X move.b $19(A1),D0
X graphics SetRGB4
X rts
X
X DEF findfont
X bsr ipop
X move.l D0,A1
X cmp.w #Name,D2
X beq 1$
X cmp.w #String,D2
X bne type_mismatch
X move.b (A1)+,D0
X bne 2$
X1$ lea fontdirectory,A2
X bsr dictsearch
X tst.l D2
X bmi 3$
X RETURN FontID
X2$ ERR big_key
X3$ ERR no_font
X
X DEF scalefont
X bsr ipop
X move.l D0,D1
X move.w D2,D3
X ARG FontID
X move.l D0,-(SP)
X move.w #FontID,D2
X bsr r.ipush
X move.l D1,D0
X move.w D3,D2
X bsr r.ipush
X
X move.l (SP)+,A0
X tst.w (A0)
X bmi _scaleg
X
X move.l A0,-(SP)
X bsr popnum
X move.l (SP)+,A0
X move.w D0,(A0)
X rts
X
X
X DEF setfont
X ARG FontID
Xresetfont
X move.l D0,A2
X move.l D0,A1
X move.w (A1)+,D0 scaled size
X bmi setresfont
X move.l A1,D2 save ptr font address
X move.l (A1)+,A0 font address, if open, and A1->TAttr
X addq.l #4,A1
X move.w (A1),D1 size in TAttr
X cmp.w D1,D0
X beq 1$ req. size same as known size?
X move.w D0,(A1)
X bra 2$ have to ask for new size
X1$ move.l A0,D0 already open?
X bne 4$ if so, use it
X* correct font and size not known
X* first see if it's on list of resident fonts
X2$ lea 6(A2),A0 TAttr for following call
X graphics OpenFont
X tst.l D0
X beq 20$ if was not found, try on disk
X
X move.l D0,A0 for SetFont call
X move.l D0,2(A2) may as well keep address, even if wrong size
X move.w $14(A0),D0 size of font found
X cmp.w (A2),D0 same as scaled value?
X beq 4$ if so, go use it
X
X20$
X* well, maybe it's on disk
X bsr opendflib make sure diskfont lib is open
X tst.l D0
X beq 3$ no diskfont lib
X
X move.l A6,-(SP)
X move.l D0,A6 diskfontbase
X lea 6(A2),A0 TAttr
X jsr -$1E(A6) OpenDiskFont
X move.l (SP)+,A6
X
X move.l D0,A0
X tst.l D0
X bne 4$ got it?
X3$ print no_font alternatives exhausted
X bra reinterp
X4$ sf resfontflag
X move.l A0,2(A2) save font address
X move.l A2,currfont for currentfont operator
X graphics SetFont
X rts
X
X
Xsetresfont
X st resfontflag
X move.l A2,currfont
X rts
X
X DEF currentfont
X move.l currfont,D0
X RETURN FontID
X
X xdef currfont
Xcurrfont dc.l _topaz
X
X*******
X
Xopendflib
X move.l diskfontbase,D0
X bne 1$
X move.l A6,-(SP)
X move.l 4,A6
X lea dflibname,A1
X moveq #0,D0
X jsr -$228(A6)
X move.l D0,diskfontbase
X move.l (SP)+,A6
X1$ rts
X
X* not used yet
Xclosedflib
X move.l diskfontbase,D0
X beq 1$
X move.l A6,-(SP)
X move.l 4,A6
X lea dflibname,A1
X moveq #0,D0
X jsr -$19E(A6)
X moveq #0,D0
X move.l D0,diskfontbase
X move.l (SP)+,A6
X1$ rts
X
X
X section gdata,data
X
X
Xdiskfontbase dc.l 0
Xdflibname dc.b 'diskfont.library',0
Xresfontflag dc.b 0
X cnop 0,2
X
Xnewfont macro
X_\1 dc.w \2
X dc.l 0
X dc.l 1$
X dc.w \2
X dc.b 0
X dc.b %01100011
X1$ dc.b '\1.font',0
X cnop 0,2
X endm
X
X newfont topaz,8
X newfont diamond,12
X newfont ruby,12
X newfont opal,11
X newfont sapphire,19
X newfont garnet,16
X newfont emerald,20
X
X_simplex dc.w $FFFF
X dc.w Real
X dc.l OnePoint
X
Xfentry macro
X dc.l .\1
X dc.w FontID
X dc.l _\1
X endm
X
Xnentry macro
X.\1 dc.b 1$-*-1
X dc.b '\1'
X1$
X endm
X
Xfontdirectory
X fentry topaz
X fentry diamond
X fentry ruby
X fentry opal
X fentry sapphire
X fentry garnet
X fentry emerald
X fentry simplex
X
X dc.l 0
X
Xfontnames
X nentry topaz
X nentry diamond
X nentry ruby
X nentry opal
X nentry sapphire
X nentry garnet
X nentry emerald
X nentry simplex
X
X bstr no_font,<can''t find font>
X bstr big_key,<key too long>
X bstr psov,<gsave overflow>
X bstr psuv,<grestore underflow>
X bstr pntsov,<too many points in path>
X bstr out01,<arg outside 0...1 interval>
X
X cnop 0,2
X
Xlinecap dc.w 1 0=butt, 1=round, 2=projecting square
Xlinejoin dc.w 0
X
Xgraylevel dc.l 0
X
Xareasptrn
X dc.w %1111111111111111
X dc.w %1111111111111111
X dc.w %1111111111111111
X dc.w %1111111111111111
X
Xareaptrn
X dc.w %0111011101110111
X dc.w %1101110111011101
X dc.w %0111011101110111
X dc.w %1101110111011101
X
X dc.w %0101010101010101
X dc.w %1010101010101010
X dc.w %0101010101010101
X dc.w %1010101010101010
X
X dc.w %0001000100010001
X dc.w %0100010001000100
X dc.w %0001000100010001
X dc.w %0100010001000100
X
X dc.w 0,0,0,0
X
X xdef strokepathflag
Xstrokepathflag dc.w 0
X
X section groom,bss
X
Xpstackcnt ds.w 1
Xpstack ds.l 1
X ds.b 18*PstackSize
Xpstacktop ds.w 1
X ds.l 1
X
X
Xpointcnt ds.w 1
Xnextpoint ds.l 1
X
Xtmpras ds.l 2
Xareainfo ds.l 4
X ds.w 4
X
Xareabuffer ds.b 5*AreaSize
X
Xpathbuffer ds.b 10*AreaSize
X
X end
X
\Rogue\Monster\
else
echo "will not over write ./graphics.a"
fi
if [ `wc -c ./graphics.a | awk '{printf $1}'` -ne 28981 ]
then
echo `wc -c ./graphics.a | awk '{print "Got " $1 ", Expected " 28981}'`
fi
if `test ! -s ./letters`
then
echo "writing ./letters"
sed 's/^X//' > ./letters << '\Rogue\Monster\'
X
Xsave
X
X2 pencolor
X
X/simplex findfont 12 scalefont setfont
X
X/char (x) def
X
X/caps {
X 65 1 65 25 add % for A to Z
X { char exch 0 exch put
X char show } for
X } def
X
X/small {
X 97 1 97 25 add
X { char exch 0 exch put
X char show } for
X } def
X
X50 300 moveto small
X50 250 moveto caps
X
X/simplex findfont 20 scalefont setfont
X
X50 200 moveto small
X50 150 moveto caps
X
Xrestore
X
\Rogue\Monster\
else
echo "will not over write ./letters"
fi
if [ `wc -c ./letters | awk '{printf $1}'` -ne 389 ]
then
echo `wc -c ./letters | awk '{print "Got " $1 ", Expected " 389}'`
fi
if `test ! -s ./lmath.a`
then
echo "writing ./lmath.a"
sed 's/^X//' > ./lmath.a << '\Rogue\Monster\'
X
X xdef ldivs
X xdef ldivu
X xdef lmulu * really signed
X xdef lmoddivu
X
X section one
X
X* divide D1 by D2
X* quotient in D1; remainder in D0
Xlmoddivu
X cmp.l #$00FFFF,D2
X bgt .bigdiv
X move.w D1,A1
X clr.w D1
X swap D1
X divu D2,D1
X move.l D1,D0
X swap D1
X move.w A1,D0
X divu D2,D0
X move.w D0,D1
X clr.w D0
X swap D0
X rts
X.bigdiv
X move.l D1,D0
X clr.w D0
X swap D0
X swap D1
X clr.w D1
X move.l D2,A1
X moveq #$0F,D2
X1$ add.l D1,D1
X addx.l D0,D0
X cmp.l D0,A1
X bgt 2$
X sub.l A1,D0
X addq.w #1,D1
X2$ dbra D2,1$
X rts
X
Xlmulu
X move.l D2,-(SP)
X move.l D0,D2
X mulu D1,D2
X move.l D2,A0
X move.l D0,D2
X swap D2
X mulu D1,D2
X swap D1
X mulu D1,D0
X add.l D2,D0
X swap D0
X clr.w D0
X add.l D0,A0
X move.l A0,D0
X move.l (SP)+,D2
X rts
X
X* remainder after unsigned divide D0 by D1
X
X* move.l D2,-(SP)
X* move.l D1,D2
X* move.l D0,D1
X* bsr lmoddivu
X* move.l (SP)+,D2
X* rts
X
X* unsigned divide D0 by D1
Xldivu
X move.l D2,-(SP)
X move.l D1,D2
X move.l D0,D1
X bsr lmoddivu
X move.l D1,D0
X move.l (SP)+,D2
X rts
X
X* signed remainder after signed divide D0 by D1
X* move.l D2,-(SP)
X* move.l D1,D2
X* bge lab736A
X* neg.l D2
X*lab736A
X* move.l D0,D1
X* moveq #0,D0
X* tst.l D1
X* bge lab7376
X* neg.l D1
X* not.l D0
X*lab7376
X* move.l D0,A0
X* bsr lmoddivu
X* move.w A0,D2
X* beq lab7382
X* neg.l D0
X*lab7382
X* move.l (SP)+,D2
X* rts
X
Xldivs
X move.l D2,-(SP)
X move.l D0,A0
X moveq #0,D0
X move.l D1,D2
X bge 1$ same as bpl
X neg.l D2
X not.l D0
X1$ move.l A0,D1
X bge 2$ same as bpl
X neg.l D1
X not.l D0
X2$ move.l D0,A0
X bsr lmoddivu
X move.l A0,D2
X beq 3$ were signs the same?
X neg.l D1
X3$ move.l D1,D0
X move.l (SP)+,D2
X rts
X
X end
X
\Rogue\Monster\
else
echo "will not over write ./lmath.a"
fi
if [ `wc -c ./lmath.a | awk '{printf $1}'` -ne 2156 ]
then
echo `wc -c ./lmath.a | awk '{print "Got " $1 ", Expected " 2156}'`
fi
if `test ! -s ./palette`
then
echo "writing ./palette"
sed 's/^X//' > ./palette << '\Rogue\Monster\'
X
Xsave
X
X0 setgray
X
X/boxheight 100 def
X/boxwidth 50 def
X/thecolor 0 def
X
X/dab {
X thecolor pencolor
X currentpoint
X currentpoint boxheight add
X currentpoint exch boxwidth add exch
X box
X exch boxwidth add exch moveto
X /thecolor thecolor 1 add def
X} def
X
X 640 8 boxwidth mul sub 2 idiv
X 400 2 boxheight mul sub 2 idiv
X 2 copy
X boxheight add moveto
X 8 {dab} repeat
X moveto
X 8 {dab} repeat
X
X1 pencolor
Xrestore
X
\Rogue\Monster\
else
echo "will not over write ./palette"
fi
if [ `wc -c ./palette | awk '{printf $1}'` -ne 423 ]
then
echo `wc -c ./palette | awk '{print "Got " $1 ", Expected " 423}'`
fi
if `test ! -s ./prg`
then
echo "writing ./prg"
sed 's/^X//' > ./prg << '\Rogue\Monster\'
Xmv $1 $1.n
Xtr -d '\015' <$1.n >$1
Xrm $1.n
\Rogue\Monster\
else
echo "will not over write ./prg"
fi
if [ `wc -c ./prg | awk '{printf $1}'` -ne 42 ]
then
echo `wc -c ./prg | awk '{print "Got " $1 ", Expected " 42}'`
fi
if `test ! -s ./ps.a`
then
echo "writing ./ps.a"
sed 's/^X//' > ./ps.a << '\Rogue\Monster\'
X
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* University of Hawaii, Honolulu, HI 96822
X* ARPA: uhccux!lee@nosc.ARPA
X*
X
X* link with ffpa.o
X xref FFPAFP
X* xref FFPFPA
X* link with lmath.o
X xref lmulu
X xref ldivu
X xref ldivs
X* xref lmoddivu
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\(A6)
X move.l (SP)+,A6
X endm
X
X
X lref Open,
X lref Close,2
X lref Read,3
X lref Write,4
X lref Input,
X lref Output,6
X lref DeleteFile,8
X lref IoErr,8
X lref LoadSeg,2
X lref UnLoadSeg,22
X lref IsInteractive,32
X
X lref SPFix,
X lref SPFlt,2
X lref SPCmp,3
X lref SPTst,4
X lref SPAbs,
X lref SPNeg,6
X lref SPAdd,7
X lref SPSub,8
X lref SPMul,9
X lref SPDiv,
X
X
X
X_RTS equ %
X_JSR equ % destination abs. long
X_JMP equ % destination abs. long
X_MOVELD equ % source immediate long
X_MOVEVD equ % source abs. long
X_MOVEWD2 equ % source immediate word
X_MOVEVD2 equ % 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
Xmain
X bsr _clear
X bsr dsclear
X
X* get more stuff to interpret
Xmain.in
X bsr getstr
X* (from here, A -> 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 #'/',D
X beq pushlit
X
X cmp.b #'(',D
X beq pushstr
X
X cmp.b #'{',D
X beq start_compile
X
X cmp.b #'}',D
X beq end_compile
X
X cmp.b #'%',D
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,A
X move.l A,D
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 A,-(SP)
X move.l D,A
X jsr (A)
X move.l (SP)+,A
X rts
X
X* exit
Xsystem
X bsr endgr
X bsr endio
X moveq #,D
X rts
X***********************
X
X DEF clear
X lea istacktop,A
X moveq #Illegal,D
X move.l D,-(A)
X move.w D,-(A)
X rts
X
Xcountistack
X moveq #-,D
X moveq #Illegal,D2
X move.l A,A
X$ addq.l #,D
X move.w (A),D
X addq.l #6,A
X cmp.w D,D2
X bne $
X rts
X
X
X DEF count
X bsr countistack
X RETURN Integer
X
Xindexistack
X bsr popnum
X addq.l #,D
X bgt ..ndxis
X bra iuflow
Xindexistack
X bsr popnum
X..ndxis
X move.l D,D3
X bmi iuflow
X bsr countistack
X cmp.l D,D3
X bhi iuflow
X move.l D3,D
X subq #,D
X mulu #6,D
X move.l A,A2
X add.l D,A2
X rts
X
X DEF copy
X bsr indexistack
X bra 2$
X$ move.w (A2)+,D2
X move.l (A2),D
X bsr r.ipush
X subq.l #8,A2
X2$ dbra D3,$
X rts
X
X DEF index
X bsr indexistack
X move.w (A2)+,D2
X move.l (A2)+,D
X bra r.ipush
X
X DEF roll
X bsr popnum
X move.l D,-(SP)
X bsr indexistack
X move.l (SP)+,D
X subq.l #,D3
X bmi 2$
X move.l D3,D4
X$ move.l D4,D3
X bsr roll
X bne $
X2$ rts
Xroll
X tst.l D
X beq $
X bmi rollm
X bra rollp
X$ rts
X
Xrollp
X subq.l #,D
X move.l D,-(SP)
X move.l A,A
X move.l A,A
X move.w (A)+,-(SP)
X move.l (A)+,-(SP)
X bra 2$
X$ move.w (A)+,(A)+
X move.l (A)+,(A)+
X2$ dbra D3,$
X move.l (SP)+,D
X move.w (SP)+,(A)+
X move.l D,(A)
X move.l (SP)+,D
X rts
X
Xrollm
X addq.l #,D
X move.l D,-(SP)
X move.l A2,A
X move.l A2,A
X subq.l #6,A
X move.w (A2)+,-(SP)
X move.l (A2)+,-(SP)
X bra 2$
X$ move.w (A)+,(A)+
X move.l (A),(A)
X subq.l #8,A
X subq.l #8,A
X2$ dbra D3,$
X move.l (SP)+,D
X move.w (SP)+,(A)+
X move.l D,(A)
X move.l (SP)+,D
X rts
X
Xdsclear
X lea dstacktop,A
X move.l A,dstack
X moveq #,D
X move.w D,dstackcnt
X lea sstacktop,A
X move.l A,sstack
X moveq #,D
X move.w D,sstackcnt
X rts
X
X
Xstart_compile
X addq.l #,A
X move.b compilelevel,D
X move.w D,-(SP)
X move.l nextcode,A
X move.w #ICode,D2
X move.w (SP),D
X tst.b D
X beq 2$
X add.l #6+4+6+6,A allow for push & jmp if doing sub-proc
X2$ move.l A,D
X* if doing sub-proc, this generates code to do the push
X bsr ipush
X move.w (SP),D
X addq.b #,D
X move.b D,compilelevel
X move.w (SP)+,D
X tst.b D
X bne 3$
X rts
X3$
X move.w #_JMP,D
X bsr stowword
X move.l nextcode,A
X move.l A,-(SP) where to put dest of jmp
X moveq #,D 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)+,A patch in dest of jmp
X move.l nextcode,(A)
X rts
X
X
Xend_compile
X addq.l #,A
X move.b compilelevel,D
X beq 2$ unmatched '}'
X move.w D,-(SP)
X move.w #_RTS,D
X bsr stowword
X move.w (SP)+,D
X subq.b #,D
X move.b D,compilelevel
X beq $
X addq.l #4,SP discard ret to main.next and ret to above
X$ rts
X2$ print rbrace
X bra reinterp
X
Xtestnumber
X cmp.b #'-',D
X beq ..endtestn
X cmp.b #'+',D
X beq ..endtestn
X cmp.b #'.',D (only if next is digit?)
X beq ..endtestn
Xtestdig
X cmp.b #'',D * is it a decimal digit?
X bcs ..endtestn
X cmp.b #'9',D
X bhi ..endtestn
X cmp.b D,D
X..endtestn
X rts
X
Xpushstr
X addq.l #,A
X move.w #,parenlevel
X move.l farea,D
X btst #,D
X beq $
X bsr stowbyte
X move.l farea,D
X$
X move.l D,-(SP) place to put length
X move.w #String,D2
X bsr ipush
X
X moveq #,D
X move.w D,-(SP) count length
X bsr stowbyte room for length
X bsr stowbyte
X
X..nextsbyte
X addq.w #,(SP)
X pea ..nextsbyte
X move.b (A)+,D
X bne 2$
X move.b #,D
X bsr stowbyte
X bra getstr
X
X2$ cmp.b #'(',D
X bne 3$
X add.w #,parenlevel
X bra stowbyte
X
X3$ cmp.b #')',D
X bne 4$
X sub.w #,parenlevel
X bne stowbyte
X addq.l #4,SP discard ret to ..nextsbyte
X
X move.w (SP)+,D
X subq.w #,D correct for ')' not stored
X move.l (SP)+,A
X move.w D,(A)
X rts
X
X4$ cmp.b #'\',D
X bne stowbyte
X move.b (A)+,D
X beq getstr
X move.b D,D
X
X move.b #,D
X cmp.b #'n',D
X beq stowbyte
X
X move.b #3,D
X cmp.b #'r',D
X beq stowbyte
X
X move.b #9,D
X cmp.b #'t',D
X beq stowbyte
X
X move.b #8,D
X cmp.b #'b',D
X beq stowbyte
X
X move.b #2,D
X cmp.b #'f',D
X beq stowbyte
X
X cmp.b #'',D
X bcs ..noct
X cmp.b #'7',D
X bhi ..noct
X moveq #,D
X bsr ..isoct
X bsr ..isoct
X sub.b #'',D
X asl.b #3,D
X add.b D,D
X bra stowbyte
X
X..isoct
X sub.b #'',D
X asl.b #3,D
X add.b D,D
X move.b (A),D
X cmp.b #'',D
X bcs $
X cmp.b #'7',D
X bhi $
X addq.l #,A
X rts
X$ addq.l #4,SP
X bra stowbyte
X
X..noct
X move.b D,D
X cmp.b #'\',D
X beq stowbyte
X cmp.b #'(',D
X beq stowbyte
X cmp.b #')',D
X beq stowbyte
X rts
X
X
Xpushlit
X addq.l #,A past '/'
X move.l farea,A save to push
X moveq #,D3 count
X bsr stowbyte room for length
X$ move.b (A)+,D
X bsr testendchar
X bne 2$
X move.b D3,(A)
X subq.l #,A
X move.l A,D
X move.w #Name,D2
X bra ipush
X2$ bsr stowbyte
X addq.l #,D3
X bra $
X
Xpushnum
X moveq #,D
X move.l D,D2 neg flag
X move.l D,D3 dec point flag
X move.l A,A
X cmp.b #'-',(A)
X bne $
X move.b (A)+,D2
X$ move.b (A)+,D
X bsr testdig
X bne 2$
X sub.b #'',D
X ext.w D
X ext.l D
X
X move.l D,-(SP)
X add.l D,D
X move.l D,D
X lsl.l #2,D
X add.l D,D
X move.l (SP)+,D
X add.l D,D
X bra $
X
X2$ tst.b D3
X beq 6$
X cmp.b #'E',D
X bne realpush
X3$ move.b (A)+,D
X cmp.b #'-',D
X bne $
X4$ move.b (A)+,D
X$ bsr testdig
X beq 4$
X bra realpush
X
X6$ cmp.b #'E',D
X beq 3$
X cmp.b #'.',D
X bne intpush
X move.b D,D3
X bra $
X
Xrealpush
X subq.l #,A
X move.l A,-(SP)
X jsr FFPAFP
X move.l (SP)+,A
X bvs $
X move.w #Real,D2
X move.l D7,D
X bra ipush
X$ print fperr
X bra reinterp
X
Xintpush
X subq.l #,A
X move.b D2,D3
X move.w #Integer,D2
X move.l D,D
X tst.b D3
X beq ipush
X neg.l D
X
Xipush
X move.b compilelevel,D3
X beq r.ipush
X bsr stowmovel
X bsr stowmovew
X..iptype
X lea r.ipush,A
X move.l A,D
X bra stowcall
X
Xvpush
X tst.b D3
X beq r.ipush
X move.l A2,D get address of value
X addq.l #2,D
X move.l A2,-(SP)
X bsr stowmovev
X move.l (SP)+,D get address of type
X bsr stowmovevw
X bra ..iptype
X
X xdef r.ipush
Xr.ipush
X* move.l istack,A
X move.l D,-(A)
X move.w D2,-(A)
X cmp.l #istackbot,A
X bhi ipush.ok
X print overflow
Xreinterp
X move.b #,compilelevel
X bsr initloops
X bsr runclose
X move.l stacksave,SP
X bra main
X
Xipush.ok
X* move.l A,istack
X rts
X
X
X xdef ipop
Xipop
X DEF pop
X* move.l istack,A
X move.w (A)+,D2
X cmp.w #Illegal,D2
X bne ..ippok
Xiuflow
X print underflow
X bra reinterp
X..ippok
X move.l (A)+,D
X* move.l A,istack
X rts
X
X xdef popnum
Xpopnum
X bsr ipop
X cmp.w #Integer,D2
X beq $
X cmp.w #Real,D2
X bne type_mismatch
X move.l D,-(SP)
X math SPFix
X move.l (SP)+,D
X move.w #Integer,D2
X$ rts
X
Xskipsp
X move.b (A),D
X beq 2$
X cmp.b #,D
X beq $
X cmp.b #' ',D
X bne 2$
X$ addq.l #,A
X bra skipsp
X2$ rts
X
Xtestendchar
X tst.b D
X beq $
X cmp.b #' ',D
X beq $
X cmp.b #,D
X beq $
X cmp.b #'}',D
X beq $
X cmp.b #'{',D
X beq $
X cmp.b #')',D
X beq $
X cmp.b #'(',D
X beq $
X cmp.b #'/',D
X beq $
X cmp.b #'%',D
X beq $
X cmp.b #']',D
X beq $
X cmp.b #'[',D
X beq $
X cmp.b #'>',D
X beq $
X cmp.b #'<',D
X$ rts
X
X* A -> name to look for
X* return with A -> past name
X* D2 = - if not found, else D2 = type
X* D = value & A2 -> type of entry
Xfindsym
X move.l A,A
X moveq #,D3
X move.l D3,D2
X
X$ move.b (A)+,D get length in D3
X bsr testendchar
X beq 2$
X addq.l #,D3
X bra $
X2$ tst.l D3
X bne 4$
X cmp.b #'[',D
X beq 3$
X cmp.b #']',D
X bne .nonefound
X3$ moveq #,D3
X4$ bsr allsym
X tst.l D2
X bpl $
X move.b compilelevel,D
X bne dummyentry
X$ add.l D3,A
X rts
X
Xallsym
X move.w dstackcnt,D
X move.l dstack,A
X$ subq.w #,D
X bmi 2$
X move.l (A)+,A2
X addq.l #2,A2
X movem.l A/D,-(SP)
X moveq #,D2
X bsr nextsym
X movem.l (SP)+,A/D
X tst.l D2
X bmi $
X rts
X2$ moveq #,D2
X lea systemdict,A2
X
X* also called by dictsearch
Xnextsym
X move.l (A2)+,D
X beq .nonefound
X move.l D,A3 A3 -> name in dict
X move.l A,A A -> name
X move.l D3,D
X move.w (A2)+,D2 D2 = type
X move.l (A2)+,D D = value
X
X cmp.b (A3)+,D same length?
X bne nextsym
X
X subq.l #,D
X4$ cmp.b (A3)+,(A)+
X dbne D,4$
X bne nextsym
X subq.l #6,A2
X rts
X
X.nonefound
X moveq #-,D2
X rts
X
X* from above -- A -> name; D3 = length
Xdummyentry
X move.l A,A
X add.l D3,A
X move.l A,-(SP)
X move.l farea,A save for entry name
X move.l D3,D
X bsr stowbyte length
X bra 2$
X$ move.b (A)+,D
X bsr stowbyte
X2$ dbra D3,$
X
X lea say_undefined,A
X move.l A,D
X move.l #Dummy,D2
X bsr newentry
X subq.l #6,A
X move.l A,A2
X bsr vpush
X lea _exec,A
X move.l #ICode,D2
X move.l A,D
X move.l (SP)+,A
X rts
X
X
X
X DEF begin
X ARG Dictionary
X lea dstackcnt,A
X cmp.w #DstackSize,(A)
X beq $
X addq.w #,(A)
X move.l dstack,A
X move.l D,-(A)
X move.l A,dstack
X rts
X$ print dstackov
X bra reinterp
X
X DEF end
X lea dstackcnt,A
X tst.w (A)
X beq $
X subq.w #,(A)
X move.l dstack,A
X move.l (A)+,D
X move.l A,dstack
X rts
X$ print dstackuv
X bra reinterp
X
X**********
X
X
Xstowbyte
X move.l farea,A2
X move.b D,(A2)+
X cmp.l #endsarea,A2
X bne $
X print areafull
X bra reinterp
X$ move.l A2,farea
X rts
X
X* store instruction 'move.w <D>,D2'
Xstowmovevw
X move.l D,-(SP)
X move.w #_MOVEVD2,D
X bra ..stowi
X* store instruction 'move.w #<D2>,D2'
Xstowmovew
X move.w #_MOVEWD2,D
X bsr stowword
X move.w D2,D
X bra stowword
X* store instruction 'move.l <D>,D'
Xstowmovev
X move.l D,-(SP)
X move.w #_MOVEVD,D
X bra ..stowi
X* store instruction 'move.l #<D>,D'
Xstowmovel
X move.l D,-(SP)
X move.w #_MOVELD,D
X bra ..stowi
X* store instruction 'jsr <D>'
Xstowcall
X move.l D,-(SP)
X move.w #_JSR,D change to BSR?
X..stowi
X bsr stowword
X move.l (SP),D
X swap D
X bsr stowword
X move.l (SP)+,D
X
Xstowword
X move.l nextcode,A2
X move.w D,(A2)+
X cmp.l #endcode,A2
X bls $
X print codefull
X bra reinterp
X$ move.l A2,nextcode
X rts
X
Xstowlong
X swap D
X bsr stowword
X swap D
X bra stowword
X
X************************************
X
X DEF hex
X bsr ipop
X bsr show8x
X move.l A,D
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 D,-(SP)
X moveq #-,D flag this is a string conversion
X bra ..prnt
X..cvs2
X* it better be long enough
X move.l (SP)+,A
X move.l A,D
X* A -> name; A -> string
X moveq #,D
X move.b D,(A)+
X move.b (A),D
X$ move.b (A)+,(A)+
X dbra D,$
X RETURN String
X
X..pors
X move.l (SP)+,D
X bne ..cvs2
X bsr msg
X bra newline
X
X DEF print
X ARG String
X move.l D,A
X moveq #,D3
X move.w (A)+,D3
X bra longmsg
X
X
X DEF equalsprint
X moveq #,D flag this is a print
X..prnt
X move.l D,-(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 D,A
X bra ..pors
X
X3$ cmp.w #String,D2
X bne 4$
X move.l D,A
X move.l (SP)+,D
X beq 3$
X move.l (SP)+,D
X bra r.ipush it's already a string -- should copy it?
X3$
X moveq #,D3
X move.w (A)+,D3
X bsr longmsg
X bra newline
X
X4$ cmp.w #Boolean,D2
X bne 6$
X lea .true,A
X tst.l D
X bne $
X lea .false,A
X$ bra ..pors
X
X6$ cmp.w #Real,D2
X bne 7$
X bsr showreal
X bra ..pors
X
X7$
X lea nsv,A
X bra ..pors
X
X
X DEF string
X bsr popnum
X move.l D,D3
X swap D
X tst.w D
X bne 2$
X
X move.l farea,D
X btst #,D
X beq $
X bsr stowbyte
X move.l farea,D
X$
X move.l D,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 D,A
X move.w D3,(A)
X move.l A2,farea
X RETURN String
X
X DEF dict
X moveq #-,D4
X bra ..arry
X
X DEF array
X moveq #,D4
X..arry
X bsr popnum
X move.l nextcode,A2
X move.l A2,A
X move.w D,(A2)+
X add.l D,D bytes -> words
X move.l D,D
X add.l D,D
X add.l D,D length * 3
X tst.l D4
X beq $
X add.l D,D
X add.l D,D length *
X addq.l #4,D + for null at end
X move.l A2,A
X clr.w (A2)+ current length is
X clr.l (A2) flag end
X$ add.l D,A2
X cmp.l #endcode,A2
X bls 2$
X ERR codefull
X2$ move.l A2,nextcode
X move.l A,D
X tst.l D4
X bne 3$
X RETURN Array
X3$ RETURN Dictionary
X
X DEF fontalloc
X move.l nextcode,A
X lea 8(A),A2
X cmp.l #endcode,A2
X bls $
X ERR codefull
X$ move.l A2,nextcode
X rts
X
X
X DEF maxlength
X bsr ipop
X move.l D,A
X subq.l #2,A
X bra ..lngth
X
X DEF length
X bsr ipop
X move.l D,A
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 #,D
X move.w (A),D
X move.w #Integer,D2
X bra r.ipush
X
X
Xarrayref
X bsr popnum
X move.l D,D the index
X bsr ipop
X move.l D,A base of array
X moveq #,D3
X cmp.w #Array,D2
X beq $
X cmp.w #String,D2
X bne type_mismatch
X$ move.w (A)+,D3
X subq.l #,D3 length - is max index
X bmi 3$
X cmp.l D3,D past end?
X bhi 3$
X cmp.w #Array,D2
X beq 2$
X add.l D,A ret not equal
X rts
X2$ add.l D,D word reference
X move.l D,D
X add.l D,D times 3
X add.l D,D
X add.l D,A index to element
X cmp.l D,D
X rts
X3$ print arr_err
X bra reinterp
X
X
X DEF get
X bsr arrayref
X bne $
X move.w (A)+,D2 type
X move.l (A),D value
X bra r.ipush
X$ move.w #Integer,D2
X moveq #,D
X move.b (A),D
X bra r.ipush
X
X DEF put
X bsr ipop
X move.l D,-(SP)
X move.w D2,-(SP)
X bsr arrayref
X bne $
X move.w (SP)+,(A)+
X move.l (SP)+,(A)
X rts
X$ move.w (SP)+,D2
X move.l (SP)+,D
X cmp.w #Integer,D2
X bne type_mismatch
X move.b D,(A)
X rts
X
X DEF mark
X moveq #,D
X RETURN Mark
X
X DEF rbracket
X moveq #,D3 count array elements
X$ bsr ipop
X cmp.w #Mark,D2
X beq 2$
X addq.l #,D3
X move.l D,-(SP)
X move.w D2,-(SP)
X bra $
X2$ move.l nextcode,D
X move.w #Array,D2
X bsr r.ipush
X move.l D3,D
X bsr stowword
X bra 4$
X
X3$ move.w (SP)+,D
X bsr stowword
X move.l (SP)+,D
X bsr stowlong
X4$ dbra D3,3$
X rts
X
X
X DEF def
X bsr ipop
X movem.l D/D2,-(SP)
X ARG Name
X move.l D,A first check dict to see if old symbol
X move.l D,-(SP) save for name of new entry
X bsr alldictsearch
X move.l (SP)+,D
X tst.l D2 found?
X bmi newentry
X* replace old entry
X movem.l (SP)+,D/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 D,(A2) new value
X rts
X
X* called from findsym
Xnewentry
X movem.l D/D2,-(SP)
X move.l A,D
X* make new entry
X* type & value on stack; D -> name
Xnewentry
X move.w dstackcnt,D
X bne 4$
X move.l nextentry,A
X move.l D,(A)+
X movem.l (SP)+,D/D2
X move.w D2,(A)+
X move.l D,(A)+
X clr.l (A)
X cmp.l #enddict,A
X bhi 3$
X move.l A,nextentry
X rts
X3$ print fulldict
X bra reinterp
X4$ move.l dstack,A
X move.l (A),A address of dict -> current size
X move.w -(A),D D = maxsize
X addq.l #2,A point at current size again
X cmp.w (A),D if max <= current, no room
X bls 3$
X moveq #,D form address for new entry
X move.w (A),D
X add.l D,D word
X move.l D,D2 * new current size
X add.l D,D
X add.l D,D
X add.l D2,D
X
X addq.w #,(A)+ new current size, & point to st entry
X add.l D,A point to new entry
X tst.l (A) if not null, imp. error
X bne imp_error
X
X move.l D,(A)+
X movem.l (SP)+,D/D2
X move.w D2,(A)+
X move.l D,(A)+
X clr.l (A)
X
X rts
X
Xalldictsearch
X move.l dstack,A
X move.w dstackcnt,D3
X$ subq.w #,D3
X bmi 3$
X move.l (A)+,A2
X addq.l #2,A2 past current length
X movem.l D3/A,-(SP)
X bsr dictsearch
X movem.l (SP)+,D3/A
X tst.l D2
X* bmi $ (it was a mistake to search past top dictionary)
X rts
X3$ lea systemdict,A2
X xdef dictsearch
X* A -> Name (bstr)
X* A2 -> dict
X* returns D2 = - if not found
X* else D2 = type
X* D = value
X* A2 -> type in entry
Xdictsearch
X move.l A,-(SP)
X moveq #,D3 len
X move.l D3,D2
X move.b (A)+,D3
X bsr nextsym
X move.l (SP)+,A
X rts
X
X
X DEF exch
X bsr ipop
X move.l D,D
X move.w D2,D3
X bsr ipop
X exg D,D
X exg D2,D3
X bsr r.ipush
X move.l D,D
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 #-,D
X RETURN Boolean
X
X DEF false
X moveq #,D
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,A
X cmp.w #SstackSize,(A)
X beq $
X addq.w #,(A)
X move.l sstack,A
X move.l farea,-(A)
X move.l nextentry,-(A)
X move.l nextcode,-(A)
X move.l A,sstack
X bsr _gsave
X moveq #,D
X RETURN Save
X$ print sstkov
X bra reinterp
X
X DEF restore
X ARG Save
X lea sstackcnt,A
X tst.w (A)
X beq $
X subq.w #,(A)
X move.l sstack,A
X move.l (A)+,nextcode
X move.l (A)+,A
X clr.l (A)
X move.l A,nextentry
X move.l (A)+,farea
X bra _grestore
X$ 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
X
X*DOS_point ds.l
X* xdef graphicsbase
Xgraphicsbase ds.l
Xintuitionbase ds.l
X* xdef mathffpbase
Xmathffpbase ds.l
X* xdef mathtransbase
Xmathtransbase ds.l
X
X* xdef wbscreen
Xwbscreen ds.l
X*thiswindow ds.l
X*doswindow ds.l
X* xdef rastport
Xrastport ds.l
X
Xohandle ds.l
X* xdef ihandle
Xihandle ds.l
X
X
Xcodearea ds.w CodeSize
Xendcode ds.w 4
X
Xistack ds.l
X ds.b 2
Xistackbot ds.b 6*IstackSize
Xistacktop ds.l
X
Xdstackcnt ds.w
Xdstack ds.l
X ds.b 8
Xdstackbot ds.b 4*DstackSize
Xdstacktop ds.l
X
X
Xsstackcnt ds.w
Xsstack ds.l
X ds.b 2
Xsstackbot ds.b 2*SstackSize
Xsstacktop ds.l
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
Xparenlevel dc.w
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 24428 ]
then
echo `wc -c ./ps.a | awk '{print "Got " $1 ", Expected " 24428}'`
fi
echo "Finished archive 2 of 3"
# if you want to concatenate archives, remove anything after t*Ar ],< qb
X