%    Copyright (C) 1992, 1993, 1994, 1995 Aladdin Enterprises.  All rights reserved.
% 
% This file is part of Aladdin Ghostscript.
% 
% Aladdin 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 Ghostscript Free Public
% License (the "License") for full details.
% 
% Every copy of Aladdin 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 Aladdin 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: font2c.ps $
% font2c.ps
% Write out a PostScript Type 0 or Type 1 font as C code
% that can be linked with the interpreter.
% This even works on protected fonts, if you use the -dWRITESYSTEMDICT
% switch in the command line.  The code is reentrant and location-
% independent and has no external references, so it can be put into
% a sharable library even on VMS.

% Define the maximum string length that all compilers will accept.
% This must be approximately
%	min(max line length, max string literal length) / 4 - 5.

/font2cdict 100 dict dup begin

/max_wcs 50 def

% Define a temporary file for writing out procedures.
/wtempname (_.tmp) def

% ------ Protection utilities ------ %

% Protection values are represented by a mask:
/a_noaccess 0 def
/a_executeonly 1 def
/a_readonly 3 def
/a_all 7 def
/prot_names
 [ (0) (a_execute) null (a_readonly) null null null (a_all)
 ] def
/prot_opers
 [ {noaccess} {executeonly} {} {readonly} {} {} {} {}
 ] def

% Get the protection of an object.
   /getpa
    { dup wcheck
       { pop a_all }
       {	% Check for executeonly or noaccess objects in protected.
         dup protected exch known
	  { protected exch get }
	  { pop a_readonly }
	 ifelse
       }
      ifelse
    } bind def

% Get the protection appropriate for (all the) values in a dictionary.
   /getva
    { a_noaccess exch
       { exch pop
         dup type dup /stringtype eq 1 index /arraytype eq or
	 exch /packedarraytype eq or
	  { getpa a_readonly and or }
	  { pop pop a_all exit }
	 ifelse
       }
      forall
    } bind def

% Keep track of executeonly and noaccess objects,
% but don't let the protection actually take effect.
.currentglobal
false .setglobal	% so protected can reference local objs
/protected		% do first so // will work
  systemdict wcheck { 1500 dict } { 1 dict } ifelse
def
systemdict wcheck not
 { (Warning: you will not be able to convert protected fonts.\n) print
   (If you need to convert a protected font, please\n) print
   (restart the program and specify the -dWRITESYSTEMDICT switch.\n) print
   flush
   (%end) .skipeof
 }
if
userdict begin
  /executeonly
   { dup //protected exch //a_executeonly put readonly
   } bind def
  /noaccess
   { dup //protected exch //a_noaccess put readonly
   } bind def
end
true .setglobal
systemdict begin
  /executeonly
   { userdict /executeonly get exec
   } bind odef
  /noaccess
   { userdict /noaccess get exec
   } bind odef
end
%end
.setglobal

% ------ Output utilities ------ %

% By convention, the output file is named cfile.

% Define some utilities for writing the output file.
   /wtstring 100 string def
   /wb {cfile exch write} bind def
   /ws {cfile exch writestring} bind def
   /wl {ws (\n) ws} bind def
   /wt {wtstring cvs ws} bind def

