1 %
2 % Dump a PostScript object, occasionally in a form that can be sent back
3 % through the interpreter. Similiar to Adobe's == procedure, but output
4 % is usually easier to read. No binding so operators like rcheck and exec
5 % can be conviently redefined.
6 %
7 
8 /GrabitDict 100 dict dup begin
9 
10 /recursive true def
11 /scratchstring 200 string def
12 /slowdown 100 def
13 
14 /column 0 def
15 /lastcolumn 80 def
16 /level 0 def
17 /multiline 100 array def
18 /nextname 0 def
19 /arraylength 0 def
20 /lengthonly false def
21 
22 /GrabitSetup {
23 	counttomark {OmitNames exch true put} repeat pop
24 	0 0 moveto		% for hardcopy output
25 } def
26 
27 /OmitNames 30 dict def		% ignore these names
28 /OtherDicts 200 dict def	% unrecognized dictionaries
29 
30 %
31 % All strings returned to the host go through Print. First pass through an
32 % array has lengthonly set to true.
33 %
34 
35 /Print {
36 	dup type /stringtype ne {scratchstring cvs} if
37 	lengthonly {
38 		length arraylength add /arraylength exch def
39 	}{
40 		dup length column add /column exch def
41 		print flush
42 		slowdown {1 pop} repeat
43 	} ifelse
44 } def
45 
46 /Indent {level {(    ) Print} repeat} def
47 /Newline {(\n) Print lengthonly not {/column 0 def} if} def
48 
49 /NextLevel {/level level 1 add def multiline level 0 put} def
50 /LastLevel {/level level 1 sub def} def
51 
52 %
53 % Make a unique name for each unrecognized dictionary and remember the name
54 % and dictionary in OtherDicts.
55 %
56 
57 /Register {
58 	dup type /dicttype eq {
59 		/nextname nextname 1 add def
60 		dup (UnknownDict   ) dup
61         	(UnknownDict) length nextname (   ) cvs putinterval
62 		0 (UnknownDict) length nextname (   ) cvs length add getinterval cvn
63 		exch OtherDicts 3 1 roll put
64 	} if
65 } def
66 
67 %
68 % Replace array or dictionary values by known names. Lookups are in the
69 % standard PostScript dictionaries and in OtherDicts. If found replace
70 % the value by the name and make it executable so nametype omits the
71 % leading /.
72 %
73 
74 /Replace {
75 	false
76 	1 index type /dicttype eq {pop true} if
77 	1 index type /arraytype eq 2 index xcheck not and {pop true} if
78 	{
79 		false
80 		[userdict systemdict statusdict serverdict OtherDicts] {
81 			{
82 				3 index eq
83 					{exch pop exch pop cvx true exit}
84 					{pop}
85 				ifelse
86 			} forall
87 			dup {exit} if
88 		} forall
89 		pop
90 	} if
91 } def
92 
93 %
94 % Simple type handlers. In some cases (e.g. savetype) what's returned can't
95 % be sent back through the interpreter.
96 %
97 
98 /booleantype {{(true )}{(false )} ifelse Print} def
99 /marktype {pop (mark ) Print} def
100 /nulltype {pop (null ) Print} def
101 /integertype {Print ( ) Print} def
102 /realtype {Print ( ) Print} def
103 /filetype {pop (-file- ) Print} def
104 /fonttype {pop (-fontID- ) Print} def
105 /savetype {pop (-saveobj- ) Print} def
106 
107 %
108 % Special formatting for operators is enabled if the flag in multiline
109 % (for the current level) is set to 1. In that case each operator, after
110 % being printed, is looked up in OperatorDict. If found the value is used
111 % as an index into the OperatorProcs array and the object at that index
112 % is retrieved and executed. Currently only used to choose the operators
113 % that end a line.
114 %
115 
116 /operatortype {
117 	dup Print ( ) Print
118 	multiline level get 1 eq {
119 		scratchstring cvs cvn dup OperatorDict exch known {
120 			OperatorDict exch get
121 			OperatorProcs exch get exec
122 		}{
123 			pop
124 			column lastcolumn gt {Newline Indent} if
125 		} ifelse
126 	}{pop} ifelse
127 } def
128 
129 %
130 % Executable names are passed to operatortype. Non-executable names get a
131 % leading /.
132 %
133 
134 /nametype {
135 	dup xcheck {
136 		operatortype
137 	}{
138 		(/) Print Print ( ) Print
139 	} ifelse
140 } def
141 
142 %
143 % Arrays are processed in two passes. The first computes the length of the
144 % string returned to the host without any special formatting. If it extends
145 % past the last column special formatting is enabled by setting a flag in
146 % array multiline. Arrays are processed in a for loop so the last element
147 % easily recognized. At that point special fortmatting is disabled.
148 %
149 
150 /packedarraytype {arraytype} def
151 
152 /arraytype {
153 	NextLevel
154 	lengthonly not {
155 		/lengthonly true def
156 		/arraylength 0 def
157 		dup dup type exec
158 		arraylength 20 gt arraylength column add lastcolumn gt and {
159 			multiline level 1 put
160 		} if
161 		/lengthonly false def
162 	} if
163 
164 	dup rcheck not {
165 		(-array- ) Print pop
166 	}{
167 		dup xcheck {({)}{([)} ifelse Print
168 		multiline level get 0 ne {Newline Indent}{( ) Print} ifelse
169 		0 1 2 index length 1 sub {
170 			2 copy exch length 1 sub eq multiline level get 1 eq and {
171 				multiline level 2 put
172 			} if
173 			2 copy get exch pop
174 			dup type /dicttype eq {
175 				Replace
176 				dup type /dicttype eq {
177 					dup Register Replace
178 					recursive {
179 						2 copy cvlit
180 						/def load 3 1 roll
181 						count 3 roll
182 					} if
183 					exch pop
184 				} if
185 			} if
186 			dup type exec
187 			dup xcheck not multiline level get 1 eq and {
188 				0 index type /arraytype eq
189 				1 index type /packedarray eq or
190 				1 index type /stringtype eq or {Newline Indent} if
191 			} if
192 		} for
193 		multiline level get 0 ne {Newline LastLevel Indent NextLevel} if
194 		xcheck {(} )}{(] )} ifelse Print
195 	} ifelse
196 	LastLevel
197 } def
198 
199 %
200 % Dictionary handler. Try to replace the value by a name before processing
201 % the dictionary.
202 %
203 
204 /dicttype {
205 	dup
206 	rcheck not {
207 		(-dictionary- ) Print pop
208 	}{
209 		dup maxlength Print ( dict dup begin) Print Newline
210 		NextLevel
211 		{
212 			1 index OmitNames exch known {
213 				pop pop
214 			}{
215 				Indent
216 				Replace		% arrays and dicts by known names
217 				Register	% new dictionaries in OtherDicts
218 				exch
219 				cvlit dup type exec	% key first - force a /
220 				dup type exec		% then the value
221 				(def) Print Newline
222 			} ifelse
223 		} forall
224 		LastLevel
225 		Indent
226 		(end ) Print
227 	} ifelse
228 } def
229 
230 %
231 % Strings containing characters not in AsciiDict are returned in hex. All
232 % others are ASCII strings and use AsciiDict for character mapping.
233 %
234 
235 /onecharstring ( ) def
236 /twocharstring (  ) def
237 
238 /stringtype {
239 	dup
240 	rcheck not {
241 		(-string- ) Print
242 	}{
243 		/hexit false def
244 		dup {
245 			onecharstring 0 3 -1 roll put
246 			AsciiDict onecharstring cvn known not {
247 				/hexit true def exit
248 			} if
249 		} forall
250 
251 		hexit {(<)}{(\()} ifelse Print
252 		0 1 2 index length 1 sub {
253 			2 copy 1 getinterval exch pop
254 			hexit {
255 				0 get /n exch def
256 				n -4 bitshift 16#F and 16 twocharstring cvrs pop
257 				n 16#F and twocharstring 1 1 getinterval 16 exch cvrs pop
258 				twocharstring
259 			}{cvn AsciiDict exch get} ifelse
260 			Print
261 			column lastcolumn gt {
262 				hexit not {(\\) Print} if
263 				Newline
264 			} if
265 		} for
266 		hexit {(> )}{(\) )} ifelse Print
267 	} ifelse
268 	pop
269 } def
270 
271 %
272 % ASCII characters and replacement strings. Ensures the returned string will
273 % reproduce the original when passed through the scanner. Strings containing
274 % characters not in this list should be returned as hex strings.
275 %
276 
277 /AsciiDict 128 dict dup begin
278 	(\n) cvn (\\n) def
279 	(\r) cvn (\\r) def
280 	(\t) cvn (\\t) def
281 	(\b) cvn (\\b) def
282 	(\f) cvn (\\f) def
283 	( ) cvn ( ) def
284 	(!) cvn (!) def
285 	(") cvn (") def
286 	(#) cvn (#) def
287 	($) cvn ($) def
288 	(%) cvn (\\%) def
289 	(&) cvn (&) def
290 	(') cvn (') def
291 	(\() cvn (\\\() def
292 	(\)) cvn (\\\)) def
293 	(*) cvn (*) def
294 	(+) cvn (+) def
295 	(,) cvn (,) def
296 	(-) cvn (-) def
297 	(.) cvn (.) def
298 	(/) cvn (/) def
299 	(0) cvn (0) def
300 	(1) cvn (1) def
301 	(2) cvn (2) def
302 	(3) cvn (3) def
303 	(4) cvn (4) def
304 	(5) cvn (5) def
305 	(6) cvn (6) def
306 	(7) cvn (7) def
307 	(8) cvn (8) def
308 	(9) cvn (9) def
309 	(:) cvn (:) def
310 	(;) cvn (;) def
311 	(<) cvn (<) def
312 	(=) cvn (=) def
313 	(>) cvn (>) def
314 	(?) cvn (?) def
315 	(@) cvn (@) def
316 	(A) cvn (A) def
317 	(B) cvn (B) def
318 	(C) cvn (C) def
319 	(D) cvn (D) def
320 	(E) cvn (E) def
321 	(F) cvn (F) def
322 	(G) cvn (G) def
323 	(H) cvn (H) def
324 	(I) cvn (I) def
325 	(J) cvn (J) def
326 	(K) cvn (K) def
327 	(L) cvn (L) def
328 	(M) cvn (M) def
329 	(N) cvn (N) def
330 	(O) cvn (O) def
331 	(P) cvn (P) def
332 	(Q) cvn (Q) def
333 	(R) cvn (R) def
334 	(S) cvn (S) def
335 	(T) cvn (T) def
336 	(U) cvn (U) def
337 	(V) cvn (V) def
338 	(W) cvn (W) def
339 	(X) cvn (X) def
340 	(Y) cvn (Y) def
341 	(Z) cvn (Z) def
342 	([) cvn ([) def
343 	(\\) cvn (\\\\) def
344 	(]) cvn (]) def
345 	(^) cvn (^) def
346 	(_) cvn (_) def
347 	(`) cvn (`) def
348 	(a) cvn (a) def
349 	(b) cvn (b) def
350 	(c) cvn (c) def
351 	(d) cvn (d) def
352 	(e) cvn (e) def
353 	(f) cvn (f) def
354 	(g) cvn (g) def
355 	(h) cvn (h) def
356 	(i) cvn (i) def
357 	(j) cvn (j) def
358 	(k) cvn (k) def
359 	(l) cvn (l) def
360 	(m) cvn (m) def
361 	(n) cvn (n) def
362 	(o) cvn (o) def
363 	(p) cvn (p) def
364 	(q) cvn (q) def
365 	(r) cvn (r) def
366 	(s) cvn (s) def
367 	(t) cvn (t) def
368 	(u) cvn (u) def
369 	(v) cvn (v) def
370 	(w) cvn (w) def
371 	(x) cvn (x) def
372 	(y) cvn (y) def
373 	(z) cvn (z) def
374 	({) cvn ({) def
375 	(|) cvn (|) def
376 	(}) cvn (}) def
377 	(~) cvn (~) def
378 end def
379 
380 %
381 % OperatorDict can help format procedure listings. The value assigned to each
382 % name is used as an index into the OperatorProcs array. The procedure at that
383 % index is fetched and executed after the named operator is printed. What's in
384 % OperatorDict is a matter of taste rather than correctness. The default list
385 % represents our choice of which of Adobe's operators should end a line.
386 %
387 
388 /OperatorProcs [{} {Newline Indent}] def
389 
390 /OperatorDict 250 dict def
391 
392 OperatorDict	/arc			1 put
393 OperatorDict	/arcn			1 put
394 OperatorDict	/ashow			1 put
395 OperatorDict	/awidthshow		1 put
396 OperatorDict	/banddevice		1 put
397 OperatorDict	/begin			1 put
398 OperatorDict	/charpath		1 put
399 OperatorDict	/clear			1 put
400 OperatorDict	/cleardictstack		1 put
401 OperatorDict	/cleartomark		1 put
402 OperatorDict	/clip			1 put
403 OperatorDict	/clippath		1 put
404 OperatorDict	/closefile		1 put
405 OperatorDict	/closepath		1 put
406 OperatorDict	/concat			1 put
407 OperatorDict	/copypage		1 put
408 OperatorDict	/curveto		1 put
409 OperatorDict	/def			1 put
410 OperatorDict	/end			1 put
411 OperatorDict	/eoclip			1 put
412 OperatorDict	/eofill			1 put
413 OperatorDict	/erasepage		1 put
414 OperatorDict	/exec			1 put
415 OperatorDict	/exit			1 put
416 OperatorDict	/fill			1 put
417 OperatorDict	/flattenpath		1 put
418 OperatorDict	/flush			1 put
419 OperatorDict	/flushfile		1 put
420 OperatorDict	/for			1 put
421 OperatorDict	/forall			1 put
422 OperatorDict	/framedevice		1 put
423 OperatorDict	/grestore		1 put
424 OperatorDict	/grestoreall		1 put
425 OperatorDict	/gsave			1 put
426 OperatorDict	/handleerror		1 put
427 OperatorDict	/if			1 put
428 OperatorDict	/ifelse			1 put
429 OperatorDict	/image			1 put
430 OperatorDict	/imagemask		1 put
431 OperatorDict	/initclip		1 put
432 OperatorDict	/initgraphics		1 put
433 OperatorDict	/initmatrix		1 put
434 OperatorDict	/kshow			1 put
435 OperatorDict	/lineto			1 put
436 OperatorDict	/loop			1 put
437 OperatorDict	/moveto			1 put
438 OperatorDict	/newpath		1 put
439 OperatorDict	/nulldevice		1 put
440 OperatorDict	/pathforall		1 put
441 OperatorDict	/print			1 put
442 OperatorDict	/prompt			1 put
443 OperatorDict	/put			1 put
444 OperatorDict	/putinterval		1 put
445 OperatorDict	/quit			1 put
446 OperatorDict	/rcurveto		1 put
447 OperatorDict	/renderbands		1 put
448 OperatorDict	/repeat			1 put
449 OperatorDict	/resetfile		1 put
450 OperatorDict	/restore		1 put
451 OperatorDict	/reversepath		1 put
452 OperatorDict	/rlineto		1 put
453 OperatorDict	/rmoveto		1 put
454 OperatorDict	/rotate			1 put
455 OperatorDict	/run			1 put
456 OperatorDict	/scale			1 put
457 OperatorDict	/setcachedevice		1 put
458 OperatorDict	/setcachelimit		1 put
459 OperatorDict	/setcacheparams		1 put
460 OperatorDict	/setcharwidth		1 put
461 OperatorDict	/setdash		1 put
462 OperatorDict	/setdefaulttimeouts	1 put
463 OperatorDict	/setdostartpage		1 put
464 OperatorDict	/seteescratch		1 put
465 OperatorDict	/setflat		1 put
466 OperatorDict	/setfont		1 put
467 OperatorDict	/setgray		1 put
468 OperatorDict	/sethsbcolor		1 put
469 OperatorDict	/setidlefonts		1 put
470 OperatorDict	/setjobtimeout		1 put
471 OperatorDict	/setlinecap		1 put
472 OperatorDict	/setlinejoin		1 put
473 OperatorDict	/setlinewidth		1 put
474 OperatorDict	/setmargins		1 put
475 OperatorDict	/setmatrix		1 put
476 OperatorDict	/setmiterlimit		1 put
477 OperatorDict	/setpacking		1 put
478 OperatorDict	/setpagetype		1 put
479 OperatorDict	/setprintname		1 put
480 OperatorDict	/setrgbcolor		1 put
481 OperatorDict	/setsccbatch		1 put
482 OperatorDict	/setsccinteractive	1 put
483 OperatorDict	/setscreen		1 put
484 OperatorDict	/settransfer		1 put
485 OperatorDict	/show			1 put
486 OperatorDict	/showpage		1 put
487 OperatorDict	/start			1 put
488 OperatorDict	/stop			1 put
489 OperatorDict	/store			1 put
490 OperatorDict	/stroke			1 put
491 OperatorDict	/strokepath		1 put
492 OperatorDict	/translate		1 put
493 OperatorDict	/widthshow		1 put
494 OperatorDict	/write			1 put
495 OperatorDict	/writehexstring		1 put
496 OperatorDict	/writestring		1 put
497 
498 end def
499 
500 %
501 % Put an object on the stack and call Grabit. Output continues until stack
502 % is empty. For example,
503 %
504 %		/letter load Grabit
505 %
506 % prints a listing of the letter procedure.
507 %
508 
509 /Grabit {
510 	/saveobj save def
511 	GrabitDict begin
512 		{
513 			count 0 eq {exit} if
514 			count {dup type exec} repeat
515 			(\n) print flush
516 		} loop
517 	end
518 	currentpoint			% for hardcopy output
519 	saveobj restore
520 	moveto
521 } def
522