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