% Write a C string.  Some compilers have unreasonably small limits on
% the length of a string literal or the length of a line, so every place
% that uses wcs must either know that the string is short,
% or be prepared to use wcca instead.
   /wbx
    { 8#1000 add 8 (0000) cvrs dup 0 (\\) 0 get put ws
    } bind def
   /wcst
    [
      32 { /wbx load } repeat
      95 { /wb load } repeat
      129 { /wbx load } repeat
    ] def
   ("\\) { wcst exch { (\\) ws wb } put } forall
   /wcs
    { (") ws { dup wcst exch get exec } forall (") ws
    } bind def
   /can_wcs	% Test if can use wcs
    { length max_wcs le
    } bind def
   /wncs	% name -> C string
    { wtstring cvs wcs
    } bind def
% Write a C string as an array of character values.
% We only need this because of line and literal length limitations.
   /wca		% <string> <prefix> <suffix> wca -
    { 0 4 -2 roll exch
       {	% Stack: suffix n prefix char
	 exch ws
	 exch dup 19 ge { () wl pop 0 } if 1 add
	 exch dup 32 ge 1 index 126 le and
	  { 39 wb dup 39 eq 1 index 92 eq or { 92 wb } if wb 39 wb }
	  { wt }
	 ifelse (,)
       } forall
      pop pop ws
    } bind def
   /wcca	% <string> wcca -
    { ({\n) (}) wca
    } bind def

% Write object protection attributes.  Note that dictionaries and arrays are
% the only objects that can be writable.
   /wpa
    { dup xcheck { (a_executable|) ws } if
      dup type dup /dicttype eq exch /arraytype eq or
       { getpa }
       { getpa a_readonly and }
      ifelse prot_names exch get ws
    } bind def
   /wva
    { getva prot_names exch get ws
    } bind def

% ------ Object writing ------ %

   /wnstring 128 string def

% Convert an object to a string to be scanned at a later time.
   /cvos		% <obj> cvos <string>
    {		% We'd like to use == and write directly to a string,
		% but we can't do the former because of operators,
		% and we can't do the latter because we can't predict
		% how long the string would have to be....
	 wtempname (w) file dup 3 -1 roll wproc closefile
	 wtempname status pop pop pop exch pop string
	 wtempname (r) file dup 3 -1 roll readstring pop exch closefile
    } bind def

% Write a string/name or null as an element of a string/name/null array.
% Convert any other kind of value to a token to be read back in.
   /wsn
    { dup null eq
       { pop (\t255,255,) wl
       }
       { dup type /nametype eq { wnstring cvs } if
	 dup type /stringtype ne { cvos (255,) ws } if
	 dup length 256 idiv wt (,) ws
	 dup length 256 mod wt
	 (,) (,\n) wca
       }
      ifelse
    } bind def
% Write a packed string/name/null array.
   /wsna	% <name> <(string|name|null)*> wsna -
    { (\tstatic const char ) ws exch wt ([] = {) wl
      { wsn } forall
      (\t0\n};) wl
    } bind def

% Write a number or an array of numbers, as refs.
/isnumber
 { type dup /integertype eq exch /realtype eq or
 } bind def
/wnums
 { dup isnumber
    { (real_v\() ws wt (\),) ws }
    { { wnums } forall }
   ifelse
 } bind def

% Test whether a procedure or unusual array can be written (printed).
/iswx 4 dict dup begin
  /arraytype { { iswproc } isall } def
  /nametype { pop true } def
  /operatortype { pop true } def	% assume it has been bound in
  /packedarraytype /arraytype load def
end def
/iswnx 6 dict dup begin
  /arraytype { { iswproc } isall } def
  /integertype { pop true } def
  /nametype { pop true } def
  /realtype { pop true } def
  /stringtype { pop true } def
  /packedarraytype /arraytype load def
end def
/iswproc	% <obj> iswproc <bool>
 { dup xcheck { iswx } { iswnx } ifelse
   1 index type .knownget { exec } { pop false } ifelse
 } bind def

% Write a printable procedure (one for which iswproc returns true).
/wproca 3 dict dup begin
  /arraytype
   { 1 index ({) writestring
      { 1 index ( ) writestring 1 index exch wproc } forall
     (}) writestring
   } bind def
  /packedarraytype /arraytype load def
  /operatortype { .writecvs } bind def	% assume binding would work
end def
/wproc		% <file> <proc> wproc -
 { dup type wproca exch .knownget { exec } { write==only } ifelse
 } bind def

% Write a named object.  Return true if this was possible.
% Legal types are: boolean, integer, name, real, string,
% array of (integer, integer+real, name, null+string),
% and certain procedures and other arrays (see iswproc above).
% All other objects are either handled specially or ignored.
   /isall	% <array> <proc> isall <bool>
    { true 3 -1 roll
       { 2 index exec not { pop false exit } if }
      forall exch pop
    } bind def
   /wott 8 dict dup begin
      /arraytype
       { woatt
          { aload pop 2 index 2 index exec
	     { exch pop exec exit }
	     { pop pop }
	    ifelse
	  }
	 forall
       } bind def
      /booleantype
       { { (\tmake_true\(&) } { (\tmake_false\(&) } ifelse ws
         wt (\);) wl true
       } bind def
      /integertype
       { (\tmake_int\(&) ws exch wt (, ) ws
         wt (\);) wl true
       } bind def
      /nametype
       { (\tcode = (*pprocs->name_create)\(&) ws exch wt
         (, ) ws wnstring cvs wcs	% OK, names are short
	 (\);) wl
	 (\tif ( code < 0 ) return code;) wl
	 true
       } bind def
      /packedarraytype
	/arraytype load def
      /realtype
       { (\tmake_real\(&) ws exch wt (, ) ws
         wt (\);) wl true
       } bind def
      /stringtype
       { ({\tstatic const char s_[] = ) ws
         dup dup can_wcs { wcs } { wcca } ifelse
	 (;) wl
	 (\tmake_const_string\(&) ws exch wt
	 (, a_readonly, ) ws length wt (, (const byte *)s_\);) wl
	 (}) wl true
       } bind def
   end def
% Write some other kind of object, if known.
   /wother
    { dup otherobjs exch known
       { otherobjs exch get (\t) ws exch wt ( = ) ws wt (;) wl true }
       { pop pop false }
      ifelse
    } bind def
% Top-level procedure.
   /wo		% name obj -> OK
    { dup type wott exch .knownget { exec } { wother } ifelse
    } bind def

% Write an array (called by wo).
   /wap		% <name> <array> wap -
    { dup xcheck not 1 index wcheck not and 1 index rcheck and
       { pop pop }
       { (\tr_set_attrs\(&) ws exch wt (, ) ws wpa (\);) wl }
      ifelse
    } bind def
   /wnuma	% <name> <array> <element_C_type> <<type>_v> wnuma -
    { 2 index wcheck
       {	% Allocate an array and copy the values into it.
		% We can't define new callback procedures, so we must
		% do this the hard way.
	 pop pop
	 ({\tstatic const byte z_[) ws dup length 1 .max 2 mul wt
	 (] = {0}; ref r_;) wl
	 (\tcode = (*pprocs->string_array_create)\(&r_, z_, ) ws
	 dup length wt (, 0\);) wl
	 (\tif ( code < 0 ) return code;) wl
	 (\tr_set_attrs\(&r_, ) ws dup wpa (\);) wl
	 (\t) ws exch wt ( = r_;) wl
	 0 1 2 index length 1 sub
	  { 2 copy get
		% Stack: array index value
	    dup type /integertype eq { (\tmake_int) } { (\tmake_real) } ifelse