don@TUMTUM.CS.UMD.EDU (Don Hopkins) (11/23/89)
======== START OF cyber.shar.splitag ========
X exch {
X PushExec
X } {
X pop
X } ifelse
X } def
X
X /ifelse load { % bool trueproc falseproc
X 3 -1 roll { exch } if % wrongproc rightproc
X PushExec pop
X } def
X
X iexec-single-forall-types begin
X {/arraytype /packedarraytype /stringtype}
X {true def} forall
X end % iexec-single-forall-types
X
X /forall load { % obj proc => -
X 10 dict begin
X /continuation /forall def
X /proc exch def
X /obj exch cvlit def
X /i 0 def
X //iexec-single-forall-types obj type known {
X /continue { % dict => -
X begin
X i obj length lt {
X currentdict cvx PushExec
X obj i get
X /proc load PushExec
X /i i 1 add def
X } if
X end
X } def
X /namestring {
X (forall: proc=% obj=% @ %: %)
X [ /proc load /obj load i
X 1 index length 1 index gt { 2 copy get } (*done*) ifelse
X ] sprintf
X } def
X } {
X /keys [
X obj {pop} forall
X ] def
X /continue { % dict => -
X begin
X i obj length lt {
X currentdict cvx PushExec
X keys i get % key
X obj 1 index get % key val
X /proc load PushExec
X /i i 1 add def
X } if
X end
X } def
X /namestring {
X (forall: proc=% obj=% @ %: %)
X [ /proc load /obj load
X keys i
X 1 index length 1 index gt {
X get 2 copy get
X } {
X pop null (*done*)
X } ifelse
X ] sprintf
X } def
X } ifelse
X currentdict cvx PushExec
X end
X } def
X
X /for load { % first step last proc
X 10 dict begin
X /continuation /for def
X /proc exch def
X /last exch def
X /step exch def
X /first exch def
X /i first def
X /continue { % dict => -
X begin
X i last step 0 gt {le} {ge} ifelse {
X currentdict cvx PushExec
X i
X /proc load PushExec
X /i i step add def
X } if
X end
X } def
X /namestring {
X (for: proc=% first=% step=% last=% i=%)
X [/proc load first step last i] sprintf
X } def
X currentdict cvx PushExec
X end
X } def
X
X /repeat load {
X 10 dict begin
X /continuation /repeat def
X /proc exch def
X /times exch def
X /i 0 def
X /continue { % dict => -
X begin
X i times lt {
X currentdict cvx PushExec
X /proc load PushExec
X /i i 1 add def
X } if
X end
X } def
X /namestring {
X (repeat: proc=% times=% i=%)
X [/proc load times i] sprintf
X } def
X currentdict cvx PushExec
X end
X } def
X
X /loop load {
X 10 dict begin
X /continuation /loop def
X /proc exch def
X /continue { % dict => -
X begin
X currentdict cvx PushExec
X /proc load PushExec
X end
X } def
X /namestring {
X /proc load (loop: proc=%) sprintf
X } def
X currentdict cvx PushExec
X end
X } def
X
X /pathforallvec load {
X%...
X } def
X
X iexec-exit-stoppers begin
X {/forall /for /repeat /loop /pathforallvec}
X {true def} forall
X end % iexec-exit-stoppers
X
X /exit load {
X { ExecSP 0 lt { % exit out of interpreter?
X true exit
X } {
X PopExec % obj
X dup dup xcheck exch type /dicttype eq and { % obj
X dup /continuation known {
X dup /continuation get iexec-exit-stoppers exch known {
X pop false exit
X } {
X pop
X } ifelse
X } {
X pop
X } ifelse
X } { % obj
X pop
X } ifelse
X } ifelse
X } loop
X
X { {exit} exit } if
X } def
X
X /stop load {
X { ExecSP 0 lt { % stop out of interpreter?
X true exit
X } {
X PopExec % obj
X dup dup xcheck exch type /dicttype eq and { % obj
X dup /continuation known {
X dup /continuation get /stopped eq {
X pop true false exit
X } {
X pop
X } ifelse
X } {
X pop
X } ifelse
X } { % obj
X pop
X } ifelse
X } ifelse
X } loop
X
X { {stop} exit } if
X } def
X
X /stopped load { % proc
X 10 dict begin
X /continuation /stopped def
X /continue { % dict => -
X pop false
X } def
X /proc 1 index def % debugging
X /namestring {
X /proc load (stopped: proc=%) sprintf
X } def
X currentdict cvx PushExec
X PushExec
X end
X } def
X
X /send load { % <args> message object => <results>
X { currentdict } MumbleFrotz % message object context
X 2 copy eq { % message object context
X pop pop cvx PushExec
X } { % message object context
X 10 dict begin
X /continuation /send def
X /context
X exch dup /ParentDictArray known not { pop null } if
X def % message object
X /object exch def % message
X /message 1 index def % message
X /continue { % cdict => -
X { % cdict
X ParentDictArray dup type /arraytype ne { % X11/NeWS
X /ParentDictArray get length 1 add
X } {
X length
X } ifelse
X 1 add {end} repeat
X /context get % context
X dup null eq { % context
X pop %
X } { % idict context
X dup /ParentDictArray get {begin} forall begin %
X } ifelse %
X } MumbleFrotz
X } def
X /unwind /continue load def
X /namestring {
X (send: message=% object=% context=%)
X [/message load object context] sprintf
X } def
X currentdict cvx PushExec
X object context % message object context
X end % of cdict
X { null ne {
X ParentDictArray length 1 add {end} repeat
X } if
X dup /ParentDictArray get
X dup type /arraytype ne { % X11/NeWS
X dup /ParentDictArray get
X {begin} forall begin begin % message
X } {
X {begin} forall begin % message
X } ifelse
X } MumbleFrotz % message
X cvx PushExec %
X } ifelse
X } def
X
X% supersend (operator in X11/NeWS, proc in 1.1?)
X
X /currentfile load { % => file
X null
X ExecStack length 1 sub -1 0 {
X ExecStack exch get % obj
X dup type /filetype eq {
X exit
X } {
X pop
X } ifelse
X } for
X dup null eq {
X pop currentfile
X } {
X exch pop
X } ifelse
X } def
X
X % We have to have the send contexts set up right when we do a fork, since
X % the child process inherits them. (i.e. so ThisWindow works)
X /fork load {
X {fork} iexec-reenter
X } def
X
X /countexecstack load {
X /countexecstack dbgbreak
X } def
X
X /quit load {
X /quit dbgbreak
X } def
X
Xend % iexec-operators
X
Xiexec-names begin
X
X /sendstack {
X [ iexec-sends
X currentprocess /SendContexts get aload pop
X ]
X } def
X
X /iexecing? true def
X
X % meta-exec is a hook back up to the interpreter context.
X /meta-exec {
X exec
X } def
X
X /append {
X {{append} stopped} MumbleFrotz
X ?iexec-handle-error
X } def
X
X /sprintf {
X {{sprintf} stopped} MumbleFrotz
X ?iexec-handle-error
X } def
X
X% execstack
X
Xend % iexec-names
X
Xend % systemdict
X
//go.sysin dd *
if [ `wc -c < ps.ps` != 17287 ]; then
made=false
echo error transmitting ps.ps --
echo length should be 17287, not `wc -c < ps.ps`
else
made=true
fi
if $made; then
chmod 664 ps.ps
echo -n ' '; ls -ld ps.ps
fi
echo Extracting scrap.ps
sed 's/^X//' <<'//go.sysin dd *' >scrap.ps
X% From owen@Sun.COM Mon Dec 12 21:12:13 1988
X% Date: Mon, 5 Dec 88 11:25:55 PST
X% From: owen@Sun.COM (Owen Densmore)
X% To: don@amanda.cs.umd.edu
X% Subject: Re: scrap.ps & codebook.ps
X%
X% The scrap.ps file is possibly not that interesting because it
X% is fairly out of date. I'll send anyway.
X% ===============================================================
X% scrap.ps
X% Anybody can pick over these for whatever purpose they'd like.
X% They are random pieces used in a class given at Sun for
X% tech support engineers.
X% Note: The /demo procedures included below are small code
X% fragments illustrating various parts of the system.
X% Because they all have the same name, each one should
X% be cut & paste to NeWS individually, as needed.
X% ===============================================================
X% Misc:
X% ===============================================================
X/cds {countdictstack =} def
X/ps {pstack} def
X/fb {framebuffer} def
X/temp {
X executive systemdict begin (~/ps/server/NeWS/scrap.ps)run end
X} def
X/scrap {(~/ps/server/NeWS/scrap.ps)run} def
X% ---------------------------------------------------------
X/setshade { % GrayOrColor => - (set gray or color)
X dup type /colortype eq {setcolor} {setgray} ifelse
X} def
X% ---------------------------------------------------------
X/fillcanvas { % GrayOrColor => - (Fills current canvas w/ GrayOrColor)
X setshade clippath fill
X} def
X% ---------------------------------------------------------
X/insetrect { % delta x y w h => x' y' w' h' (return new rect inset by delta)
X10 dict begin
X [/h /w /y /x /delta] {exch def} forall
X x delta add y delta add w delta dup add sub h delta dup add sub
Xend
X} def
X% ---------------------------------------------------------
X/rectpath { % x y w h => - (make a rect path)
X 4 2 roll moveto
X dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath
X} def
X% ---------------------------------------------------------
X/ovalpath { % x y w h => - (make a oval path)
X matrix currentmatrix 5 1 roll % xfm x y w h
X 4 2 roll translate scale % xfm
X .5 .5 translate 0 0 .5 0 360 arc closepath % xfm
X setmatrix % -
X} def
X% ---------------------------------------------------------
X/starpath { % x y w h => - (make a star path)
X matrix currentmatrix 5 1 roll % xfm x y w h
X 4 2 roll translate scale % xfm
X .2 0 moveto .5 1 lineto .8 0 lineto % xfm
X 0 .65 lineto 1 .65 lineto closepath % xfm
X setmatrix % -
X} def
X% ===============================================================
X% Canvases:
X% ===============================================================
X/demo {
Xgsave
X framebuffer setcanvas
X 100 100 translate 0 0 300 300 rectpath
X
X /can framebuffer newcanvas def
X can reshapecanvas
X can /Mapped true put
X
X can setcanvas .5 fillcanvas
Xgrestore
X} def
X% ---------------------------------------------------------
X/pathcanvas { % x y w h parent path => canvas (make a "path" shaped canvas)
X10 dict begin
X gsave
X cvx [/path /parent /h /w /y /x] {exch def} forall
X /can parent newcanvas def
X
X parent setcanvas
X x y translate 0 0 w h path
X
X can reshapecanvas
X can /Mapped true put
X can
X grestore
Xend
X} def
X% ---------------------------------------------------------
X/rectcanvas { {rectpath} pathcanvas } def % x y w h parent => canvas
X/rectcanvas { /rectpath pathcanvas } def % x y w h parent => canvas
X
X/demo {
X /can 100 100 200 200 framebuffer rectcanvas def
X can setcanvas .5 fillcanvas
X} def
X% ---------------------------------------------------------
X/ovalcanvas { {ovalpath} pathcanvas } def % x y w h parent => canvas
X
X/demo {
X /can 100 100 200 200 framebuffer ovalcanvas def
X can setcanvas .5 fillcanvas
X} def
X% ---------------------------------------------------------
X/starcanvas { {starpath} pathcanvas } def % x y w h parent => canvas
X
X/demo {
X /can 100 100 200 200 framebuffer starcanvas def
X can setcanvas .5 fillcanvas
X} def
X% ===============================================================
X% Sub Canvases:
X% ===============================================================
X/demo {
X /can 100 100 200 200 framebuffer rectcanvas def
X /can1 10 10 180 180 can rectcanvas def
X can setcanvas .5 fillcanvas
X can1 setcanvas 1 fillcanvas
X} def
X% ---------------------------------------------------------
X/demo {
X /can 100 100 200 200 framebuffer ovalcanvas def
X /can1 10 10 180 180 can ovalcanvas def
X can setcanvas .5 fillcanvas
X can1 setcanvas 1 fillcanvas
X} def
X% ---------------------------------------------------------
X/demo {
X /can 100 100 200 200 framebuffer starcanvas def
X /can1 25 25 150 150 can starcanvas def
X can setcanvas .5 fillcanvas
X can1 setcanvas 1 fillcanvas
X} def
X% ---------------------------------------------------------
X/demo {
X /look { % canvas => - (print a canvas & its sub-tree)
X countdictstack 2 sub {( ) print} repeat dup ==
X begin
X TopChild null ne {TopChild look} if
X CanvasBelow
X end
X dup null ne {look} {pop} ifelse
X } def
X framebuffer look
X} def
X% ===============================================================
X% Transparency:
X% ===============================================================
X/demo { % transparent? => - (make /can & /can1)
Xgsave
X framebuffer setcanvas
X 100 100 translate 0 0 300 300 rectpath
X
X /can framebuffer newcanvas def
X can reshapecanvas
X can /Mapped true put
X
X can setcanvas
X 75 75 translate 0 0 150 150 ovalpath
X
X /can1 can newcanvas def
X can1 reshapecanvas
X can1 /Transparent 3 -1 roll put
X can1 /Mapped true put
Xgrestore
X} def
X
X/demo1 {
X true demo
X can1 setcanvas .5 fillcanvas
X can setcanvas 0 fillcanvas
X can1 setcanvas .5 fillcanvas
X
X false demo
X can1 setcanvas .5 fillcanvas
X can setcanvas 0 fillcanvas
X} def
X% ===============================================================
X% Overlay Canvases:
X% ===============================================================
X/demo { % needs /can to be defined
X /Times-Roman findfont 36 scalefont setfont
X
X /olay can createoverlay def
X can setcanvas 1 fillcanvas
X 0 setshade 20 20 moveto (Here Is Some Text) show
X olay setcanvas
X
X 0 fillcanvas
X erasepage
X
X 20 20 50 50 ovalpath stroke
X 20 100 moveto (Here Is Some Text) show
X erasepage
X} def
X% ===============================================================
X% Lightweight Processes
X% ===============================================================
X/demo {
X /p {2 2 add} def
X p =
X % 4
X /pp {p} fork def
X pp =
X % process(7663140, runnable)
X pp waitprocess =
X % 4
X} def
X% ---------------------------------------------------------
X/demo {
X /p {2 2 add} fork def
X p =
X % process(7762460, runnable)
X pause
X p =
X % process(7762460, zombie)
X p waitprocess =
X % 4
X} def
X% ---------------------------------------------------------
X/demo {
X /p {1 2 3} fork def
X p waitprocess =
X % 3
X /p {[1 2 3]} fork def
X p waitprocess dup ==
X % [1 2 3]
X aload pop ps clear
X % 1 2 3
X} def
X% ---------------------------------------------------------
X/demo {
X clear
X /a 1 def
X /p null def
X /peek { % - => array (Return an array showing the current status.)
X [ count 1 roll ]
X [ exch
X (Dictstack=% a=% Stack=) [countdictstack a] sprintf
X exch
X ]
X } def
X
X 10 dict begin
X /a 10 def
X (Hi!)
X /p {
X peek
X } fork store
X pop
X end
X
X peek ==
X % [(Dictstack=2 a=1 Stack=) []]
X p waitprocess ==
X % [(Dictstack=3 a=10 Stack=) [(Hi!) /p]]
X} def
X/demo {
X /a 1 def
X /PrintStatus { % - => - (Print current processes status.)
X (State of process:%\n a=% Dictstack=% stack=)
X [currentprocess a countdictstack] printf
X pstack
X } def
X
X PrintStatus
X
X%State of process:process(2222550, runnable)
X% a=1 Dictstack=2 stack=Empty stack
X
X 10 dict begin
X /a 10 def
X (Hi!)
X /p {
X PrintStatus
X } fork store
X pop
X end
X
X%State of process:process(4041374, runnable)
X% a=10 Dictstack=3 stack=(Hi!) /p
X} def
X% ===============================================================
X% Events & Interests
X% ===============================================================
X/snoop {
X /snoopprocess {
X createevent expressinterest {awaitevent dup == redistributeevent} loop
X } fork def
X} def
X/killsnoop {snoopprocess killprocess} def
X
X/demo {
X snoop
X% event(0x1f7f3c, [382,223], name(/MouseDragged), action(null))
X% event(0x1f42f0, [382,223], name(/LeftMouseButton), action(/DownTransition))
X% event(0x1f7f3c, [382,223], name(/LeftMouseButton), action(/UpTransition))
X% event(0x1f7f3c, [382,223], name(28493), action(/DownTransition))
X% event(0x1f7f3c, [382,223], name(28493), action(/UpTransition))
X% event(0x1f42f0, [356,229], name(/MouseDragged), action(null))
X killsnoop
X} def
X% ---------------------------------------------------------
X/settarget { % - => - (set tty target = current selection holder)
X /TtyTarget createevent dup begin
X /Name /InsertValue def
X /Process /PrimarySelection getselection /SelectionHolder get def
X /Canvas /PrimarySelection getselection /Canvas get def
X end def
X} def
X
X/sendtarget { % string => - (send string to current tty target)
X TtyTarget /Action 3 -1 roll put
X TtyTarget sendevent
X} def
X
X/demo {
X settarget
X (ls\n) sendtarget
X (ps\n) sendtarget
X} def
X
X/demo {
X settarget
X (
X 1 2 add =
X ) sendtarget
X} def
X/demo {
X settarget
X(/settarget { % - => - (set tty target = current selection holder)
X /TtyTarget createevent dup begin
X /Name /InsertValue def
X /Process /PrimarySelection getselection /SelectionHolder get def
X /Canvas /PrimarySelection getselection /Canvas get def
X end def
X} def
X
X/sendtarget { % string => - (send string to current tty target)
X TtyTarget /Action 3 -1 roll put
X TtyTarget sendevent
X} def
X) sendtarget
X} def
X% ---------------------------------------------------------
X/demo {
X /sendtimeevent { % timedelta => -
X createevent begin
X /Name /Timer def
X /TimeStamp exch currenttime add def
X currentdict
X end sendevent
X } def
X
X /p {
X /timercount 0 def
X createevent dup /Name /Timer put expressinterest
X { awaitevent pop
X (Tick\n) print
X /timercount timercount 1 add def
X timercount 10 eq {exit} if
X 1 60 div sendtimeevent
X } loop
X } fork def
X
X p =
X (Starting processes:\n) print
X 1 60 div sendtimeevent
X p waitprocess pop
X p =
X% process(2716670, runnable)
X% Starting processes:
X% Tick
X% Tick
X% Tick
X% Tick
X% Tick
X% Tick
X% Tick
X% Tick
X% Tick
X% Tick
X% process(2716670, zombie)
X} def
X% ---------------------------------------------------------
X/demo {
X /sendnameevent { % name => -
X createevent dup /Name 4 -1 roll put sendevent
X } def
X
X /p1 {
X /p1count 0 def
X createevent dup /Name /Tick put expressinterest
X { awaitevent pop
X (Tick ) print
X /Tock sendnameevent
X /p1count p1count 1 add def
X p1count 10 eq {exit} if
X } loop
X } fork def
X
X /p2 {
X /p2count 0 def
X createevent dup /Name /Tock put expressinterest
X { awaitevent pop
X (Tock!\n) print
X /Tick sendnameevent
X /p2count p2count 1 add def
X p2count 10 eq {exit} if
X } loop
X } fork def
X
X p1 = p2 =
X (Starting processes:\n) print
X /Tick sendnameevent
X 21 {pause} repeat
X p1 = p2 =
X% process(4244540, input_wait)
X% process(2716670, runnable)
X% Starting processes:
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% Tick Tock!
X% process(4244540, zombie)
X% process(2716670, zombie)
X} def
X% ===============================================================
X% ADD MONITORS
X% ===============================================================
X
X% ===============================================================
X% Keyboard
X% ===============================================================
X/snoop {
X /snoopprocess {
X createevent dup /Priority 10 put expressinterest
X {awaitevent dup == redistributeevent} loop
X } fork def
X} def
X/killsnoop {snoopprocess killprocess} def
X
X% snoop
X% event(0x27836C, [184,325], name(/MouseDragged), action(null))
X% event(0x27836C, [186,325], name(28493), action(/DownTransition))
X% event(0x24C17C, [186,325], name(28493), action(/UpTransition))
X% event(0x27836C, [186,325], name(/RightMouseButton), action(/DownTransition))
X% event(0x26CFA4, [170,324], name(/RightMouseButton), action(/UpTransition))
X% event(0x279564, [0,0], name(/DoItEvent), action(/Window))
X% event(0x24C1D8, [169,324], name(/MouseDragged), action(null))
X% killsnoop
X
X% ---------------------------------------------------------
X/demo {(
X% Text Sample (Jerry Farrell)
X/MaxLen 1024 def
X/buffer MaxLen string def
X/buflen 0 def
X
X/addchar {
X buflen MaxLen lt {
X buffer buflen Name put
X /buflen buflen 1 add store
X } if
X} def
X/backchar {
X buflen 0 gt {
X /buflen buflen 1 sub store
X } if
X} def
X/clearline {
X /buflen 0 def
X} def
X/replaceline {
X Action length MaxLen gt {
X /Action Action 0 MaxLen getinterval def
X } if
X buffer 0 Action putinterval
X /buflen Action length store
X} def
X
X/namedict dictbegin
X 8 /backchar load def % BS
X 10 /clearline load def % LF
X 13 /clearline load def % CR
X 21 /clearline load def % ^U
X 32 1 126 { /addchar load def } for % printable characters
X 127 /backchar load def % DEL
X /InsertValue /replaceline load def % strings
Xdictend def
X
X/win framebuffer /new DefaultWindow send def
X{ /PaintClient {
X 1 fillcanvas 0 setgray 10 10 moveto
X buffer 0 buflen getinterval show
X } def
X /FrameLabel (Text Example) def
X /DestroyClient {
X kbdinterests ClientCanvas revokekbdinterests
X KbdHandler killprocessgroup
X } def
X} win send
X/reshapefromuser win send
X/map win send
X
X/KbdHandler {
X /kbdinterests win /ClientCanvas get addkbdinterests def
X { awaitevent begin
X namedict Name known {
X namedict Name get exec
X /paintclient win send
X } if
X end
X } loop
X} fork def
X) runprogram }def
X% ---------------------------------------------------------
X/seteventmgrcallback { % interest proc => -
X /ClientData 10 dict dup /CallBack 5 -1 roll put put
X} def
X/eventmgrkbdinterest { % callback can Editkeys? Fnames? Fstrings? => proc
X [6 1 roll] {
X 3 index addkbdinterests % p can E? FN? FS? a
X exch {[4 index addfunctionstringsinterest] append} if % p can E? FN? a
X exch {[3 index addfunctionnamesinterest] append} if % p can E? a
X exch {[2 index addeditkeysinterest] append} if % p can a
X {2 index seteventmgrcallback} forall % p can
X pop pop
X } append cvx
X} def
X/demo {
X framebuffer setcanvas
X 100 100 translate 0 0 300 300 rectpath
X /can framebuffer newcanvas def
X can reshapecanvas
X can /Mapped true put
X can setcanvas .5 fillcanvas
X
X /MyEventProc {==} def
X /p [
X PointButton {interactivemove .5 fillcanvas}
X /DownTransition can eventmgrinterest
X
X {MyEventProc} can true true false eventmgrkbdinterest
X ] forkeventmgr def
X} def
X% ===============================================================
X% User Interaction
X% ===============================================================
X/interact { % proc startup? => result
X% Repeatedly call proc, with x0 y0 x y defined in a local
X% dictionary, whenever MouseDragged & MouseUp. If startup?
X% also call on initial MouseDown. Returns TOS of tracker.
X% Uses "callback" procedures stored in interests.
X20 dict begin
X /startup? exch def
X /proc exch cvx def
X
X currentcursorlocation /y0 exch def /x0 exch def
X /x x0 def /y y0 def
X /callproc {/x XLocation store /y YLocation store proc} def
X
X MakeInteractInterests
X
X { startup?
X {[StartInterest]}
X {proc [TrackInterest StopInterest]} ifelse
X {expressinterest} forall
X { awaitevent begin
X Interest /ClientData get exec
X end
X } loop
X } fork waitprocess
Xend
X} def
X
X/MakeInteractInterests { % proc startup?
X /StartInterest createevent dup begin
X /Name [/LeftMouseButton /RightMouseButton /MiddleMouseButton] def
X /Action /DownTransition def
X /ClientData {
X /x0 XLocation store /y0 YLocation store
X StopInterest /Name Name put
X TrackInterest expressinterest
X StopInterest expressinterest
X callproc
X } def
X end def
X /TrackInterest createevent dup begin
X /Name /MouseDragged def
X /ClientData {callproc} def
X end def
X /StopInterest createevent dup begin
X /Action /UpTransition def
X /ClientData {callproc exit} def
X end def
X} def
X% ---------------------------------------------------------
X/demo {
X /p { (x0=% y0=% x=% y=%\n) [x0 y0 x y] printf } def
X /p true interact ==
X /p false interact ==
X% x0=463 y0=283 x=463 y=283
X% x0=463 y0=283 x=422 y=267
X% x0=463 y0=283 x=298 y=193
X% x0=463 y0=283 x=238 y=153
X% x0=463 y0=283 x=10 y=59
X% x0=463 y0=283 x=-64 y=37
X% x0=463 y0=283 x=-66 y=35
X% x0=463 y0=283 x=-66 y=35
X% null
X} def
X% ---------------------------------------------------------
X/calcbbox {x0 x min y0 y min x x0 sub abs y y0 sub abs} def
X/getbbox { % canvas pathproc startup? => [x y w h] (relative to canvas)
X gsave
X 3 -1 roll createoverlay setcanvas % pathproc bool
X { erasepage calcbbox
X 4 index cvx exec stroke % use the path proc
X Action /UpTransition eq {
X erasepage [calcbbox]
X } if
X } exch interact % pathproc array
X exch pop % array
X grestore
X} def
X
X/demo {
X framebuffer /starpath true getbbox
X /can exch aload pop framebuffer starcanvas def
X can setcanvas .5 fillcanvas
X} def
X% ---------------------------------------------------------
X/canvasfromuser { % parent pathproc => canvas
X 2 copy true getbbox aload pop % parent proc x y w h
X 6 -2 roll pathcanvas % canvas
X} def
X
X/demo {
X /can framebuffer /starpath canvasfromuser def
X can setcanvas .5 fillcanvas
X} def
X% ---------------------------------------------------------
X/slidecanvas { % canvas startup? => - (interactively move canvas)
X gsave
X 1 index /Parent get setcanvas
X {gsave dup setcanvas x y movecanvas grestore} exch interact
X pop pop
X grestore
X} def
X/slidecanvas { % canvas startup? => - (interactively move canvas)
X gsave
X exch dup /Parent get setcanvas % bool canvas (parent=current)
X dup getcanvaslocation % bool canvas x1 y1
X { gsave 2 index setcanvas % canvas x1 y1
X x x0 sub 2 index add % canvas x1 y1 x
X y y0 sub 2 index add movecanvas % canvas x1 y1
X grestore
X } 5 -1 roll interact % canvas x1 y1 result
X pop pop pop pop
X grestore
X} def
X
X/demo {
X can true slidecanvas
X} def
X% ===============================================================
X% Utilities
X% ===============================================================
X/isutility { % keyword => bool
X load type /arraytype eq =
X} def
X
X/demo {
X /add isutility
X % false
X /rectpath isutility
X % true
X
X% forkeventmgr: interests => process (fork a process with these interests)
X% eventmgrinterest: eventname eventproc action canvas => interest
X
X} def
X% ===============================================================
X% Classes
X% ===============================================================
X/temp { % FCS documentation
X
X/Foo Object % Foo is a subclass of Object
Xdictbegin % (initialized) instance variables
X /Value 0 def
X /Time null def
Xdictend
Xclassbegin
X /ClassTime currenttime def % The class variable "ClassTime".
X
X % class methods
X /new { % - => - (Make a new Foo)
X /new super send begin
X /resettime self send
X currentdict
X end
X } def
X /printvars { % - => - (Print current state)
X (..we got: Value=%, Time=%.\n) [Value Time] printf
X } def
X /changevalue { % value => - (Change the value of "Value")
X /Value exch def
X } def
X /resettime { % - => - (Change Time to the current time)
X /Time currenttime def
X } def
Xclassend def
X
X/foo /new Foo send def
X/printvars foo send
X% ..we got: Value=0, Time=1.31435.
X
X(A String) /changevalue foo send
X/printvars foo send
X% ..we got: Value=A String, Time=1.31435.
X
X/resettime foo send
X/printvars foo send
X% ..we got: Value=A String, Time=1.31667.
X
X{/Time ClassTime def} foo send
X/printvars foo send
X% ..we got: Value=A String, Time=1.31168.
X
X{currenttime Time sub round /changevalue self send} /doit foo send
X/printvars foo send
X% ..we got: Value=0, Time=1.31168.
X
X{currenttime 60 mul round} /changevalue foo send
X/printvars foo send 1000 {pause} repeat /printvars foo send
X% ..we got: Value=79, Time=1.31168.
X% ..we got: Value=81, Time=1.31168.
X
X} def
X% ===============================================================
X/demo { % page 62-65 of smalltalk blue book
X /One Object [] classbegin
X /test {1} def
X /result1 {/test self send} def
X classend def
X
X /Two One [] classbegin
X /test {2} def
X classend def
X
X /ex1 /new One send def
X /ex2 /new Two send def
X
X /test ex1 send =
X /result1 ex1 send =
X /test ex2 send =
X /result1 ex2 send =
X
X /Three Two [] classbegin
X /result2 {/result1 self send} def
X /result3 {/test super send} def
X classend def
X /Four Three [] classbegin
X /test {4} def
X classend def
X
X /ex3 /new Three send def
X /ex4 /new Four send def
X
X /test ex3 send =
X /result1 ex4 send =
X /result2 ex3 send =
X /result2 ex4 send =
X /result3 ex3 send =
X /result3 ex4 send =
X} def
X% ===============================================================
X/Canvas Object [/TheCanvas /EventMgr /Height /Width]
Xclassbegin
X /FillColor 1 1 1 rgbcolor def
X /EdgeColor .5 .5 .5 rgbcolor def
X /EdgeSize 8 def
X
X /new { % ParentCanvas => instance
X /new super send begin
X /TheCanvas exch newcanvas store
X currentdict
X end
X } def
X
X /path {rectpath} def % x y w h => - (currentpath now is my kind of path)
X
X /reshape { % x y w h => -
X gsave
X TheCanvas /Parent get setcanvas
X /Height exch def /Width exch def translate
X 0 0 Width Height /path self send
X TheCanvas reshapecanvas
X grestore
X } def
X
X /reshapefromuser { % - => -
X TheCanvas /Parent get /path true getbbox
X aload pop /reshape self send
X } def
X
X /paint { % - => -
X gsave
X TheCanvas setcanvas
X EdgeColor fillcanvas FillColor setcolor
X EdgeSize 0 0 Width Height % delta x y w h
X insetrect /path self send % -
X fill
X grestore
X } def
X
X /fix { % - => -
X gsave
X TheCanvas setcanvas
X damagepath clipcanvas
X /paint self send
X newpath clipcanvas
X grestore
X } def
X
X /map { % - => -
X EventMgr null eq {/fork self send} if
X TheCanvas /Mapped true put
X } def
X
X /fork { % - => -
X /EventMgr [
X PointButton {TheCanvas canvastotop}
X /DownTransition TheCanvas eventmgrinterest
X
X AdjustButton {TheCanvas false slidecanvas}
X /DownTransition TheCanvas eventmgrinterest
X
X /Damaged {/fix self send}
X null TheCanvas eventmgrinterest
X ] forkeventmgr def
X } def
Xclassend def
X% ---------------------------------------------------------
X/demo {
X /can framebuffer /new Canvas send def
X /reshapefromuser can send
X /map can send
X
X 10 20 100 200 /reshape can send
X} def
X% ---------------------------------------------------------
X/OvalCanvas Canvas []
Xclassbegin
X /path {ovalpath} def
Xclassend def
X
X/demo {
X /can1 framebuffer /new OvalCanvas send def
X /reshapefromuser can1 send
X /map can1 send
X} def
X% ---------------------------------------------------------
X/StarCanvas Canvas []
Xclassbegin
X /EdgeSize 20 def
X /path {starpath} def
Xclassend def
X
X/demo {
X /can2 framebuffer /new StarCanvas send def
X /reshapefromuser can2 send
X /map can2 send
X} def
X% ===============================================================
X% Windows & Menus
X% ===============================================================
X/demo {
X /win framebuffer /new DefaultWindow send def
X { /FrameLabel (USENIX is a Star!) def
X /IconImage /hello_world def
X /PaintClient {
X .5 fillcanvas 1 setshade
X clippath pathbbox starpath fill
X } def
X } win send
X /reshapefromuser win send
X /map win send
X} def
X% ---------------------------------------------------------
X/demo {
X /StarGray 1 def
X /FillGray .5 def
X /FillCanvasWithStar { % stargray fillgray => -
X fillcanvas setshade
X clippath pathbbox starpath fill
X } def
X /SetStarGrays { % stargray fillgray => -
X /FillGray exch store /StarGray exch store
X /paintclient win send
X } def
X
X /win framebuffer /new DefaultWindow send def
X { /FrameLabel (USENIX is a Star!) def
X /PaintIcon {.25 .75 FillCanvasWithStar 0 strokecanvas} def
X /PaintClient {StarGray FillGray FillCanvasWithStar} def
X /ClientMenu [
X (White Star) { 1 FillGray SetStarGrays}
X (Lite Star) {.75 FillGray SetStarGrays}
X (Gray Star) {.50 FillGray SetStarGrays}
X (Dark Star) {.25 FillGray SetStarGrays}
X (Black Star) { 0 FillGray SetStarGrays}
X (White Fill) {StarGray 1 SetStarGrays}
X (Gray Fill) {StarGray .50 SetStarGrays}
X (Black Fill) {StarGray 0 SetStarGrays}
X ] /new DefaultMenu send def
X } win send
X /reshapefromuser win send
X /map win send
X} def
X% ---------------------------------------------------------
X/demo {
X /StarGray 1 def
X /FillGray .5 def
X /FillCanvasWithStar { % stargray fillgray => -
X fillcanvas setshade
X clippath pathbbox starpath fill
X } def
X /SetStarGrays { % stargray fillgray => -
X /FillGray exch store /StarGray exch store
X /paintclient win send
X } def
X
X /GetMenuNumber {/currentkey self send cvr} def % - => num
X /StarGraysMenu
X [(.1) (.2) (.25) (.3) (.4) (.5) (.6) (.7) (.75) (.8) (.9) (1.0)]
X [{GetMenuNumber FillGray SetStarGrays}]
X /new DefaultMenu send def
X /FillGraysMenu
X [(.1) (.2) (.25) (.3) (.4) (.5) (.6) (.7) (.75) (.8) (.9) (1.0)]
X [{StarGray GetMenuNumber SetStarGrays}]
X /new DefaultMenu send def
X
X /win framebuffer /new DefaultWindow send def
X { /FrameLabel (USENIX is a Star!) def
X /PaintIcon {.25 .75 FillCanvasWithStar 0 strokecanvas} def
X /PaintClient {StarGray FillGray FillCanvasWithStar} def
X /ClientMenu [
X (White on Black) { 1 0 SetStarGrays}
X (Black on White) { 0 1 SetStarGrays}
X (Lite on Dark) {.75 .25 SetStarGrays}
X (Star Grays =>) StarGraysMenu
X (Fill Grays =>) FillGraysMenu
X ] /new DefaultMenu send def
X } win send
X /reshapefromuser win send
X /map win send
X} def
X% ===============================================================
X% Custom Windows
X% ===============================================================
X/OvalWindow LiteWindow []
Xclassbegin
X /Border 16 def
X /FrameFillColor .75 .75 .75 rgbcolor def
X
X /ShapeFrameCanvas { % - => - ([Re]set frame canvas' shape)
X gsave
X ParentCanvas setcanvas
X FrameX FrameY translate 0 0 FrameWidth FrameHeight ovalpath
X FrameCanvas reshapecanvas
X grestore
X } def
X /PaintFrame { % - => - (Paint frame canvas)
X FrameFillColor fillcanvas PaintFocus
X } def
X /PaintFocus { % - => - (Paint frame focus)
X gsave
X FrameCanvas setcanvas
X KeyFocus? {0} {FrameFillColor} ifelse setshade
X Border 2 div 0 0 FrameWidth FrameHeight insetrect ovalpath stroke
X grestore
X } def
X /ShapeClientCanvas { % - => - ([Re]set client canvas' shape)
X ClientCanvas null ne {
X gsave
X FrameCanvas setcanvas
X Border 0 0 FrameWidth FrameHeight insetrect
X 4 2 roll translate 0 0 4 2 roll ovalpath
X ClientCanvas reshapecanvas
X grestore
X } if
X } def
Xclassend def
X
X/demo {
X /win framebuffer /new OvalWindow send def
X { /IconImage /hello_world def
X /PaintClient {1 fillcanvas} def
X } win send
X /reshapefromuser win send
X /map win send
X} def
X% ===============================================================
X% Development
X% ===============================================================
X/demo {
X /win framebuffer /new DefaultWindow send def
X /reshapefromuser win send
X /map win send
X
X /paintme {.5 fillcanvas} def
X win /PaintClient {paintme} put
X} def
X% ---------------------------------------------------------
X/runprogram { % string => - (exececute the string as a psh program)
X (/tmp/pshscript) (w) file % str file
X dup 3 -1 roll % file file str
X writestring closefile % -
X (psh /tmp/pshscript) forkunix
X} def
X%
X% timeit
X%
X/Temp 10 dict dup begin
X /timeitms { % - => int
X % (T2-T1)*60000/Count -or- (T2-T1)/(minim*Count)
X T2 T1 sub
X 60000 mul
X Count div
X % truncate at third decimal.
X 1000 mul round 1000 div
X } def
Xend def
X/timeit { % count test => -
X //Temp begin
X /Proc 1 index def
X /Count 2 index def
X /T1 currenttime def
X end
X repeat currenttime
X //Temp begin
X /T2 exch def
X (Time: % ms, Loops: %, Test: ) [timeitms Count] printf /Proc load ==
X end
X} def
X%------------------------------------------
X% from Sam Leffler @ Pixar
X% Time: 6998.291 ms
X/bubblesort { % array => array (sort array with bubble sort)
X10 dict begin
X /a exch def
X a length 2 sub -1 -1 { % for j=n-2 step -1 until 0 do
X 0 1 3 -1 roll { % for i=0 step 1 until j do
X /i exch def
X a i 1 add get a i get lt { % if a[i+1] < a[i] then
X a i get % a[i]
X a i 1 add get a i 3 -1 roll put % a[i] = a[i+1]
X a i 1 add 3 -1 roll put % a[i+1] = a[i]
X } if
X } for
X } for
X a
Xend
X} def
X%------------------------------------------
X% Time: 1952.82 ms (358% faster!)
X/SiftDown { % L U => -
X /U exch def
X /L exch def
X /Xl X L get def
X {
X /C L 2 mul 1 add def
X C U gt {exit} if
X /Xc X C get def
X /C+1 C 1 add def
X
X C+1 U le {
X X C+1 get dup Xc Bigger?
X {/Xc exch def /C C+1 def} {pop} ifelse
X } if
X
X Xl Xc Bigger? {exit} if
X X L Xc put
X /L C def
X } loop
X X L Xl put
X} def
X/heapsort { % array proc => array (sorted)
X10 dict begin
X /Bigger? exch cvx def % a b bigger? => t if a>b
X /X exch def
X /N X length 1 sub def
X
X % Make the heap
X N % X N
X dup 1 sub 2 div floor -1 0 { % N n; for: |N/2| -1 0
X 1 index SiftDown
X } for % N
X
X % Sort the heap
X -1 1 { % i:N -1 1
X /I exch def
X X 0 get X I get
X X 0 3 -1 roll put
X X I 3 -1 roll put
X 0 I 1 sub SiftDown
X } for
X X
Xend
X} def
X
X% Time: 1679.69 ms (16% faster than above)
X/SiftDown { % L U => -
X /U exch def
X /L exch def
X /Xl X L get def
X { L 2 mul 1 add % C (i.e child index)
X dup U gt {pop exit} if
X X 1 index get % C Xc
X 1 index 1 add % C Xc C+1
X
X dup U le {
X X 1 index get % C Xc C+1 Xc+1
X dup 3 index Bigger? {4 2 roll} if
X pop pop % C' Xc' (largest child)
X } {pop} ifelse
X
X Xl 1 index Bigger? {pop pop exit} if
X X L 3 -1 roll put
X /L exch def
X } loop
X X L Xl put
X} def
X/heapsort { % array proc => array (sorted)
X10 dict begin
X /Bigger? exch cvx def % a b bigger? => t if a>b
X /X exch def
X
X % Make the heap
X X dup length 1 sub % X N
X dup 1 sub 2 div floor -1 0 { % X N for: |N/2| -1 0
X 1 index SiftDown
X } for % X N
X
X % Sort the heap
X -1 1 { % X i:N -1 1
X 2 copy 1 index 0 % X i X i X 0
X 4 copy get 3 1 roll get exch % X i X i X 0 Xi X0
X 4 1 roll put put % X i
X
X 0 exch 1 sub SiftDown
X } for
Xend
X} def
X
X% Time: 1599.43 ms (6% faster than above)
X% Converting /Bigger? to use /gt rather than {gt}: 1499.634!
X% Using gt rather than Bigger? 100ms faster.
X/SiftDown { % X L U => -
X 3 1 roll 2 copy get exch % U X Xl L
X {
X dup 2 mul 1 add % U X Xl L C (i.e child index)
X dup 5 index gt {pop exit} if % C>U: exit
X 3 index 1 index get % U X Xl L C Xc
X 1 index 1 add % U X Xl L C Xc C+1
X
X dup 7 index le { % C+1<=U: check right child
X 5 index 1 index get % U X Xl L C Xc C+1 Xc+1
X dup 3 index Bigger? % Xc+1 > Xc: roll
X {4 2 roll} if
X pop pop % U X Xl L C' Xc' (largest child)
X } {pop} ifelse
X % U X Xl L C Xc
X 3 index 1 index Bigger? % Xl > Xc: exit
X {pop pop exit} if
X 4 index 3 index 3 -1 roll put % U X Xl L C; X[L]=Xc
X exch pop % U X Xl L'; L=C
X } loop
X exch put pop % -; X[L]=Xl
X} def
X/heapsort { % array proc => array (sorted)
X10 dict begin
X /Bigger? exch cvx def % a b bigger? => t if a>b
X
X % Make the heap
X dup length 1 sub % X N
X dup 1 sub 2 div floor -1 0 { % X N n ; for: |N/2| -1 0
X 3 copy exch SiftDown pop
X } for % X N
X
X % Sort the heap
X -1 1 { % X i:N -1 1
X
X 57 type =
X 11.56 type =
X true type =
X (Foo) type =
X /Foo type =
X [1 2 3] type =
X {3 4 add} type =
X {3 4 add} xcheck =
X 10 dict type =
X
X clear pstack
X 64 (Hi) /Name pstack
X exch pstack
X dup pstack
X 2 index pstack
X pop pop pstack
X 3 1 roll
X pstack
X 3 copy
X pstack
X
X clear
X
X
X /min
X {dup 2
X index
X lt
X pstack
X
X {xch
X pop
X (1st)
X ==}
X
X {op
X (2nd)
X ==}
X
X ielse
X } def
X
X 76
X -6
X min
X ==
X
X
X
X -676 m =
X 2 copy 1 index 0 % X i X i X 0
X 4 copy get 3 1 roll get exch % X i X i X 0 Xi X0
X 4 1 roll put put % X i
X 2 copy 1 sub 0 exch SiftDown pop % X
X } for
Xend
X} def
X%------------------------------------------
X
X
//go.sysin dd *
if [ `wc -c < scrap.ps` != 34241 ]; then
made=false
echo error transmitting scrap.ps --
echo length should be 34241, not `wc -c < scrap.ps`
else
made=true
fi
if $made; then
chmod 664 scrap.ps
echo -n ' '; ls -ld scrap.ps
fi
echo Extracting cond.ps
sed 's/^X//' <<'//go.sysin dd *' >cond.ps
Xsystemdict begin
X
X/setpacking {pop} ?def
X/currentpacking false ?def
X
X%
X% A "cond" (condition) statement: Consists of predicate-proc pairs.
X% The first predicate that evaluates to true executes its correnponding
X% procedure. Thus:
X%
X% 2 {
X% {dup 1 eq} {(one)}
X% {dup 2 eq} {(two)}
X% true {(other)}
X% } cond
X%
X% results in "2 (two)" being left on the stack. Note "true" effects
X% a default branch.
X%
X% The implementation is very wierd. Here are the author's notes:
X% Here's another entry in the cond-test. It's like Owen & Jerry's last
X% ones in that it uses forall to step through all the elements, except
X% instead of leaving a boolean or integer on the top of the stack to tell
X% it what to do on the next iteration, it puts the code to be executed
X% itself. Notice the mind-bending self referentiality:
X%
X% NextProc contains the code to be executed the next time a test is to be
X% made, "exec null exit" gets executed in the clause after a true result,
X% "pop /NextProc" gets executed in the clause after a false result -
X% which is setting up for the next test.
X%
X% The "/NextProc" in the definition of /NextProc should really be
X% //NextProc except that NextProc isn't defined yet...
X% I then reach into the array and install it after /NextProc
X% is defined.
X%
Xcurrentpacking % bool left on stack for later setpacking call
Xfalse setpacking
X/NextProc { exec { { exec null exit } } { { pop /NextProc } } ifelse } def
X//NextProc 2 get 0 get 1 //NextProc put % replace placeholder by a recursion
Xsetpacking
X
X/cond { % args array => args
X //NextProc % args a nextproc
X exch { % args nextproc ai
X exch exec % args newnextproc
X } forall
X pop
X} ?def
Xcurrentdict /NextProc undef
X
Xend % systemdict
//go.sysin dd *
if [ `wc -c < cond.ps` != 1749 ]; then
made=false
echo error transmitting cond.ps --
echo length should be 1749, not `wc -c < cond.ps`
else
made=true
fi
if $made; then
chmod 664 cond.ps
echo -n ' '; ls -ld cond.ps
fi
echo Extracting trace.ps
sed 's/^X//' <<'//go.sysin dd *' >trace.ps
X% Copyright (c) 1989, Sun Microsystems, Inc. RESTRICTED RIGHTS LEGEND:
X% Use, duplication, or disclosure by the Government is subject to
X% restrictions as set forth in subparagraph (c)(1)(ii) of the Rights in
X% Technical Data and Computer Software clause at DFARS 52.227-7013 and
X% in similar clauses in the FAR and NASA FAR Supplement.
X%
X% @(#)trace.ps 1.9 89/05/17
X%
X
X% Trace utilities.
X
X% How to use the trace utilities.
X%
X% Here is a summary of the most commonly used trace functions. See the
X% documentation above the function definitions in the code for more
X% information and for more functions.
X%
X% /<function> trace % find fn in dict stack
X% /<method> /trace <object> send % find fn in class dict stack
X% /<function> untrace
X% /<method> /untrace <object> send
X%
X% listtraces % list all set traces
X% untraceall % remove all set traces
X%
X% /traceclass <class> send % trace all methods in a class
X% /untraceclass <class> send
X%
X% /<method> /tracesupers <object> send % trace method in class & all supers
X% /<method> /untracesupers <object> send
X%
X% The trace works by replacing the function's definition with one that
X% wraps the original definition with calls to functions tracein and
X% traceout. The default versions of these functions print the
X% dictionary and name of the traced function, and the dictionary stack.
X% Untrace removes the wrapper. Here are some samples:
X%
X% /reshape /trace ClassButton send
X% /but /demo OpenLookButton send def
X% /B /setname but send
X% 0 0 100 20 /reshape but send
X% In ClassButton /reshape ["B"]: 0 0 100 20
X% Out ClassButton /reshape ["B"]: Empty stack
X%
X% The last two lines are produced by trace. They show the class and
X% method being entered and exited, the object on the top of the dict
X% stack, i.e. the instance to which /reshape was sent, and the operand
X% stack contents. Since we used /setname to name the instance "B", that
X% is what trace prints.
X%
X% Here's a more involved example:
X%
X% /newinit /tracesupers ClassButton send
X% listtraces
X% Object: /newinit
X% ClassCanvas: /newinit
X% ClassControl: /newinit
X% ClassButton: /newinit
X%
X% (Hello) {pop} framebuffer /new OpenLookButton send
X% In ClassButton /newinit [.OpenLookButton]: (Hello) array{1}
X% In ClassControl /newinit [.OpenLookButton]: (Hello) array{1}
X% In ClassCanvas /newinit [.OpenLookButton]: (Hello) array{1}
X% In Object /newinit [.OpenLookButton]: (Hello) array{1}
X% Out Object /newinit [.OpenLookButton]: (Hello) array{1}
X% Out ClassCanvas /newinit [.OpenLookButton]: (Hello) array{1}
X% Out ClassControl /newinit [.OpenLookButton]: (Hello)
X% In Object /newinit [.OpenLookButtonGraphic]: (Hello)
X% Out Object /newinit [.OpenLookButtonGraphic]: (Hello)
X% Out ClassButton /newinit [.OpenLookButton]: Empty stack
X%
X% This illustrates:
X% /tracesupers traces a method in all superclasses.
X% listtraces shows traced methods and their classes.
X% Trace output is indented to show nested calls.
X% Unnamed instances of classes are printed as .ClassName
X%
X% If you turn off autobinding you can trace operators:
X%
X% false setautobind
X% /add trace
X% 5 6 add
X% In systemdict /add []: 5 6
X% Out systemdict /add []: 11
X%
X% You can even trace send. If you are feeling real adventurous, try
X% tracing def or store!
X
X
X% Implementation:
X%
X% The /trace function finds the named function in a dictionary then wraps
X% the function with calls to the tracein and traceout functions. The
X% /untrace function finds the function, looks at it to see if it has the
X% trace wrapper, then removes the wrapper.
X%
X% An array of traced functions is kept in tracelist. Since the first
X% two elements of the trace wrapper are the dictionary and function name
X% of the traced function, they can be used to locate the function for
X% removing the trace. Function /untraceall goes through the list and
X% removes all the traces. Function /listtraces displays all functions
X% in the list.
X
Xsystemdict begin
X
X/print-operator /print load def
X/printf-operator /printf load def
X
X % NeWS 1.1 compatibility
X
X %
X
X systemdict /XNeWS? known not {
X systemdict /XNeWS? false put
X } if
X
X XNeWS? not { % Is it NeWS 1.1?
X
X% Force print not to autobind
X/print {//print-operator} def
X/printf {//printf-operator} def
X
X/setpacking {pop} ?def
X/currentpacking false ?def
X
X% from basics.ps
X
X%
X% A "cond" (condition) statement: Consists of predicate-proc pairs.
X% The first predicate that evaluates to true executes its correnponding
X% procedure. Thus:
X%
X% 2 {
X% {dup 1 eq} {(one)}
X% {dup 2 eq} {(two)}
X% true {(other)}
X% } cond
X%
X% results in "2 (two)" being left on the stack. Note "true" effects
X% a default branch.
X%
X% The implementation is very wierd. Here are the author's notes:
X% Here's another entry in the cond-test. It's like Owen & Jerry's last
X% ones in that it uses forall to step through all the elements, except
X% instead of leaving a boolean or integer on the top of the stack to tell
X% it what to do on the next iteration, it puts the code to be executed
X% itself. Notice the mind-bending self referentiality:
X%
X% NextProc contains the code to be executed the next time a test is to be
X% made, "exec null exit" gets executed in the clause after a true result,
X% "pop /NextProc" gets executed in the clause after a false result -
X% which is setting up for the next test.
X%
X% The "/NextProc" in the definition of /NextProc should really be
X% //NextProc except that NextProc isn't defined yet...
X% I then reach into the array and install it after /NextProc
X% is defined.
X%
Xcurrentpacking % bool left on stack for later setpacking call
Xfalse setpacking
X% Beginning of string
X% This is a string so the scanner doesn't see //NextProc before it's defined.
X(
X/NextProc { exec { { exec null exit } } { { pop /NextProc } } ifelse } def
X//NextProc 2 get 0 get 1 //NextProc put % replace placeholder by a recursion
Xsetpacking
X
X/cond { % args array => args
X //NextProc % args a nextproc
X exch { % args nextproc ai
X exch exec % args newnextproc
X } forall
X pop
X} ?def
Xcurrentdict /NextProc undef
X% End the string and execute it:
X) cvx exec
X
X/isarray? { % any => boolean
X type dup /arraytype eq exch /packedarraytype eq or
X} def
X
X% from util.ps
X
X%%%%%%%%%%%%%%%%%%%
X% array utilities %
X%%%%%%%%%%%%%%%%%%%
X
X/arraycontains? { % array value => bool ; returns true if value is in array.
X exch false exch { % value bool ai
X 2 index eq {pop true exit} if
X } forall % value bool
X exch pop
X} def
X
X/arraysequal? { % A B => bool
X 0 exch { % A i bi
X 2 index 2 index get ne % A i bool
X {exit} {1 add} ifelse % A i
X } forall
X exch length eq
X} def
X
X/arrayindex { % array value => index true -or- false
X exch 0 exch { % value i ai
X 2 index eq % value i
X {exch pop true exit} {1 add} ifelse
X } forall % i true -or- value i
X dup true ne {pop pop false} if % i true -or- false
X} def
X
X% From class.ps
X(
X/Temp 10 dict dup begin
X /dicttype dup def
X /canvastype dup def
X /eventtype dup def
X /processtype dup def
Xend def
X/isobject? { % obj => bool; test for "sendable" object (instance or class).
X //Temp 1 index type known {
X /ParentDictArray known
X } {pop false} ifelse
X} def
X/isclass? { % obj => bool; test for class.
X //Temp 1 index type known {
X /ClassName known
X } {pop false} ifelse
X} def
X/isinstance? { % obj => bool; test for instance of class.
X //Temp 1 index type known {
X dup /ParentDictArray known exch /ClassName known not and
X } {pop false} ifelse
X} def
X) cvx exec
X
X{ % Send to Object:
X /installmethod { % name proc => -; compile and install a new method.
X ParentDict % NeWS 1.1 /methodcompile takes different args!
X /methodcompile self send def
X } dup exec % what convenience!
X
X /superclasses { % - => array ;return inheritance array.
X ParentDictArray
X dup type /dicttype eq {
X dup /ParentDictArray get
X exch 1 array astore append
X } if
X } installmethod
X % NeWS 1.1 has subclass names, instead of the actual subclasses
X /subclasses {
X [ SubClasses {
X dup where {
X exch get
X } { pop } ifelse
X } forall
X ]
X } installmethod
X
X % Routines to handle promotion of defaults to instance vars.
X % promote: promote a class variable to an instance variable.
X % promoted?: check if the variable is an instance variable.
X % ?promote: promote variable if it differs from the class version.
X % unpromote: remove variable from instance vars.
X /promote {self 3 1 roll put} installmethod % name object => -
X /promoted? {self exch known} installmethod % name => bool
X /unpromote {self exch undef} installmethod % name => -; remove name as an instance
X /?promote { % name object => -
X % Note: the value of the variable is determined by /send because
X % it may be executable.
X 2 copy exch self send eq {pop pop} {/promote self send} ifelse
X } installmethod
X
X /classname { ClassName } def
X
X /name { Name } installmethod % - => name
X /setname { self /Name 3 -1 roll put } installmethod % name => -
X /id { ID } installmethod % - => name
X /setid { self /ID 3 -1 roll put } installmethod % name => -
X
X% Class Variables
X /Name {ClassName} def
X /ID null def
X
X} Object send
X
X } if % end if NeWS 1.1
X
X % CyberSpace pallet interface
X
X/args { pop pop } ?def
X
X/TraceDict 200 dict def
XTraceDict begin
X /list-traces /listtraces def
X /show-trace-stats /showtracestats def
X /list-callcount-stats {
X /callcount listtracestats
X } def
X /list-totaltime-stats {
X /totaltime listtracestats
X } def
X /clear-trace-stats { {procname} null args
X cleartracestats
X } def
X /set-trace-output { null null args
X currentfile settraceoutput
X } def
X /set-trace-default { null null args
X /defaulttracein /defaulttraceout settracefunctions
X } def
X /set-trace-fast { null null args
X /fasttracein /fasttraceout settracefunctions
X } def
X /trace-name { {procname} null args
X trace
X } def
X /trace-class-method { {class procname} null args
X exch /trace exch send
X } def
X /untrace-name { {procname} null args
X trace
X } def
X /untrace-all /untraceall def
X /trace-list { null {array} args
X tracelist
X } def
X /trace-class { {class} null args
X /traceclass exch send
X } def
X /untrace-class { {class} null args
X /traceclass exch send
X } def
X /trace-supers { {class procname} null args
X exch /tracesupers exch send
X } def
X /untrace-supers { {class procname} null args
X exch /untracesupers exch send
X } def
X /trace-subclasses { {class} null args
X /tracesubclasses exch send
X } def
X /trace-superclasses { {class} null args
X /tracesubclasses exch send
X } def
Xend
X
X % This function in systemdict makes sure ClassName is always in a
X % dictionary on the dict stack. Objects all have their own class
X % name. This function provides names for /systemdict and /userdict.
X % It returns the dictionary itself for other dictionaries.
X %
X % The use of this is a little bad and hacky because /ClassName is used
X % as a method for any object (including classes themselves), even though
X % it is not an advertised method in class Object.
X %
X /ClassName { % - => name | dict
X currentdict
X dup userdict eq {pop /userdict} if
X dup systemdict eq {pop /systemdict} if
X } def
X
X % Each traced function has a dictionary of information about the function.
X % The dictionary contains:
X %
X % Key Value
X % /dictname Printable name of dictionary (class) containing routine
X % /fnname Printable name of function
X % /fndict The actual dictionary containing the routine
X % /callcount Number of times routine is called
X % /totaltime Total time spent in the routine
X % /stackdelta Change in # of objects on stack from entry to exit
X
X % Array of info dicts for all traced functions.
X %
X /tracelist [] def
X
X
X% Functions for Setting and Removing Traces:
X
X % Add trace to a function. Usually used in a send context on a
X % method in a class.
X %
X % /procname trace
X % /procname /trace object send
X %
X /trace { % procname => -
X %
X % Locate the named proc by finding the given name in the current
X % dictionary stack. Get the value associated with it, usually a
X % function. Construct a new function that is the old one with a
X % wrapper around it. The new function is:
X %
X % {<tracedict> tracein <oldproc> exec <tracedict> traceout}
X %
X % Where <tracedict> is a dictionary with the keys listed above.
X %
X % If the proc is already of the form above, i.e. is already being
X % traced, the trace function does nothing.
X %
X 4 dict begin
X /proc exch def
X proc where {
X /dct exch def
X /dctname /ClassName dct send def
X
X dct proc get istraced? not {
X
X % Create trace info dictionary.
X /tracedict 6 dict dup begin
X /dictname dctname def
X /fnname proc def
X /fndict dct def
X /callcount 0 def
X /stackdelta null def
X /totaltime 0 def
X end def
X
X % Add trace info dict to trace array.
X tracelist [tracedict] append
X /tracelist exch store
X
X % Build wrapper code.
X [
X tracedict /tracein cvx
X dct proc get
X dup isarray? {/exec cvx} if
X tracedict /traceout cvx
X ] cvx
X
X % Store new wrapped code in place of old.
X dct proc 3 -1 roll put
X } if
X } if
X end
X } def
X
X % Remove trace from one method.
X %
X % /procname untrace
X % /procname /untrace object send
X %
X /untrace { % procname => -
X %
X % The given proc is located in the current dictionary stack, and
X % if it has the trace wrapper code, the wrapper code is removed
X % and the trace dict is removed from the tracelist array.
X %
X 1 dict begin
X /proc exch def
X
X proc load % proc
X dup istraced? {
X dup 0 get exch % tracedict proc
X 2 get % tracedict oldproc
X proc exch store % tracedict
X
X % Remove from tracelist.
X tracelist exch arrayindex {
X tracelist exch arraydelete
X /tracelist exch store
X } if
X } {pop} ifelse
X end
X } def
X
X % Return true if the given proc has the trace wrapper around it.
X %
X /istraced? { % proc => -
X dup isarray? {
X dup length 5 ge {
X 1 get /tracein eq
X } {pop false} ifelse
X } {pop false} ifelse
X } def
X
X % Remove all traces that have been set.
X %
X /untraceall { % - => -
X % Note: we loop through a copy of the tracelist array because
X % untrace alters the original array.
X tracelist dup length array copy {
X begin % tracedict
X fndict begin % dict containing routine
X fnname untrace
X end
X end
X pause
X } forall
X /trace_level 0 store
X } def
X
X % Trace all methods in a class.
X %
X % /traceclass class send
X %
X /traceclass { % - => -
X % Note: check for class Object is a kludge because some methods
X % in that class are used by the trace utilities and infinite
X % loops can occur if they are traced.
X Object currentdict ne {
X currentdict {
X xcheck {trace} {pop} ifelse
X } forall
X } if
X } def
X
X % Untrace all methods in a class.
X %
X % /untraceclass class send
X %
X /untraceclass { % - => -
X currentdict {
X xcheck {untrace} {pop} ifelse
X } forall
X } def
X
X % Trace a method in a class and all its superclasses.
X %
X % /method /tracesupers class send
X % /method /tracesupers object send
X %
X /tracesupers { % method => -
X /superclasses self send self arrayappend {
X 2 copy exch known {
X 2 copy /trace exch send
X } if
X pop
X } forall
X pop
X } def
X
X % Untrace a method in a class and all its superclasses.
X %
X % /method /untracesupers class send
X % /method /untracesupers object send
X %
X /untracesupers { % method => -
X /superclasses self send self arrayappend {
X 2 copy exch known {
X 2 copy /untrace exch send
X } if
X pop
X } forall
X pop
X } def
X
X % Trace a class and all its subclasses.
X %
X % /tracesubclasses class send
X %
X /tracesubclasses { % - => -
X {(Tracing %\n) [/classname self send] printf} traceoutput
X /traceclass self send
X /subclasses self send {
X pause
X /tracesubclasses exch send
X } forall
X } def
X
X % Trace a class and all its superclasses.
X %
X % /tracesuperclasses class|instance send
X %
X /tracesuperclasses { % - => -
X {(Tracing %\n) [/classname self send] printf} traceoutput
X /traceclass self send
X /superclasses self send {
X pause
X /traceclass exch send
X } forall
X } def
X
X
X% Functions for Displaying Traces and Statistics:
X
X % List all traced functions.
X %
X /listtraces { % - => -
X {
X tracelist {
X begin
X (%: /%\n)
X [dictname fnname] printf
X end
X } forall
X } traceoutput
X } def
X
X % Display the stats collected for a particular proc.
X %
X /showtracestats { % procname => -
X load
X dup istraced? {
X 0 get begin
X {
X (% /%:\n) [dictname fnname] printf
X ( Calls: %\n) [callcount] printf
X ( Time: %\n) [totaltime] printf
X ( Stack delta: ) printf stackdelta ==
X } traceoutput
X end
X } {pop} ifelse
X } def
X
X % Show a sorted list of all traced functions with statistics.
X % Argument is the name of the field to sort by: /callcount or /totaltime.
X %
X % /callcount: sort by how often function was called
X % /totaltime: sort by total time spent in function
X %
X /listtracestats { % sortby => -
X 1 dict begin
X /attribute exch def
X
X % Build array of all functions that were called at least once.
X [tracelist {dup /stackdelta get null eq {pop} if} forall]
X
X % Sort the array.
X {
X attribute get exch
X attribute get exch
X lt
X } quicksort % array
X
X {
X {
X begin
X (% %: /% /callcount=% /totaltime=% stack=%\n)
X [attribute cvx exec
X dictname fnname callcount totaltime stackdelta]
X printf
X end
X } forall
X } traceoutput
X end
X } def
X
X % Zero the function call counts for all traced routines.
X %
X /cleartracestats { % - => -
X tracelist {
X dup /callcount 0 put
X /totaltime 0 put
X } forall
X } def
X
X
X% Functions Called on Entry and Exit of Traced Functions:
X
X % Note: Functions called within traces are bound immediately so you can
X % trace any operator inside them (e.g. send, store) without worrying about
X % infinite recursion. It is assumed that these operators are not
X % traced when these functions are defined.
X
X /trace_level 0 def
X /trace_indent 1 def
X /trace_stackcounts 100 array def
X /trace_entertimes 100 array def
X
X % Function called on entry to traced function.
X %
X /tracein { % tracedict => -
X pop
X } def
X
X % Function called on exit from traced function.
X %
X /traceout { % tracedict => -
X pop
X } def
X
X % Change trace in and trace out functions. The arguments are either
X % executable arrays or the names of functions.
X %
X /settracefunctions { % tracein traceout => -
X dup xcheck not {load} if
X /traceout exch store
X dup xcheck not {load} if
X /tracein exch store
X } def
X
X % The next two functions display messages of the form
X %
X % In/Out <class> /<method> [<object>]: <stack>
X %
X % Where <class> is the dictionary containing the traced function,
X % <method> is the name of the traced function,
X % <object> is the printable name of the currentdict
X % <stack> is the current contents of the operand stack.
X %
X % The messages are prefixed by blank spaces so the nesting structure
X % is apparent visually. Each Out message is always aligned directly
X % below its corresponding In message.
X
X % Function called on entry into a traced function.
X %
X /defaulttracein { % tracedict => -
X count trace_stackcounts trace_level 3 -1 roll put
X
X {
X begin
X trace_level trace_indent mul { ( ) print } repeat
X (In % /% [%]: )
X [dictname fnname
X currentdict end
X currentdict isobject?
X {currentdict objectstring} {nullstring} ifelse
X exch begin
X ] printf
X /callcount callcount 1 add store
X end
X showstack
X } traceoutput
X
X trace_entertimes trace_level
X /trace_level trace_level 1 add store
X currenttime put
X } bind def
X
X % Function called on exit from a traced function.
X %
X /defaulttraceout { % tracedict => -
X currenttime
X /trace_level trace_level 1 sub store
X trace_entertimes trace_level get sub exch % time tracedict
X
X begin % time
X count trace_stackcounts trace_level get sub % time count
X
X % Update the stack delta.
X dup stackdelta eq {pop}{
X stackdelta type {
X /integertype {[exch stackdelta]}
X /arraytype {
X stackdelta 1 index arraycontains? {
X pop stackdelta
X }{
X [exch] stackdelta append
X } ifelse
X }
X } case
X /stackdelta exch store
X } ifelse
X
X totaltime add
X /totaltime exch store
X {
X trace_level trace_indent mul { ( ) print } repeat
X (Out % /% [%]: )
X [dictname fnname
X currentdict end
X currentdict isobject?
X {currentdict objectstring} {nullstring} ifelse
X exch begin
X ] printf
X showstack
X } traceoutput
X end
X } bind def
X
X % A tracein function that collects stats without printing anything.
X %
X /fasttracein { % tracedict => -
X begin
X /callcount callcount 1 add store
X /stackdelta 99 store
X end
X
X trace_entertimes trace_level
X /trace_level trace_level 1 add store
X currenttime put
X } bind def
X
X % A traceout function that collects stats without printing anything.
X %
X /fasttraceout { % tracedict => -
X currenttime
X /trace_level trace_level 1 sub store
X trace_entertimes trace_level get sub exch % time tracedict
X
X begin
X totaltime add
X /totaltime exch store
X end
X } bind def
X
X % Initialize the tracein and traceout functions to the defaults.
X %
X /defaulttracein /defaulttraceout settracefunctions
X
X% Functions for Printing Objects:
X
X % Return a printable string for an object.
X %
X % type = nametype:
X % Executable: name
X % Non-executable: /name
X % type = stringtype: (string)
X % Objects:
X % Class: ClassName
X % Named instance: "name"
X % Other instances: .ClassName
X % Special dicts:
X % systemdict: systemdict
X % userdict: userdict
X %
X /objectstring { % object => string
X dup type {
X /nametype {dup xcheck {(%)}{(/%)} ifelse [3 -1 roll] sprintf}
X /stringtype {((%)) [3 -1 roll] sprintf}
X /Default {
X dup isobject? {
X dup isclass? {
======== END OF cyber.shar.splitag ========