Subversion Repositories planix.SVN

%

% 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

} 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

		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

			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 {

				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

			2 copy 1 getinterval exch pop

			hexit {

				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