path: root/Master/tlpkg/tlgs/lib/font2c.ps

% Copyright (C) 2001-2012 Artifex Software, Inc.
% All Rights Reserved.
%
% This software is provided AS-IS with no warranty, either express or
% implied.
%
% This software is distributed under license and may not be copied,
% modified or distributed except as expressly authorized under the terms
% of the license contained in the file LICENSE in this distribution.
%
% Refer to licensing information at http://www.artifex.com or contact
% Artifex Software, Inc.,  7 Mt. Lassen Drive - Suite A-134, San Rafael,
% CA  94903, U.S.A., +1(415)492-9861, for further information.
%

% 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.

/font2cdict 100 dict dup begin

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

/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 unsigned 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)\(i_ctx_p, &) 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 (, (float)) ws
         wt (\);) wl true
       } bind def
      /stringtype
       { ({\tstatic const unsigned 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 -
      ({\tstatic const ref_\() ws exch ws (\) a_[] = {) wl exch
                % Stack: name type_v array
      dup length 0 eq {
        (\t) ws 1 index ws (\(0\)) wl
      } {
        dup {
          (\t) ws 2 index ws (\() ws wt (\),) wl
        } forall
      } ifelse exch pop
                % Stack: name array
      (\t};) wl
      dup wcheck {
        (\tcode = (*pprocs->scalar_array_create)\(i_ctx_p, &) ws exch wt
        (, (const ref *)a_, ) ws dup length wt
        (, ) ws wpa (\);) wl
        (\tif ( code < 0 ) return code;) wl
      } {
        (\tmake_const_array\(&) ws exch wt
        (, avm_foreign|) ws dup wpa (, ) ws length wt
        (, (const ref *)a_\);) wl
      } ifelse
      (}) wl
    } bind def
   /woatt [
        % Integers
     { { { type /integertype eq } isall }
       { (long) (integer_v) wnuma true }
     }
        % Integers + reals
     { { { type dup /integertype eq exch /realtype eq or } isall }
       { (float) (real_v) wnuma true }
     }
        % Strings + nulls
     { { { type dup /nulltype eq exch /stringtype eq or } isall }
       { ({) ws dup (sa_) exch wsna
         (\tcode = (*pprocs->string_array_create)\(i_ctx_p, &) ws exch wt
         (, \(const char *\)sa_, ) ws dup length wt (, ) ws wpa (\);) wl
         (\tif ( code < 0 ) return code;) wl
         (}) wl true
       }
     }
        % Names
     { { { type /nametype eq } isall }
       { ({) ws dup (na_) exch wsna
         (\tcode = (*pprocs->name_array_create)\(i_ctx_p, &) ws 1 index wt
         (, \(const char *\)na_, ) ws dup length wt (\);) wl
         (\tif ( code < 0 ) return code;) wl
         wap (}) wl true
       }
     }
        % Procedure
     { { iswproc }
       { dup cvos
                % Stack: name proc string
         ({\tstatic const unsigned char s_[] = ) ws
         dup dup can_wcs { wcs } { wcca } ifelse
         (;) wl
         (\tcode = (*pprocs->ref_from_string)\(i_ctx_p, &) ws 2 index wt
         (, \(const char *\)s_, ) ws length wt (\);) wl
         (\tif ( code < 0 ) return code;) wl
         wap (}) wl true
         wtempname deletefile
       }
     }
        % Default
     { { pop true }
       { wother }
     }
   ] def

% Write a named dictionary.  We assume the ref is already declared.
   /wd		% <name> <dict> <extra> wd -
    { 3 1 roll
      ({) ws
      (\tref v_[) ws dup length wt (];) wl
      dup [ exch
       { counttomark 2 sub wtstring cvs
         (v_[) exch concatstrings (]) concatstrings exch wo not
          { (Skipping ) print ==only (....\n) print }
         if
       } forall
      ]
                % Stack: array of keys (names)
      ({) ws dup (str_keys_) exch wsna
      (\tstatic const cfont_dict_keys keys_ =) wl
      (\t { 0, 0, ) ws length wt (, ) ws 3 -1 roll wt (, ) ws
      dup wpa (, ) ws dup wva ( };) wl pop
      (\tcode = \(*pprocs->ref_dict_create\)\(i_ctx_p, &) ws wt
      (, &keys_, \(const char *\)str_keys_, v_\);) wl
      (\tif ( code < 0 ) return code;) wl
      (}) wl
      (}) wl
    } bind def

% Write character dictionary keys.
% We save a lot of space by abbreviating keys which appear in
% StandardEncoding or ISOLatin1Encoding.
% Writes code to declare and initialize enc_keys_, str_keys, and keys_.
/wcdkeys	% <dict> wcdkeys -
 {	% Write keys present in StandardEncoding or ISOLatin1Encoding,
        % pushing other keys on the o-stack.
   (static const charindex enc_keys_[] = {) wl
   dup [ exch 0 exch
    { pop decoding 1 index known
       { decoding exch get ({) ws dup -8 bitshift wt
         (,) ws 255 and wt (}, ) ws
         1 add dup 5 mod 0 eq { (\n) ws } if
       }
       { exch }
      ifelse
    }
   forall pop
   ]
   ({0,0}\n};) wl
        % Write other keys.
   (str_keys_) exch wsna
        % Write the declaration for keys_.
   (static const cfont_dict_keys keys_ = {) wl
   (\tenc_keys_, countof\(enc_keys_\) - 1,) wl
   (\t) ws dup length wt ( - \(countof\(enc_keys_\) - 1\), 0, ) ws
   dup wpa (, ) ws wva () wl
   (};) wl
 } bind def

% Enumerate character dictionary values in the same order that
% the keys appear in enc_keys_ and str_keys_.
% <proc> is called with each value in turn.
/cdforall	% <dict> <proc> cdforall -
 { 2 copy
    { decoding 3 index known
       { 3 -1 roll pop exec }
       { pop pop pop }
      ifelse
    }
   /exec cvx 3 packedarray cvx
   /forall cvx
   5 -2 roll
    { decoding 3 index known
       { pop pop pop }
       { 3 -1 roll pop exec }
      ifelse
    }
   /exec cvx 3 packedarray cvx
   /forall cvx
   6 packedarray cvx exec
 } bind def

% ------ Writers for special objects ------ %

/writespecial 10 dict dup begin

   /FontInfo { 0 wd } def

   /Private { 0 wd } def

   /CharStrings
    { ({) wl
      dup wcdkeys
      (static const unsigned char values_[] = {) wl
       { wsn } cdforall
      (\t0\n};) wl
      (\tcode = \(*pprocs->string_dict_create\)\(i_ctx_p, &) ws wt
      (, &keys_, (const char *)str_keys_, \(const char *\)values_\);) wl
      (\tif ( code < 0 ) return code;) wl
      (}) wl
    } bind def

   /Metrics
    { ({) wl
      dup wcdkeys
      (static const ref_(float) values_[] = {) wl
      dup { (\t) ws wnums () wl } cdforall
      (\t0\n};) wl
      (static const unsigned char lengths_[] = {) wl
       { (\t) ws dup isnumber
          { pop 0 }
          { length 1 add }
         ifelse wt (,) wl
       } cdforall
      (\t0\n};) wl
      (\tcode = \(*pprocs->num_dict_create\)\(i_ctx_p, &) ws wt
      (, &keys_, str_keys_, (const ref *)values_, lengths_\);) wl
      (\tif ( code < 0 ) return code;) wl
      (}) wl
    } bind def

   /Metrics2 /Metrics load def

   /FDepVector pop	% (converted to a list of font names)

end def

% ------ The main program ------ %

% Construct an inverse dictionary of encodings.
[ /StandardEncoding /ISOLatin1Encoding
  /SymbolEncoding /DingbatsEncoding
  /KanjiSubEncoding
]
dup length dict begin
 { mark exch dup { .findencoding exch def } stopped cleartomark
 } forall
currentdict end /encodingnames exch def

% Invert the StandardEncoding and ISOLatin1Encoding vectors.
512 dict begin
  0 1 255 { dup ISOLatin1Encoding exch get exch 256 add def } for
  0 1 255 { dup StandardEncoding exch get exch def } for
currentdict end /decoding exch def

/writefont		% cfilename procname -> [writes the current font]
 { (gsf_) exch concatstrings
     /fontprocname exch def
   /cfname exch def
   /cfile cfname (w) file def

% Remove unwanted keys from the font.
   currentfont dup length dict begin { def } forall
    { /FID /MIDVector /CurMID } { currentdict exch undef } forall
   /Font currentdict end def

% Replace the FDepVector with a list of font names.
   Font /FDepVector .knownget
    { [ exch { /FontName get } forall ]
      Font /FDepVector 3 -1 roll put
    }
   if

% Find all the special objects we know about.
% wo uses this to write out references to otherwise intractable objects.
   /otherobjs writespecial length dict dup begin
     writespecial
      { pop Font 1 index .knownget { exch def } { pop } ifelse
      }
     forall
   end def

% Define a dummy FontInfo, in case the font doesn't have one.
   /FontInfo 0 dict def

% Write out the boilerplate.
   Font begin
   (/****************************************************************) wl
   (   Portions of this file are subject to the following notice(s):) wl
   systemdict /copyright get wl
   FontInfo /Notice .knownget
    { (----------------------------------------------------------------) wl wl
    } if
   (****************************************************************/) wl
   () wl
   (/* ) ws cfname ws ( */) wl
   (/* This file was created by the ) ws product ws ( font2c utility. */) wl
   () wl
   (#undef DEBUG) wl
   (#include "ccfont.h") wl
   () wl

% Write the procedure prologue.
   (#ifdef __PROTOTYPES__) wl
   (ccfont_proc\() ws fontprocname ws (\);) wl
   (int) wl
   fontprocname ws ((i_ctx_t *i_ctx_p, const cfont_procs *pprocs, ref *pfont)) wl
   (#else) wl
   (int) wl
   fontprocname ws ((i_ctx_p, pprocs, pfont) i_ctx_t *i_ctx_p; const cfont_procs *pprocs; ref *pfont;) wl
   (#endif) wl
   ({\tint code;) wl
   (\tref Font;) wl
   otherobjs
    { exch pop (\tref ) ws wt (;) wl }
   forall

% Write out the special objects.
   otherobjs
    { exch writespecial 2 index get exec
    }
   forall

% Write out the main font dictionary.
% If possible, substitute the encoding name for the encoding;
% PostScript code will fix this up.
    { /Encoding /PrefEnc }
    { Font 1 index .knownget
       { encodingnames exch .knownget { def } { pop } ifelse }
       { pop }
      ifelse
    }
   forall
   (Font) Font FontType 0 eq { 5 } { 1 } ifelse wd

% Finish the procedural initialization code.
   (\t*pfont = Font;) wl
   (\treturn 0;) wl
   (}) wl
   end				% Font

   cfile closefile

 } bind def

end def			% font2cdict

% Compute the procedure name from the font name.
% Replace all non-alphanumeric characters with '_'.
/makefontprocnamemap 256 string
   0 1 255 { 2 copy 95 put pop } for
   (0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz)
    { 2 copy dup put pop } forall
readonly def
/makefontprocname	% <fontname> makefontprocname <procnamestring>
 { dup length string cvs
   dup length 1 sub -1 0
    {		% Stack: string index
      2 copy 2 copy get //makefontprocnamemap exch get put pop
    }
   for
 } def

/writefont { font2cdict begin writefont end } def

% If the program was invoked from the command line, run it now.
[ shellarguments
 { counttomark dup 2 eq exch 3 eq or
    { counttomark -1 roll cvn
      (Converting ) print dup =only ( font.\n) print flush
                % Ensure that we get a clean copy of the font from the
                % file system.
      2 {	% do both local and global
        currentglobal not setglobal
        dup undefinefont
      } repeat
      findfont setfont
      (FontName is ) print currentfont /FontName get ==only (.\n) print flush
      counttomark 1 eq
       {	% Construct the procedure name from the file name.
         currentfont /FontName get makefontprocname
       }
      if
      writefont
      (Done.\n) print flush
    }
    { cleartomark
      (Usage: font2c fontname cfilename.c [shortname]\n) print
      ( e.g.: font2c Courier cour.c\n) print flush
      mark
    }
   ifelse
 }
if pop