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