tlgs/gs8.64

git-svn-id: svn://tug.org/texlive/trunk@13059 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 675 insertions, 0 deletions

diff --git a/Master/tlpkg/tlgs/lib/font2c.ps b/Master/tlpkg/tlgs/lib/font2c.ps
new file mode 100644
index 00000000000..c5234d72b02
--- /dev/null
+++ b/Master/tlpkg/tlgs/lib/font2c.ps
@@ -0,0 +1,675 @@
+%    Copyright (C) 1992, 1993, 1994, 1995, 1999 Aladdin Enterprises.  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.

+% 

+% For more information about licensing, please refer to

+% http://www.ghostscript.com/licensing/. For information on

+% commercial licensing, go to http://www.artifex.com/licensing/ or

+% contact Artifex Software, Inc., 101 Lucas Valley Road #110,

+% San Rafael, CA  94903, U.S.A., +1(415)492-9861.

+

+% $Id: font2c.ps 6300 2005-12-28 19:56:24Z giles $

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