harvey/sys/src/cmd/gs/lib/gs_btokn.ps

%    Copyright (C) 1994, 2000 Aladdin Enterprises.  All rights reserved.
% 
% This file is part of AFPL Ghostscript.
% 
% AFPL Ghostscript is distributed with NO WARRANTY OF ANY KIND.  No author or
% distributor accepts any responsibility for the consequences of using it, or
% for whether it serves any particular purpose or works at all, unless he or
% she says so in writing.  Refer to the Aladdin Free Public License (the
% "License") for full details.
% 
% Every copy of AFPL Ghostscript must include a copy of the License, normally
% in a plain ASCII text file named PUBLIC.  The License grants you the right
% to copy, modify and redistribute AFPL Ghostscript, but only under certain
% conditions described in the License.  Among other things, the License
% requires that the copyright notice and this notice be preserved on all
% copies.

% $Id: gs_btokn.ps,v 1.5 2001/09/15 07:11:00 masata-y Exp $
% Initialization file for binary tokens.
% When this is run, systemdict is still writable,
% but everything defined here goes into level2dict.

% Define whether or not to allow writing dictionaries.
% This is a non-standard feature!
/WRITEDICTS false def

languagelevel 1 .setlanguagelevel
level2dict begin

% Initialization for the system name table.

mark
% 0
	/abs /add /aload /anchorsearch /and
	/arc /arcn /arct /arcto /array
	/ashow /astore /awidthshow /begin /bind
	/bitshift /ceiling /charpath /clear /cleartomark
% 20
	/clip /clippath /closepath /concat /concatmatrix
	/copy /count /counttomark /currentcmykcolor /currentdash
	/currentdict /currentfile /currentfont /currentgray /currentgstate
	/currenthsbcolor /currentlinecap /currentlinejoin /currentlinewidth /currentmatrix
% 40
	/currentpoint /currentrgbcolor /currentshared /curveto /cvi
	/cvlit /cvn /cvr /cvrs /cvs
	/cvx /def /defineusername /dict /div
	/dtransform /dup /end /eoclip /eofill
% 60
	/eoviewclip /eq /exch /exec /exit
	/file /fill /findfont /flattenpath /floor
	/flush /flushfile /for /forall /ge
	/get /getinterval /grestore /gsave /gstate
% 80
	/gt /identmatrix /idiv /idtransform /if
	/ifelse /image /imagemask /index /ineofill
	/infill /initviewclip /inueofill /inufill /invertmatrix
	/itransform /known /le /length /lineto
% 100
	/load /loop /lt /makefont /matrix
	/maxlength /mod /moveto /mul /ne
	/neg /newpath /not /null /or
	/pathbbox /pathforall /pop /print /printobject
% 120
	/put /putinterval /rcurveto /read /readhexstring
	/readline /readstring /rectclip /rectfill /rectstroke
	/rectviewclip /repeat /restore /rlineto /rmoveto
	/roll /rotate /round /save /scale
% 140
	/scalefont /search /selectfont /setbbox /setcachedevice
	/setcachedevice2 /setcharwidth /setcmykcolor /setdash /setfont
	/setgray /setgstate /sethsbcolor /setlinecap /setlinejoin
	/setlinewidth /setmatrix /setrgbcolor /setshared /shareddict
% 160
	/show /showpage /stop /stopped /store
	/string /stringwidth /stroke /strokepath /sub
	/systemdict /token /transform /translate /truncate
	/type /uappend /ucache /ueofill /ufill
% 180
	/undef /upath /userdict /ustroke /viewclip
	/viewclippath /where /widthshow /write /writehexstring
	/writeobject /writestring /wtranslation /xor /xshow
	/xyshow /yshow /FontDirectory /SharedFontDirectory /Courier
% 200
	/Courier-Bold /Courier-BoldOblique /Courier-Oblique /Helvetica /Helvetica-Bold
	/Helvetica-BoldOblique /Helvetica-Oblique /Symbol /Times-Bold /Times-BoldItalic
	/Times-Italic /Times-Roman /execuserobject /currentcolor /currentcolorspace
	/currentglobal /execform /filter /findresource /globaldict
% 220
	/makepattern /setcolor /setcolorspace /setglobal /setpagedevice
	/setpattern
% pad to 256
	counttomark 256 exch sub { 0 } repeat
% 256
	/= /== /ISOLatin1Encoding /StandardEncoding
