diff options
Diffstat (limited to 'postscript/prologues/grabit.ps')
| -rw-r--r-- | postscript/prologues/grabit.ps | 522 |
1 files changed, 522 insertions, 0 deletions
diff --git a/postscript/prologues/grabit.ps b/postscript/prologues/grabit.ps new file mode 100644 index 00000000..dab313c5 --- /dev/null +++ b/postscript/prologues/grabit.ps @@ -0,0 +1,522 @@ +% +% 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 + |