home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / GhostScript / !GhostScr / 6_01 / lib / font2c.ps < prev    next >
Text File  |  2000-03-09  |  20KB  |  673 lines
  1. %    Copyright (C) 1992, 1993, 1994, 1995, 1999 Aladdin Enterprises.  All rights reserved.
  2. % 
  3. % This file is part of Aladdin Ghostscript.
  4. % 
  5. % Aladdin Ghostscript is distributed with NO WARRANTY OF ANY KIND.  No author
  6. % or distributor accepts any responsibility for the consequences of using it,
  7. % or for whether it serves any particular purpose or works at all, unless he
  8. % or she says so in writing.  Refer to the Aladdin Ghostscript Free Public
  9. % License (the "License") for full details.
  10. % 
  11. % Every copy of Aladdin Ghostscript must include a copy of the License,
  12. % normally in a plain ASCII text file named PUBLIC.  The License grants you
  13. % the right to copy, modify and redistribute Aladdin Ghostscript, but only
  14. % under certain conditions described in the License.  Among other things, the
  15. % License requires that the copyright notice and this notice be preserved on
  16. % all copies.
  17.  
  18. % $Id: font2c.ps,v 1.1 2000/03/09 08:40:39 lpd Exp $
  19. % font2c.ps
  20. % Write out a PostScript Type 0 or Type 1 font as C code
  21. % that can be linked with the interpreter.
  22. % This even works on protected fonts, if you use the -dWRITESYSTEMDICT
  23. % switch in the command line.  The code is reentrant and location-
  24. % independent and has no external references, so it can be put into
  25. % a sharable library even on VMS.
  26.  
  27. % Define the maximum string length that all compilers will accept.
  28. % This must be approximately
  29. %    min(max line length, max string literal length) / 4 - 5.
  30.  
  31. /font2cdict 100 dict dup begin
  32.  
  33. /max_wcs 50 def
  34.  
  35. % Define a temporary file for writing out procedures.
  36. /wtempname (_.tmp) def
  37.  
  38. % ------ Protection utilities ------ %
  39.  
  40. % Protection values are represented by a mask:
  41. /a_noaccess 0 def
  42. /a_executeonly 1 def
  43. /a_readonly 3 def
  44. /a_all 7 def
  45. /prot_names
  46.  [ (0) (a_execute) null (a_readonly) null null null (a_all)
  47.  ] def
  48. /prot_opers
  49.  [ {noaccess} {executeonly} {} {readonly} {} {} {} {}
  50.  ] def
  51.  
  52. % Get the protection of an object.
  53.    /getpa
  54.     { dup wcheck
  55.        { pop a_all }
  56.        {    % Check for executeonly or noaccess objects in protected.
  57.          dup protected exch known
  58.       { protected exch get }
  59.       { pop a_readonly }
  60.      ifelse
  61.        }
  62.       ifelse
  63.     } bind def
  64.  
  65. % Get the protection appropriate for (all the) values in a dictionary.
  66.    /getva
  67.     { a_noaccess exch
  68.        { exch pop
  69.          dup type dup /stringtype eq 1 index /arraytype eq or
  70.      exch /packedarraytype eq or
  71.       { getpa a_readonly and or }
  72.       { pop pop a_all exit }
  73.      ifelse
  74.        }
  75.       forall
  76.     } bind def
  77.  
  78. % Keep track of executeonly and noaccess objects,
  79. % but don't let the protection actually take effect.
  80. .currentglobal
  81. false .setglobal    % so protected can reference local objs
  82. /protected        % do first so // will work
  83.   systemdict wcheck { 1500 dict } { 1 dict } ifelse
  84. def
  85. systemdict wcheck not
  86.  { (Warning: you will not be able to convert protected fonts.\n) print
  87.    (If you need to convert a protected font, please\n) print
  88.    (restart the program and specify the -dWRITESYSTEMDICT switch.\n) print
  89.    flush
  90.    (%end) .skipeof
  91.  }
  92. if
  93. userdict begin
  94.   /executeonly
  95.    { dup //protected exch //a_executeonly put readonly
  96.    } bind def
  97.   /noaccess
  98.    { dup //protected exch //a_noaccess put readonly
  99.    } bind def
  100. end
  101. true .setglobal
  102. systemdict begin
  103.   /executeonly
  104.    { userdict /executeonly get exec
  105.    } bind odef
  106.   /noaccess
  107.    { userdict /noaccess get exec
  108.    } bind odef
  109. end
  110. %end
  111. .setglobal
  112.  
  113. % ------ Output utilities ------ %
  114.  
  115. % By convention, the output file is named cfile.
  116.  
  117. % Define some utilities for writing the output file.
  118.    /wtstring 100 string def
  119.    /wb {cfile exch write} bind def
  120.    /ws {cfile exch writestring} bind def
  121.    /wl {ws (\n) ws} bind def
  122.    /wt {wtstring cvs ws} bind def
  123.  
  124. % Write a C string.  Some compilers have unreasonably small limits on
  125. % the length of a string literal or the length of a line, so every place
  126. % that uses wcs must either know that the string is short,
  127. % or be prepared to use wcca instead.
  128.    /wbx
  129.     { 8#1000 add 8 (0000) cvrs dup 0 (\\) 0 get put ws
  130.     } bind def
  131.    /wcst
  132.     [
  133.       32 { /wbx load } repeat
  134.       95 { /wb load } repeat
  135.       129 { /wbx load } repeat
  136.     ] def
  137.    ("\\) { wcst exch { (\\) ws wb } put } forall
  138.    /wcs
  139.     { (") ws { dup wcst exch get exec } forall (") ws
  140.     } bind def
  141.    /can_wcs    % Test if can use wcs
  142.     { length max_wcs le
  143.     } bind def
  144.    /wncs    % name -> C string
  145.     { wtstring cvs wcs
  146.     } bind def
  147. % Write a C string as an array of character values.
  148. % We only need this because of line and literal length limitations.
  149.    /wca        % <string> <prefix> <suffix> wca -
  150.     { 0 4 -2 roll exch
  151.        {    % Stack: suffix n prefix char
  152.      exch ws
  153.      exch dup 19 ge { () wl pop 0 } if 1 add
  154.      exch dup 32 ge 1 index 126 le and
  155.       { 39 wb dup 39 eq 1 index 92 eq or { 92 wb } if wb 39 wb }
  156.       { wt }
  157.      ifelse (,)
  158.        } forall
  159.       pop pop ws
  160.     } bind def
  161.    /wcca    % <string> wcca -
  162.     { ({\n) (}) wca
  163.     } bind def
  164.  
  165. % Write object protection attributes.  Note that dictionaries and arrays are
  166. % the only objects that can be writable.
  167.    /wpa
  168.     { dup xcheck { (a_executable|) ws } if
  169.       dup type dup /dicttype eq exch /arraytype eq or
  170.        { getpa }
  171.        { getpa a_readonly and }
  172.       ifelse prot_names exch get ws
  173.     } bind def
  174.    /wva
  175.     { getva prot_names exch get ws
  176.     } bind def
  177.  
  178. % ------ Object writing ------ %
  179.  
  180.    /wnstring 128 string def
  181.  
  182. % Convert an object to a string to be scanned at a later time.
  183.    /cvos        % <obj> cvos <string>
  184.     {        % We'd like to use == and write directly to a string,
  185.         % but we can't do the former because of operators,
  186.         % and we can't do the latter because we can't predict
  187.         % how long the string would have to be....
  188.      wtempname (w) file dup 3 -1 roll wproc closefile
  189.      wtempname status pop pop pop exch pop string
  190.      wtempname (r) file dup 3 -1 roll readstring pop exch closefile
  191.     } bind def
  192.  
  193. % Write a string/name or null as an element of a string/name/null array.
  194. % Convert any other kind of value to a token to be read back in.
  195.    /wsn
  196.     { dup null eq
  197.        { pop (\t255,255,) wl
  198.        }
  199.        { dup type /nametype eq { wnstring cvs } if
  200.      dup type /stringtype ne { cvos (255,) ws } if
  201.      dup length 256 idiv wt (,) ws
  202.      dup length 256 mod wt
  203.      (,) (,\n) wca
  204.        }
  205.       ifelse
  206.     } bind def
  207. % Write a packed string/name/null array.
  208.    /wsna    % <name> <(string|name|null)*> wsna -
  209.     { (\tstatic const char ) ws exch wt ([] = {) wl
  210.       { wsn } forall
  211.       (\t0\n};) wl
  212.     } bind def
  213.  
  214. % Write a number or an array of numbers, as refs.
  215. /isnumber
  216.  { type dup /integertype eq exch /realtype eq or
  217.  } bind def
  218. /wnums
  219.  { dup isnumber
  220.     { (real_v\() ws wt (\),) ws }
  221.     { { wnums } forall }
  222.    ifelse
  223.  } bind def
  224.  
  225. % Test whether a procedure or unusual array can be written (printed).
  226. /iswx 4 dict dup begin
  227.   /arraytype { { iswproc } isall } def
  228.   /nametype { pop true } def
  229.   /operatortype { pop true } def    % assume it has been bound in
  230.   /packedarraytype /arraytype load def
  231. end def
  232. /iswnx 6 dict dup begin
  233.   /arraytype { { iswproc } isall } def
  234.   /integertype { pop true } def
  235.   /nametype { pop true } def
  236.   /realtype { pop true } def
  237.   /stringtype { pop true } def
  238.   /packedarraytype /arraytype load def
  239. end def
  240. /iswproc    % <obj> iswproc <bool>
  241.  { dup xcheck { iswx } { iswnx } ifelse
  242.    1 index type .knownget { exec } { pop false } ifelse
  243.  } bind def
  244.  
  245. % Write a printable procedure (one for which iswproc returns true).
  246. /wproca 3 dict dup begin
  247.   /arraytype
  248.    { 1 index ({) writestring
  249.       { 1 index ( ) writestring 1 index exch wproc } forall
  250.      (}) writestring
  251.    } bind def
  252.   /packedarraytype /arraytype load def
  253.   /operatortype { .writecvs } bind def    % assume binding would work
  254. end def
  255. /wproc        % <file> <proc> wproc -
  256.  { dup type wproca exch .knownget { exec } { write==only } ifelse
  257.  } bind def
  258.  
  259. % Write a named object.  Return true if this was possible.
  260. % Legal types are: boolean, integer, name, real, string,
  261. % array of (integer, integer+real, name, null+string),
  262. % and certain procedures and other arrays (see iswproc above).
  263. % All other objects are either handled specially or ignored.
  264.    /isall    % <array> <proc> isall <bool>
  265.     { true 3 -1 roll
  266.        { 2 index exec not { pop false exit } if }
  267.       forall exch pop
  268.     } bind def
  269.    /wott 8 dict dup begin
  270.       /arraytype
  271.        { woatt
  272.           { aload pop 2 index 2 index exec
  273.          { exch pop exec exit }
  274.          { pop pop }
  275.         ifelse
  276.       }
  277.      forall
  278.        } bind def
  279.       /booleantype
  280.        { { (\tmake_true\(&) } { (\tmake_false\(&) } ifelse ws
  281.          wt (\);) wl true
  282.        } bind def
  283.       /integertype
  284.        { (\tmake_int\(&) ws exch wt (, ) ws
  285.          wt (\);) wl true
  286.        } bind def
  287.       /nametype
  288.        { (\tcode = (*pprocs->name_create)\(i_ctx_p, &) ws exch wt
  289.          (, ) ws wnstring cvs wcs    % OK, names are short
  290.      (\);) wl
  291.      (\tif ( code < 0 ) return code;) wl
  292.      true
  293.        } bind def
  294.       /packedarraytype
  295.     /arraytype load def
  296.       /realtype
  297.        { (\tmake_real\(&) ws exch wt (, ) ws
  298.          wt (\);) wl true
  299.        } bind def
  300.       /stringtype
  301.        { ({\tstatic const char s_[] = ) ws
  302.          dup dup can_wcs { wcs } { wcca } ifelse
  303.      (;) wl
  304.      (\tmake_const_string\(&) ws exch wt
  305.      (, a_readonly, ) ws length wt (, (const byte *)s_\);) wl
  306.      (}) wl true
  307.        } bind def
  308.    end def
  309. % Write some other kind of object, if known.
  310.    /wother
  311.     { dup otherobjs exch known
  312.        { otherobjs exch get (\t) ws exch wt ( = ) ws wt (;) wl true }
  313.        { pop pop false }
  314.       ifelse
  315.     } bind def
  316. % Top-level procedure.
  317.    /wo        % name obj -> OK
  318.     { dup type wott exch .knownget { exec } { wother } ifelse
  319.     } bind def
  320.  
  321. % Write an array (called by wo).
  322.    /wap        % <name> <array> wap -
  323.     { dup xcheck not 1 index wcheck not and 1 index rcheck and
  324.        { pop pop }
  325.        { (\tr_set_attrs\(&) ws exch wt (, ) ws wpa (\);) wl }
  326.       ifelse
  327.     } bind def
  328.    /wnuma {    % <name> <array> <element_C_type> <<type>_v> wnuma -
  329.       ({\tstatic const ref_\() ws exch ws (\) a_[] = {) wl exch
  330.         % Stack: name type_v array
  331.       dup length 0 eq {
  332.     (\t) ws 1 index ws (\(0\)) wl
  333.       } {
  334.     dup {
  335.       (\t) ws 2 index ws (\() ws wt (\),) wl
  336.     } forall
  337.       } ifelse exch pop
  338.         % Stack: name array
  339.       (\t};) wl
  340.       dup wcheck {
  341.     (\tcode = (*pprocs->scalar_array_create)\(i_ctx_p, &) ws exch wt
  342.     (, (const ref *)a_, ) ws dup length wt
  343.     (, ) ws wpa (\);) wl
  344.     (\tif ( code < 0 ) return code;) wl
  345.       } {
  346.     (\tmake_const_array\(&) ws exch wt
  347.     (, avm_foreign|) ws dup wpa (, ) ws length wt
  348.     (, (const ref *)a_\);) wl
  349.       } ifelse
  350.       (}) wl
  351.     } bind def
  352.    /woatt [
  353.     % Integers
  354.      { { { type /integertype eq } isall }
  355.        { (long) (integer_v) wnuma true }
  356.      }
  357.     % Integers + reals
  358.      { { { type dup /integertype eq exch /realtype eq or } isall }
  359.        { (float) (real_v) wnuma true }
  360.      }
  361.     % Strings + nulls
  362.      { { { type dup /nulltype eq exch /stringtype eq or } isall }
  363.        { ({) ws dup (sa_) exch wsna
  364.      (\tcode = (*pprocs->string_array_create)\(i_ctx_p, &) ws exch wt
  365.      (, sa_, ) ws dup length wt (, ) ws wpa (\);) wl
  366.      (\tif ( code < 0 ) return code;) wl
  367.      (}) wl true
  368.        }
  369.      }
  370.     % Names
  371.      { { { type /nametype eq } isall }
  372.        { ({) ws dup (na_) exch wsna
  373.      (\tcode = (*pprocs->name_array_create)\(i_ctx_p, &) ws 1 index wt
  374.      (, na_, ) ws dup length wt (\);) wl
  375.      (\tif ( code < 0 ) return code;) wl
  376.      wap (}) wl true
  377.        }
  378.      }
  379.     % Procedure
  380.      { { iswproc }
  381.        { dup cvos
  382.         % Stack: name proc string
  383.      ({\tstatic const char s_[] = ) ws
  384.          dup dup can_wcs { wcs } { wcca } ifelse
  385.      (;) wl
  386.      (\tcode = (*pprocs->ref_from_string)\(i_ctx_p, &) ws 2 index wt
  387.      (, s_, ) ws length wt (\);) wl
  388.      (\tif ( code < 0 ) return code;) wl
  389.      wap (}) wl true
  390.      wtempname deletefile
  391.        }
  392.      }
  393.     % Default
  394.      { { pop true }
  395.        { wother }
  396.      }
  397.    ] def
  398.  
  399. % Write a named dictionary.  We assume the ref is already declared.
  400.    /wd        % <name> <dict> <extra> wd -
  401.     { 3 1 roll
  402.       ({) ws
  403.       (\tref v_[) ws dup length wt (];) wl
  404.       dup [ exch
  405.        { counttomark 2 sub wtstring cvs
  406.          (v_[) exch concatstrings (]) concatstrings exch wo not
  407.           { (Skipping ) print ==only (....\n) print }
  408.      if
  409.        } forall
  410.       ]
  411.         % Stack: array of keys (names)
  412.       ({) ws dup (str_keys_) exch wsna
  413.       (\tstatic const cfont_dict_keys keys_ =) wl
  414.       (\t { 0, 0, ) ws length wt (, ) ws 3 -1 roll wt (, ) ws
  415.       dup wpa (, ) ws dup wva ( };) wl pop
  416.       (\tcode = \(*pprocs->ref_dict_create\)\(i_ctx_p, &) ws wt
  417.       (, &keys_, str_keys_, v_\);) wl
  418.       (\tif ( code < 0 ) return code;) wl
  419.       (}) wl
  420.       (}) wl
  421.     } bind def
  422.  
  423. % Write character dictionary keys.
  424. % We save a lot of space by abbreviating keys which appear in
  425. % StandardEncoding or ISOLatin1Encoding.
  426. % Writes code to declare and initialize enc_keys_, str_keys, and keys_.
  427. /wcdkeys    % <dict> wcdkeys -
  428.  {    % Write keys present in StandardEncoding or ISOLatin1Encoding,
  429.     % pushing other keys on the o-stack.
  430.    (static const charindex enc_keys_[] = {) wl
  431.    dup [ exch 0 exch
  432.     { pop decoding 1 index known
  433.        { decoding exch get ({) ws dup -8 bitshift wt
  434.      (,) ws 255 and wt (}, ) ws
  435.      1 add dup 5 mod 0 eq { (\n) ws } if
  436.        }
  437.        { exch }
  438.       ifelse
  439.     }
  440.    forall pop
  441.    ]
  442.    ({0,0}\n};) wl
  443.     % Write other keys.
  444.    (str_keys_) exch wsna
  445.     % Write the declaration for keys_.
  446.    (static const cfont_dict_keys keys_ = {) wl
  447.    (\tenc_keys_, countof\(enc_keys_\) - 1,) wl
  448.    (\t) ws dup length wt ( - \(countof\(enc_keys_\) - 1\), 0, ) ws
  449.    dup wpa (, ) ws wva () wl
  450.    (};) wl
  451.  } bind def
  452.  
  453. % Enumerate character dictionary values in the same order that
  454. % the keys appear in enc_keys_ and str_keys_.
  455. % <proc> is called with each value in turn.
  456. /cdforall    % <dict> <proc> cdforall -
  457.  { 2 copy
  458.     { decoding 3 index known
  459.        { 3 -1 roll pop exec }
  460.        { pop pop pop }
  461.       ifelse
  462.     }
  463.    /exec cvx 3 packedarray cvx
  464.    /forall cvx
  465.    5 -2 roll
  466.     { decoding 3 index known
  467.        { pop pop pop }
  468.        { 3 -1 roll pop exec }
  469.       ifelse
  470.     }
  471.    /exec cvx 3 packedarray cvx
  472.    /forall cvx
  473.    6 packedarray cvx exec
  474.  } bind def
  475.  
  476. % ------ Writers for special objects ------ %
  477.  
  478. /writespecial 10 dict dup begin
  479.  
  480.    /FontInfo { 0 wd } def
  481.  
  482.    /Private { 0 wd } def
  483.  
  484.    /CharStrings
  485.     { ({) wl
  486.       dup wcdkeys
  487.       (static const char values_[] = {) wl
  488.        { wsn } cdforall
  489.       (\t0\n};) wl
  490.       (\tcode = \(*pprocs->string_dict_create\)\(i_ctx_p, &) ws wt
  491.       (, &keys_, str_keys_, values_\);) wl
  492.       (\tif ( code < 0 ) return code;) wl
  493.       (}) wl
  494.     } bind def
  495.  
  496.    /Metrics
  497.     { ({) wl
  498.       dup wcdkeys
  499.       (static const ref_(float) values_[] = {) wl
  500.       dup { (\t) ws wnums () wl } cdforall
  501.       (\t0\n};) wl
  502.       (static const char lengths_[] = {) wl
  503.        { (\t) ws dup isnumber
  504.       { pop 0 }
  505.       { length 1 add }
  506.      ifelse wt (,) wl
  507.        } cdforall
  508.       (\t0\n};) wl
  509.       (\tcode = \(*pprocs->num_dict_create\)\(i_ctx_p, &) ws wt
  510.       (, &keys_, str_keys_, (const ref *)values_, lengths_\);) wl
  511.       (\tif ( code < 0 ) return code;) wl
  512.       (}) wl
  513.     } bind def
  514.  
  515.    /Metrics2 /Metrics load def
  516.  
  517.    /FDepVector pop    % (converted to a list of font names)
  518.  
  519. end def
  520.  
  521. % ------ The main program ------ %
  522.  
  523. % Construct an inverse dictionary of encodings.
  524. [ /StandardEncoding /ISOLatin1Encoding
  525.   /SymbolEncoding /DingbatsEncoding
  526.   /KanjiSubEncoding
  527. ]
  528. dup length dict begin
  529.  { mark exch dup { .findencoding exch def } stopped cleartomark
  530.  } forall
  531. currentdict end /encodingnames exch def
  532.  
  533. % Invert the StandardEncoding and ISOLatin1Encoding vectors.
  534. 512 dict begin
  535.   0 1 255 { dup ISOLatin1Encoding exch get exch 256 add def } for
  536.   0 1 255 { dup StandardEncoding exch get exch def } for
  537. currentdict end /decoding exch def
  538.  
  539. /writefont        % cfilename procname -> [writes the current font]
  540.  { (gsf_) exch concatstrings
  541.      /fontprocname exch def
  542.    /cfname exch def
  543.    /cfile cfname (w) file def
  544.  
  545. % Remove unwanted keys from the font.
  546.    currentfont dup length dict begin { def } forall
  547.     { /FID /MIDVector /CurMID } { currentdict exch undef } forall
  548.    /Font currentdict end def
  549.  
  550. % Replace the FDepVector with a list of font names.
  551.    Font /FDepVector .knownget
  552.     { [ exch { /FontName get } forall ]
  553.       Font /FDepVector 3 -1 roll put
  554.     }
  555.    if
  556.  
  557. % Find all the special objects we know about.
  558. % wo uses this to write out references to otherwise intractable objects.
  559.    /otherobjs writespecial length dict dup begin
  560.      writespecial
  561.       { pop Font 1 index .knownget { exch def } { pop } ifelse
  562.       }
  563.      forall
  564.    end def
  565.  
  566. % Define a dummy FontInfo, in case the font doesn't have one.
  567.    /FontInfo 0 dict def
  568.  
  569. % Write out the boilerplate.
  570.    Font begin
  571.    (/****************************************************************) wl
  572.    (   Portions of this file are subject to the following notice(s):) wl
  573.    systemdict /copyright get wl
  574.    FontInfo /Notice .knownget
  575.     { (----------------------------------------------------------------) wl wl
  576.     } if
  577.    (****************************************************************/) wl
  578.    () wl
  579.    (/* ) ws cfname ws ( */) wl
  580.    (/* This file was created by the ) ws product ws ( font2c utility. */) wl
  581.    () wl
  582.    (#undef DEBUG) wl
  583.    (#include "ccfont.h") wl
  584.    () wl
  585.  
  586. % Write the procedure prologue.
  587.    (#ifdef __PROTOTYPES__) wl
  588.    (ccfont_proc\() ws fontprocname ws (\);) wl
  589.    (int) wl
  590.    fontprocname ws ((i_ctx_t *i_ctx_p, const cfont_procs *pprocs, ref *pfont)) wl
  591.    (#else) wl
  592.    (int) wl
  593.    fontprocname ws ((i_ctx_p, pprocs, pfont) i_ctx_t *i_ctx_p; const cfont_procs *pprocs; ref *pfont;) wl
  594.    (#endif) wl
  595.    ({\tint code;) wl
  596.    (\tref Font;) wl
  597.    otherobjs
  598.     { exch pop (\tref ) ws wt (;) wl }
  599.    forall
  600.  
  601. % Write out the special objects.
  602.    otherobjs
  603.     { exch writespecial 2 index get exec
  604.     }
  605.    forall
  606.  
  607. % Write out the main font dictionary.
  608. % If possible, substitute the encoding name for the encoding;
  609. % PostScript code will fix this up.
  610.     { /Encoding /PrefEnc }
  611.     { Font 1 index .knownget
  612.        { encodingnames exch .knownget { def } { pop } ifelse }
  613.        { pop }
  614.       ifelse
  615.     }
  616.    forall
  617.    (Font) Font FontType 0 eq { 5 } { 1 } ifelse wd
  618.  
  619. % Finish the procedural initialization code.
  620.    (\t*pfont = Font;) wl
  621.    (\treturn 0;) wl
  622.    (}) wl
  623.    end                % Font
  624.  
  625.    cfile closefile
  626.  
  627.  } bind def
  628.  
  629. end def            % font2cdict
  630.  
  631. % Compute the procedure name from the font name.
  632. % Replace all non-alphanumeric characters with '_'.
  633. /makefontprocnamemap 256 string
  634.    0 1 255 { 2 copy 95 put pop } for
  635.    (0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz)
  636.     { 2 copy dup put pop } forall
  637. readonly def
  638. /makefontprocname    % <fontname> makefontprocname <procnamestring>
  639.  { dup length string cvs
  640.    dup length 1 sub -1 0
  641.     {        % Stack: string index
  642.       2 copy 2 copy get //makefontprocnamemap exch get put pop
  643.     }
  644.    for 
  645.  } def
  646.  
  647. /writefont { font2cdict begin writefont end } def
  648.  
  649. % If the program was invoked from the command line, run it now.
  650. [ shellarguments
  651.  { counttomark dup 2 eq exch 3 eq or
  652.     { counttomark -1 roll cvn
  653.       (Converting ) print dup =only ( font.\n) print flush
  654.       dup FontDirectory exch known { dup FontDirectory exch undef } if
  655.       findfont setfont
  656.       (FontName is ) print currentfont /FontName get ==only (.\n) print flush
  657.       counttomark 1 eq
  658.        {    % Construct the procedure name from the file name.
  659.          currentfont /FontName get makefontprocname
  660.        }
  661.       if
  662.       writefont
  663.       (Done.\n) print flush
  664.     }
  665.     { cleartomark
  666.       (Usage: font2c fontname cfilename.c [shortname]\n) print
  667.       ( e.g.: font2c Courier cour.c\n) print flush
  668.       mark
  669.     }
  670.    ifelse
  671.  }
  672. if pop
  673.