% 260
	([) cvn (]) cvn /atan /banddevice /bytesavailable
	/cachestatus /closefile /colorimage /condition /copypage
	/cos /countdictstack /countexecstack /cshow /currentblackgeneration
	/currentcacheparams /currentcolorscreen /currentcolortransfer /currentcontext /currentflat
% 280
	/currenthalftone /currenthalftonephase /currentmiterlimit /currentobjectformat /currentpacking
	/currentscreen /currentstrokeadjust /currenttransfer /currentundercolorremoval /defaultmatrix
	/definefont /deletefile /detach /deviceinfo /dictstack
	/echo /erasepage /errordict /execstack /executeonly
% 300
	/exp /false /filenameforall /fileposition /fork
	/framedevice /grestoreall /handleerror /initclip /initgraphics
	/initmatrix /instroke /inustroke /join /kshow
	/ln /lock /log /mark /monitor
% 320
	/noaccess /notify /nulldevice /packedarray /quit
	/rand /rcheck /readonly /realtime /renamefile
	/renderbands /resetfile /reversepath /rootfont /rrand
	/run /scheck /setblackgeneration /setcachelimit /setcacheparams
% 340
	/setcolorscreen /setcolortransfer /setfileposition /setflat /sethalftone
	/sethalftonephase /setmiterlimit /setobjectformat /setpacking /setscreen
	/setstrokeadjust /settransfer /setucacheparams /setundercolorremoval /sin
	/sqrt /srand /stack /status /statusdict
% 360
	/true /ucachestatus /undefinefont /usertime /ustrokepath
	/version /vmreclaim /vmstatus /wait /wcheck
	/xcheck /yield /defineuserobject /undefineuserobject /UserObjects
	/cleardictstack
% 376
	/A /B /C /D /E /F /G /H /I /J /K /L /M
	/N /O /P /Q /R /S /T /U /V /W /X /Y /Z
	/a /b /c /d /e /f /g /h /i /j /k /l /m
	/n /o /p /q /r /s /t /u /v /w /x /y /z
% 428
	/setvmthreshold (<<) cvn
	(>>) cvn /currentcolorrendering /currentdevparams /currentoverprint /currentpagedevice
	/currentsystemparams /currentuserparams /defineresource /findencoding /gcheck
% 440
	/glyphshow /languagelevel /product /pstack /resourceforall
	/resourcestatus /revision /serialnumber /setcolorrendering /setdevparams
	/setoverprint /setsystemparams /setuserparams /startjob /undefineresource
	/GlobalFontDirectory /ASCII85Decode /ASCII85Encode /ASCIIHexDecode /ASCIIHexEncode
% 460
	/CCITTFaxDecode /CCITTFaxEncode /DCTDecode /DCTEncode /LZWDecode
	/LZWEncode /NullEncode /RunLengthDecode /RunLengthEncode /SubFileDecode
	/CIEBasedA /CIEBasedABC /DeviceCMYK /DeviceGray /DeviceRGB
	/Indexed /Pattern /Separation /CIEBasedDEF /CIEBasedDEFG
% 480
	/DeviceN
% 481 -- end
.packtomark
dup /SystemNames exch def .installsystemnames

% Define printobject and writeobject.
% These are mostly implemented in PostScript, so that we don't have to
% worry about interrupts or callbacks when writing to the output file.

% Define procedures for accumulating the space required to represent
% an object in binary form.
/cntdict mark		% <#refs> <#chars> <obj> -proc- <#refs> <#chars>
  /integertype /pop load
  /realtype 1 index
  /marktype 1 index
  /nulltype 1 index
  /booleantype 1 index
  /nametype { length add } bind
  /stringtype 1 index
  /arraytype null
  /dicttype null
.dicttomark def
cntdict /arraytype {
  dup length 4 -1 roll add 3 1 roll {
    dup type //cntdict exch get exec
  } forall
} bind put
cntdict /dicttype {
  WRITEDICTS {
    dup dup length 2 mul 5 -1 roll add 4 2 roll {
      4 1 roll dup type //cntdict exch get exec
      3 -1 roll dup type //cntdict exch get exec
    } forall
  } {
    /writeobject load /typecheck signalerror
  } ifelse
} bind put

/w2dict mark
  /nametype { 2 copy .writecvs pop } bind
  /stringtype 1 index
