ref: 4fe7daeca4d8cc06e50b5862f3f6bc9c71cbf835
dir: /sys/lib/postscript/prologues/grabit.ps/
%
% Dump a PostScript object, occasionally in a form that can be sent back
% through the interpreter. Similiar to Adobe's == procedure, but output
% is usually easier to read. No binding so operators like rcheck and exec
% can be conviently redefined.
%
/GrabitDict 100 dict dup begin
/recursive true def
/scratchstring 200 string def
/slowdown 100 def
/column 0 def
/lastcolumn 80 def
/level 0 def
/multiline 100 array def
/nextname 0 def
/arraylength 0 def
/lengthonly false def
/GrabitSetup {
counttomark {OmitNames exch true put} repeat pop
0 0 moveto % for hardcopy output
} def
/OmitNames 30 dict def % ignore these names
/OtherDicts 200 dict def % unrecognized dictionaries
%
% All strings returned to the host go through Print. First pass through an
% array has lengthonly set to true.
%
/Print {
dup type /stringtype ne {scratchstring cvs} if
lengthonly {
length arraylength add /arraylength exch def
}{
dup length column add /column exch def
print flush
slowdown {1 pop} repeat
} ifelse
} def
/Indent {level {( ) Print} repeat} def
/Newline {(\n) Print lengthonly not {/column 0 def} if} def
/NextLevel {/level level 1 add def multiline level 0 put} def
/LastLevel {/level level 1 sub def} def
%
% Make a unique name for each unrecognized dictionary and remember the name
% and dictionary in OtherDicts.
%
/Register {
dup type /dicttype eq {
/nextname nextname 1 add def
dup (UnknownDict ) dup
(UnknownDict) length nextname ( ) cvs putinterval
0 (UnknownDict) length nextname ( ) cvs length add getinterval cvn
exch OtherDicts 3 1 roll put
} if
} def
%
% Replace array or dictionary values by known names. Lookups are in the
% standard PostScript dictionaries and in OtherDicts. If found replace
% the value by the name and make it executable so nametype omits the
% leading /.
%
/Replace {
false
1 index type /dicttype eq {pop true} if
1 index type /arraytype eq 2 index xcheck not and {pop true} if
{
false
[userdict systemdict statusdict serverdict OtherDicts] {
{
3 index eq
{exch pop exch pop cvx true exit}
{pop}
ifelse
} forall
dup {exit} if
} forall
pop
} if
} def
%
% Simple type handlers. In some cases (e.g. savetype) what's returned can't
% be sent back through the interpreter.
%
/booleantype {{(true )}{(false )} ifelse Print} def
/marktype {pop (mark ) Print} def
/nulltype {pop (null ) Print} def
/integertype {Print ( ) Print} def
/realtype {Print ( ) Print} def
/filetype {pop (-file- ) Print} def
/fonttype {pop (-fontID- ) Print} def
/savetype {pop (-saveobj- ) Print} def
%
% Special formatting for operators is enabled if the flag in multiline
% (for the current level) is set to 1. In that case each operator, after
% being printed, is looked up in OperatorDict. If found the value is used
% as an index into the OperatorProcs array and the object at that index
% is retrieved and executed. Currently only used to choose the operators
% that end a line.
%
/operatortype {
dup Print ( ) Print
multiline level get 1 eq {
scratchstring cvs cvn dup OperatorDict exch known {
OperatorDict exch get
OperatorProcs exch get exec
}{
pop
column lastcolumn gt {Newline Indent} if
} ifelse
}{pop} ifelse
} def
%
% Executable names are passed to operatortype. Non-executable names get a
% leading /.
%
/nametype {
dup xcheck {
operatortype
}{
(/) Print Print ( ) Print
} ifelse
} def
%
% Arrays are processed in two passes. The first computes the length of the
% string returned to the host without any special formatting. If it extends
% past the last column special formatting is enabled by setting a flag in
% array multiline. Arrays are processed in a for loop so the last element
% easily recognized. At that point special fortmatting is disabled.
%
/packedarraytype {arraytype} def
/arraytype {
NextLevel
lengthonly not {
/lengthonly true def
/arraylength 0 def
dup dup type exec
arraylength 20 gt arraylength column add lastcolumn gt and {
multiline level 1 put
} if
/lengthonly false def
} if
dup rcheck not {
(-array- ) Print pop
}{
dup xcheck {({)}{([)} ifelse Print
multiline level get 0 ne {Newline Indent}{( ) Print} ifelse
0 1 2 index length 1 sub {
2 copy exch length 1 sub eq multiline level get 1 eq and {
multiline level 2 put
} if
2 copy get exch pop
dup type /dicttype eq {
Replace
dup type /dicttype eq {
dup Register Replace
recursive {
2 copy cvlit
/def load 3 1 roll
count 3 roll
} if
exch pop
} if
} if
dup type exec
dup xcheck not multiline level get 1 eq and {
0 index type /arraytype eq
1 index type /packedarray eq or
1 index type /stringtype eq or {Newline Indent} if
} if
} for
multiline level get 0 ne {Newline LastLevel Indent NextLevel} if
xcheck {(} )}{(] )} ifelse Print
} ifelse
LastLevel
} def
%
% Dictionary handler. Try to replace the value by a name before processing
% the dictionary.
%
/dicttype {
dup
rcheck not {
(-dictionary- ) Print pop
}{
dup maxlength Print ( dict dup begin) Print Newline
NextLevel
{
1 index OmitNames exch known {
pop pop
}{
Indent
Replace % arrays and dicts by known names
Register % new dictionaries in OtherDicts
exch
cvlit dup type exec % key first - force a /
dup type exec % then the value
(def) Print Newline
} ifelse
} forall
LastLevel
Indent
(end ) Print
} ifelse
} def
%
% Strings containing characters not in AsciiDict are returned in hex. All
% others are ASCII strings and use AsciiDict for character mapping.
%
/onecharstring ( ) def
/twocharstring ( ) def
/stringtype {
dup
rcheck not {
(-string- ) Print
}{
/hexit false def
dup {
onecharstring 0 3 -1 roll put
AsciiDict onecharstring cvn known not {
/hexit true def exit
} if
} forall
hexit {(<)}{(\()} ifelse Print
0 1 2 index length 1 sub {
2 copy 1 getinterval exch pop
hexit {
0 get /n exch def
n -4 bitshift 16#F and 16 twocharstring cvrs pop
n 16#F and twocharstring 1 1 getinterval 16 exch cvrs pop
twocharstring
}{cvn AsciiDict exch get} ifelse
Print
column lastcolumn gt {
hexit not {(\\) Print} if
Newline
} if
} for
hexit {(> )}{(\) )} ifelse Print
} ifelse
pop
} def
%
% ASCII characters and replacement strings. Ensures the returned string will
% reproduce the original when passed through the scanner. Strings containing
% characters not in this list should be returned as hex strings.
%
/AsciiDict 128 dict dup begin
(\n) cvn (\\n) def
(\r) cvn (\\r) def
(\t) cvn (\\t) def
(\b) cvn (\\b) def
(\f) cvn (\\f) def
( ) cvn ( ) def
(!) cvn (!) def
(") cvn (") def
(#) cvn (#) def
($) cvn ($) def
(%) cvn (\\%) def
(&) cvn (&) def
(') cvn (') def
(\() cvn (\\\() def
(\)) cvn (\\\)) def
(*) cvn (*) def
(+) cvn (+) def
(,) cvn (,) def
(-) cvn (-) def
(.) cvn (.) def
(/) cvn (/) def
(0) cvn (0) def
(1) cvn (1) def
(2) cvn (2) def
(3) cvn (3) def
(4) cvn (4) def
(5) cvn (5) def
(6) cvn (6) def
(7) cvn (7) def
(8) cvn (8) def
(9) cvn (9) def
(:) cvn (:) def
(;) cvn (;) def
(<) cvn (<) def
(=) cvn (=) def
(>) cvn (>) def
(?) cvn (?) def
(@) cvn (@) def
(A) cvn (A) def
(B) cvn (B) def
(C) cvn (C) def
(D) cvn (D) def
(E) cvn (E) def
(F) cvn (F) def
(G) cvn (G) def
(H) cvn (H) def
(I) cvn (I) def
(J) cvn (J) def
(K) cvn (K) def
(L) cvn (L) def
(M) cvn (M) def
(N) cvn (N) def
(O) cvn (O) def
(P) cvn (P) def
(Q) cvn (Q) def
(R) cvn (R) def
(S) cvn (S) def
(T) cvn (T) def
(U) cvn (U) def
(V) cvn (V) def
(W) cvn (W) def
(X) cvn (X) def
(Y) cvn (Y) def
(Z) cvn (Z) def
([) cvn ([) def
(\\) cvn (\\\\) def
(]) cvn (]) def
(^) cvn (^) def
(_) cvn (_) def
(`) cvn (`) def
(a) cvn (a) def
(b) cvn (b) def
(c) cvn (c) def
(d) cvn (d) def
(e) cvn (e) def
(f) cvn (f) def
(g) cvn (g) def
(h) cvn (h) def
(i) cvn (i) def
(j) cvn (j) def
(k) cvn (k) def
(l) cvn (l) def
(m) cvn (m) def
(n) cvn (n) def
(o) cvn (o) def
(p) cvn (p) def
(q) cvn (q) def
(r) cvn (r) def
(s) cvn (s) def
(t) cvn (t) def
(u) cvn (u) def
(v) cvn (v) def
(w) cvn (w) def
(x) cvn (x) def
(y) cvn (y) def
(z) cvn (z) def
({) cvn ({) def
(|) cvn (|) def
(}) cvn (}) def
(~) cvn (~) def
end def
%
% OperatorDict can help format procedure listings. The value assigned to each
% name is used as an index into the OperatorProcs array. The procedure at that
% index is fetched and executed after the named operator is printed. What's in
% OperatorDict is a matter of taste rather than correctness. The default list
% represents our choice of which of Adobe's operators should end a line.
%
/OperatorProcs [{} {Newline Indent}] def
/OperatorDict 250 dict def
OperatorDict /arc 1 put
OperatorDict /arcn 1 put
OperatorDict /ashow 1 put
OperatorDict /awidthshow 1 put
OperatorDict /banddevice 1 put
OperatorDict /begin 1 put
OperatorDict /charpath 1 put
OperatorDict /clear 1 put
OperatorDict /cleardictstack 1 put
OperatorDict /cleartomark 1 put
OperatorDict /clip 1 put
OperatorDict /clippath 1 put
OperatorDict /closefile 1 put
OperatorDict /closepath 1 put
OperatorDict /concat 1 put
OperatorDict /copypage 1 put
OperatorDict /curveto 1 put
OperatorDict /def 1 put
OperatorDict /end 1 put
OperatorDict /eoclip 1 put
OperatorDict /eofill 1 put
OperatorDict /erasepage 1 put
OperatorDict /exec 1 put
OperatorDict /exit 1 put
OperatorDict /fill 1 put
OperatorDict /flattenpath 1 put
OperatorDict /flush 1 put
OperatorDict /flushfile 1 put
OperatorDict /for 1 put
OperatorDict /forall 1 put
OperatorDict /framedevice 1 put
OperatorDict /grestore 1 put
OperatorDict /grestoreall 1 put
OperatorDict /gsave 1 put
OperatorDict /handleerror 1 put
OperatorDict /if 1 put
OperatorDict /ifelse 1 put
OperatorDict /image 1 put
OperatorDict /imagemask 1 put
OperatorDict /initclip 1 put
OperatorDict /initgraphics 1 put
OperatorDict /initmatrix 1 put
OperatorDict /kshow 1 put
OperatorDict /lineto 1 put
OperatorDict /loop 1 put
OperatorDict /moveto 1 put
OperatorDict /newpath 1 put
OperatorDict /nulldevice 1 put
OperatorDict /pathforall 1 put
OperatorDict /print 1 put
OperatorDict /prompt 1 put
OperatorDict /put 1 put
OperatorDict /putinterval 1 put
OperatorDict /quit 1 put
OperatorDict /rcurveto 1 put
OperatorDict /renderbands 1 put
OperatorDict /repeat 1 put
OperatorDict /resetfile 1 put
OperatorDict /restore 1 put
OperatorDict /reversepath 1 put
OperatorDict /rlineto 1 put
OperatorDict /rmoveto 1 put
OperatorDict /rotate 1 put
OperatorDict /run 1 put
OperatorDict /scale 1 put
OperatorDict /setcachedevice 1 put
OperatorDict /setcachelimit 1 put
OperatorDict /setcacheparams 1 put
OperatorDict /setcharwidth 1 put
OperatorDict /setdash 1 put
OperatorDict /setdefaulttimeouts 1 put
OperatorDict /setdostartpage 1 put
OperatorDict /seteescratch 1 put
OperatorDict /setflat 1 put
OperatorDict /setfont 1 put
OperatorDict /setgray 1 put
OperatorDict /sethsbcolor 1 put
OperatorDict /setidlefonts 1 put
OperatorDict /setjobtimeout 1 put
OperatorDict /setlinecap 1 put
OperatorDict /setlinejoin 1 put
OperatorDict /setlinewidth 1 put
OperatorDict /setmargins 1 put
OperatorDict /setmatrix 1 put
OperatorDict /setmiterlimit 1 put
OperatorDict /setpacking 1 put
OperatorDict /setpagetype 1 put
OperatorDict /setprintname 1 put
OperatorDict /setrgbcolor 1 put
OperatorDict /setsccbatch 1 put
OperatorDict /setsccinteractive 1 put
OperatorDict /setscreen 1 put
OperatorDict /settransfer 1 put
OperatorDict /show 1 put
OperatorDict /showpage 1 put
OperatorDict /start 1 put
OperatorDict /stop 1 put
OperatorDict /store 1 put
OperatorDict /stroke 1 put
OperatorDict /strokepath 1 put
OperatorDict /translate 1 put
OperatorDict /widthshow 1 put
OperatorDict /write 1 put
OperatorDict /writehexstring 1 put
OperatorDict /writestring 1 put
end def
%
% Put an object on the stack and call Grabit. Output continues until stack
% is empty. For example,
%
% /letter load Grabit
%
% prints a listing of the letter procedure.
%
/Grabit {
/saveobj save def
GrabitDict begin
{
count 0 eq {exit} if
count {dup type exec} repeat
(\n) print flush
} loop
end
currentpoint % for hardcopy output
saveobj restore
moveto
} def