.dicttomark def

/.bosheader {		% <top_length> <total_length> <string8> .bosheader
			%   <string4|8>
  dup 0 currentobjectformat 127 add put		% object format => BOS tag
  2 index 255 le 2 index 65531 le and {
	% Use the short header format: tag toplen(1) totlen(2)
    exch 4 add exch
    0 4 getinterval
    dup 1 5 -1 roll put
  } {
	% Use the long header format: tag 0(1) toplen(2) totlen(4)
    exch 8 add exch
    0 0 4 2 roll .bosobject exch pop exch pop	% store with byte swapping
  } ifelse		% Stack: shortlen str
  exch dup -8 bitshift exch 255 and	% str hibyte lobyte
  currentobjectformat 1 and 0 eq {	% lsb first
    exch
  } if
  2 index 3 3 -1 roll put
  1 index 2 3 -1 roll put
} .bind def

/.writeobjects {	% <file> <tag> <array> .writeobjects -
  mark exch

	% Count the space required for refs and strings.

  dup length 0 3 -1 roll
	% Stack: file tag -mark- #refs #chars array
  dup 4 1 roll {
      dup type /arraytype eq {
	  % Nested array. An element of the array is also
	  % an array(sub array). Push the sub array to the stack.
	  dup 4 1 roll
      } if
      dup type //cntdict exch get exec
   } forall

	% Write the header.

	% Stack: file tag -mark- array1 ... array|dictN #refs #chars
  counttomark 3 add -2 roll 4 1 roll
	% Stack: -mark- array1 ... array|dictN tag #refs #chars file
  dup counttomark 1 sub index length
  4 index 3 bitshift 4 index add
  (xxxxxxxx) .bosheader writestring

	% Write the objects per se.

  3 1 roll pop
  counttomark 1 sub index length 3 bitshift exch
  3 bitshift
	% Stack: -mark- array1 ... array|dictN tag file ref# char#
  counttomark 4 sub {
    counttomark -1 roll dup 6 1 roll
    dup type /dicttype eq {		% can't be first object
      { 5 1 roll (xxxxxxxx) .bosobject
	3 index exch writestring
	4 -1 roll (xxxxxxxx) .bosobject
	3 index exch writestring
      } forall
    } {
      { (xxxxxxxx) .bosobject
	dup 1 6 index put
	3 index exch writestring
	4 -1 roll pop 0 4 1 roll	% clear tag
      } forall
    } ifelse
  } repeat

	% Write the strings and names.

  pop pop exch pop
	% Stack: -mark- array1 ... array|dictN file
  counttomark 1 sub {
    counttomark -1 roll {
		% The counting pass ensured that the keys and values
		% of any dictionary must be writable objects.
		% Hence, we are processing a dictionary iff
		% the next-to-top stack element is not a file.
      1 index type /filetype ne {
	exch 2 index exch dup type //w2dict exch .knownget
	 { exec } { pop } ifelse pop
      } if
      dup type //w2dict exch .knownget { exec } { pop } ifelse
    } forall
  } repeat

	% Clean up.

	% Stack: -mark- file
  pop pop

} odef

/printobject {		% <obj> <tag> printobject -
  (%stdout) (w) file 2 index 2 index writeobject pop pop
} odef
/writeobject {		% <file> <obj> <tag> writeobject -
  3 copy exch
		% We must allocate the array in local VM
		% to avoid a possible invalidaccess.
  .currentglobal false .setglobal exch 1 array astore exch .setglobal
  .writeobjects pop pop pop
} odef

% Implement binary error message output.
/.objectprinttest {		% <obj> .objectprinttest -
		% This is a pseudo-operator so it will restore the stack
		% if it gets an error.
  0 0 2 index roll dup type //cntdict exch get exec pop pop pop
} bind odef
/.printerror {
  $error /binary get .languagelevel 2 ge and {
    currentobjectformat 0 ne {
      [ /Error $error /errorname get $error /command get
		% Convert the object with cvs if it isn't printable.
      dup { .objectprinttest } .internalstopped {
	pop 100 string cvs
      } if
      false ] 250 printobject
    }
    //.printerror	% known to be a procedure
    ifelse
  }
  //.printerror		% known to be a procedure
  ifelse
} bind def

currentdict /cntdict .undef
currentdict /w2dict .undef

% End of level2dict

end
.setlanguagelevel